diff options
| author | Jacques Garrigue <garrigue at math.nagoya-u.ac.jp> | 2012-08-21 07:10:35 +0000 |
|---|---|---|
| committer | Jacques Garrigue <garrigue at math.nagoya-u.ac.jp> | 2012-08-21 07:10:35 +0000 |
| commit | 35185d610b16e81ea11834963be61cecab7147c9 (patch) | |
| tree | 56307d76b703e694cf582e40c28f5b558c7d878e | |
| parent | de7262e181af27ecba9c2f356bc80905e7262b66 (diff) | |
| download | ocaml-35185d610b16e81ea11834963be61cecab7147c9.tar.gz | |
merge version/4.00 at revision 12866
git-svn-id: http://caml.inria.fr/svn/ocaml/branches/short-paths@12869 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
766 files changed, 23799 insertions, 10889 deletions
@@ -1,847 +1,907 @@ -utils/ccomp.cmi: -utils/clflags.cmi: -utils/config.cmi: -utils/consistbl.cmi: -utils/misc.cmi: -utils/tbl.cmi: -utils/terminfo.cmi: -utils/warnings.cmi: -utils/ccomp.cmo: utils/misc.cmi utils/config.cmi utils/clflags.cmi \ +utils/ccomp.cmi : +utils/clflags.cmi : +utils/config.cmi : +utils/consistbl.cmi : +utils/misc.cmi : +utils/tbl.cmi : +utils/terminfo.cmi : +utils/warnings.cmi : +utils/ccomp.cmo : utils/misc.cmi utils/config.cmi utils/clflags.cmi \ utils/ccomp.cmi -utils/ccomp.cmx: utils/misc.cmx utils/config.cmx utils/clflags.cmx \ +utils/ccomp.cmx : utils/misc.cmx utils/config.cmx utils/clflags.cmx \ utils/ccomp.cmi -utils/clflags.cmo: utils/config.cmi utils/clflags.cmi -utils/clflags.cmx: utils/config.cmx utils/clflags.cmi -utils/config.cmo: utils/config.cmi -utils/config.cmx: utils/config.cmi -utils/consistbl.cmo: utils/consistbl.cmi -utils/consistbl.cmx: utils/consistbl.cmi -utils/misc.cmo: utils/misc.cmi -utils/misc.cmx: utils/misc.cmi -utils/tbl.cmo: utils/tbl.cmi -utils/tbl.cmx: utils/tbl.cmi -utils/terminfo.cmo: utils/terminfo.cmi -utils/terminfo.cmx: utils/terminfo.cmi -utils/warnings.cmo: utils/warnings.cmi -utils/warnings.cmx: utils/warnings.cmi -parsing/asttypes.cmi: -parsing/lexer.cmi: parsing/parser.cmi parsing/location.cmi -parsing/location.cmi: utils/warnings.cmi -parsing/longident.cmi: -parsing/parse.cmi: parsing/parsetree.cmi -parsing/parser.cmi: parsing/parsetree.cmi -parsing/parsetree.cmi: parsing/longident.cmi parsing/location.cmi \ +utils/clflags.cmo : utils/config.cmi utils/clflags.cmi +utils/clflags.cmx : utils/config.cmx utils/clflags.cmi +utils/config.cmo : utils/config.cmi +utils/config.cmx : utils/config.cmi +utils/consistbl.cmo : utils/consistbl.cmi +utils/consistbl.cmx : utils/consistbl.cmi +utils/misc.cmo : utils/misc.cmi +utils/misc.cmx : utils/misc.cmi +utils/tbl.cmo : utils/tbl.cmi +utils/tbl.cmx : utils/tbl.cmi +utils/terminfo.cmo : utils/terminfo.cmi +utils/terminfo.cmx : utils/terminfo.cmi +utils/warnings.cmo : utils/warnings.cmi +utils/warnings.cmx : utils/warnings.cmi +parsing/asttypes.cmi : parsing/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/longident.cmi \ + parsing/location.cmi +parsing/parsetree.cmi : parsing/longident.cmi parsing/location.cmi \ parsing/asttypes.cmi -parsing/printast.cmi: parsing/parsetree.cmi -parsing/syntaxerr.cmi: parsing/location.cmi -parsing/lexer.cmo: utils/warnings.cmi parsing/parser.cmi utils/misc.cmi \ +parsing/printast.cmi : parsing/parsetree.cmi +parsing/syntaxerr.cmi : parsing/location.cmi +parsing/lexer.cmo : utils/warnings.cmi parsing/parser.cmi utils/misc.cmi \ parsing/location.cmi parsing/lexer.cmi -parsing/lexer.cmx: utils/warnings.cmx parsing/parser.cmx utils/misc.cmx \ +parsing/lexer.cmx : utils/warnings.cmx parsing/parser.cmx utils/misc.cmx \ parsing/location.cmx parsing/lexer.cmi -parsing/linenum.cmo: utils/misc.cmi -parsing/linenum.cmx: utils/misc.cmx -parsing/location.cmo: utils/warnings.cmi utils/terminfo.cmi \ +parsing/location.cmo : utils/warnings.cmi utils/terminfo.cmi \ parsing/location.cmi -parsing/location.cmx: utils/warnings.cmx utils/terminfo.cmx \ +parsing/location.cmx : utils/warnings.cmx utils/terminfo.cmx \ parsing/location.cmi -parsing/longident.cmo: utils/misc.cmi parsing/longident.cmi -parsing/longident.cmx: utils/misc.cmx parsing/longident.cmi -parsing/parse.cmo: parsing/syntaxerr.cmi parsing/parser.cmi \ +parsing/longident.cmo : utils/misc.cmi parsing/longident.cmi +parsing/longident.cmx : utils/misc.cmx parsing/longident.cmi +parsing/parse.cmo : parsing/syntaxerr.cmi parsing/parser.cmi \ parsing/location.cmi parsing/lexer.cmi parsing/parse.cmi -parsing/parse.cmx: parsing/syntaxerr.cmx parsing/parser.cmx \ +parsing/parse.cmx : parsing/syntaxerr.cmx parsing/parser.cmx \ parsing/location.cmx parsing/lexer.cmx parsing/parse.cmi -parsing/parser.cmo: parsing/syntaxerr.cmi parsing/parsetree.cmi \ +parsing/parser.cmo : parsing/syntaxerr.cmi parsing/parsetree.cmi \ parsing/longident.cmi parsing/location.cmi utils/clflags.cmi \ parsing/asttypes.cmi parsing/parser.cmi -parsing/parser.cmx: parsing/syntaxerr.cmx parsing/parsetree.cmi \ +parsing/parser.cmx : parsing/syntaxerr.cmx parsing/parsetree.cmi \ parsing/longident.cmx parsing/location.cmx utils/clflags.cmx \ parsing/asttypes.cmi parsing/parser.cmi -parsing/printast.cmo: parsing/parsetree.cmi parsing/longident.cmi \ +parsing/printast.cmo : parsing/parsetree.cmi parsing/longident.cmi \ parsing/location.cmi parsing/asttypes.cmi parsing/printast.cmi -parsing/printast.cmx: parsing/parsetree.cmi parsing/longident.cmx \ +parsing/printast.cmx : parsing/parsetree.cmi parsing/longident.cmx \ parsing/location.cmx parsing/asttypes.cmi parsing/printast.cmi -parsing/syntaxerr.cmo: parsing/location.cmi parsing/syntaxerr.cmi -parsing/syntaxerr.cmx: parsing/location.cmx parsing/syntaxerr.cmi -typing/annot.cmi: parsing/location.cmi -typing/btype.cmi: typing/types.cmi typing/path.cmi parsing/asttypes.cmi -typing/ctype.cmi: typing/types.cmi typing/path.cmi parsing/longident.cmi \ +parsing/syntaxerr.cmo : parsing/location.cmi parsing/syntaxerr.cmi +parsing/syntaxerr.cmx : parsing/location.cmx parsing/syntaxerr.cmi +typing/annot.cmi : parsing/location.cmi +typing/btype.cmi : typing/types.cmi typing/path.cmi parsing/asttypes.cmi +typing/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/ident.cmi: -typing/includeclass.cmi: typing/types.cmi typing/typedtree.cmi typing/env.cmi \ - typing/ctype.cmi -typing/includecore.cmi: typing/types.cmi typing/typedtree.cmi \ +typing/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/env.cmi typing/ctype.cmi +typing/includecore.cmi : typing/types.cmi typing/typedtree.cmi \ typing/ident.cmi typing/env.cmi -typing/includemod.cmi: typing/types.cmi typing/typedtree.cmi typing/path.cmi \ - typing/includecore.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi -typing/mtype.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi \ +typing/includemod.cmi : typing/types.cmi typing/typedtree.cmi \ + typing/path.cmi typing/includecore.cmi typing/ident.cmi typing/env.cmi \ + typing/ctype.cmi +typing/mtype.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi \ typing/env.cmi -typing/oprint.cmi: typing/outcometree.cmi -typing/outcometree.cmi: parsing/asttypes.cmi -typing/parmatch.cmi: typing/types.cmi typing/typedtree.cmi \ - parsing/parsetree.cmi parsing/location.cmi typing/env.cmi -typing/path.cmi: typing/ident.cmi -typing/predef.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi -typing/primitive.cmi: -typing/printtyp.cmi: typing/types.cmi typing/path.cmi typing/outcometree.cmi \ - parsing/longident.cmi typing/ident.cmi -typing/stypes.cmi: typing/typedtree.cmi parsing/location.cmi typing/annot.cmi -typing/subst.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi -typing/typeclass.cmi: typing/types.cmi typing/typedtree.cmi \ +typing/oprint.cmi : typing/outcometree.cmi +typing/outcometree.cmi : parsing/asttypes.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 +typing/typeclass.cmi : typing/types.cmi typing/typedtree.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ typing/ident.cmi typing/env.cmi typing/ctype.cmi parsing/asttypes.cmi -typing/typecore.cmi: typing/types.cmi typing/typedtree.cmi typing/path.cmi \ +typing/typecore.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/annot.cmi -typing/typedecl.cmi: typing/types.cmi typing/path.cmi parsing/parsetree.cmi \ - parsing/longident.cmi parsing/location.cmi typing/includecore.cmi \ - typing/ident.cmi typing/env.cmi -typing/typedtree.cmi: typing/types.cmi typing/primitive.cmi typing/path.cmi \ - parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi -typing/typemod.cmi: typing/types.cmi typing/typedtree.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/longident.cmi parsing/location.cmi typing/ident.cmi \ + typing/env.cmi parsing/asttypes.cmi +typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ typing/includemod.cmi typing/ident.cmi typing/env.cmi -typing/types.cmi: typing/primitive.cmi typing/path.cmi 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/btype.cmo: typing/types.cmi typing/path.cmi utils/misc.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/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.cmx : typing/types.cmx typing/path.cmx utils/misc.cmx \ typing/btype.cmi -typing/ctype.cmo: typing/types.cmi typing/subst.cmi typing/path.cmi \ +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 \ parsing/asttypes.cmi typing/ctype.cmi -typing/ctype.cmx: typing/types.cmx typing/subst.cmx typing/path.cmx \ +typing/ctype.cmx : typing/types.cmx typing/subst.cmx typing/path.cmx \ utils/misc.cmx parsing/longident.cmx parsing/location.cmx \ typing/ident.cmx typing/env.cmx utils/clflags.cmx typing/btype.cmx \ parsing/asttypes.cmi typing/ctype.cmi -typing/datarepr.cmo: typing/types.cmi typing/predef.cmi utils/misc.cmi \ - typing/btype.cmi parsing/asttypes.cmi typing/datarepr.cmi -typing/datarepr.cmx: typing/types.cmx typing/predef.cmx utils/misc.cmx \ - typing/btype.cmx parsing/asttypes.cmi typing/datarepr.cmi -typing/env.cmo: utils/warnings.cmi typing/types.cmi utils/tbl.cmi \ +typing/datarepr.cmo : typing/types.cmi typing/predef.cmi utils/misc.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/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/env.cmx: utils/warnings.cmx typing/types.cmx utils/tbl.cmx \ + 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/ident.cmo: typing/ident.cmi -typing/ident.cmx: typing/ident.cmi -typing/includeclass.cmo: typing/types.cmi typing/printtyp.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 \ typing/ctype.cmi typing/includeclass.cmi -typing/includeclass.cmx: typing/types.cmx typing/printtyp.cmx \ +typing/includeclass.cmx : typing/types.cmx typing/printtyp.cmx \ typing/ctype.cmx typing/includeclass.cmi -typing/includecore.cmo: typing/types.cmi typing/typedtree.cmi \ +typing/includecore.cmo : typing/types.cmi typing/typedtree.cmi \ typing/predef.cmi typing/path.cmi utils/misc.cmi typing/ident.cmi \ typing/env.cmi typing/ctype.cmi typing/btype.cmi parsing/asttypes.cmi \ typing/includecore.cmi -typing/includecore.cmx: typing/types.cmx typing/typedtree.cmx \ +typing/includecore.cmx : typing/types.cmx typing/typedtree.cmx \ typing/predef.cmx typing/path.cmx utils/misc.cmx typing/ident.cmx \ typing/env.cmx typing/ctype.cmx typing/btype.cmx parsing/asttypes.cmi \ typing/includecore.cmi -typing/includemod.cmo: typing/types.cmi typing/typedtree.cmi utils/tbl.cmi \ +typing/includemod.cmo : typing/types.cmi typing/typedtree.cmi utils/tbl.cmi \ typing/subst.cmi typing/printtyp.cmi typing/path.cmi typing/mtype.cmi \ utils/misc.cmi parsing/location.cmi typing/includecore.cmi \ typing/includeclass.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ utils/clflags.cmi typing/includemod.cmi -typing/includemod.cmx: typing/types.cmx typing/typedtree.cmx utils/tbl.cmx \ +typing/includemod.cmx : typing/types.cmx typing/typedtree.cmx utils/tbl.cmx \ typing/subst.cmx typing/printtyp.cmx typing/path.cmx typing/mtype.cmx \ utils/misc.cmx parsing/location.cmx typing/includecore.cmx \ typing/includeclass.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ utils/clflags.cmx typing/includemod.cmi -typing/mtype.cmo: typing/types.cmi typing/subst.cmi typing/path.cmi \ +typing/mtype.cmo : typing/types.cmi typing/subst.cmi typing/path.cmi \ typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \ typing/btype.cmi parsing/asttypes.cmi typing/mtype.cmi -typing/mtype.cmx: typing/types.cmx typing/subst.cmx typing/path.cmx \ +typing/mtype.cmx : typing/types.cmx typing/subst.cmx typing/path.cmx \ typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/clflags.cmx \ typing/btype.cmx parsing/asttypes.cmi typing/mtype.cmi -typing/oprint.cmo: typing/outcometree.cmi parsing/asttypes.cmi \ +typing/oprint.cmo : typing/outcometree.cmi parsing/asttypes.cmi \ typing/oprint.cmi -typing/oprint.cmx: typing/outcometree.cmi parsing/asttypes.cmi \ +typing/oprint.cmx : typing/outcometree.cmi parsing/asttypes.cmi \ typing/oprint.cmi -typing/parmatch.cmo: utils/warnings.cmi typing/types.cmi typing/typedtree.cmi \ - typing/subst.cmi typing/predef.cmi typing/path.cmi parsing/parsetree.cmi \ - utils/misc.cmi parsing/longident.cmi parsing/location.cmi \ - typing/ident.cmi typing/env.cmi typing/datarepr.cmi typing/ctype.cmi \ - typing/btype.cmi parsing/asttypes.cmi typing/parmatch.cmi -typing/parmatch.cmx: utils/warnings.cmx typing/types.cmx typing/typedtree.cmx \ - typing/subst.cmx typing/predef.cmx typing/path.cmx parsing/parsetree.cmi \ - utils/misc.cmx parsing/longident.cmx parsing/location.cmx \ - typing/ident.cmx typing/env.cmx typing/datarepr.cmx typing/ctype.cmx \ - typing/btype.cmx parsing/asttypes.cmi typing/parmatch.cmi -typing/path.cmo: typing/ident.cmi typing/path.cmi -typing/path.cmx: typing/ident.cmx typing/path.cmi -typing/predef.cmo: typing/types.cmi typing/path.cmi parsing/location.cmi \ +typing/parmatch.cmo : utils/warnings.cmi typing/types.cmi \ + typing/typedtree.cmi typing/subst.cmi typing/predef.cmi typing/path.cmi \ + parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi typing/ident.cmi typing/env.cmi typing/datarepr.cmi \ + typing/ctype.cmi typing/btype.cmi parsing/asttypes.cmi \ + typing/parmatch.cmi +typing/parmatch.cmx : utils/warnings.cmx typing/types.cmx \ + typing/typedtree.cmx typing/subst.cmx typing/predef.cmx typing/path.cmx \ + parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx typing/ident.cmx typing/env.cmx typing/datarepr.cmx \ + typing/ctype.cmx typing/btype.cmx parsing/asttypes.cmi \ + typing/parmatch.cmi +typing/path.cmo : typing/ident.cmi typing/path.cmi +typing/path.cmx : typing/ident.cmx typing/path.cmi +typing/predef.cmo : typing/types.cmi typing/path.cmi parsing/location.cmi \ typing/ident.cmi typing/btype.cmi parsing/asttypes.cmi typing/predef.cmi -typing/predef.cmx: typing/types.cmx typing/path.cmx parsing/location.cmx \ +typing/predef.cmx : typing/types.cmx typing/path.cmx parsing/location.cmx \ typing/ident.cmx typing/btype.cmx parsing/asttypes.cmi typing/predef.cmi -typing/primitive.cmo: utils/misc.cmi typing/primitive.cmi -typing/primitive.cmx: utils/misc.cmx typing/primitive.cmi -typing/printtyp.cmo: typing/types.cmi typing/primitive.cmi typing/predef.cmi \ - typing/path.cmi typing/outcometree.cmi typing/oprint.cmi utils/misc.cmi \ - parsing/longident.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ - utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ - typing/printtyp.cmi -typing/printtyp.cmx: typing/types.cmx typing/primitive.cmx typing/predef.cmx \ - typing/path.cmx typing/outcometree.cmi typing/oprint.cmx utils/misc.cmx \ - parsing/longident.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ - utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ - typing/printtyp.cmi -typing/stypes.cmo: typing/typedtree.cmi typing/printtyp.cmi \ +typing/primitive.cmo : utils/misc.cmi typing/primitive.cmi +typing/primitive.cmx : utils/misc.cmx typing/primitive.cmi +typing/printtyp.cmo : typing/types.cmi typing/primitive.cmi \ + typing/predef.cmi typing/path.cmi typing/outcometree.cmi \ + typing/oprint.cmi utils/misc.cmi parsing/longident.cmi typing/ident.cmi \ + typing/env.cmi typing/ctype.cmi utils/clflags.cmi typing/btype.cmi \ + parsing/asttypes.cmi typing/printtyp.cmi +typing/printtyp.cmx : typing/types.cmx typing/primitive.cmx \ + typing/predef.cmx typing/path.cmx typing/outcometree.cmi \ + typing/oprint.cmx utils/misc.cmx parsing/longident.cmx typing/ident.cmx \ + typing/env.cmx typing/ctype.cmx utils/clflags.cmx typing/btype.cmx \ + parsing/asttypes.cmi typing/printtyp.cmi +typing/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 \ +typing/stypes.cmx : typing/typedtree.cmx typing/printtyp.cmx \ parsing/location.cmx utils/clflags.cmx typing/annot.cmi typing/stypes.cmi -typing/subst.cmo: typing/types.cmi utils/tbl.cmi typing/path.cmi \ +typing/subst.cmo : typing/types.cmi utils/tbl.cmi typing/path.cmi \ utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/btype.cmi \ typing/subst.cmi -typing/subst.cmx: typing/types.cmx utils/tbl.cmx typing/path.cmx \ +typing/subst.cmx : typing/types.cmx utils/tbl.cmx typing/path.cmx \ utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/btype.cmx \ typing/subst.cmi -typing/typeclass.cmo: utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \ - typing/typedtree.cmi typing/typedecl.cmi typing/typecore.cmi \ - typing/subst.cmi typing/stypes.cmi typing/printtyp.cmi typing/predef.cmi \ - typing/path.cmi parsing/parsetree.cmi typing/parmatch.cmi utils/misc.cmi \ +typing/typeclass.cmo : utils/warnings.cmi typing/typetexp.cmi \ + typing/types.cmi typing/typedtree.cmi typing/typedecl.cmi \ + typing/typecore.cmi typing/subst.cmi typing/stypes.cmi \ + typing/printtyp.cmi typing/predef.cmi typing/path.cmi \ + parsing/parsetree.cmi typing/parmatch.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi typing/includeclass.cmi \ - typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \ - typing/btype.cmi parsing/asttypes.cmi typing/typeclass.cmi -typing/typeclass.cmx: utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \ - typing/typedtree.cmx typing/typedecl.cmx typing/typecore.cmx \ - typing/subst.cmx typing/stypes.cmx typing/printtyp.cmx typing/predef.cmx \ - typing/path.cmx parsing/parsetree.cmi typing/parmatch.cmx utils/misc.cmx \ + typing/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/typecore.cmo: utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \ - typing/typedtree.cmi typing/subst.cmi typing/stypes.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/typedtree.cmi typing/subst.cmi typing/stypes.cmi \ typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \ typing/path.cmi parsing/parsetree.cmi typing/parmatch.cmi \ typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \ parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ - utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \ - typing/typecore.cmi -typing/typecore.cmx: utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \ - typing/typedtree.cmx typing/subst.cmx typing/stypes.cmx \ + typing/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/typedtree.cmx typing/subst.cmx typing/stypes.cmx \ typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \ typing/path.cmx parsing/parsetree.cmi typing/parmatch.cmx \ typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \ parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ - utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \ - typing/typecore.cmi -typing/typedecl.cmo: utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \ - typing/typedtree.cmi typing/subst.cmi typing/printtyp.cmi \ - typing/primitive.cmi typing/predef.cmi typing/path.cmi \ - parsing/parsetree.cmi utils/misc.cmi parsing/longident.cmi \ - parsing/location.cmi typing/includecore.cmi typing/ident.cmi \ - typing/env.cmi typing/ctype.cmi utils/config.cmi utils/clflags.cmi \ - typing/btype.cmi parsing/asttypes.cmi typing/typedecl.cmi -typing/typedecl.cmx: utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \ - typing/typedtree.cmx typing/subst.cmx typing/printtyp.cmx \ - typing/primitive.cmx typing/predef.cmx typing/path.cmx \ - parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \ - parsing/location.cmx typing/includecore.cmx typing/ident.cmx \ - typing/env.cmx typing/ctype.cmx utils/config.cmx utils/clflags.cmx \ - typing/btype.cmx parsing/asttypes.cmi typing/typedecl.cmi -typing/typedtree.cmo: typing/types.cmi typing/primitive.cmi typing/path.cmi \ - utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/env.cmi \ - parsing/asttypes.cmi typing/typedtree.cmi -typing/typedtree.cmx: typing/types.cmx typing/primitive.cmx typing/path.cmx \ - utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/env.cmx \ - parsing/asttypes.cmi typing/typedtree.cmi -typing/typemod.cmo: utils/warnings.cmi typing/typetexp.cmi typing/types.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 \ + typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi typing/includecore.cmi \ + typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/config.cmi \ + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + typing/typedecl.cmi +typing/typedecl.cmx : utils/warnings.cmx typing/typetexp.cmx \ + typing/types.cmx typing/typedtree.cmx typing/subst.cmx \ + typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \ + typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx typing/includecore.cmx \ + typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \ + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + typing/typedecl.cmi +typing/typedtree.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \ + utils/misc.cmi parsing/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/longident.cmx parsing/location.cmx \ + typing/ident.cmx typing/env.cmx parsing/asttypes.cmi typing/typedtree.cmi +typing/typemod.cmo : utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \ typing/typedtree.cmi typing/typedecl.cmi typing/typecore.cmi \ typing/typeclass.cmi typing/subst.cmi typing/stypes.cmi \ typing/printtyp.cmi typing/path.cmi parsing/parsetree.cmi \ typing/mtype.cmi utils/misc.cmi parsing/longident.cmi \ parsing/location.cmi typing/includemod.cmi typing/ident.cmi \ - typing/env.cmi typing/ctype.cmi utils/config.cmi utils/clflags.cmi \ - typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi typing/typemod.cmi -typing/typemod.cmx: utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \ + typing/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/types.cmo: typing/primitive.cmi typing/path.cmi utils/misc.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 \ +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 -bytecomp/bytegen.cmi: bytecomp/lambda.cmi bytecomp/instruct.cmi -bytecomp/bytelibrarian.cmi: -bytecomp/bytelink.cmi: bytecomp/symtable.cmi bytecomp/cmo_format.cmi -bytecomp/bytepackager.cmi: typing/ident.cmi -bytecomp/bytesections.cmi: -bytecomp/cmo_format.cmi: bytecomp/lambda.cmi typing/ident.cmi -bytecomp/dll.cmi: -bytecomp/emitcode.cmi: bytecomp/instruct.cmi bytecomp/cmo_format.cmi -bytecomp/instruct.cmi: typing/types.cmi typing/subst.cmi parsing/location.cmi \ - bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi -bytecomp/lambda.cmi: typing/types.cmi typing/primitive.cmi typing/path.cmi \ +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 +bytecomp/bytepackager.cmi : typing/ident.cmi +bytecomp/bytesections.cmi : +bytecomp/cmo_format.cmi : bytecomp/lambda.cmi typing/ident.cmi +bytecomp/dll.cmi : +bytecomp/emitcode.cmi : bytecomp/instruct.cmi bytecomp/cmo_format.cmi +bytecomp/instruct.cmi : typing/types.cmi typing/subst.cmi \ + parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi +bytecomp/lambda.cmi : typing/types.cmi typing/primitive.cmi typing/path.cmi \ parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi -bytecomp/matching.cmi: typing/typedtree.cmi parsing/location.cmi \ +bytecomp/matching.cmi : typing/typedtree.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi -bytecomp/meta.cmi: -bytecomp/printinstr.cmi: bytecomp/instruct.cmi -bytecomp/printlambda.cmi: bytecomp/lambda.cmi -bytecomp/runtimedef.cmi: -bytecomp/simplif.cmi: bytecomp/lambda.cmi -bytecomp/switch.cmi: -bytecomp/symtable.cmi: typing/ident.cmi bytecomp/cmo_format.cmi -bytecomp/translclass.cmi: typing/typedtree.cmi parsing/location.cmi \ +bytecomp/meta.cmi : +bytecomp/printinstr.cmi : bytecomp/instruct.cmi +bytecomp/printlambda.cmi : bytecomp/lambda.cmi +bytecomp/runtimedef.cmi : +bytecomp/simplif.cmi : bytecomp/lambda.cmi +bytecomp/switch.cmi : +bytecomp/symtable.cmi : typing/ident.cmi bytecomp/cmo_format.cmi +bytecomp/translclass.cmi : typing/typedtree.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi -bytecomp/translcore.cmi: typing/types.cmi typing/typedtree.cmi \ +bytecomp/translcore.cmi : typing/types.cmi typing/typedtree.cmi \ typing/primitive.cmi typing/path.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi -bytecomp/translmod.cmi: typing/typedtree.cmi typing/primitive.cmi \ +bytecomp/translmod.cmi : typing/typedtree.cmi typing/primitive.cmi \ parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi -bytecomp/translobj.cmi: bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi -bytecomp/typeopt.cmi: typing/typedtree.cmi typing/path.cmi \ +bytecomp/translobj.cmi : bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi +bytecomp/typeopt.cmi : typing/typedtree.cmi typing/path.cmi \ bytecomp/lambda.cmi -bytecomp/bytegen.cmo: typing/types.cmi bytecomp/switch.cmi typing/subst.cmi \ +bytecomp/bytegen.cmo : typing/types.cmi bytecomp/switch.cmi typing/subst.cmi \ typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi \ bytecomp/instruct.cmi typing/ident.cmi utils/config.cmi \ parsing/asttypes.cmi bytecomp/bytegen.cmi -bytecomp/bytegen.cmx: typing/types.cmx bytecomp/switch.cmx typing/subst.cmx \ +bytecomp/bytegen.cmx : typing/types.cmx bytecomp/switch.cmx typing/subst.cmx \ typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx \ bytecomp/instruct.cmx typing/ident.cmx utils/config.cmx \ parsing/asttypes.cmi bytecomp/bytegen.cmi -bytecomp/bytelibrarian.cmo: utils/misc.cmi utils/config.cmi \ - bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytelink.cmi \ - bytecomp/bytelibrarian.cmi -bytecomp/bytelibrarian.cmx: utils/misc.cmx utils/config.cmx \ - bytecomp/cmo_format.cmi utils/clflags.cmx bytecomp/bytelink.cmx \ - bytecomp/bytelibrarian.cmi -bytecomp/bytelink.cmo: utils/warnings.cmi bytecomp/symtable.cmi \ +bytecomp/bytelibrarian.cmo : utils/misc.cmi parsing/location.cmi \ + utils/config.cmi bytecomp/cmo_format.cmi utils/clflags.cmi \ + bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi +bytecomp/bytelibrarian.cmx : utils/misc.cmx parsing/location.cmx \ + utils/config.cmx bytecomp/cmo_format.cmi utils/clflags.cmx \ + bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmi +bytecomp/bytelink.cmo : utils/warnings.cmi bytecomp/symtable.cmi \ bytecomp/opcodes.cmo utils/misc.cmi parsing/location.cmi \ bytecomp/instruct.cmi typing/ident.cmi bytecomp/dll.cmi \ utils/consistbl.cmi utils/config.cmi bytecomp/cmo_format.cmi \ utils/clflags.cmi utils/ccomp.cmi bytecomp/bytesections.cmi \ bytecomp/bytelink.cmi -bytecomp/bytelink.cmx: utils/warnings.cmx bytecomp/symtable.cmx \ +bytecomp/bytelink.cmx : utils/warnings.cmx bytecomp/symtable.cmx \ bytecomp/opcodes.cmx utils/misc.cmx parsing/location.cmx \ bytecomp/instruct.cmx typing/ident.cmx bytecomp/dll.cmx \ utils/consistbl.cmx utils/config.cmx bytecomp/cmo_format.cmi \ utils/clflags.cmx utils/ccomp.cmx bytecomp/bytesections.cmx \ bytecomp/bytelink.cmi -bytecomp/bytepackager.cmo: typing/typemod.cmi bytecomp/translmod.cmi \ - typing/subst.cmi typing/path.cmi utils/misc.cmi bytecomp/instruct.cmi \ - typing/ident.cmi typing/env.cmi bytecomp/emitcode.cmi utils/config.cmi \ - bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytelink.cmi \ - bytecomp/bytegen.cmi bytecomp/bytepackager.cmi -bytecomp/bytepackager.cmx: typing/typemod.cmx bytecomp/translmod.cmx \ - typing/subst.cmx typing/path.cmx utils/misc.cmx bytecomp/instruct.cmx \ - typing/ident.cmx typing/env.cmx bytecomp/emitcode.cmx utils/config.cmx \ - bytecomp/cmo_format.cmi utils/clflags.cmx bytecomp/bytelink.cmx \ - bytecomp/bytegen.cmx bytecomp/bytepackager.cmi -bytecomp/bytesections.cmo: utils/config.cmi bytecomp/bytesections.cmi -bytecomp/bytesections.cmx: utils/config.cmx bytecomp/bytesections.cmi -bytecomp/dll.cmo: utils/misc.cmi utils/config.cmi bytecomp/dll.cmi -bytecomp/dll.cmx: utils/misc.cmx utils/config.cmx bytecomp/dll.cmi -bytecomp/emitcode.cmo: bytecomp/translmod.cmi typing/primitive.cmi \ +bytecomp/bytepackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \ + typing/subst.cmi typing/path.cmi utils/misc.cmi parsing/location.cmi \ + bytecomp/instruct.cmi typing/ident.cmi typing/env.cmi \ + bytecomp/emitcode.cmi utils/config.cmi bytecomp/cmo_format.cmi \ + utils/clflags.cmi bytecomp/bytelink.cmi bytecomp/bytegen.cmi \ + bytecomp/bytepackager.cmi +bytecomp/bytepackager.cmx : typing/typemod.cmx bytecomp/translmod.cmx \ + typing/subst.cmx typing/path.cmx utils/misc.cmx parsing/location.cmx \ + bytecomp/instruct.cmx typing/ident.cmx typing/env.cmx \ + bytecomp/emitcode.cmx utils/config.cmx bytecomp/cmo_format.cmi \ + utils/clflags.cmx bytecomp/bytelink.cmx bytecomp/bytegen.cmx \ + bytecomp/bytepackager.cmi +bytecomp/bytesections.cmo : utils/misc.cmi utils/config.cmi \ + bytecomp/bytesections.cmi +bytecomp/bytesections.cmx : utils/misc.cmx utils/config.cmx \ + bytecomp/bytesections.cmi +bytecomp/dll.cmo : utils/misc.cmi utils/config.cmi bytecomp/dll.cmi +bytecomp/dll.cmx : utils/misc.cmx utils/config.cmx bytecomp/dll.cmi +bytecomp/emitcode.cmo : bytecomp/translmod.cmi typing/primitive.cmi \ bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi bytecomp/lambda.cmi \ bytecomp/instruct.cmi typing/env.cmi utils/config.cmi \ bytecomp/cmo_format.cmi utils/clflags.cmi typing/btype.cmi \ parsing/asttypes.cmi bytecomp/emitcode.cmi -bytecomp/emitcode.cmx: bytecomp/translmod.cmx typing/primitive.cmx \ +bytecomp/emitcode.cmx : bytecomp/translmod.cmx typing/primitive.cmx \ bytecomp/opcodes.cmx utils/misc.cmx bytecomp/meta.cmx bytecomp/lambda.cmx \ bytecomp/instruct.cmx typing/env.cmx utils/config.cmx \ bytecomp/cmo_format.cmi utils/clflags.cmx typing/btype.cmx \ parsing/asttypes.cmi bytecomp/emitcode.cmi -bytecomp/instruct.cmo: typing/types.cmi typing/subst.cmi parsing/location.cmi \ - bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi bytecomp/instruct.cmi -bytecomp/instruct.cmx: typing/types.cmx typing/subst.cmx parsing/location.cmx \ - bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx bytecomp/instruct.cmi -bytecomp/lambda.cmo: typing/types.cmi typing/primitive.cmi typing/path.cmi \ +bytecomp/instruct.cmo : typing/types.cmi typing/subst.cmi \ + parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ + bytecomp/instruct.cmi +bytecomp/instruct.cmx : typing/types.cmx typing/subst.cmx \ + parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ + bytecomp/instruct.cmi +bytecomp/lambda.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \ utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/env.cmi \ parsing/asttypes.cmi bytecomp/lambda.cmi -bytecomp/lambda.cmx: typing/types.cmx typing/primitive.cmx typing/path.cmx \ +bytecomp/lambda.cmx : typing/types.cmx typing/primitive.cmx typing/path.cmx \ utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/env.cmx \ parsing/asttypes.cmi bytecomp/lambda.cmi -bytecomp/matching.cmo: typing/types.cmi bytecomp/typeopt.cmi \ +bytecomp/matching.cmo : typing/types.cmi bytecomp/typeopt.cmi \ typing/typedtree.cmi bytecomp/switch.cmi bytecomp/printlambda.cmi \ typing/primitive.cmi typing/predef.cmi typing/path.cmi \ typing/parmatch.cmi utils/misc.cmi parsing/longident.cmi \ parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ bytecomp/matching.cmi -bytecomp/matching.cmx: typing/types.cmx bytecomp/typeopt.cmx \ +bytecomp/matching.cmx : typing/types.cmx bytecomp/typeopt.cmx \ typing/typedtree.cmx bytecomp/switch.cmx bytecomp/printlambda.cmx \ typing/primitive.cmx typing/predef.cmx typing/path.cmx \ typing/parmatch.cmx utils/misc.cmx parsing/longident.cmx \ parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ bytecomp/matching.cmi -bytecomp/meta.cmo: bytecomp/meta.cmi -bytecomp/meta.cmx: bytecomp/meta.cmi -bytecomp/opcodes.cmo: -bytecomp/opcodes.cmx: -bytecomp/printinstr.cmo: bytecomp/printlambda.cmi parsing/location.cmi \ +bytecomp/meta.cmo : bytecomp/meta.cmi +bytecomp/meta.cmx : bytecomp/meta.cmi +bytecomp/opcodes.cmo : +bytecomp/opcodes.cmx : +bytecomp/printinstr.cmo : bytecomp/printlambda.cmi parsing/location.cmi \ bytecomp/lambda.cmi bytecomp/instruct.cmi typing/ident.cmi \ bytecomp/printinstr.cmi -bytecomp/printinstr.cmx: bytecomp/printlambda.cmx parsing/location.cmx \ +bytecomp/printinstr.cmx : bytecomp/printlambda.cmx parsing/location.cmx \ bytecomp/lambda.cmx bytecomp/instruct.cmx typing/ident.cmx \ bytecomp/printinstr.cmi -bytecomp/printlambda.cmo: typing/types.cmi typing/primitive.cmi \ +bytecomp/printlambda.cmo : typing/types.cmi typing/primitive.cmi \ parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \ parsing/asttypes.cmi bytecomp/printlambda.cmi -bytecomp/printlambda.cmx: typing/types.cmx typing/primitive.cmx \ +bytecomp/printlambda.cmx : typing/types.cmx typing/primitive.cmx \ parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \ parsing/asttypes.cmi bytecomp/printlambda.cmi -bytecomp/runtimedef.cmo: bytecomp/runtimedef.cmi -bytecomp/runtimedef.cmx: bytecomp/runtimedef.cmi -bytecomp/simplif.cmo: utils/tbl.cmi typing/stypes.cmi bytecomp/lambda.cmi \ +bytecomp/runtimedef.cmo : bytecomp/runtimedef.cmi +bytecomp/runtimedef.cmx : bytecomp/runtimedef.cmi +bytecomp/simplif.cmo : utils/tbl.cmi typing/stypes.cmi bytecomp/lambda.cmi \ typing/ident.cmi utils/clflags.cmi parsing/asttypes.cmi typing/annot.cmi \ bytecomp/simplif.cmi -bytecomp/simplif.cmx: utils/tbl.cmx typing/stypes.cmx bytecomp/lambda.cmx \ +bytecomp/simplif.cmx : utils/tbl.cmx typing/stypes.cmx bytecomp/lambda.cmx \ typing/ident.cmx utils/clflags.cmx parsing/asttypes.cmi typing/annot.cmi \ bytecomp/simplif.cmi -bytecomp/switch.cmo: bytecomp/switch.cmi -bytecomp/switch.cmx: bytecomp/switch.cmi -bytecomp/symtable.cmo: utils/tbl.cmi bytecomp/runtimedef.cmi \ +bytecomp/switch.cmo : bytecomp/switch.cmi +bytecomp/switch.cmx : bytecomp/switch.cmi +bytecomp/symtable.cmo : utils/tbl.cmi bytecomp/runtimedef.cmi \ typing/predef.cmi utils/misc.cmi bytecomp/meta.cmi bytecomp/lambda.cmi \ typing/ident.cmi bytecomp/dll.cmi bytecomp/cmo_format.cmi \ utils/clflags.cmi bytecomp/bytesections.cmi parsing/asttypes.cmi \ bytecomp/symtable.cmi -bytecomp/symtable.cmx: utils/tbl.cmx bytecomp/runtimedef.cmx \ +bytecomp/symtable.cmx : utils/tbl.cmx bytecomp/runtimedef.cmx \ typing/predef.cmx utils/misc.cmx bytecomp/meta.cmx bytecomp/lambda.cmx \ typing/ident.cmx bytecomp/dll.cmx bytecomp/cmo_format.cmi \ utils/clflags.cmx bytecomp/bytesections.cmx parsing/asttypes.cmi \ bytecomp/symtable.cmi -bytecomp/translclass.cmo: typing/types.cmi bytecomp/typeopt.cmi \ +bytecomp/translclass.cmo : typing/types.cmi bytecomp/typeopt.cmi \ typing/typedtree.cmi bytecomp/translobj.cmi bytecomp/translcore.cmi \ typing/path.cmi utils/misc.cmi bytecomp/matching.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi utils/clflags.cmi \ typing/btype.cmi parsing/asttypes.cmi bytecomp/translclass.cmi -bytecomp/translclass.cmx: typing/types.cmx bytecomp/typeopt.cmx \ +bytecomp/translclass.cmx : typing/types.cmx bytecomp/typeopt.cmx \ typing/typedtree.cmx bytecomp/translobj.cmx bytecomp/translcore.cmx \ typing/path.cmx utils/misc.cmx bytecomp/matching.cmx parsing/location.cmx \ bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/clflags.cmx \ typing/btype.cmx parsing/asttypes.cmi bytecomp/translclass.cmi -bytecomp/translcore.cmo: typing/types.cmi bytecomp/typeopt.cmi \ +bytecomp/translcore.cmo : typing/types.cmi bytecomp/typeopt.cmi \ typing/typedtree.cmi bytecomp/translobj.cmi typing/primitive.cmi \ typing/predef.cmi typing/path.cmi typing/parmatch.cmi utils/misc.cmi \ - bytecomp/matching.cmi parsing/location.cmi bytecomp/lambda.cmi \ - typing/ident.cmi typing/env.cmi utils/config.cmi utils/clflags.cmi \ - typing/btype.cmi parsing/asttypes.cmi bytecomp/translcore.cmi -bytecomp/translcore.cmx: typing/types.cmx bytecomp/typeopt.cmx \ + bytecomp/matching.cmi parsing/longident.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi utils/config.cmi \ + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + bytecomp/translcore.cmi +bytecomp/translcore.cmx : typing/types.cmx bytecomp/typeopt.cmx \ typing/typedtree.cmx bytecomp/translobj.cmx typing/primitive.cmx \ typing/predef.cmx typing/path.cmx typing/parmatch.cmx utils/misc.cmx \ - bytecomp/matching.cmx parsing/location.cmx bytecomp/lambda.cmx \ - typing/ident.cmx typing/env.cmx utils/config.cmx utils/clflags.cmx \ - typing/btype.cmx parsing/asttypes.cmi bytecomp/translcore.cmi -bytecomp/translmod.cmo: typing/types.cmi typing/typedtree.cmi \ + bytecomp/matching.cmx parsing/longident.cmx parsing/location.cmx \ + bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/config.cmx \ + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + bytecomp/translcore.cmi +bytecomp/translmod.cmo : typing/types.cmi typing/typedtree.cmi \ bytecomp/translobj.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \ typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \ typing/path.cmi typing/mtype.cmi utils/misc.cmi parsing/longident.cmi \ parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ typing/ctype.cmi parsing/asttypes.cmi bytecomp/translmod.cmi -bytecomp/translmod.cmx: typing/types.cmx typing/typedtree.cmx \ +bytecomp/translmod.cmx : typing/types.cmx typing/typedtree.cmx \ bytecomp/translobj.cmx bytecomp/translcore.cmx bytecomp/translclass.cmx \ typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \ typing/path.cmx typing/mtype.cmx utils/misc.cmx parsing/longident.cmx \ parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ typing/ctype.cmx parsing/asttypes.cmi bytecomp/translmod.cmi -bytecomp/translobj.cmo: typing/primitive.cmi utils/misc.cmi \ +bytecomp/translobj.cmo : typing/primitive.cmi utils/misc.cmi \ parsing/longident.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ bytecomp/translobj.cmi -bytecomp/translobj.cmx: typing/primitive.cmx utils/misc.cmx \ +bytecomp/translobj.cmx : typing/primitive.cmx utils/misc.cmx \ parsing/longident.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ bytecomp/translobj.cmi -bytecomp/typeopt.cmo: typing/types.cmi typing/typedtree.cmi \ +bytecomp/typeopt.cmo : typing/types.cmi typing/typedtree.cmi \ typing/primitive.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \ bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ parsing/asttypes.cmi bytecomp/typeopt.cmi -bytecomp/typeopt.cmx: typing/types.cmx typing/typedtree.cmx \ +bytecomp/typeopt.cmx : typing/types.cmx typing/typedtree.cmx \ typing/primitive.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \ bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ parsing/asttypes.cmi bytecomp/typeopt.cmi -asmcomp/asmgen.cmi: bytecomp/lambda.cmi asmcomp/cmm.cmi -asmcomp/asmlibrarian.cmi: -asmcomp/asmlink.cmi: asmcomp/cmx_format.cmi -asmcomp/asmpackager.cmi: -asmcomp/clambda.cmi: bytecomp/lambda.cmi typing/ident.cmi \ +asmcomp/asmgen.cmi : bytecomp/lambda.cmi asmcomp/cmm.cmi +asmcomp/asmlibrarian.cmi : +asmcomp/asmlink.cmi : asmcomp/cmx_format.cmi +asmcomp/asmpackager.cmi : +asmcomp/clambda.cmi : bytecomp/lambda.cmi typing/ident.cmi \ asmcomp/debuginfo.cmi parsing/asttypes.cmi -asmcomp/closure.cmi: bytecomp/lambda.cmi asmcomp/clambda.cmi -asmcomp/cmm.cmi: typing/ident.cmi asmcomp/debuginfo.cmi -asmcomp/cmmgen.cmi: asmcomp/cmx_format.cmi asmcomp/cmm.cmi \ +asmcomp/closure.cmi : bytecomp/lambda.cmi asmcomp/clambda.cmi +asmcomp/cmm.cmi : typing/ident.cmi asmcomp/debuginfo.cmi +asmcomp/cmmgen.cmi : asmcomp/cmx_format.cmi asmcomp/cmm.cmi \ asmcomp/clambda.cmi -asmcomp/cmx_format.cmi: asmcomp/clambda.cmi -asmcomp/codegen.cmi: asmcomp/cmm.cmi -asmcomp/coloring.cmi: -asmcomp/comballoc.cmi: asmcomp/mach.cmi -asmcomp/compilenv.cmi: bytecomp/lambda.cmi typing/ident.cmi \ +asmcomp/cmx_format.cmi : asmcomp/clambda.cmi +asmcomp/codegen.cmi : asmcomp/cmm.cmi +asmcomp/coloring.cmi : +asmcomp/comballoc.cmi : asmcomp/mach.cmi +asmcomp/compilenv.cmi : bytecomp/lambda.cmi typing/ident.cmi \ asmcomp/cmx_format.cmi asmcomp/clambda.cmi -asmcomp/debuginfo.cmi: parsing/location.cmi bytecomp/lambda.cmi -asmcomp/emit.cmi: asmcomp/linearize.cmi asmcomp/cmm.cmi -asmcomp/emitaux.cmi: asmcomp/debuginfo.cmi -asmcomp/interf.cmi: asmcomp/mach.cmi -asmcomp/linearize.cmi: asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi -asmcomp/liveness.cmi: asmcomp/mach.cmi -asmcomp/mach.cmi: asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ +asmcomp/debuginfo.cmi : parsing/location.cmi bytecomp/lambda.cmi +asmcomp/emit.cmi : asmcomp/linearize.cmi asmcomp/cmm.cmi +asmcomp/emitaux.cmi : asmcomp/debuginfo.cmi +asmcomp/interf.cmi : asmcomp/mach.cmi +asmcomp/linearize.cmi : asmcomp/reg.cmi asmcomp/mach.cmi \ + asmcomp/debuginfo.cmi +asmcomp/liveness.cmi : asmcomp/mach.cmi +asmcomp/mach.cmi : asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ asmcomp/arch.cmo -asmcomp/printcmm.cmi: asmcomp/cmm.cmi -asmcomp/printlinear.cmi: asmcomp/linearize.cmi -asmcomp/printmach.cmi: asmcomp/reg.cmi asmcomp/mach.cmi -asmcomp/proc.cmi: asmcomp/reg.cmi asmcomp/mach.cmi -asmcomp/reg.cmi: asmcomp/cmm.cmi -asmcomp/reload.cmi: asmcomp/mach.cmi -asmcomp/reloadgen.cmi: asmcomp/reg.cmi asmcomp/mach.cmi -asmcomp/schedgen.cmi: asmcomp/mach.cmi asmcomp/linearize.cmi -asmcomp/scheduling.cmi: asmcomp/linearize.cmi -asmcomp/selectgen.cmi: utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ +asmcomp/printclambda.cmi : asmcomp/clambda.cmi +asmcomp/printcmm.cmi : asmcomp/cmm.cmi +asmcomp/printlinear.cmi : asmcomp/linearize.cmi +asmcomp/printmach.cmi : asmcomp/reg.cmi asmcomp/mach.cmi +asmcomp/proc.cmi : asmcomp/reg.cmi asmcomp/mach.cmi +asmcomp/reg.cmi : asmcomp/cmm.cmi +asmcomp/reload.cmi : asmcomp/mach.cmi +asmcomp/reloadgen.cmi : asmcomp/reg.cmi asmcomp/mach.cmi +asmcomp/schedgen.cmi : asmcomp/mach.cmi asmcomp/linearize.cmi +asmcomp/scheduling.cmi : asmcomp/linearize.cmi +asmcomp/selectgen.cmi : utils/tbl.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo -asmcomp/selection.cmi: asmcomp/mach.cmi asmcomp/cmm.cmi -asmcomp/spill.cmi: asmcomp/mach.cmi -asmcomp/split.cmi: asmcomp/mach.cmi -asmcomp/arch.cmo: -asmcomp/arch.cmx: -asmcomp/asmgen.cmo: bytecomp/translmod.cmi asmcomp/split.cmi \ +asmcomp/selection.cmi : asmcomp/mach.cmi asmcomp/cmm.cmi +asmcomp/spill.cmi : asmcomp/mach.cmi +asmcomp/split.cmi : asmcomp/mach.cmi +asmcomp/arch.cmo : +asmcomp/arch.cmx : +asmcomp/asmgen.cmo : bytecomp/translmod.cmi asmcomp/split.cmi \ asmcomp/spill.cmi asmcomp/selection.cmi asmcomp/scheduling.cmi \ asmcomp/reload.cmi asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \ asmcomp/printlinear.cmi asmcomp/printcmm.cmi typing/primitive.cmi \ - utils/misc.cmi asmcomp/mach.cmi asmcomp/liveness.cmi \ + utils/misc.cmi asmcomp/mach.cmi parsing/location.cmi asmcomp/liveness.cmi \ asmcomp/linearize.cmi asmcomp/interf.cmi asmcomp/emitaux.cmi \ asmcomp/emit.cmi utils/config.cmi asmcomp/compilenv.cmi \ asmcomp/comballoc.cmi asmcomp/coloring.cmi asmcomp/cmmgen.cmi \ asmcomp/cmm.cmi asmcomp/closure.cmi utils/clflags.cmi asmcomp/asmgen.cmi -asmcomp/asmgen.cmx: bytecomp/translmod.cmx asmcomp/split.cmx \ +asmcomp/asmgen.cmx : bytecomp/translmod.cmx asmcomp/split.cmx \ asmcomp/spill.cmx asmcomp/selection.cmx asmcomp/scheduling.cmx \ asmcomp/reload.cmx asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \ asmcomp/printlinear.cmx asmcomp/printcmm.cmx typing/primitive.cmx \ - utils/misc.cmx asmcomp/mach.cmx asmcomp/liveness.cmx \ + utils/misc.cmx asmcomp/mach.cmx parsing/location.cmx asmcomp/liveness.cmx \ asmcomp/linearize.cmx asmcomp/interf.cmx asmcomp/emitaux.cmx \ asmcomp/emit.cmx utils/config.cmx asmcomp/compilenv.cmx \ asmcomp/comballoc.cmx asmcomp/coloring.cmx asmcomp/cmmgen.cmx \ asmcomp/cmm.cmx asmcomp/closure.cmx utils/clflags.cmx asmcomp/asmgen.cmi -asmcomp/asmlibrarian.cmo: utils/misc.cmi utils/config.cmi \ +asmcomp/asmlibrarian.cmo : utils/misc.cmi utils/config.cmi \ asmcomp/compilenv.cmi asmcomp/cmx_format.cmi utils/clflags.cmi \ asmcomp/clambda.cmi utils/ccomp.cmi asmcomp/asmlink.cmi \ asmcomp/asmlibrarian.cmi -asmcomp/asmlibrarian.cmx: utils/misc.cmx utils/config.cmx \ +asmcomp/asmlibrarian.cmx : utils/misc.cmx utils/config.cmx \ asmcomp/compilenv.cmx asmcomp/cmx_format.cmi utils/clflags.cmx \ asmcomp/clambda.cmx utils/ccomp.cmx asmcomp/asmlink.cmx \ asmcomp/asmlibrarian.cmi -asmcomp/asmlink.cmo: bytecomp/runtimedef.cmi asmcomp/proc.cmi utils/misc.cmi \ - parsing/location.cmi asmcomp/emitaux.cmi asmcomp/emit.cmi \ +asmcomp/asmlink.cmo : bytecomp/runtimedef.cmi asmcomp/proc.cmi \ + utils/misc.cmi parsing/location.cmi asmcomp/emitaux.cmi asmcomp/emit.cmi \ utils/consistbl.cmi utils/config.cmi asmcomp/compilenv.cmi \ asmcomp/cmx_format.cmi asmcomp/cmmgen.cmi utils/clflags.cmi \ utils/ccomp.cmi asmcomp/asmgen.cmi asmcomp/asmlink.cmi -asmcomp/asmlink.cmx: bytecomp/runtimedef.cmx asmcomp/proc.cmx utils/misc.cmx \ - parsing/location.cmx asmcomp/emitaux.cmx asmcomp/emit.cmx \ +asmcomp/asmlink.cmx : bytecomp/runtimedef.cmx asmcomp/proc.cmx \ + utils/misc.cmx parsing/location.cmx asmcomp/emitaux.cmx asmcomp/emit.cmx \ utils/consistbl.cmx utils/config.cmx asmcomp/compilenv.cmx \ asmcomp/cmx_format.cmi asmcomp/cmmgen.cmx utils/clflags.cmx \ utils/ccomp.cmx asmcomp/asmgen.cmx asmcomp/asmlink.cmi -asmcomp/asmpackager.cmo: typing/typemod.cmi bytecomp/translmod.cmi \ +asmcomp/asmpackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \ utils/misc.cmi parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \ typing/env.cmi utils/config.cmi asmcomp/compilenv.cmi \ asmcomp/cmx_format.cmi utils/clflags.cmi asmcomp/clambda.cmi \ utils/ccomp.cmi asmcomp/asmlink.cmi asmcomp/asmgen.cmi \ asmcomp/asmpackager.cmi -asmcomp/asmpackager.cmx: typing/typemod.cmx bytecomp/translmod.cmx \ +asmcomp/asmpackager.cmx : typing/typemod.cmx bytecomp/translmod.cmx \ utils/misc.cmx parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \ typing/env.cmx utils/config.cmx asmcomp/compilenv.cmx \ asmcomp/cmx_format.cmi utils/clflags.cmx asmcomp/clambda.cmx \ utils/ccomp.cmx asmcomp/asmlink.cmx asmcomp/asmgen.cmx \ asmcomp/asmpackager.cmi -asmcomp/clambda.cmo: bytecomp/lambda.cmi typing/ident.cmi \ +asmcomp/clambda.cmo : bytecomp/lambda.cmi typing/ident.cmi \ asmcomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/clambda.cmi -asmcomp/clambda.cmx: bytecomp/lambda.cmx typing/ident.cmx \ +asmcomp/clambda.cmx : bytecomp/lambda.cmx typing/ident.cmx \ asmcomp/debuginfo.cmx parsing/asttypes.cmi asmcomp/clambda.cmi -asmcomp/closure.cmo: utils/tbl.cmi bytecomp/switch.cmi typing/primitive.cmi \ +asmcomp/closure.cmo : utils/tbl.cmi bytecomp/switch.cmi typing/primitive.cmi \ utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi asmcomp/debuginfo.cmi \ asmcomp/compilenv.cmi utils/clflags.cmi asmcomp/clambda.cmi \ parsing/asttypes.cmi asmcomp/closure.cmi -asmcomp/closure.cmx: utils/tbl.cmx bytecomp/switch.cmx typing/primitive.cmx \ +asmcomp/closure.cmx : utils/tbl.cmx bytecomp/switch.cmx typing/primitive.cmx \ utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx asmcomp/debuginfo.cmx \ asmcomp/compilenv.cmx utils/clflags.cmx asmcomp/clambda.cmx \ parsing/asttypes.cmi asmcomp/closure.cmi -asmcomp/cmm.cmo: typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/arch.cmo \ +asmcomp/cmm.cmo : typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/arch.cmo \ asmcomp/cmm.cmi -asmcomp/cmm.cmx: typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/arch.cmx \ +asmcomp/cmm.cmx : typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/arch.cmx \ asmcomp/cmm.cmi -asmcomp/cmmgen.cmo: typing/types.cmi bytecomp/switch.cmi asmcomp/proc.cmi \ +asmcomp/cmmgen.cmo : typing/types.cmi bytecomp/switch.cmi asmcomp/proc.cmi \ typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \ asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \ asmcomp/cmx_format.cmi asmcomp/cmm.cmi utils/clflags.cmi \ asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/arch.cmo \ asmcomp/cmmgen.cmi -asmcomp/cmmgen.cmx: typing/types.cmx bytecomp/switch.cmx asmcomp/proc.cmx \ +asmcomp/cmmgen.cmx : typing/types.cmx bytecomp/switch.cmx asmcomp/proc.cmx \ typing/primitive.cmx utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx \ asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \ asmcomp/cmx_format.cmi asmcomp/cmm.cmx utils/clflags.cmx \ asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \ asmcomp/cmmgen.cmi -asmcomp/codegen.cmo: asmcomp/split.cmi asmcomp/spill.cmi asmcomp/reload.cmi \ +asmcomp/codegen.cmo : asmcomp/split.cmi asmcomp/spill.cmi asmcomp/reload.cmi \ asmcomp/reg.cmi asmcomp/printmach.cmi asmcomp/printlinear.cmi \ asmcomp/printcmm.cmi asmcomp/liveness.cmi asmcomp/linearize.cmi \ asmcomp/interf.cmi asmcomp/emit.cmi asmcomp/coloring.cmi asmcomp/cmm.cmi \ asmcomp/codegen.cmi -asmcomp/codegen.cmx: asmcomp/split.cmx asmcomp/spill.cmx asmcomp/reload.cmx \ +asmcomp/codegen.cmx : asmcomp/split.cmx asmcomp/spill.cmx asmcomp/reload.cmx \ asmcomp/reg.cmx asmcomp/printmach.cmx asmcomp/printlinear.cmx \ asmcomp/printcmm.cmx asmcomp/liveness.cmx asmcomp/linearize.cmx \ asmcomp/interf.cmx asmcomp/emit.cmx asmcomp/coloring.cmx asmcomp/cmm.cmx \ asmcomp/codegen.cmi -asmcomp/coloring.cmo: asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/coloring.cmi -asmcomp/coloring.cmx: asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/coloring.cmi -asmcomp/comballoc.cmo: asmcomp/reg.cmi asmcomp/mach.cmi utils/config.cmi \ +asmcomp/coloring.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/coloring.cmi +asmcomp/coloring.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/coloring.cmi +asmcomp/comballoc.cmo : asmcomp/reg.cmi asmcomp/mach.cmi utils/config.cmi \ asmcomp/arch.cmo asmcomp/comballoc.cmi -asmcomp/comballoc.cmx: asmcomp/reg.cmx asmcomp/mach.cmx utils/config.cmx \ +asmcomp/comballoc.cmx : asmcomp/reg.cmx asmcomp/mach.cmx utils/config.cmx \ asmcomp/arch.cmx asmcomp/comballoc.cmi -asmcomp/compilenv.cmo: utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi \ - typing/env.cmi utils/config.cmi asmcomp/cmx_format.cmi \ - asmcomp/clambda.cmi asmcomp/compilenv.cmi -asmcomp/compilenv.cmx: utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx \ - typing/env.cmx utils/config.cmx asmcomp/cmx_format.cmi \ - asmcomp/clambda.cmx asmcomp/compilenv.cmi -asmcomp/debuginfo.cmo: parsing/location.cmi bytecomp/lambda.cmi \ +asmcomp/compilenv.cmo : utils/misc.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi utils/config.cmi \ + asmcomp/cmx_format.cmi asmcomp/clambda.cmi asmcomp/compilenv.cmi +asmcomp/compilenv.cmx : utils/misc.cmx parsing/location.cmx \ + bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/config.cmx \ + asmcomp/cmx_format.cmi asmcomp/clambda.cmx asmcomp/compilenv.cmi +asmcomp/debuginfo.cmo : parsing/location.cmi bytecomp/lambda.cmi \ asmcomp/debuginfo.cmi -asmcomp/debuginfo.cmx: parsing/location.cmx bytecomp/lambda.cmx \ +asmcomp/debuginfo.cmx : parsing/location.cmx bytecomp/lambda.cmx \ asmcomp/debuginfo.cmi -asmcomp/emit.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ +asmcomp/emit.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ asmcomp/mach.cmi asmcomp/linearize.cmi asmcomp/emitaux.cmi \ asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \ asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emit.cmi -asmcomp/emit.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ +asmcomp/emit.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ asmcomp/mach.cmx asmcomp/linearize.cmx asmcomp/emitaux.cmx \ asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \ asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emit.cmi -asmcomp/emitaux.cmo: asmcomp/reg.cmi asmcomp/linearize.cmi \ - asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ - asmcomp/emitaux.cmi -asmcomp/emitaux.cmx: asmcomp/reg.cmx asmcomp/linearize.cmx \ - asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ - asmcomp/emitaux.cmi -asmcomp/interf.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ +asmcomp/emitaux.cmo : asmcomp/reg.cmi asmcomp/linearize.cmi \ + asmcomp/debuginfo.cmi utils/config.cmi asmcomp/cmm.cmi utils/clflags.cmi \ + asmcomp/arch.cmo asmcomp/emitaux.cmi +asmcomp/emitaux.cmx : asmcomp/reg.cmx asmcomp/linearize.cmx \ + asmcomp/debuginfo.cmx utils/config.cmx asmcomp/cmm.cmx utils/clflags.cmx \ + asmcomp/arch.cmx asmcomp/emitaux.cmi +asmcomp/interf.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ asmcomp/mach.cmi asmcomp/interf.cmi -asmcomp/interf.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ +asmcomp/interf.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ asmcomp/mach.cmx asmcomp/interf.cmi -asmcomp/linearize.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ +asmcomp/linearize.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ asmcomp/linearize.cmi -asmcomp/linearize.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ +asmcomp/linearize.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \ asmcomp/linearize.cmi -asmcomp/liveness.cmo: asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \ - utils/misc.cmi asmcomp/mach.cmi asmcomp/liveness.cmi -asmcomp/liveness.cmx: asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \ - utils/misc.cmx asmcomp/mach.cmx asmcomp/liveness.cmi -asmcomp/mach.cmo: asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ +asmcomp/liveness.cmo : asmcomp/reg.cmi asmcomp/proc.cmi \ + asmcomp/printmach.cmi utils/misc.cmi asmcomp/mach.cmi \ + asmcomp/liveness.cmi +asmcomp/liveness.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \ + asmcomp/printmach.cmx utils/misc.cmx asmcomp/mach.cmx \ + asmcomp/liveness.cmi +asmcomp/mach.cmo : asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ asmcomp/arch.cmo asmcomp/mach.cmi -asmcomp/mach.cmx: asmcomp/reg.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \ +asmcomp/mach.cmx : asmcomp/reg.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \ asmcomp/arch.cmx asmcomp/mach.cmi -asmcomp/printcmm.cmo: typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ - asmcomp/printcmm.cmi -asmcomp/printcmm.cmx: typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \ - asmcomp/printcmm.cmi -asmcomp/printlinear.cmo: asmcomp/printmach.cmi asmcomp/mach.cmi \ +asmcomp/printclambda.cmo : bytecomp/printlambda.cmi bytecomp/lambda.cmi \ + typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/clambda.cmi \ + parsing/asttypes.cmi asmcomp/printclambda.cmi +asmcomp/printclambda.cmx : bytecomp/printlambda.cmx bytecomp/lambda.cmx \ + typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/clambda.cmx \ + parsing/asttypes.cmi asmcomp/printclambda.cmi +asmcomp/printcmm.cmo : typing/ident.cmi asmcomp/debuginfo.cmi \ + asmcomp/cmm.cmi asmcomp/printcmm.cmi +asmcomp/printcmm.cmx : typing/ident.cmx asmcomp/debuginfo.cmx \ + asmcomp/cmm.cmx asmcomp/printcmm.cmi +asmcomp/printlinear.cmo : asmcomp/printmach.cmi asmcomp/mach.cmi \ asmcomp/linearize.cmi asmcomp/debuginfo.cmi asmcomp/printlinear.cmi -asmcomp/printlinear.cmx: asmcomp/printmach.cmx asmcomp/mach.cmx \ +asmcomp/printlinear.cmx : asmcomp/printmach.cmx asmcomp/mach.cmx \ asmcomp/linearize.cmx asmcomp/debuginfo.cmx asmcomp/printlinear.cmi -asmcomp/printmach.cmo: asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printcmm.cmi \ - asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ - asmcomp/printmach.cmi -asmcomp/printmach.cmx: asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printcmm.cmx \ - asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ - asmcomp/printmach.cmi -asmcomp/proc.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ +asmcomp/printmach.cmo : asmcomp/reg.cmi asmcomp/proc.cmi \ + asmcomp/printcmm.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi \ + asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/printmach.cmi +asmcomp/printmach.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \ + asmcomp/printcmm.cmx asmcomp/mach.cmx asmcomp/debuginfo.cmx \ + asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/printmach.cmi +asmcomp/proc.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ utils/config.cmi asmcomp/cmm.cmi utils/clflags.cmi utils/ccomp.cmi \ asmcomp/arch.cmo asmcomp/proc.cmi -asmcomp/proc.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ +asmcomp/proc.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ utils/config.cmx asmcomp/cmm.cmx utils/clflags.cmx utils/ccomp.cmx \ asmcomp/arch.cmx asmcomp/proc.cmi -asmcomp/reg.cmo: asmcomp/cmm.cmi asmcomp/reg.cmi -asmcomp/reg.cmx: asmcomp/cmm.cmx asmcomp/reg.cmi -asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ +asmcomp/reg.cmo : asmcomp/cmm.cmi asmcomp/reg.cmi +asmcomp/reg.cmx : asmcomp/cmm.cmx asmcomp/reg.cmi +asmcomp/reload.cmo : asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/reload.cmi -asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \ +asmcomp/reload.cmx : asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \ asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/reload.cmi -asmcomp/reloadgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ +asmcomp/reloadgen.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ asmcomp/reloadgen.cmi -asmcomp/reloadgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ +asmcomp/reloadgen.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ asmcomp/reloadgen.cmi -asmcomp/schedgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ +asmcomp/schedgen.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ asmcomp/schedgen.cmi -asmcomp/schedgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ +asmcomp/schedgen.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ asmcomp/linearize.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ asmcomp/schedgen.cmi -asmcomp/scheduling.cmo: asmcomp/schedgen.cmi asmcomp/scheduling.cmi -asmcomp/scheduling.cmx: asmcomp/schedgen.cmx asmcomp/scheduling.cmi -asmcomp/selectgen.cmo: utils/tbl.cmi bytecomp/simplif.cmi asmcomp/reg.cmi \ +asmcomp/scheduling.cmo : asmcomp/schedgen.cmi asmcomp/scheduling.cmi +asmcomp/scheduling.cmx : asmcomp/schedgen.cmx asmcomp/scheduling.cmi +asmcomp/selectgen.cmo : utils/tbl.cmi bytecomp/simplif.cmi asmcomp/reg.cmi \ asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi typing/ident.cmi \ asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ asmcomp/selectgen.cmi -asmcomp/selectgen.cmx: utils/tbl.cmx bytecomp/simplif.cmx asmcomp/reg.cmx \ +asmcomp/selectgen.cmx : utils/tbl.cmx bytecomp/simplif.cmx asmcomp/reg.cmx \ asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx typing/ident.cmx \ asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ asmcomp/selectgen.cmi -asmcomp/selection.cmo: asmcomp/selectgen.cmi asmcomp/reg.cmi asmcomp/proc.cmi \ - utils/misc.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ +asmcomp/selection.cmo : asmcomp/selectgen.cmi asmcomp/reg.cmi \ + asmcomp/proc.cmi utils/misc.cmi asmcomp/mach.cmi asmcomp/cmm.cmi \ utils/clflags.cmi asmcomp/arch.cmo asmcomp/selection.cmi -asmcomp/selection.cmx: asmcomp/selectgen.cmx asmcomp/reg.cmx asmcomp/proc.cmx \ - utils/misc.cmx asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \ +asmcomp/selection.cmx : asmcomp/selectgen.cmx asmcomp/reg.cmx \ + asmcomp/proc.cmx utils/misc.cmx asmcomp/mach.cmx asmcomp/cmm.cmx \ utils/clflags.cmx asmcomp/arch.cmx asmcomp/selection.cmi -asmcomp/spill.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ +asmcomp/spill.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ asmcomp/mach.cmi asmcomp/spill.cmi -asmcomp/spill.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ +asmcomp/spill.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ asmcomp/mach.cmx asmcomp/spill.cmi -asmcomp/split.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ +asmcomp/split.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ asmcomp/split.cmi -asmcomp/split.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ +asmcomp/split.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ asmcomp/split.cmi -driver/compile.cmi: typing/env.cmi -driver/errors.cmi: -driver/main.cmi: -driver/main_args.cmi: -driver/optcompile.cmi: typing/env.cmi -driver/opterrors.cmi: -driver/optmain.cmi: -driver/pparse.cmi: -driver/compile.cmo: utils/warnings.cmi typing/typemod.cmi \ +driver/compile.cmi : typing/env.cmi +driver/errors.cmi : +driver/main.cmi : +driver/main_args.cmi : +driver/optcompile.cmi : typing/env.cmi +driver/opterrors.cmi : +driver/optmain.cmi : +driver/pparse.cmi : +driver/compile.cmo : utils/warnings.cmi typing/typemod.cmi \ typing/typedtree.cmi bytecomp/translmod.cmi typing/stypes.cmi \ bytecomp/simplif.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \ bytecomp/printinstr.cmi parsing/printast.cmi driver/pparse.cmi \ parsing/parse.cmi utils/misc.cmi parsing/location.cmi typing/ident.cmi \ typing/env.cmi bytecomp/emitcode.cmi utils/config.cmi utils/clflags.cmi \ utils/ccomp.cmi bytecomp/bytegen.cmi driver/compile.cmi -driver/compile.cmx: utils/warnings.cmx typing/typemod.cmx \ +driver/compile.cmx : utils/warnings.cmx typing/typemod.cmx \ typing/typedtree.cmx bytecomp/translmod.cmx typing/stypes.cmx \ bytecomp/simplif.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \ bytecomp/printinstr.cmx parsing/printast.cmx driver/pparse.cmx \ parsing/parse.cmx utils/misc.cmx parsing/location.cmx typing/ident.cmx \ typing/env.cmx bytecomp/emitcode.cmx utils/config.cmx utils/clflags.cmx \ utils/ccomp.cmx bytecomp/bytegen.cmx driver/compile.cmi -driver/errors.cmo: utils/warnings.cmi typing/typetexp.cmi typing/typemod.cmi \ - typing/typedecl.cmi typing/typecore.cmi typing/typeclass.cmi \ - bytecomp/translmod.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \ - parsing/syntaxerr.cmi bytecomp/symtable.cmi driver/pparse.cmi \ - parsing/location.cmi parsing/lexer.cmi typing/includemod.cmi \ - typing/env.cmi typing/ctype.cmi bytecomp/bytepackager.cmi \ - bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi driver/errors.cmi -driver/errors.cmx: utils/warnings.cmx typing/typetexp.cmx typing/typemod.cmx \ - typing/typedecl.cmx typing/typecore.cmx typing/typeclass.cmx \ - bytecomp/translmod.cmx bytecomp/translcore.cmx bytecomp/translclass.cmx \ - parsing/syntaxerr.cmx bytecomp/symtable.cmx driver/pparse.cmx \ - parsing/location.cmx parsing/lexer.cmx typing/includemod.cmx \ - typing/env.cmx typing/ctype.cmx bytecomp/bytepackager.cmx \ - bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmx driver/errors.cmi -driver/main.cmo: utils/warnings.cmi utils/misc.cmi driver/main_args.cmi \ +driver/errors.cmo : utils/warnings.cmi typing/typetexp.cmi \ + typing/typemod.cmi typing/typedecl.cmi typing/typecore.cmi \ + typing/typeclass.cmi bytecomp/translmod.cmi bytecomp/translcore.cmi \ + bytecomp/translclass.cmi parsing/syntaxerr.cmi bytecomp/symtable.cmi \ + driver/pparse.cmi parsing/location.cmi parsing/lexer.cmi \ + typing/includemod.cmi typing/env.cmi typing/ctype.cmi \ + 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 \ + typing/typeclass.cmx bytecomp/translmod.cmx bytecomp/translcore.cmx \ + bytecomp/translclass.cmx parsing/syntaxerr.cmx bytecomp/symtable.cmx \ + driver/pparse.cmx parsing/location.cmx parsing/lexer.cmx \ + typing/includemod.cmx typing/env.cmx typing/ctype.cmx \ + 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 \ driver/compile.cmi utils/clflags.cmi bytecomp/bytepackager.cmi \ bytecomp/bytelink.cmi bytecomp/bytelibrarian.cmi driver/main.cmi -driver/main.cmx: utils/warnings.cmx utils/misc.cmx driver/main_args.cmx \ +driver/main.cmx : utils/warnings.cmx utils/misc.cmx driver/main_args.cmx \ parsing/location.cmx driver/errors.cmx utils/config.cmx \ driver/compile.cmx utils/clflags.cmx bytecomp/bytepackager.cmx \ bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmx driver/main.cmi -driver/main_args.cmo: utils/warnings.cmi driver/main_args.cmi -driver/main_args.cmx: utils/warnings.cmx driver/main_args.cmi -driver/optcompile.cmo: utils/warnings.cmi typing/typemod.cmi \ +driver/main_args.cmo : utils/warnings.cmi driver/main_args.cmi +driver/main_args.cmx : utils/warnings.cmx driver/main_args.cmi +driver/optcompile.cmo : utils/warnings.cmi typing/typemod.cmi \ typing/typedtree.cmi bytecomp/translmod.cmi typing/stypes.cmi \ bytecomp/simplif.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \ parsing/printast.cmi driver/pparse.cmi parsing/parse.cmi utils/misc.cmi \ parsing/location.cmi typing/ident.cmi typing/env.cmi utils/config.cmi \ asmcomp/compilenv.cmi utils/clflags.cmi utils/ccomp.cmi \ asmcomp/asmgen.cmi driver/optcompile.cmi -driver/optcompile.cmx: utils/warnings.cmx typing/typemod.cmx \ +driver/optcompile.cmx : utils/warnings.cmx typing/typemod.cmx \ typing/typedtree.cmx bytecomp/translmod.cmx typing/stypes.cmx \ bytecomp/simplif.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \ parsing/printast.cmx driver/pparse.cmx parsing/parse.cmx utils/misc.cmx \ parsing/location.cmx typing/ident.cmx typing/env.cmx utils/config.cmx \ asmcomp/compilenv.cmx utils/clflags.cmx utils/ccomp.cmx \ asmcomp/asmgen.cmx driver/optcompile.cmi -driver/opterrors.cmo: utils/warnings.cmi typing/typetexp.cmi \ +driver/opterrors.cmo : utils/warnings.cmi typing/typetexp.cmi \ typing/typemod.cmi typing/typedecl.cmi typing/typecore.cmi \ typing/typeclass.cmi bytecomp/translmod.cmi bytecomp/translcore.cmi \ bytecomp/translclass.cmi parsing/syntaxerr.cmi driver/pparse.cmi \ 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 -driver/opterrors.cmx: utils/warnings.cmx typing/typetexp.cmx \ + 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 -driver/optmain.cmo: utils/warnings.cmi asmcomp/printmach.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 \ utils/clflags.cmi asmcomp/asmpackager.cmi asmcomp/asmlink.cmi \ asmcomp/asmlibrarian.cmi asmcomp/arch.cmo driver/optmain.cmi -driver/optmain.cmx: utils/warnings.cmx asmcomp/printmach.cmx \ +driver/optmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \ driver/opterrors.cmx driver/optcompile.cmx utils/misc.cmx \ driver/main_args.cmx parsing/location.cmx utils/config.cmx \ utils/clflags.cmx asmcomp/asmpackager.cmx asmcomp/asmlink.cmx \ asmcomp/asmlibrarian.cmx asmcomp/arch.cmx driver/optmain.cmi -driver/pparse.cmo: utils/misc.cmi parsing/location.cmi utils/clflags.cmi \ +driver/pparse.cmo : utils/misc.cmi parsing/location.cmi utils/clflags.cmi \ utils/ccomp.cmi driver/pparse.cmi -driver/pparse.cmx: utils/misc.cmx parsing/location.cmx utils/clflags.cmx \ +driver/pparse.cmx : utils/misc.cmx parsing/location.cmx utils/clflags.cmx \ utils/ccomp.cmx driver/pparse.cmi -toplevel/genprintval.cmi: typing/types.cmi typing/path.cmi \ +toplevel/genprintval.cmi : typing/types.cmi typing/path.cmi \ typing/outcometree.cmi typing/env.cmi -toplevel/opttopdirs.cmi: parsing/longident.cmi -toplevel/opttoploop.cmi: utils/warnings.cmi typing/types.cmi typing/path.cmi \ - parsing/parsetree.cmi typing/outcometree.cmi parsing/longident.cmi \ - parsing/location.cmi typing/env.cmi -toplevel/opttopmain.cmi: -toplevel/topdirs.cmi: parsing/longident.cmi -toplevel/toploop.cmi: utils/warnings.cmi typing/types.cmi typing/path.cmi \ +toplevel/opttopdirs.cmi : parsing/longident.cmi +toplevel/opttoploop.cmi : utils/warnings.cmi typing/types.cmi \ + typing/path.cmi parsing/parsetree.cmi typing/outcometree.cmi \ + parsing/longident.cmi parsing/location.cmi typing/env.cmi +toplevel/opttopmain.cmi : +toplevel/topdirs.cmi : parsing/longident.cmi +toplevel/toploop.cmi : utils/warnings.cmi typing/types.cmi typing/path.cmi \ parsing/parsetree.cmi typing/outcometree.cmi parsing/longident.cmi \ parsing/location.cmi typing/env.cmi -toplevel/topmain.cmi: -toplevel/trace.cmi: typing/types.cmi typing/path.cmi parsing/longident.cmi \ +toplevel/topmain.cmi : +toplevel/trace.cmi : typing/types.cmi typing/path.cmi parsing/longident.cmi \ typing/env.cmi -toplevel/expunge.cmo: bytecomp/symtable.cmi bytecomp/runtimedef.cmi \ +toplevel/expunge.cmo : bytecomp/symtable.cmi bytecomp/runtimedef.cmi \ utils/misc.cmi typing/ident.cmi bytecomp/bytesections.cmi -toplevel/expunge.cmx: bytecomp/symtable.cmx bytecomp/runtimedef.cmx \ +toplevel/expunge.cmx : bytecomp/symtable.cmx bytecomp/runtimedef.cmx \ utils/misc.cmx typing/ident.cmx bytecomp/bytesections.cmx -toplevel/genprintval.cmo: typing/types.cmi typing/printtyp.cmi \ +toplevel/genprintval.cmo : typing/types.cmi typing/printtyp.cmi \ typing/predef.cmi typing/path.cmi typing/outcometree.cmi utils/misc.cmi \ parsing/longident.cmi typing/ident.cmi typing/env.cmi typing/datarepr.cmi \ typing/ctype.cmi typing/btype.cmi toplevel/genprintval.cmi -toplevel/genprintval.cmx: typing/types.cmx typing/printtyp.cmx \ +toplevel/genprintval.cmx : typing/types.cmx typing/printtyp.cmx \ typing/predef.cmx typing/path.cmx typing/outcometree.cmi utils/misc.cmx \ parsing/longident.cmx typing/ident.cmx typing/env.cmx typing/datarepr.cmx \ typing/ctype.cmx typing/btype.cmx toplevel/genprintval.cmi -toplevel/opttopdirs.cmo: utils/warnings.cmi typing/types.cmi \ +toplevel/opttopdirs.cmo : utils/warnings.cmi typing/types.cmi \ typing/printtyp.cmi typing/path.cmi toplevel/opttoploop.cmi \ utils/misc.cmi parsing/longident.cmi typing/ident.cmi typing/env.cmi \ typing/ctype.cmi utils/config.cmi utils/clflags.cmi asmcomp/asmlink.cmi \ toplevel/opttopdirs.cmi -toplevel/opttopdirs.cmx: utils/warnings.cmx typing/types.cmx \ +toplevel/opttopdirs.cmx : utils/warnings.cmx typing/types.cmx \ typing/printtyp.cmx typing/path.cmx toplevel/opttoploop.cmx \ utils/misc.cmx parsing/longident.cmx typing/ident.cmx typing/env.cmx \ typing/ctype.cmx utils/config.cmx utils/clflags.cmx asmcomp/asmlink.cmx \ toplevel/opttopdirs.cmi -toplevel/opttoploop.cmo: utils/warnings.cmi typing/types.cmi \ +toplevel/opttoploop.cmo : utils/warnings.cmi typing/types.cmi \ typing/typemod.cmi typing/typedtree.cmi typing/typecore.cmi \ bytecomp/translmod.cmi bytecomp/simplif.cmi typing/printtyp.cmi \ bytecomp/printlambda.cmi parsing/printast.cmi typing/predef.cmi \ @@ -852,7 +912,7 @@ toplevel/opttoploop.cmo: utils/warnings.cmi typing/types.cmi \ typing/ident.cmi toplevel/genprintval.cmi typing/env.cmi utils/config.cmi \ asmcomp/compilenv.cmi utils/clflags.cmi typing/btype.cmi \ asmcomp/asmlink.cmi asmcomp/asmgen.cmi toplevel/opttoploop.cmi -toplevel/opttoploop.cmx: utils/warnings.cmx typing/types.cmx \ +toplevel/opttoploop.cmx : utils/warnings.cmx typing/types.cmx \ typing/typemod.cmx typing/typedtree.cmx typing/typecore.cmx \ bytecomp/translmod.cmx bytecomp/simplif.cmx typing/printtyp.cmx \ bytecomp/printlambda.cmx parsing/printast.cmx typing/predef.cmx \ @@ -863,63 +923,67 @@ toplevel/opttoploop.cmx: utils/warnings.cmx typing/types.cmx \ typing/ident.cmx toplevel/genprintval.cmx typing/env.cmx utils/config.cmx \ asmcomp/compilenv.cmx utils/clflags.cmx typing/btype.cmx \ asmcomp/asmlink.cmx asmcomp/asmgen.cmx toplevel/opttoploop.cmi -toplevel/opttopmain.cmo: utils/warnings.cmi asmcomp/printmach.cmi \ +toplevel/opttopmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \ toplevel/opttoploop.cmi toplevel/opttopdirs.cmi driver/opterrors.cmi \ utils/misc.cmi driver/main_args.cmi parsing/location.cmi utils/config.cmi \ utils/clflags.cmi toplevel/opttopmain.cmi -toplevel/opttopmain.cmx: utils/warnings.cmx asmcomp/printmach.cmx \ +toplevel/opttopmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \ toplevel/opttoploop.cmx toplevel/opttopdirs.cmx driver/opterrors.cmx \ utils/misc.cmx driver/main_args.cmx parsing/location.cmx utils/config.cmx \ utils/clflags.cmx toplevel/opttopmain.cmi -toplevel/opttopstart.cmo: toplevel/opttopmain.cmi -toplevel/opttopstart.cmx: toplevel/opttopmain.cmx -toplevel/topdirs.cmo: utils/warnings.cmi typing/types.cmi toplevel/trace.cmi \ - toplevel/toploop.cmi bytecomp/symtable.cmi typing/printtyp.cmi \ - typing/path.cmi bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi \ - parsing/longident.cmi typing/ident.cmi typing/env.cmi bytecomp/dll.cmi \ - typing/ctype.cmi utils/consistbl.cmi utils/config.cmi \ +toplevel/opttopstart.cmo : toplevel/opttopmain.cmi +toplevel/opttopstart.cmx : toplevel/opttopmain.cmx +toplevel/topdirs.cmo : utils/warnings.cmi typing/types.cmi \ + toplevel/trace.cmi toplevel/toploop.cmi bytecomp/symtable.cmi \ + typing/printtyp.cmi typing/path.cmi bytecomp/opcodes.cmo utils/misc.cmi \ + bytecomp/meta.cmi parsing/longident.cmi typing/ident.cmi typing/env.cmi \ + bytecomp/dll.cmi typing/ctype.cmi utils/consistbl.cmi utils/config.cmi \ bytecomp/cmo_format.cmi utils/clflags.cmi toplevel/topdirs.cmi -toplevel/topdirs.cmx: utils/warnings.cmx typing/types.cmx toplevel/trace.cmx \ - toplevel/toploop.cmx bytecomp/symtable.cmx typing/printtyp.cmx \ - typing/path.cmx bytecomp/opcodes.cmx utils/misc.cmx bytecomp/meta.cmx \ - parsing/longident.cmx typing/ident.cmx typing/env.cmx bytecomp/dll.cmx \ - typing/ctype.cmx utils/consistbl.cmx utils/config.cmx \ +toplevel/topdirs.cmx : utils/warnings.cmx typing/types.cmx \ + toplevel/trace.cmx toplevel/toploop.cmx bytecomp/symtable.cmx \ + typing/printtyp.cmx typing/path.cmx bytecomp/opcodes.cmx utils/misc.cmx \ + bytecomp/meta.cmx parsing/longident.cmx typing/ident.cmx typing/env.cmx \ + bytecomp/dll.cmx typing/ctype.cmx utils/consistbl.cmx utils/config.cmx \ bytecomp/cmo_format.cmi utils/clflags.cmx toplevel/topdirs.cmi -toplevel/toploop.cmo: utils/warnings.cmi typing/types.cmi typing/typemod.cmi \ - typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \ - bytecomp/symtable.cmi bytecomp/simplif.cmi typing/printtyp.cmi \ - bytecomp/printlambda.cmi bytecomp/printinstr.cmi parsing/printast.cmi \ - typing/predef.cmi typing/path.cmi parsing/parsetree.cmi parsing/parse.cmi \ - typing/outcometree.cmi typing/oprint.cmi utils/misc.cmi bytecomp/meta.cmi \ - parsing/longident.cmi parsing/location.cmi parsing/lexer.cmi \ +toplevel/toploop.cmo : utils/warnings.cmi typing/types.cmi \ + typing/typemod.cmi typing/typedtree.cmi typing/typecore.cmi \ + bytecomp/translmod.cmi bytecomp/symtable.cmi bytecomp/simplif.cmi \ + typing/printtyp.cmi bytecomp/printlambda.cmi bytecomp/printinstr.cmi \ + parsing/printast.cmi typing/predef.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/parse.cmi typing/outcometree.cmi \ + typing/oprint.cmi utils/misc.cmi bytecomp/meta.cmi parsing/longident.cmi \ + parsing/location.cmi parsing/lexer.cmi typing/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 typing/typemod.cmx \ - typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \ - bytecomp/symtable.cmx bytecomp/simplif.cmx typing/printtyp.cmx \ - bytecomp/printlambda.cmx bytecomp/printinstr.cmx parsing/printast.cmx \ - typing/predef.cmx typing/path.cmx parsing/parsetree.cmi parsing/parse.cmx \ - typing/outcometree.cmi typing/oprint.cmx utils/misc.cmx bytecomp/meta.cmx \ - parsing/longident.cmx parsing/location.cmx parsing/lexer.cmx \ +toplevel/toploop.cmx : utils/warnings.cmx typing/types.cmx \ + typing/typemod.cmx typing/typedtree.cmx typing/typecore.cmx \ + bytecomp/translmod.cmx bytecomp/symtable.cmx bytecomp/simplif.cmx \ + typing/printtyp.cmx bytecomp/printlambda.cmx bytecomp/printinstr.cmx \ + parsing/printast.cmx typing/predef.cmx typing/path.cmx \ + parsing/parsetree.cmi parsing/parse.cmx typing/outcometree.cmi \ + typing/oprint.cmx utils/misc.cmx bytecomp/meta.cmx parsing/longident.cmx \ + parsing/location.cmx parsing/lexer.cmx typing/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 \ +toplevel/topmain.cmo : utils/warnings.cmi toplevel/toploop.cmi \ toplevel/topdirs.cmi utils/misc.cmi driver/main_args.cmi \ parsing/location.cmi driver/errors.cmi utils/config.cmi utils/clflags.cmi \ toplevel/topmain.cmi -toplevel/topmain.cmx: utils/warnings.cmx toplevel/toploop.cmx \ +toplevel/topmain.cmx : utils/warnings.cmx toplevel/toploop.cmx \ toplevel/topdirs.cmx utils/misc.cmx driver/main_args.cmx \ parsing/location.cmx driver/errors.cmx utils/config.cmx utils/clflags.cmx \ toplevel/topmain.cmi -toplevel/topstart.cmo: toplevel/topmain.cmi -toplevel/topstart.cmx: toplevel/topmain.cmx -toplevel/trace.cmo: typing/types.cmi toplevel/toploop.cmi typing/printtyp.cmi \ - typing/predef.cmi typing/path.cmi utils/misc.cmi bytecomp/meta.cmi \ - parsing/longident.cmi typing/ctype.cmi toplevel/trace.cmi -toplevel/trace.cmx: typing/types.cmx toplevel/toploop.cmx typing/printtyp.cmx \ - typing/predef.cmx typing/path.cmx utils/misc.cmx bytecomp/meta.cmx \ - parsing/longident.cmx typing/ctype.cmx toplevel/trace.cmi +toplevel/topstart.cmo : toplevel/topmain.cmi +toplevel/topstart.cmx : toplevel/topmain.cmx +toplevel/trace.cmo : typing/types.cmi toplevel/toploop.cmi \ + typing/printtyp.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \ + bytecomp/meta.cmi parsing/longident.cmi typing/ctype.cmi \ + toplevel/trace.cmi +toplevel/trace.cmx : typing/types.cmx toplevel/toploop.cmx \ + typing/printtyp.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \ + bytecomp/meta.cmx parsing/longident.cmx typing/ctype.cmx \ + toplevel/trace.cmi @@ -1,12 +1,22 @@ -OCaml 3.13.0: +OCaml 4.00.1: ------------- +Bug fixes: +- PR#5700: crash with native-code stack backtraces under MacOS 10.8 x86-64 +- PR#5712: some documentation problems +- PR#5718: false positive on 'unused constructor' warning +- PR#5719: ocamlyacc generates code that is not warning 33-compliant + +OCaml 4.00.0: +------------- + +(Changes that can break existing programs are marked with a "*") + - The official name of the language is now OCaml. Language features: -- Added Generalized Abstract Data Types (GADTs) to the language. See - testsuite/tests/typing-gadts for the syntax and some examples of - use. Please use -principal for testing. +- Added Generalized Algebraic 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. @@ -18,11 +28,40 @@ Compilers: - Better reporting of compiler version mismatch in .cmi files * Warning 28 is now enabled by default. - New option -absname to use absolute paths in error messages +- Optimize away compile-time beta-redexes, e.g. (fun x y -> e) a b. +- 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) - Small improvements in code generated for array bounds checks (PR#5345, PR#5360). +* New ARM backend (PR#5433): + . Supports both Linux/EABI (armel) and Linux/EABI+VFPv3 (armhf). + . Added support for the Thumb-2 instruction set with average code size + savings of 28%. + . Added support for position-independent code, natdynlink, profiling and + exception backtraces. +- 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) @@ -33,59 +72,267 @@ 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#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 +- PR#4705: camlp4 does not allow to define types with `True or `False +- PR#4746: wrong detection of stack overflows in native code under Linux - PR#4869: rare collisions between assembly labels for code and data - PR#4880: "assert" constructs now show up in the exception stack backtrace +- PR#4892: Array.set could raise "out of bounds" before evaluating 3rd arg +- PR#4937: camlp4 incorrectly handles optional arguments if 'option' is + redefined +- PR#5024: camlp4r now handles underscores in irrefutable 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#5291: undetected loop in class initialization +- 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 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#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#4688: (Windows) special floating-point values aren't converted to strings correctly +- 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 +- PR#5509: misclassification of statically-allocated empty array that + falls exactly at beginning of an otherwise unused data page. +- PR#5510: ocamldep has duplicate -ml{,i}-synonym options +- PR#5511: in Bigarray.reshape, unwarranted limitation on new array dimensions. +- PR#5513: Int64.div causes floating point exception (ocamlopt, x86) +- PR#5516: in Bigarray C stubs, use C99 flexible array types if possible +- PR#5518: segfault with lazy empty array +- PR#5531: Allow ocamlbuild to add ocamldoc flags through -docflag + and -docflags switches +- PR#5538: combining -i and -annot in ocamlc +- PR#5543: in Bigarray.map_file, try to avoid using lseek() when growing file +- 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 -- PR5475: Wrapper script for interpreted LablTk wrongly handles command line parameters -- PR5461: Double linking of bytecode modules +- 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#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 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. OCaml 3.12.1: ----------------------- +------------- Bug fixes: - PR#4345, PR#4767: problems with camlp4 printing of float values @@ -2807,5 +3054,3 @@ Caml Special Light 1.06: ------------------------ * First public release. - -$Id$ @@ -43,18 +43,21 @@ in the config/ subdirectory. The "configure" script accepts the following options: --bindir <dir> (default: /usr/local/bin) - Directory where the binaries will be installed +-prefix <dir> (default: /usr/local) + Set the PREFIX variable used to define the defaults of the + following three options. Must be an absolute path name. --libdir <dir> (default: /usr/local/lib/ocaml) - Directory where the Caml library will be installed +-bindir <dir> (default: $(PREFIX)/bin) + Directory where the binaries will be installed. + Must be an absolute path name, or start with "$(PREFIX)" --mandir <dir> (default: /usr/local/man/man1) - Directory where the manual pages will be installed +-libdir <dir> (default: $(PREFIX)/lib/ocaml) + Directory where the OCaml library will be installed + Must be an absolute path name, or start with "$(PREFIX)" --prefix <dir> (default: /usr/local) - Set bindir, libdir and mandir to - <dir>/bin, <dir>/lib/ocaml, <dir>/man/man1 respectively. +-mandir <dir> (default: $(PREFIX)/man/man1) + Directory where the manual pages will be installed + Must be an absolute path name, or start with "$(PREFIX)" -cc <C compiler and options> (default: gcc if available, cc otherwise) C compiler to use for building the system @@ -67,10 +70,11 @@ The "configure" script accepts the following options: -host <hosttype> (default: determined automatically) The type of the host machine, in GNU's "configuration name" - format (CPU-COMPANY-SYSTEM). This info is generally determined - automatically by the "configure" script, and rarely ever - needs to be provided by hand. The installation instructions - for gcc or emacs contain a complete list of configuration names. + format (CPU-COMPANY-SYSTEM or CPU-COMPANY-KERNEL-SYSTEM). + This info is generally determined automatically by the + "configure" script, and rarely ever needs to be provided by + hand. The installation instructions for gcc or emacs contain a + complete list of configuration names. -x11include <include_dir> (default: determined automatically) -x11lib <lib_dir> (default: determined automatically) @@ -127,6 +131,16 @@ The "configure" script accepts the following options: Verbose output of the configuration tests. Use it if the outcome of configure is not what you were expecting. +-no-camlp4 + Do not compile Camlp4. + +-no-graph + Do not compile the Graphics library. + +-partialld <linker and options> (default: determined automatically) + The linker and options to use for producing an object file + (rather than an executable) from several other object files. + Examples: Standard installation in /usr/{bin,lib,man} instead of /usr/local: @@ -134,6 +148,8 @@ Examples: Installation in /usr, man pages in section "l": ./configure -bindir /usr/bin -libdir /usr/lib/ocaml -mandir /usr/man/manl + or: + ./configure -prefix /usr -mandir '$(PREFIX)/man/manl' On a MacOSX 10.5/Intel Core 2 or MacOSX 10.5/PowerPC host, to build a 64-bit version of OCaml: @@ -146,13 +162,16 @@ Examples: ./configure -cc "gcc -m32" -as "as --32" -aspp "gcc -m32 -c" On a Linux x86/64 bits host, to build the run-time system in PIC mode - (enables putting the runtime in a shared library, + (enables putting the runtime in a shared library, at a small performance cost): ./configure -cc "gcc -fPIC" -aspp "gcc -c -fPIC" For Sun Solaris with the "acc" compiler: ./configure -cc "acc -fast" -libs "-lucb" + For Sun Solaris on Sparc 64bit, to compile natively (32bit only) + ./configure -cc "gcc -m32" -as "as -32" -aspp "gcc -m32 -c" + For AIX 4.3 with the IBM compiler xlc: ./configure -cc "xlc_r -D_AIX43 -Wl,-bexpall,-brtl -qmaxmem=8192" @@ -237,9 +256,9 @@ autoconfiguration): ocamllex the lexer generator ocaml the interactive, toplevel-based system ocamlmktop a tool to make toplevel systems that integrate - user-defined C primitives and Caml code + user-defined C primitives and OCaml code ocamldebug the source-level replay debugger - ocamldep generator of "make" dependencies for Caml sources + ocamldep generator of "make" dependencies for OCaml sources ocamldoc documentation generator ocamlprof execution count profiler ocamlcp the bytecode compiler in profiling mode @@ -271,7 +290,7 @@ In the latter case, the destination directory defaults to the 9- After installation, do *not* strip the ocamldebug and ocamlbrowser executables. (These are mixed-mode executables, containing both -compiled C code and Caml bytecode; stripping erases the bytecode!) +compiled C code and OCaml bytecode; stripping erases the bytecode!) Other executables such as ocamlrun can safely be stripped. IF SOMETHING GOES WRONG: @@ -19,7 +19,7 @@ include stdlib/StdlibModules CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink -COMPFLAGS=-strict-sequence -warn-error A $(INCLUDES) +COMPFLAGS= -strict-sequence -warn-error A $(INCLUDES) LINKFLAGS= CAMLYACC=boot/ocamlyacc @@ -31,6 +31,9 @@ CAMLRUN=byterun/ocamlrun SHELL=/bin/sh MKDIR=mkdir -p +CAMLP4OUT=$(CAMLP4:=out) +CAMLP4OPT=$(CAMLP4:=opt) + INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \ -I toplevel @@ -38,8 +41,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 @@ -48,12 +49,12 @@ 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/stypes.cmo typing/typecore.cmo \ + typing/cmt_format.cmo typing/stypes.cmo typing/typecore.cmo \ typing/typedecl.cmo typing/typeclass.cmo \ typing/typemod.cmo @@ -61,17 +62,21 @@ 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 \ asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \ - asmcomp/clambda.cmo asmcomp/compilenv.cmo \ + asmcomp/clambda.cmo asmcomp/printclambda.cmo asmcomp/compilenv.cmo \ asmcomp/closure.cmo asmcomp/cmmgen.cmo \ asmcomp/printmach.cmo asmcomp/selectgen.cmo asmcomp/selection.cmo \ asmcomp/comballoc.cmo asmcomp/liveness.cmo \ @@ -81,42 +86,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 - -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) +BYTESTART=driver/main.cmo -TOPLIB=$(UTILS) $(PARSING) $(TYPING) $(COMP) $(BYTECOMP) $(TOPLEVEL) +OPTSTART=driver/optmain.cmo -TOPOBJS=$(TOPLEVELLIB) $(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) outcometree topdirs toploop # For users who don't read the INSTALL file @@ -131,7 +116,7 @@ defaultentry: # Recompile the system using the bootstrap compiler all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml \ - otherlibraries ocamlbuild.byte camlp4out $(DEBUGGER) ocamldoc + otherlibraries ocamlbuild.byte $(CAMLP4OUT) $(DEBUGGER) ocamldoc # Compile everything the first time world: @@ -142,6 +127,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) @@ -260,25 +246,31 @@ opt: $(MAKE) ocamlopt $(MAKE) libraryopt $(MAKE) otherlibrariesopt + $(MAKE) ocamltoolsopt $(MAKE) ocamlbuildlib.native # Native-code versions of the tools opt.opt: checkstack runtime core ocaml opt-core ocamlc.opt otherlibraries \ - $(DEBUGGER) ocamldoc ocamlbuild.byte camlp4out \ + $(DEBUGGER) ocamldoc ocamlbuild.byte $(CAMLP4OUT) \ ocamlopt.opt otherlibrariesopt ocamllex.opt ocamltoolsopt.opt \ - ocamldoc.opt ocamlbuild.native camlp4opt + ocamldoc.opt ocamlbuild.native $(CAMLP4OPT) base.opt: checkstack runtime core ocaml opt-core ocamlc.opt otherlibraries \ - ocamlbuild.byte camlp4out $(DEBUGGER) ocamldoc ocamlopt.opt \ + ocamlbuild.byte $(CAMLP4OUT) $(DEBUGGER) ocamldoc ocamlopt.opt \ otherlibrariesopt # Installation + +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)/ cd $(LIBDIR); rm -f dllbigarray.so dlllabltk.so dllnums.so \ dllthreads.so dllunix.so dllgraphics.so dllstr.so \ dlltkanim.so @@ -288,12 +280,10 @@ install: cd stdlib; $(MAKE) 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; $(MAKE) install -cd man; $(MAKE) install for i in $(OTHERLIBRARIES); do \ @@ -312,33 +302,59 @@ installopt: cd asmrun; $(MAKE) install cp ocamlopt $(BINDIR)/ocamlopt$(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)/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 $(MAKE) installoptopt; fi + cd tools; $(MAKE) installopt + +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 \ + $(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 -ocamlc: $(COMPOBJS) - $(CAMLC) $(LINKFLAGS) -o ocamlc $(COMPOBJS) +# 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 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 @@ -348,16 +364,20 @@ partialclean:: # 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 toplevel/toplevellib.cma + rm -f ocaml # The native toplevel @@ -368,7 +388,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 @@ -394,6 +414,7 @@ utils/config.ml: utils/config.mlp config/Makefile -e 's|%%EXT_DLL%%|.so|' \ -e 's|%%SYSTHREAD_SUPPORT%%|$(SYSTHREAD_SUPPORT)|' \ -e 's|%%ASM%%|$(ASM)|' \ + -e 's|%%ASM_CFI_SUPPORTED%%|$(ASM_CFI_SUPPORTED)|' \ -e 's|%%MKDLL%%|$(MKDLL)|' \ -e 's|%%MKEXE%%|$(MKEXE)|' \ -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \ @@ -425,13 +446,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 @@ -441,8 +473,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 @@ -450,7 +489,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 @@ -541,8 +580,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 @@ -619,6 +659,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 @@ -710,11 +753,16 @@ checkstack: fi @rm -f tools/checkstack +# Make clean in the test suite + +clean:: + cd testsuite; $(MAKE) clean + # Make MacOS X package 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 @@ -755,8 +803,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 35c73a1759..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. @@ -211,35 +194,37 @@ opt: opt-core otherlibrariesopt ocamlbuildlib.native # Native-code versions of the tools opt.opt: core opt-core ocamlc.opt all ocamlopt.opt ocamllex.opt \ - ocamltoolsopt.opt ocamlbuild.native camlp4opt ocamldoc.opt + ocamltoolsopt.opt ocamlbuild.native $(CAMLP4OPT) ocamldoc.opt # Complete build using fast compilers world.opt: coldstart opt.opt # 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 @@ -335,6 +349,7 @@ utils/config.ml: utils/config.mlp config/Makefile -e "s|%%EXT_DLL%%|.dll|" \ -e "s|%%SYSTHREAD_SUPPORT%%|true|" \ -e 's|%%ASM%%|$(ASM)|' \ + -e 's|%%ASM_CFI_SUPPORTED%%|false|' \ -e 's|%%MKDLL%%|$(MKDLL)|' \ -e 's|%%MKEXE%%|$(MKEXE)|' \ -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \ @@ -367,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 @@ -381,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 @@ -390,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 @@ -485,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 @@ -615,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 @@ -653,4 +681,18 @@ depend: beforedepend alldepend:: depend +distclean: + ./build/distclean.sh + +.PHONY: all backup bootstrap camlp4opt camlp4out checkstack clean +.PHONY: partialclean beforedepend alldepend cleanboot coldstart +.PHONY: compare core coreall +.PHONY: coreboot defaultentry depend distclean install installopt +.PHONY: library library-cross libraryopt ocamlbuild-mixed-boot +.PHONY: ocamlbuild.byte ocamlbuild.native ocamldebugger ocamldoc +.PHONY: ocamldoc.opt ocamllex ocamllex.opt ocamltools ocamltools.opt +.PHONY: ocamlyacc opt-core opt opt.opt otherlibraries +.PHONY: otherlibrariesopt promote promote-cross +.PHONY: restore runtime runtimeopt makeruntimeopt world world.opt + include .depend @@ -19,7 +19,7 @@ the generated programs deliver excellent performance, while retaining the moderate memory requirements of the bytecode compiler. The native-code compiler currently runs on the following platforms: -Tier 1 (actively used and maintained by the core Caml team): +Tier 1 (actively used and maintained by the core OCaml team): AMD64 (Opteron) Linux, MacOS X, MS Windows IA32 (Pentium) Linux, FreeBSD, MacOS X, MS Windows @@ -48,7 +48,7 @@ CONTENTS: LICENSE license and copyright notice Makefile main Makefile README this file - README.win32 infos on the MS Windows ports of O.Caml + README.win32 infos on the MS Windows ports of OCaml asmcomp/ native-code compiler and linker asmrun/ native-code runtime library boot/ bootstrap compiler @@ -58,7 +58,7 @@ CONTENTS: config/ autoconfiguration stuff debugger/ source-level replay debugger driver/ driver code for the compilers - emacs/ Caml editing mode and debugger interface for GNU Emacs + emacs/ OCaml editing mode and debugger interface for GNU Emacs lex/ lexer generator maccaml/ the Macintosh GUI ocamldoc/ documentation generator @@ -99,10 +99,10 @@ The complete OCaml distribution can be accessed at KEEPING IN TOUCH WITH THE CAML COMMUNITY: -There exists a mailing list of users of the Caml implementations +There exists a mailing list of users of the OCaml implementations developed at INRIA. The purpose of this list is to share experience, exchange ideas (and even code), and report on applications -of the Caml language. Messages can be written in English or in +of the OCaml language. Messages can be written in English or in French. The list has more than 1000 subscribers. Messages to the list should be sent to: @@ -117,7 +117,7 @@ Archives of the list are available on the Web site above. The Usenet news groups comp.lang.ml and comp.lang.functional also contains discussions about the ML family of programming languages, -including Caml. +including OCaml. BUG REPORTS AND USER FEEDBACK: diff --git a/README.win32 b/README.win32 index c15492b637..ddd010a08e 100644 --- a/README.win32 +++ b/README.win32 @@ -59,7 +59,7 @@ runs without any additional tools. The native-code compiler (ocamlopt) requires the Microsoft Windows SDK (item [1]) and the flexdll tool (item [2]). -Statically linking Caml bytecode with C code (ocamlc -custom) also requires +Statically linking OCaml bytecode with C code (ocamlc -custom) also requires items [1] and [2]. The LablTk GUI requires Tcl/Tk 8.5 (item [3]). @@ -87,12 +87,11 @@ THIRD-PARTY SOFTWARE: http://www.microsoft.com/downloads/en/default.aspx under the name "Microsoft Windows 7 SDK". -[2] flexdll version 0.23 or later. +[2] flexdll version 0.29 or later. Can be downloaded from http://alain.frisch.fr/flexdll.html [3] TCL/TK version 8.5. Windows binaries are available as part of the - ActiveTCL distribution at http://www.activestate.com/products/ActiveTcl/ - + ActiveTCL distribution at http://www.activestate.com/activetcl/downloads RECOMPILATION FROM THE SOURCES: @@ -106,7 +105,8 @@ You will need the following software components to perform the recompilation: Make sure to install the 32-bit version of TCL/TK, even if you are compiling on a 64-bit Windows. - The Cygwin port of GNU tools, available from http://www.cygwin.com/ - Install at least the following packages: diffutils, make, ncurses. + Install at least the following packages (and their dependencies): + diffutils, make, ncurses. First, you need to set up your cygwin environment for using the MS tools. The following assumes that you have installed [1], [2], and [3] @@ -121,13 +121,14 @@ to adjust the paths accordingly. Then enter the following commands: cd "%PFPATH%\Microsoft Visual Studio 9.0\VC\bin" + set FLEXDLLDIR=%PFPATH%\flexdll vcvars32 echo VCPATH="`cygpath -p '%Path%'`" >C:\cygwin\tmp\msenv echo LIB="%LIB%;C:\Tcl\lib" >>C:\cygwin\tmp\msenv echo LIBPATH="%LIBPATH%" >>C:\cygwin\tmp\msenv - echo INCLUDE="%INCLUDE%;C:\Tcl\include" >>C:\cygwin\tmp\msenv - echo FLPATH="`cygpath '%PFPATH%\flexdll'`" >>C:\cygwin\tmp\msenv - echo PATH="${VCPATH}:$PATH:${FLPATH}" >>C:\cygwin\tmp\msenv + echo INCLUDE="%INCLUDE%;%FLEXDLLDIR%;C:\Tcl\include" >>C:\cygwin\tmp\msenv + echo FLPATH="`cygpath '%FLEXDLLDIR%'`" >>C:\cygwin\tmp\msenv + echo PATH="$VCPATH:$FLPATH:$PATH" >>C:\cygwin\tmp\msenv echo export PATH LIB LIBPATH INCLUDE >>C:\cygwin\tmp\msenv echo export OCAMLBUILD_FIND=/usr/bin/find >>C:\cygwin\tmp\msenv @@ -175,10 +176,7 @@ CREDITS: The initial port of Caml Special Light (the ancestor of OCaml) to Windows NT was done by Kevin Gallo at Microsoft Research, who kindly -contributed his changes to the Caml project. - -The graphical user interface for the toplevel was initially developed -by Jacob Navia, then significantly improved by Christopher A. Watford. +contributed his changes to the OCaml project. ------------------------------------------------------------------------------ @@ -187,13 +185,13 @@ by Jacob Navia, then significantly improved by Christopher A. Watford. REQUIREMENTS: -This port runs under MS Windows Vista, XP, and 2000. +This port runs under MS Windows Seven, Vista, XP, and 2000. The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...) runs without any additional tools. The native-code compiler (ocamlopt), as well as static linking of -Caml bytecode with C code (ocamlc -custom), require +OCaml bytecode with C code (ocamlc -custom), require the Cygwin development tools, available at http://www.cygwin.com/ and the flexdll tool, available at @@ -203,10 +201,14 @@ the Setup tool from Cygwin): mingw64-i686-binutils mingw64-i686-gcc + mingw64-i686-gcc-core mingw64-i686-runtime -NOTE: +NOTES: + + - Do not use the Cygwin version of flexdll for this port. + - There is another 32-bit gcc compiler, from the MinGW.org project, packaged in Cygwin under the name mingw-gcc. It is not currently supported by flexdll and OCaml. @@ -224,7 +226,7 @@ NOTE: The LablTk GUI requires Tcl/Tk 8.5. Windows binaries are available as part of the ActiveTCL distribution at -http://www.activestate.com/products/ActiveTcl/ + http://www.activestate.com/activetcl/downloads Note that you will need to install the 32-bit version of ActiveTCL, even if you are on a 64-bit version of Windows. @@ -247,23 +249,26 @@ environment variable. E.g. if Tcl/Tk was installed in C:\tcl, add RECOMPILATION FROM THE SOURCES: You will need the following software components to perform the recompilation: -- Windows NT, 2000, XP, or Vista. -- Cygwin: http://sourceware.cygnus.com/cygwin/ - Install at least the following packages: +- Windows NT, 2000, XP, Vista, or Seven. +- Cygwin: http://cygwin.com/ + Install at least the following packages (and their dependencies, as + computed by Cygwin's setup.exe): mingw64-i686-binutils mingw64-i686-gcc + mingw64-i686-gcc-core mingw64-i686-runtime diffutils make ncurses -- TCL/TK version 8.5 (see above). -- The flexdll tool (see above). +- Tcl/Tk version 8.5 (see above). +- The flexdll tool (see above). Do not forget to add the flexdll directory + to your PATH The standalone mingw toolchain from the MinGW-w64 project (http://mingw-w64.sourceforge.net/) is not supported. Please use the version packaged in Cygwin instead. -Start a Cygwin shell and unpack the source distribution +Start a new Cygwin shell and unpack the source distribution (ocaml-X.YY.Z.tar.gz) with "tar xzf". Change to the top-level directory of the OCaml distribution. Then, do @@ -274,7 +279,7 @@ directory of the OCaml distribution. Then, do Then, edit config/Makefile as needed, following the comments in this file. Normally, the only variables that need to be changed are PREFIX where to install everything - TK_ROOT where TCL/TK was installed + TK_ROOT where Tcl/Tk was installed Finally, use "make -f Makefile.nt" to build the system, e.g. @@ -318,16 +323,42 @@ the OCaml packages). Alternatively, recompile from the source distribution. RECOMPILATION FROM THE SOURCES: -Just follow the instructions for Unix machines given in the file INSTALL. +Before starting, make sure that the gcc version installed by cygwin +is not 4.5.3 (it has a bug that affects OCaml). If needed, use cygwin's +setup.exe to downgrade to 4.3.4. + +You will need to recompile (and install) flexdll from source with +Cygwin's C compiler because the official binary version of flexdll +doesn't handle Cygwin's symbolic links and sometimes fails to +launch the C compiler. + +In order to recompile flexdll, you first need to configure, compile, +and install OCaml without flexdll support (configure with options +-no-shared-libs -no-tk -no-camlp4), then modify the flexdll Makefile +to change line 51 from: + LINKFLAGS = -ccopt "-link version_res.o" +to: + LINKFLAGS = -cclib version_res.o + +Then "make CHAINS=cygwin" and add the flexdll directory to your PATH. +Make sure to add it before "/usr/bin" or you will get cygwin's flexlink. + +Then, in OCaml's source directory, type: + make clean + make distclean +and follow the instructions for Unix machines given in the file INSTALL. NOTES: -The libraries available in this port are "num", "str", "threads", -"unix" and "labltk". "graph" is not available. -The replay debugger is fully supported. -When upgrading from 3.12.0 to 3.12.1, you will need to remove -/usr/local/bin/ocamlmktop.exe before typing "make install". +- There is a problem with cygwin's port of gcc version 4.5.3. You should + use cygwin's setup program to downgrade to 4.3.4 before compiling OCaml. +- The replay debugger is fully supported. +- When upgrading from 3.12.0 to 3.12.1, you will need to remove + /usr/local/bin/ocamlmktop.exe before typing "make install". +- In order to use the "graph" and "labltk" libraries, you will need + to use Cygwin's setup.exe to install the xinit, libX11-devel, tcl, + and tcl-tk packages before compiling OCaml. ------------------------------------------------------------------------------ @@ -342,7 +373,7 @@ Windows 7 64 on Intel64/AMD64 machines. The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...) runs without any additional tools. -Statically linking Caml bytecode with C code (ocamlc -custom) requires the +Statically linking OCaml bytecode with C code (ocamlc -custom) requires the Microsoft Platform SDK compiler (item [1] in the section "third-party software" below) and the flexdll tool (item [2]). @@ -364,7 +395,7 @@ THIRD-PARTY SOFTWARE: http://www.microsoft.com/downloads/en/default.aspx under the name "Microsoft Windows 7 SDK". -[2] flexdll version 0.27 or later. +[2] flexdll version 0.29 or later. Can be downloaded from http://alain.frisch.fr/flexdll.html @@ -1,4 +1,4 @@ -3.13.0+dev10 (2012-01-10) +4.00.1+dev2_2012-08-06 # 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/arch.ml b/asmcomp/amd64/arch.ml index dfacdad9e4..8e065d9ae0 100644 --- a/asmcomp/amd64/arch.ml +++ b/asmcomp/amd64/arch.ml @@ -51,6 +51,10 @@ let size_addr = 8 let size_int = 8 let size_float = 8 +(* Behavior of division *) + +let division_crashes_on_overflow = true + (* Operations on addressing modes *) let identity_addressing = Iindexed 0 diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index 097c6cd2e2..2ff57dd437 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -317,11 +317,17 @@ let emit_float_test cmp neg arg lbl = (* Deallocate the stack frame before a return or tail call *) -let output_epilogue () = +let output_epilogue f = if frame_required() then begin let n = frame_size() - 8 in - ` addq ${emit_int n}, %rsp\n` + ` addq ${emit_int n}, %rsp\n`; + cfi_adjust_cfa_offset (-n); + f (); + (* reset CFA back cause function body may continue *) + cfi_adjust_cfa_offset n end + else + f () (* Output the assembly code for an instruction *) @@ -332,7 +338,9 @@ let tailrec_entry_point = ref 0 let float_constants = ref ([] : (int * string) list) +(* Emit an instruction *) let emit_instr fallthrough i = + emit_debug_info i.dbg; match i.desc with Lend -> () | Lop(Imove | Ispill | Ireload) -> @@ -373,20 +381,24 @@ let emit_instr fallthrough i = ` {emit_call s}\n`; record_frame i.live i.dbg | Lop(Itailcall_ind) -> - output_epilogue(); + output_epilogue begin fun () -> ` jmp *{emit_reg i.arg.(0)}\n` + end | Lop(Itailcall_imm s) -> if s = !function_name then ` jmp {emit_label !tailrec_entry_point}\n` else begin - output_epilogue(); + output_epilogue begin fun () -> ` {emit_jump s}\n` + end end | Lop(Iextcall(s, alloc)) -> if alloc then begin ` {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 @@ -394,6 +406,7 @@ let emit_instr fallthrough i = if n < 0 then ` addq ${emit_int(-n)}, %rsp\n` else ` subq ${emit_int(n)}, %rsp\n`; + cfi_adjust_cfa_offset n; stack_offset := !stack_offset + n | Lop(Iload(chunk, addr)) -> let dest = i.res.(0) in @@ -536,8 +549,9 @@ let emit_instr fallthrough i = | Lreloadretaddr -> () | Lreturn -> - output_epilogue(); + output_epilogue begin fun () -> ` ret\n` + end | Llabel lbl -> `{emit_Llabel fallthrough lbl}:\n` | Lbranch lbl -> @@ -616,12 +630,16 @@ let emit_instr fallthrough i = | Lsetuptrap lbl -> ` call {emit_label lbl}\n` | Lpushtrap -> + cfi_adjust_cfa_offset 8; ` pushq %r14\n`; + cfi_adjust_cfa_offset 8; ` movq %rsp, %r14\n`; stack_offset := !stack_offset + 16 | Lpoptrap -> ` popq %r14\n`; + cfi_adjust_cfa_offset (-8); ` addq $8, %rsp\n`; + cfi_adjust_cfa_offset (-8); stack_offset := !stack_offset - 16 | Lraise -> if !Clflags.debug then begin @@ -653,7 +671,7 @@ let emit_profile () = | "linux" | "gnu" -> (* mcount preserves rax, rcx, rdx, rsi, rdi, r8, r9 explicitly and rbx, rbp, r12-r15 like all C functions. - We need to preserve r10 and r11 ourselves, since Caml can + We need to preserve r10 and r11 ourselves, since OCaml can use them for argument passing. *) ` pushq %r10\n`; ` movq %rsp, %rbp\n`; @@ -685,15 +703,19 @@ let fundecl fundecl = else ` .globl {emit_symbol fundecl.fun_name}\n`; `{emit_symbol fundecl.fun_name}:\n`; + emit_debug_info fundecl.fun_dbg; + cfi_startproc (); if !Clflags.gprofile then emit_profile(); if frame_required() then begin let n = frame_size() - 8 in - ` subq ${emit_int n}, %rsp\n` + ` subq ${emit_int n}, %rsp\n`; + cfi_adjust_cfa_offset n; end; `{emit_label !tailrec_entry_point}:\n`; emit_all true fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; emit_call_bound_errors (); + cfi_endproc (); begin match Config.system with "linux" | "gnu" -> ` .type {emit_symbol fundecl.fun_name},@function\n`; @@ -749,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/amd64/proc.ml b/asmcomp/amd64/proc.ml index fa0387bb6f..193bad8e4e 100644 --- a/asmcomp/amd64/proc.ml +++ b/asmcomp/amd64/proc.ml @@ -56,10 +56,10 @@ let masm = xmm0 - xmm15 100 - 115 *) (* Conventions: - rax - r11: Caml function arguments - rax: Caml and C function results - xmm0 - xmm9: Caml function arguments - xmm0: Caml and C function results + rax - r11: OCaml function arguments + rax: OCaml and C function results + xmm0 - xmm9: OCaml function arguments + xmm0: OCaml and C function results Under Unix: rdi, rsi, rdx, rcx, r8, r9: C function arguments xmm0 - xmm7: C function arguments @@ -188,7 +188,7 @@ let loc_results res = return value in rax or xmm0. C calling conventions under Win64: first integer args in rcx, rdx, r8, r9 - first float args in xmm0 ... xmm3 + first float args in xmm0 ... xmm3 each integer arg consumes a float reg, and conversely remaining args on stack always 32 bytes reserved at bottom of stack. diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml index 86c4a9b58a..9c4464aed9 100644 --- a/asmcomp/amd64/selection.ml +++ b/asmcomp/amd64/selection.ml @@ -121,7 +121,7 @@ method is_immediate n = n <= 0x7FFFFFFF && n >= -0x80000000 method is_immediate_natint n = n <= 0x7FFFFFFFn && n >= -0x80000000n -method select_addressing exp = +method select_addressing chunk exp = let (a, d) = select_addr exp in (* PR#4625: displacement must be a signed 32-bit immediate *) if d < -0x8000_0000 || d > 0x7FFF_FFFF @@ -157,7 +157,7 @@ method! select_operation op args = match op with (* Recognize the LEA instruction *) Caddi | Cadda | Csubi | Csuba -> - begin match self#select_addressing (Cop(op, args)) with + begin match self#select_addressing Word (Cop(op, args)) with (Iindexed d, _) -> super#select_operation op args | (Iindexed2 0, _) -> super#select_operation op args | (addr, arg) -> (Ispecific(Ilea addr), [arg]) @@ -191,7 +191,7 @@ method! select_operation op args = begin match args with [loc; Cop(Caddi, [Cop(Cload _, [loc']); Cconst_int n])] when loc = loc' && self#is_immediate n -> - let (addr, arg) = self#select_addressing loc in + let (addr, arg) = self#select_addressing Word loc in (Ispecific(Ioffset_loc(n, addr)), [arg]) | _ -> super#select_operation op args @@ -202,12 +202,12 @@ method! select_operation op args = method select_floatarith commutative regular_op mem_op args = match args with - [arg1; Cop(Cload (Double|Double_u), [loc2])] -> - let (addr, arg2) = self#select_addressing loc2 in + [arg1; Cop(Cload (Double|Double_u as chunk), [loc2])] -> + let (addr, arg2) = self#select_addressing chunk loc2 in (Ispecific(Ifloatarithmem(mem_op, addr)), [arg1; arg2]) - | [Cop(Cload (Double|Double_u), [loc1]); arg2] when commutative -> - let (addr, arg1) = self#select_addressing loc1 in + | [Cop(Cload (Double|Double_u as chunk), [loc1]); arg2] when commutative -> + let (addr, arg1) = self#select_addressing chunk loc1 in (Ispecific(Ifloatarithmem(mem_op, addr)), [arg2; arg1]) | [arg1; arg2] -> @@ -227,9 +227,6 @@ method! insert_op_debug op dbg rs rd = with Use_default -> super#insert_op_debug op dbg rs rd -method! insert_op op rs rd = - self#insert_op_debug op Debuginfo.none rs rd - end let fundecl f = (new selector)#emit_fundecl f diff --git a/asmcomp/arm/arch.ml b/asmcomp/arm/arch.ml index 845ea97333..c4aca8df0f 100644 --- a/asmcomp/arm/arch.ml +++ b/asmcomp/arm/arch.ml @@ -2,11 +2,12 @@ (* *) (* OCaml *) (* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) (* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) +(* Copyright 1998 Institut National de Recherche en Informatique *) +(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) +(* reserved. This file is distributed under the terms of the Q *) +(* Public License version 1.0. *) (* *) (***********************************************************************) @@ -17,9 +18,81 @@ open Misc open Format +type abi = EABI | EABI_VFP +type arch = ARMv4 | ARMv5 | ARMv5TE | ARMv6 | ARMv6T2 | ARMv7 +type fpu = Soft | VFPv3_D16 | VFPv3 + +let abi = + match Config.system with + "linux_eabi" -> EABI + | "linux_eabihf" -> EABI_VFP + | _ -> assert false + +let string_of_arch = function + ARMv4 -> "armv4" + | ARMv5 -> "armv5" + | ARMv5TE -> "armv5te" + | ARMv6 -> "armv6" + | ARMv6T2 -> "armv6t2" + | ARMv7 -> "armv7" + +let string_of_fpu = function + Soft -> "soft" + | VFPv3_D16 -> "vfpv3-d16" + | VFPv3 -> "vfpv3" + (* Machine-specific command-line options *) -let command_line_options = [] +let (arch, fpu, thumb) = + let (def_arch, def_fpu, def_thumb) = + begin match abi, Config.model with + (* Defaults for architecture, FPU and Thumb *) + EABI, "armv5" -> ARMv5, Soft, false + | EABI, "armv5te" -> ARMv5TE, Soft, false + | EABI, "armv6" -> ARMv6, Soft, false + | EABI, "armv6t2" -> ARMv6T2, Soft, false + | EABI, "armv7" -> ARMv7, Soft, false + | EABI, _ -> ARMv4, Soft, false + | EABI_VFP, _ -> ARMv7, VFPv3_D16, true + end in + (ref def_arch, ref def_fpu, ref def_thumb) + +let pic_code = ref false + +let farch spec = + arch := (match spec with + "armv4" when abi <> EABI_VFP -> ARMv4 + | "armv5" when abi <> EABI_VFP -> ARMv5 + | "armv5te" when abi <> EABI_VFP -> ARMv5TE + | "armv6" when abi <> EABI_VFP -> ARMv6 + | "armv6t2" when abi <> EABI_VFP -> ARMv6T2 + | "armv7" -> ARMv7 + | spec -> raise (Arg.Bad spec)) + +let ffpu spec = + fpu := (match spec with + "soft" when abi <> EABI_VFP -> Soft + | "vfpv3-d16" when abi = EABI_VFP -> VFPv3_D16 + | "vfpv3" when abi = EABI_VFP -> VFPv3 + | spec -> raise (Arg.Bad spec)) + +let command_line_options = + [ "-farch", Arg.String farch, + "<arch> Select the ARM target architecture" + ^ " (default: " ^ (string_of_arch !arch) ^ ")"; + "-ffpu", Arg.String ffpu, + "<fpu> Select the floating-point hardware" + ^ " (default: " ^ (string_of_fpu !fpu) ^ ")"; + "-fPIC", Arg.Set pic_code, + " Generate position-independent machine code"; + "-fno-PIC", Arg.Clear pic_code, + " Generate position-dependent machine code"; + "-fthumb", Arg.Set thumb, + " Enable Thumb/Thumb-2 code generation" + ^ (if !thumb then " (default)" else ""); + "-fno-thumb", Arg.Clear thumb, + " Disable Thumb/Thumb-2 code generation" + ^ (if not !thumb then " (default" else "")] (* Addressing modes *) @@ -37,6 +110,14 @@ type specific_operation = Ishiftarith of arith_operation * int | Ishiftcheckbound of int | Irevsubimm of int + | Imuladd (* multiply and add *) + | Imulsub (* multiply and subtract *) + | Inegmulf (* floating-point negate and multiply *) + | Imuladdf (* floating-point multiply and add *) + | Inegmuladdf (* floating-point negate, multiply and add *) + | Imulsubf (* floating-point multiply and subtract *) + | Inegmulsubf (* floating-point negate, multiply and subtract *) + | Isqrtf (* floating-point square root *) and arith_operation = Ishiftadd @@ -51,6 +132,10 @@ let size_addr = 4 let size_int = 4 let size_float = 8 +(* Behavior of division *) + +let division_crashes_on_overflow = false + (* Operations on addressing modes *) let identity_addressing = Iindexed 0 @@ -84,3 +169,56 @@ let print_specific_operation printreg op ppf arg = fprintf ppf "check %a >> %i > %a" printreg arg.(0) n printreg arg.(1) | Irevsubimm n -> fprintf ppf "%i %s %a" n "-" printreg arg.(0) + | Imuladd -> + fprintf ppf "(%a * %a) + %a" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Imulsub -> + fprintf ppf "-(%a * %a) + %a" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Inegmulf -> + fprintf ppf "-f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + | Imuladdf -> + fprintf ppf "%a +f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Inegmuladdf -> + fprintf ppf "%a -f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Imulsubf -> + fprintf ppf "(-f %a) +f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Inegmulsubf -> + fprintf ppf "(-f %a) -f (%a *f %a)" + printreg arg.(0) + printreg arg.(1) + printreg arg.(2) + | Isqrtf -> + fprintf ppf "sqrtf %a" + printreg arg.(0) + +(* Recognize immediate operands *) + +(* Immediate operands are 8-bit immediate values, zero-extended, + and rotated right by 0 ... 30 bits. + In Thumb/Thumb-2 mode we utilize 26 ... 30. *) + +let is_immediate n = + let n = ref n in + let s = ref 0 in + let m = if !thumb then 24 else 30 in + while (!s <= m && Int32.logand !n 0xffl <> !n) do + n := Int32.logor (Int32.shift_right_logical !n 2) (Int32.shift_left !n 30); + s := !s + 2 + done; + !s <= m diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp index dd995f26be..b0baf86523 100644 --- a/asmcomp/arm/emit.mlp +++ b/asmcomp/arm/emit.mlp @@ -2,11 +2,12 @@ (* *) (* OCaml *) (* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) (* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) +(* Copyright 1998 Institut National de Recherche en Informatique *) +(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) +(* reserved. This file is distributed under the terms of the Q *) +(* Public License version 1.0. *) (* *) (***********************************************************************) @@ -36,16 +37,25 @@ let emit_label lbl = let emit_data_label lbl = emit_string ".Ld"; emit_int lbl -(* Output a symbol *) +(* Symbols *) let emit_symbol s = Emitaux.emit_symbol '$' s +let emit_call s = + if !Clflags.dlcode || !pic_code + then `bl {emit_symbol s}(PLT)` + else `bl {emit_symbol s}` + +let emit_jump s = + if !Clflags.dlcode || !pic_code + then `b {emit_symbol s}(PLT)` + else `b {emit_symbol s}` + (* Output a pseudo-register *) -let emit_reg r = - match r.loc with - | Reg r -> emit_string (register_name r) +let emit_reg = function + {loc = Reg r} -> emit_string (register_name r) | _ -> fatal_error "Emit_arm.emit_reg" (* Layout of the stack frame *) @@ -56,14 +66,23 @@ let frame_size () = let sz = !stack_offset + 4 * num_stack_slots.(0) + + 8 * num_stack_slots.(1) + + 8 * num_stack_slots.(2) + (if !contains_calls then 4 else 0) in Misc.align sz 8 let slot_offset loc cl = match loc with - Incoming n -> frame_size() + n - | Local n -> !stack_offset + n * 4 - | Outgoing n -> n + Incoming n -> + assert (n >= 0); + frame_size() + n + | Local n -> + if cl = 0 + then !stack_offset + n * 4 + else !stack_offset + num_stack_slots.(0) * 4 + n * 8 + | Outgoing n -> + assert (n >= 0); + n (* Output a stack reference *) @@ -82,20 +101,13 @@ let emit_addressing addr r n = (* Record live pointers at call points *) -type frame_descr = - { fd_lbl: int; (* Return address *) - fd_frame_size: int; (* Size of stack frame *) - fd_live_offset: int list } (* Offsets/regs of live addresses *) - -let frame_descriptors = ref([] : frame_descr list) - -let record_frame live = +let record_frame_label live dbg = let lbl = new_label() in let live_offset = ref [] in Reg.Set.iter (function {typ = Addr; loc = Reg r} -> - live_offset := (r lsl 1) + 1 :: !live_offset + live_offset := ((r lsl 1) + 1) :: !live_offset | {typ = Addr; loc = Stack s} as reg -> live_offset := slot_offset s (register_class reg) :: !live_offset | _ -> ()) @@ -103,18 +115,57 @@ let record_frame live = frame_descriptors := { fd_lbl = lbl; fd_frame_size = frame_size(); - fd_live_offset = !live_offset } :: !frame_descriptors; - `{emit_label lbl}:` - -let emit_frame fd = - ` .word {emit_label fd.fd_lbl} + 4\n`; - ` .short {emit_int fd.fd_frame_size}\n`; - ` .short {emit_int (List.length fd.fd_live_offset)}\n`; - List.iter - (fun n -> - ` .short {emit_int n}\n`) - fd.fd_live_offset; - ` .align 2\n` + fd_live_offset = !live_offset; + fd_debuginfo = dbg } :: !frame_descriptors; + lbl + +let record_frame live dbg = + let lbl = record_frame_label live dbg in `{emit_label lbl}:` + +(* Record calls to the GC -- we've moved them out of the way *) + +type gc_call = + { gc_lbl: label; (* Entry label *) + gc_return_lbl: label; (* Where to branch after GC *) + gc_frame_lbl: label } (* Label of frame descriptor *) + +let call_gc_sites = ref ([] : gc_call list) + +let emit_call_gc gc = + `{emit_label gc.gc_lbl}: {emit_call "caml_call_gc"}\n`; + `{emit_label gc.gc_frame_lbl}: b {emit_label gc.gc_return_lbl}\n` + +(* Record calls to caml_ml_array_bound_error. + In debug mode, we maintain one call to caml_ml_array_bound_error + per bound check site. Otherwise, we can share a single call. *) + +type bound_error_call = + { bd_lbl: label; (* Entry label *) + bd_frame_lbl: label } (* Label of frame descriptor *) + +let bound_error_sites = ref ([] : bound_error_call list) + +let bound_error_label dbg = + if !Clflags.debug || !bound_error_sites = [] then begin + let lbl_bound_error = new_label() in + let lbl_frame = record_frame_label Reg.Set.empty dbg in + bound_error_sites := + { bd_lbl = lbl_bound_error; + bd_frame_lbl = lbl_frame } :: !bound_error_sites; + lbl_bound_error + end else begin + let bd = List.hd !bound_error_sites in bd.bd_lbl + end + +let emit_call_bound_error bd = + `{emit_label bd.bd_lbl}: {emit_call "caml_ml_array_bound_error"}\n`; + `{emit_label bd.bd_frame_lbl}:\n` + +(* Negate a comparison *) + +let negate_integer_comparison = function + Isigned cmp -> Isigned(negate_comparison cmp) + | Iunsigned cmp -> Iunsigned(negate_comparison cmp) (* Names of various instructions *) @@ -124,22 +175,13 @@ let name_for_comparison = function | Iunsigned Ceq -> "eq" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "ls" | Iunsigned Cge -> "cs" | Iunsigned Clt -> "cc" | Iunsigned Cgt -> "hi" -let name_for_float_comparison cmp neg = - match cmp with - Ceq -> if neg then "ne" else "eq" - | Cne -> if neg then "eq" else "ne" - | Cle -> if neg then "hi" else "ls" - | Cge -> if neg then "lt" else "ge" - | Clt -> if neg then "pl" else "mi" - | Cgt -> if neg then "le" else "gt" - let name_for_int_operation = function Iadd -> "add" | Isub -> "sub" | Imul -> "mul" - | Iand -> "and" - | Ior -> "orr" - | Ixor -> "eor" + | Iand -> "and" + | Ior -> "orr" + | Ixor -> "eor" | _ -> assert false let name_for_shift_operation = function @@ -148,193 +190,306 @@ let name_for_shift_operation = function | Iasr -> "asr" | _ -> assert false -let name_for_shift_int_operation = function - Ishiftadd -> "add" - | Ishiftsub -> "sub" - | Ishiftsubrev -> "rsb" - -(* Recognize immediate operands *) - -(* Immediate operands are 8-bit immediate values, zero-extended, and rotated - right by 0, 2, 4, ... 30 bits. - We check only with 8-bit values shifted left 0 to 24 bits. *) - -let rec is_immed n shift = - shift <= 24 && - (Nativeint.logand n (Nativeint.shift_left (Nativeint.of_int 0xFF) shift) = n - || is_immed n (shift + 2)) - -let is_immediate n = is_immed n 0 - (* General functional to decompose a non-immediate integer constant - into 8-bit chunks shifted left 0 ... 24 bits *) + into 8-bit chunks shifted left 0 ... 30 bits. *) let decompose_intconst n fn = let i = ref n in let shift = ref 0 in let ninstr = ref 0 in - while !i <> 0n do - if Nativeint.to_int (Nativeint.shift_right !i !shift) land 3 = 0 then + while !i <> 0l do + if Int32.logand (Int32.shift_right !i !shift) 3l = 0l then shift := !shift + 2 else begin - let mask = Nativeint.shift_left 0xFFn !shift in - let bits = Nativeint.logand !i mask in - fn bits; + let bits = Int32.logand !i (Int32.shift_left 0xffl !shift) in + i := Int32.sub !i bits; shift := !shift + 8; - i := Nativeint.sub !i bits; - incr ninstr + incr ninstr; + fn bits end done; !ninstr (* Load an integer constant into a register *) -let emit_intconst r n = - let nr = Nativeint.lognot n in +let emit_intconst dst n = + let nr = Int32.lognot n in if is_immediate n then begin - ` mov {emit_reg r}, #{emit_nativeint n}\n`; 1 + (* Use movs here to enable 16-bit T1 encoding *) + ` movs {emit_reg dst}, #{emit_int32 n}\n`; 1 end else if is_immediate nr then begin - ` mvn {emit_reg r}, #{emit_nativeint nr}\n`; 1 + ` mvn {emit_reg dst}, #{emit_int32 nr}\n`; 1 + end else if !arch > ARMv6 then begin + let nl = Int32.logand 0xffffl n in + let nh = Int32.logand 0xffffl (Int32.shift_right_logical n 16) in + if nh = 0l then begin + ` movw {emit_reg dst}, #{emit_int32 nl}\n`; 1 + end else if Int32.logand nl 0xffl = nl then begin + ` movs {emit_reg dst}, #{emit_int32 nl}\n`; + ` movt {emit_reg dst}, #{emit_int32 nh}\n`; 2 + end else begin + ` movw {emit_reg dst}, #{emit_int32 nl}\n`; + ` movt {emit_reg dst}, #{emit_int32 nh}\n`; 2 + end end else begin let first = ref true in decompose_intconst n (fun bits -> if !first - then ` mov {emit_reg r}, #{emit_nativeint bits} @ {emit_nativeint n}\n` - else ` add {emit_reg r}, {emit_reg r}, #{emit_nativeint bits}\n`; + then ` mov {emit_reg dst}, #{emit_int32 bits} @ {emit_int32 n}\n` + else ` add {emit_reg dst}, {emit_reg dst}, #{emit_int32 bits}\n`; first := false) end (* Adjust sp (up or down) by the given byte amount *) -let emit_stack_adjustment instr n = - if n <= 0 then 0 else - decompose_intconst (Nativeint.of_int n) - (fun bits -> - ` {emit_string instr} sp, sp, #{emit_nativeint 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 "" (* Entry point for tail recursive calls *) let tailrec_entry_point = ref 0 -(* Table of symbols referenced *) -let symbol_constants = (Hashtbl.create 11 : (string, int) Hashtbl.t) -(* Table of floating-point literals *) -let float_constants = (Hashtbl.create 11 : (string, int) Hashtbl.t) -(* Total space (in word) occupied by pending literals *) +(* Pending floating-point literals *) +let float_literals = ref ([] : (string * label) list) +(* Pending relative references to the global offset table *) +let gotrel_literals = ref ([] : (label * label) list) +(* Pending symbol literals *) +let symbol_literals = ref ([] : (string * label) list) +(* Total space (in words) occupied by pending literals *) let num_literals = ref 0 -(* Label a symbol or float constant *) -let label_constant tbl s size = +(* Label a floating-point literal *) +let float_literal f = try - Hashtbl.find tbl s + List.assoc f !float_literals with Not_found -> let lbl = new_label() in - Hashtbl.add tbl s lbl; - num_literals := !num_literals + size; + num_literals := !num_literals + 2; + float_literals := (f, lbl) :: !float_literals; lbl -(* Emit all pending constants *) - -let emit_constants () = - Hashtbl.iter - (fun s lbl -> - `{emit_label lbl}: .word {emit_symbol s}\n`) - symbol_constants; - Hashtbl.iter - (fun s lbl -> - `{emit_label lbl}: .double {emit_string s}\n`) - float_constants; - Hashtbl.clear symbol_constants; - Hashtbl.clear float_constants; +(* Label a GOTREL literal *) +let gotrel_literal l = + let lbl = new_label() in + num_literals := !num_literals + 1; + gotrel_literals := (l, lbl) :: !gotrel_literals; + lbl + +(* Label a symbol literal *) +let symbol_literal s = + try + List.assoc s !symbol_literals + with Not_found -> + let lbl = new_label() in + num_literals := !num_literals + 1; + symbol_literals := (s, lbl) :: !symbol_literals; + lbl + +(* Emit all pending literals *) +let emit_literals() = + if !float_literals <> [] then begin + ` .align 3\n`; + List.iter + (fun (f, lbl) -> + `{emit_label lbl}: .double {emit_string f}\n`) + !float_literals; + float_literals := [] + end; + if !symbol_literals <> [] then begin + let offset = if !thumb then 4 else 8 in + let suffix = if !pic_code then "(GOT)" else "" in + ` .align 2\n`; + List.iter + (fun (l, lbl) -> + `{emit_label lbl}: .word _GLOBAL_OFFSET_TABLE_-({emit_label l}+{emit_int offset})\n`) + !gotrel_literals; + List.iter + (fun (s, lbl) -> + `{emit_label lbl}: .word {emit_symbol s}{emit_string suffix}\n`) + !symbol_literals; + gotrel_literals := []; + symbol_literals := [] + end; num_literals := 0 +(* Emit code to load the address of a symbol *) + +let emit_load_symbol_addr dst s = + if !pic_code then begin + let lbl_pic = new_label() in + let lbl_got = gotrel_literal lbl_pic in + let lbl_sym = symbol_literal s in + (* Both r3 and r12 are marked as clobbered in PIC mode (cf. proc.ml), + so use r12 as temporary scratch register unless the destination is + r12, then we use r3 instead. *) + let tmp = if dst.loc = Reg 8 (*r12*) + then phys_reg 3 (*r3*) + else phys_reg 8 (*r12*) in + ` ldr {emit_reg tmp}, {emit_label lbl_got}\n`; + ` ldr {emit_reg dst}, {emit_label lbl_sym}\n`; + `{emit_label lbl_pic}: add {emit_reg tmp}, pc, {emit_reg tmp}\n`; + ` ldr {emit_reg dst}, [{emit_reg tmp}, {emit_reg dst}] @ {emit_symbol s}\n`; + 4 + end else if !arch > ARMv6 && not !Clflags.dlcode && !fastcode_flag then begin + ` movw {emit_reg dst}, #:lower16:{emit_symbol s}\n`; + ` movt {emit_reg dst}, #:upper16:{emit_symbol s}\n`; + 2 + end else begin + let lbl = symbol_literal s in + ` ldr {emit_reg dst}, {emit_label lbl} @ {emit_symbol s}\n`; + 1 + end + (* Output the assembly code for an instruction *) let emit_instr i = + emit_debug_info i.dbg; match i.desc with Lend -> 0 | Lop(Imove | Ispill | Ireload) -> let src = i.arg.(0) and dst = i.res.(0) in if src.loc = dst.loc then 0 else begin - match (src, dst) with - {loc = Reg rs; typ = Int|Addr}, {loc = Reg rd; typ = Int|Addr} -> - ` mov {emit_reg dst}, {emit_reg src}\n`; 1 - | {loc = Reg rs; typ = Int|Addr}, {loc = Stack sd} -> - ` str {emit_reg src}, {emit_stack dst}\n`; 1 - | {loc = Stack ss; typ = Int|Addr}, {loc = Reg rd} -> - ` ldr {emit_reg dst}, {emit_stack src}\n`; 1 + begin match (src, dst) with + {loc = Reg _; typ = Float}, {loc = Reg _} -> + ` fcpyd {emit_reg dst}, {emit_reg src}\n` + | {loc = Reg _}, {loc = Reg _} -> + ` mov {emit_reg dst}, {emit_reg src}\n` + | {loc = Reg _; typ = Float}, _ -> + ` fstd {emit_reg src}, {emit_stack dst}\n` + | {loc = Reg _}, _ -> + ` str {emit_reg src}, {emit_stack dst}\n` + | {typ = Float}, _ -> + ` fldd {emit_reg dst}, {emit_stack src}\n` | _ -> - assert false + ` ldr {emit_reg dst}, {emit_stack src}\n` + end; 1 end | Lop(Iconst_int n) -> - emit_intconst i.res.(0) n - | Lop(Iconst_float s) -> - let bits = Int64.bits_of_float (float_of_string s) in - let high_bits = Int64.to_nativeint (Int64.shift_right_logical bits 32) - and low_bits = Int64.to_nativeint bits in - if is_immediate low_bits && is_immediate high_bits then begin - ` mov {emit_reg i.res.(0)}, #{emit_nativeint low_bits} @ {emit_string s}\n`; - ` mov {emit_reg i.res.(1)}, #{emit_nativeint high_bits}\n`; - 2 + emit_intconst i.res.(0) (Nativeint.to_int32 n) + | Lop(Iconst_float f) when !fpu = Soft -> + ` @ {emit_string f}\n`; + let bits = Int64.bits_of_float (float_of_string f) in + let high_bits = Int64.to_int32 (Int64.shift_right_logical bits 32) + and low_bits = Int64.to_int32 bits in + if is_immediate low_bits || is_immediate high_bits then begin + let ninstr_low = emit_intconst i.res.(0) low_bits + and ninstr_high = emit_intconst i.res.(1) high_bits in + ninstr_low + ninstr_high end else begin - let lbl = label_constant float_constants s 2 in - ` ldr {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string s}\n`; + let lbl = float_literal f in + ` ldr {emit_reg i.res.(0)}, {emit_label lbl}\n`; ` ldr {emit_reg i.res.(1)}, {emit_label lbl} + 4\n`; 2 end + | Lop(Iconst_float f) -> + let encode imm = + let sg = Int64.to_int (Int64.shift_right_logical imm 63) in + let ex = Int64.to_int (Int64.shift_right_logical imm 52) in + let ex = (ex land 0x7ff) - 1023 in + let mn = Int64.logand imm 0xfffffffffffffL in + if Int64.logand mn 0xffffffffffffL <> 0L || ex < -3 || ex > 4 + then + None + else begin + let mn = Int64.to_int (Int64.shift_right_logical mn 48) in + if mn land 0x0f <> mn then + None + else + let ex = ((ex + 3) land 0x07) lxor 0x04 in + Some((sg lsl 7) lor (ex lsl 4) lor mn) + end in + begin match encode (Int64.bits_of_float (float_of_string f)) with + None -> + let lbl = float_literal f in + ` fldd {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_string f}\n` + | Some imm8 -> + ` fconstd {emit_reg i.res.(0)}, #{emit_int imm8} @ {emit_string f}\n` + end; 1 | Lop(Iconst_symbol s) -> - let lbl = label_constant symbol_constants s 1 in - ` ldr {emit_reg i.res.(0)}, {emit_label lbl} @ {emit_symbol s}\n`; 1 + emit_load_symbol_addr i.res.(0) s | Lop(Icall_ind) -> - ` mov lr, pc\n`; - `{record_frame i.live} bx {emit_reg i.arg.(0)}\n`; 2 + if !arch >= ARMv5 then begin + ` blx {emit_reg i.arg.(0)}\n`; + `{record_frame i.live i.dbg}\n`; 1 + end else begin + ` mov lr, pc\n`; + ` bx {emit_reg i.arg.(0)}\n`; + `{record_frame i.live i.dbg}\n`; 2 + end | Lop(Icall_imm s) -> - `{record_frame i.live} bl {emit_symbol s}\n`; 1 + ` {emit_call s}\n`; + `{record_frame i.live i.dbg}\n`; 1 | Lop(Itailcall_ind) -> - let n = frame_size() in - if !contains_calls then - ` 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 - ` b {emit_symbol s}\n`; - 2 + ninstr - end - | Lop(Iextcall(s, alloc)) -> - if alloc then begin - let lbl = label_constant symbol_constants s 1 in - ` ldr r12, {emit_label lbl} @ {emit_symbol s}\n`; - `{record_frame i.live} bl caml_c_call\n`; 2 - end else begin - ` bl {emit_symbol s}\n`; 1 + 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 + | Lop(Iextcall(s, true)) -> + let ninstr = emit_load_symbol_addr (phys_reg 7 (* r7 *)) s in + ` {emit_call "caml_c_call"}\n`; + `{record_frame i.live i.dbg}\n`; + 1 + ninstr | Lop(Istackoffset n) -> assert (n mod 8 = 0); - let ninstr = - 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((Double | Double_u), addr)) -> - let addr' = offset_addressing addr 4 in - if i.res.(0).loc <> i.arg.(0).loc then begin - ` ldr {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n`; - ` ldr {emit_reg i.res.(1)}, {emit_addressing addr' i.arg 0}\n` - end else begin - ` ldr {emit_reg i.res.(1)}, {emit_addressing addr' i.arg 0}\n`; - ` ldr {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n` - end; - 2 + | Lop(Iload(Single, addr)) when !fpu >= VFPv3_D16 -> + ` flds s14, {emit_addressing addr i.arg 0}\n`; + ` fcvtds {emit_reg i.res.(0)}, s14\n`; 2 + | Lop(Iload((Double | Double_u), addr)) when !fpu = Soft -> + (* Use LDM or LDRD if possible *) + begin match i.res.(0), i.res.(1), addr with + {loc = Reg rt}, {loc = Reg rt2}, Iindexed 0 + when rt < rt2 -> + ` ldm {emit_reg i.arg.(0)}, \{{emit_reg i.res.(0)}, {emit_reg i.res.(1)}}\n`; 1 + | {loc = Reg rt}, {loc = Reg rt2}, addr + when !arch >= ARMv5TE && rt mod 2 == 0 && rt2 = rt + 1 -> + ` ldrd {emit_reg i.res.(0)}, {emit_reg i.res.(1)}, {emit_addressing addr i.arg 0}\n`; 1 + | _ -> + let addr' = offset_addressing addr 4 in + if i.res.(0).loc <> i.arg.(0).loc then begin + ` ldr {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n`; + ` ldr {emit_reg i.res.(1)}, {emit_addressing addr' i.arg 0}\n` + end else begin + ` ldr {emit_reg i.res.(1)}, {emit_addressing addr' i.arg 0}\n`; + ` ldr {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n` + end; 2 + end | Lop(Iload(size, addr)) -> let r = i.res.(0) in let instr = @@ -343,65 +498,114 @@ let emit_instr i = | Byte_signed -> "ldrsb" | Sixteen_unsigned -> "ldrh" | Sixteen_signed -> "ldrsh" + | Double + | Double_u -> "fldd" | _ (* 32-bit quantities *) -> "ldr" in - ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 0}\n`; - 1 - | Lop(Istore((Double | Double_u), addr)) -> - let addr' = offset_addressing addr 4 in - ` str {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 2}\n`; - ` str {emit_reg i.arg.(1)}, {emit_addressing addr' i.arg 2}\n`; - 2 + ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 0}\n`; 1 + | Lop(Istore(Single, addr)) when !fpu >= VFPv3_D16 -> + ` fcvtsd s14, {emit_reg i.arg.(0)}\n`; + ` fsts s14, {emit_addressing addr i.arg 1}\n`; 2 + | Lop(Istore((Double | Double_u), addr)) when !fpu = Soft -> + (* Use STM or STRD if possible *) + begin match i.arg.(0), i.arg.(1), addr with + {loc = Reg rt}, {loc = Reg rt2}, Iindexed 0 + when rt < rt2 -> + ` stm {emit_reg i.arg.(2)}, \{{emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}}\n`; 1 + | {loc = Reg rt}, {loc = Reg rt2}, addr + when !arch >= ARMv5TE && rt mod 2 == 0 && rt2 = rt + 1 -> + ` strd {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_addressing addr i.arg 2}\n`; 1 + | _ -> + let addr' = offset_addressing addr 4 in + ` str {emit_reg i.arg.(0)}, {emit_addressing addr i.arg 2}\n`; + ` str {emit_reg i.arg.(1)}, {emit_addressing addr' i.arg 2}\n`; 2 + end | Lop(Istore(size, addr)) -> let r = i.arg.(0) in let instr = match size with - Byte_unsigned | Byte_signed -> "strb" - | Sixteen_unsigned | Sixteen_signed -> "strh" + Byte_unsigned + | Byte_signed -> "strb" + | Sixteen_unsigned + | Sixteen_signed -> "strh" + | Double + | Double_u -> "fstd" | _ (* 32-bit quantities *) -> "str" in - ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 1}\n`; - 1 + ` {emit_string instr} {emit_reg r}, {emit_addressing addr i.arg 1}\n`; 1 | Lop(Ialloc n) -> + let lbl_frame = record_frame_label i.live i.dbg in if !fastcode_flag then begin - let ni = emit_intconst (phys_reg 8 (*r12*)) (Nativeint.of_int n) in - ` sub alloc_ptr, alloc_ptr, r12\n`; + let lbl_redo = new_label() in + `{emit_label lbl_redo}:`; + let ninstr = decompose_intconst + (Int32.of_int n) + (fun i -> + ` sub alloc_ptr, alloc_ptr, #{emit_int32 i}\n`) in ` cmp alloc_ptr, alloc_limit\n`; - `{record_frame i.live} blcc caml_call_gc\n`; ` add {emit_reg i.res.(0)}, alloc_ptr, #4\n`; - 4 + ni - end else if n = 8 || n = 12 || n = 16 then begin - `{record_frame i.live} bl caml_alloc{emit_int ((n-4)/4)}\n`; - ` add {emit_reg i.res.(0)}, alloc_ptr, #4\n`; 2 + let lbl_call_gc = new_label() in + ` bcc {emit_label lbl_call_gc}\n`; + call_gc_sites := + { gc_lbl = lbl_call_gc; + gc_return_lbl = lbl_redo; + gc_frame_lbl = lbl_frame } :: !call_gc_sites; + 3 + ninstr end else begin - let ni = emit_intconst (phys_reg 8 (*r12*)) (Nativeint.of_int n) in - `{record_frame i.live} bl caml_allocN\n`; - ` add {emit_reg i.res.(0)}, alloc_ptr, #4\n`; - 2 + ni + let ninstr = + begin match n with + 8 -> ` {emit_call "caml_alloc1"}\n`; 1 + | 12 -> ` {emit_call "caml_alloc2"}\n`; 1 + | 16 -> ` {emit_call "caml_alloc3"}\n`; 1 + | _ -> let ninstr = emit_intconst (phys_reg 7) (Int32.of_int n) in + ` {emit_call "caml_allocN"}\n`; 1 + ninstr + end in + `{emit_label lbl_frame}: add {emit_reg i.res.(0)}, alloc_ptr, #4\n`; + 1 + ninstr end | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> let shift = name_for_shift_operation op in ` mov {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_string shift} {emit_reg i.arg.(1)}\n`; 1 | Lop(Iintop(Icomp cmp)) -> - let comp = name_for_comparison cmp in + let compthen = name_for_comparison cmp in + let compelse = name_for_comparison (negate_integer_comparison cmp) in ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; - ` mov {emit_reg i.res.(0)}, #0\n`; - ` mov{emit_string comp} {emit_reg i.res.(0)}, #1\n`; 3 - | Lop(Iintop(Icheckbound)) -> + ` ite {emit_string compthen}\n`; + ` mov{emit_string compthen} {emit_reg i.res.(0)}, #1\n`; + ` mov{emit_string compelse} {emit_reg i.res.(0)}, #0\n`; 4 + | Lop(Iintop_imm(Icomp cmp, n)) -> + let compthen = name_for_comparison cmp in + let compelse = name_for_comparison (negate_integer_comparison cmp) in + ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; + ` ite {emit_string compthen}\n`; + ` mov{emit_string compthen} {emit_reg i.res.(0)}, #1\n`; + ` mov{emit_string compelse} {emit_reg i.res.(0)}, #0\n`; 4 + | Lop(Iintop Icheckbound) -> + let lbl = bound_error_label i.dbg in ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; - ` blls caml_ml_array_bound_error\n`; 2 + ` bls {emit_label lbl}\n`; 2 + | Lop(Iintop_imm(Icheckbound, n)) -> + let lbl = bound_error_label i.dbg in + ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; + ` bls {emit_label lbl}\n`; 2 + | Lop(Ispecific(Ishiftcheckbound shift)) -> + let lbl = bound_error_label i.dbg in + ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`; + ` bcs {emit_label lbl}\n`; 2 | Lop(Iintop op) -> let instr = name_for_int_operation op in - ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1 + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; 1 | Lop(Iintop_imm(Idiv, n)) -> (* n is a power of 2 *) let l = Misc.log2 n in let r = i.res.(0) in ` movs {emit_reg r}, {emit_reg i.arg.(0)}\n`; - if n <= 256 then + if n <= 256 then begin + ` it lt\n`; ` addlt {emit_reg r}, {emit_reg r}, #{emit_int (n-1)}\n` - else begin + end else begin + ` itt lt\n`; ` addlt {emit_reg r}, {emit_reg r}, #{emit_int n}\n`; ` sublt {emit_reg r}, {emit_reg r}, #1\n` end; - ` mov {emit_reg r}, {emit_reg r}, asr #{emit_int l}\n`; 4 + ` mov {emit_reg r}, {emit_reg r}, asr #{emit_int l}\n`; 5 | Lop(Iintop_imm(Imod, n)) -> (* n is a power of 2 *) let l = Misc.log2 n in let a = i.arg.(0) in @@ -412,47 +616,78 @@ let emit_instr i = ` mov {emit_reg r}, {emit_reg r}, lsr #{emit_int (32-l)}\n`; ` bpl {emit_label lbl}\n`; ` cmp {emit_reg r}, #0\n`; + ` it ne\n`; ` subne {emit_reg r}, {emit_reg r}, #{emit_int n}\n`; - `{emit_label lbl}:\n`; 6 + `{emit_label lbl}:\n`; 7 | Lop(Iintop_imm((Ilsl | Ilsr | Iasr as op), n)) -> let shift = name_for_shift_operation op in ` mov {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_string shift} #{emit_int n}\n`; 1 - | Lop(Iintop_imm(Icomp cmp, n)) -> - let comp = name_for_comparison cmp in - ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; - ` mov {emit_reg i.res.(0)}, #0\n`; - ` mov{emit_string comp} {emit_reg i.res.(0)}, #1\n`; 3 - | Lop(Iintop_imm(Icheckbound, n)) -> - ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; - ` blls caml_ml_array_bound_error\n`; 2 | Lop(Iintop_imm(op, n)) -> let instr = name_for_int_operation op in - ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1 - | Lop(Inegf) -> (* argument and result in (r0, r1) *) - ` eor r1, r1, #0x80000000\n`; 1 - | Lop(Iabsf) -> (* argument and result in (r0, r1) *) - ` bic r1, r1, #0x80000000\n`; 1 - | Lop(Ifloatofint | Iintoffloat | Iaddf | Isubf | Imulf | Idivf) -> - assert false + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1 + | Lop(Iabsf | Inegf as op) when !fpu = Soft -> + let instr = (match op with + Iabsf -> "bic" + | Inegf -> "eor" + | _ -> assert false) in + ` {emit_string instr} {emit_reg i.res.(1)}, {emit_reg i.arg.(1)}, #0x80000000\n`; 1 + | Lop(Iabsf | Inegf | Ispecific Isqrtf as op) -> + let instr = (match op with + Iabsf -> "fabsd" + | Inegf -> "fnegd" + | Ispecific Isqrtf -> "fsqrtd" + | _ -> assert false) in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n`; 1 + | Lop(Ifloatofint) -> + ` fmsr s14, {emit_reg i.arg.(0)}\n`; + ` fsitod {emit_reg i.res.(0)}, s14\n`; 2 + | Lop(Iintoffloat) -> + ` ftosizd s14, {emit_reg i.arg.(0)}\n`; + ` fmrs {emit_reg i.res.(0)}, s14\n`; 2 + | Lop(Iaddf | Isubf | Imulf | Idivf | Ispecific Inegmulf as op) -> + let instr = (match op with + Iaddf -> "faddd" + | Isubf -> "fsubd" + | Imulf -> "fmuld" + | Idivf -> "fdivd" + | Ispecific Inegmulf -> "fnmuld" + | _ -> assert false) in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + 1 + | Lop(Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf as op)) -> + let instr = (match op with + Imuladdf -> "fmacd" + | Inegmuladdf -> "fnmacd" + | Imulsubf -> "fmscd" + | Inegmulsubf -> "fnmscd" + | _ -> assert false) in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`; + 1 | Lop(Ispecific(Ishiftarith(op, shift))) -> - let instr = name_for_shift_int_operation op in - ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}`; + let instr = (match op with + Ishiftadd -> "add" + | Ishiftsub -> "sub" + | Ishiftsubrev -> "rsb") in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}`; if shift >= 0 then `, lsl #{emit_int shift}\n` else `, asr #{emit_int (-shift)}\n`; 1 - | Lop(Ispecific(Ishiftcheckbound shift)) -> - ` cmp {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}, lsr #{emit_int shift}\n`; - ` blcs caml_ml_array_bound_error\n`; 2 | Lop(Ispecific(Irevsubimm n)) -> ` rsb {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, #{emit_int n}\n`; 1 + | Lop(Ispecific(Imuladd | Imulsub as op)) -> + let instr = (match op with + Imuladd -> "mla" + | Imulsub -> "mls" + | _ -> assert false) in + ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n`; 1 | Lreloadretaddr -> let n = frame_size() in ` ldr lr, [sp, #{emit_int(n-4)}]\n`; 1 | 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 -> @@ -461,29 +696,41 @@ let emit_instr i = begin match tst with Itruetest -> ` cmp {emit_reg i.arg.(0)}, #0\n`; - ` bne {emit_label lbl}\n` + ` bne {emit_label lbl}\n`; 2 | Ifalsetest -> ` cmp {emit_reg i.arg.(0)}, #0\n`; - ` beq {emit_label lbl}\n` + ` beq {emit_label lbl}\n`; 2 | Iinttest cmp -> ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; let comp = name_for_comparison cmp in - ` b{emit_string comp} {emit_label lbl}\n` + ` b{emit_string comp} {emit_label lbl}\n`; 2 | Iinttest_imm(cmp, n) -> ` cmp {emit_reg i.arg.(0)}, #{emit_int n}\n`; let comp = name_for_comparison cmp in - ` b{emit_string comp} {emit_label lbl}\n` + ` b{emit_string comp} {emit_label lbl}\n`; 2 | Ifloattest(cmp, neg) -> - assert false + let comp = (match (cmp, neg) with + (Ceq, false) | (Cne, true) -> "eq" + | (Cne, false) | (Ceq, true) -> "ne" + | (Clt, false) -> "cc" + | (Clt, true) -> "cs" + | (Cle, false) -> "ls" + | (Cle, true) -> "hi" + | (Cgt, false) -> "gt" + | (Cgt, true) -> "le" + | (Cge, false) -> "ge" + | (Cge, true) -> "lt") in + ` fcmpd {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` fmstat\n`; + ` b{emit_string comp} {emit_label lbl}\n`; 3 | Ioddtest -> ` tst {emit_reg i.arg.(0)}, #1\n`; - ` bne {emit_label lbl}\n` + ` bne {emit_label lbl}\n`; 2 | Ieventest -> ` tst {emit_reg i.arg.(0)}, #1\n`; - ` beq {emit_label lbl}\n` - end; - 2 - | Lcondbranch3(lbl0, lbl1, lbl2) -> + ` beq {emit_label lbl}\n`; 2 + end + | Lcondbranch3(lbl0, lbl1, lbl2) -> ` cmp {emit_reg i.arg.(0)}, #1\n`; begin match lbl0 with None -> () @@ -498,108 +745,151 @@ let emit_instr i = | Some lbl -> ` bgt {emit_label lbl}\n` end; 4 - | Lswitch jumptbl -> - ` ldr pc, [pc, {emit_reg i.arg.(0)}, lsl #2]\n`; - ` mov r0, r0\n`; (* nop *) - for i = 0 to Array.length jumptbl - 1 do - ` .word {emit_label jumptbl.(i)}\n` - done; + | Lswitch jumptbl -> + if !arch > ARMv6 && !thumb then begin + (* 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; + (* 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 + (* 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; - ` stmfd sp!, \{trap_ptr, lr}\n`; + ` push \{trap_ptr, lr}\n`; + cfi_adjust_cfa_offset 8; ` mov trap_ptr, sp\n`; 2 | Lpoptrap -> - ` ldmfd sp!, \{trap_ptr, lr}\n`; + ` pop \{trap_ptr, lr}\n`; + cfi_adjust_cfa_offset (-8); stack_offset := !stack_offset - 8; 1 | Lraise -> - ` mov sp, trap_ptr\n`; - ` ldmfd sp!, \{trap_ptr, pc}\n`; 2 + if !Clflags.debug then begin + ` {emit_call "caml_raise_exn"}\n`; + `{record_frame Reg.Set.empty i.dbg}\n`; 1 + end else begin + ` mov sp, trap_ptr\n`; + ` pop \{trap_ptr, pc}\n`; 2 + end (* Emission of an instruction sequence *) -let no_fallthrough = function - Lop(Itailcall_ind | Itailcall_imm _) -> true - | Lreturn -> true - | Lbranch _ -> true - | Lswitch _ -> true - | Lraise -> true - | _ -> false - let rec emit_all ninstr i = if i.desc = Lend then () else begin let n = emit_instr i in let ninstr' = ninstr + n in - let limit = 511 - !num_literals in - if ninstr' >= limit - 64 && no_fallthrough i.desc then begin - emit_constants(); + (* fldd can address up to +/-1KB, ldr can address up to +/-4KB *) + let limit = (if !fpu >= VFPv3_D16 && !float_literals <> [] + then 127 + else 511) in + let limit = limit - !num_literals in + if ninstr' >= limit - 64 && not(has_fallthrough i.desc) then begin + emit_literals(); emit_all 0 i.next - end else - if ninstr' >= limit then begin + end else if !num_literals != 0 && ninstr' >= limit then begin let lbl = new_label() in ` b {emit_label lbl}\n`; - emit_constants(); + emit_literals(); `{emit_label lbl}:\n`; emit_all 0 i.next end else emit_all ninstr' i.next end +(* Emission of the profiling prelude *) + +let emit_profile() = + match Config.system with + "linux_eabi" | "linux_eabihf" -> + ` push \{lr}\n`; + ` {emit_call "__gnu_mcount_nc"}\n` + | _ -> () + (* Emission of a function declaration *) let fundecl fundecl = function_name := fundecl.fun_name; fastcode_flag := fundecl.fun_fast; tailrec_entry_point := new_label(); + float_literals := []; + gotrel_literals := []; + symbol_literals := []; stack_offset := 0; - Hashtbl.clear symbol_constants; - Hashtbl.clear float_constants; + call_gc_sites := []; + bound_error_sites := []; ` .text\n`; ` .align 2\n`; - ` .global {emit_symbol fundecl.fun_name}\n`; + ` .globl {emit_symbol fundecl.fun_name}\n`; + if !arch > ARMv6 && !thumb then + ` .thumb\n` + else + ` .arm\n`; ` .type {emit_symbol fundecl.fun_name}, %function\n`; `{emit_symbol fundecl.fun_name}:\n`; + 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_constants() + 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` (* Emission of data *) let emit_item = function - Cglobal_symbol s -> - ` .global {emit_symbol s}\n`; - | Cdefine_symbol s -> - `{emit_symbol s}:\n` - | Cdefine_label lbl -> - `{emit_data_label lbl}:\n` - | Cint8 n -> - ` .byte {emit_int n}\n` - | Cint16 n -> - ` .short {emit_int n}\n` - | Cint32 n -> - ` .word {emit_nativeint n}\n` - | Cint n -> - ` .word {emit_nativeint n}\n` - | Csingle f -> - emit_float32_directive ".long" f - | Cdouble f -> - emit_float64_split_directive ".long" f - | Csymbol_address s -> - ` .word {emit_symbol s}\n` - | Clabel_address lbl -> - ` .word {emit_data_label lbl}\n` - | Cstring s -> - emit_string_directive " .ascii " s - | Cskip n -> - if n > 0 then ` .space {emit_int n}\n` - | Calign n -> - ` .align {emit_int(Misc.log2 n)}\n` + Cglobal_symbol s -> ` .globl {emit_symbol s}\n`; + | Cdefine_symbol s -> `{emit_symbol s}:\n` + | Cdefine_label lbl -> `{emit_data_label lbl}:\n` + | Cint8 n -> ` .byte {emit_int n}\n` + | Cint16 n -> ` .short {emit_int n}\n` + | Cint32 n -> ` .long {emit_int32 (Nativeint.to_int32 n)}\n` + | Cint n -> ` .long {emit_int32 (Nativeint.to_int32 n)}\n` + | Csingle f -> ` .single {emit_string f}\n` + | Cdouble f -> ` .double {emit_string f}\n` + | Csymbol_address s -> ` .word {emit_symbol s}\n` + | Clabel_address lbl -> ` .word {emit_data_label lbl}\n` + | Cstring s -> emit_string_directive " .ascii " s + | Cskip n -> if n > 0 then ` .space {emit_int n}\n` + | Calign n -> ` .align {emit_int(Misc.log2 n)}\n` let data l = ` .data\n`; @@ -608,32 +898,63 @@ let data l = (* Beginning / end of an assembly file *) let begin_assembly() = - `trap_ptr .req r11\n`; - `alloc_ptr .req r8\n`; - `alloc_limit .req r10\n`; + reset_debug_info(); + ` .syntax unified\n`; + begin match !arch with + | ARMv4 -> ` .arch armv4t\n` + | ARMv5 -> ` .arch armv5t\n` + | ARMv5TE -> ` .arch armv5te\n` + | ARMv6 -> ` .arch armv6\n` + | ARMv6T2 -> ` .arch armv6t2\n` + | ARMv7 -> ` .arch armv7-a\n` + end; + begin match !fpu with + Soft -> ` .fpu softvfp\n` + | VFPv3_D16 -> ` .fpu vfpv3-d16\n` + | VFPv3 -> ` .fpu vfpv3\n` + end; + `trap_ptr .req r8\n`; + `alloc_ptr .req r10\n`; + `alloc_limit .req r11\n`; let lbl_begin = Compilenv.make_symbol (Some "data_begin") in ` .data\n`; - ` .global {emit_symbol lbl_begin}\n`; + ` .globl {emit_symbol lbl_begin}\n`; `{emit_symbol lbl_begin}:\n`; let lbl_begin = Compilenv.make_symbol (Some "code_begin") in ` .text\n`; - ` .global {emit_symbol lbl_begin}\n`; + ` .globl {emit_symbol lbl_begin}\n`; `{emit_symbol lbl_begin}:\n` let end_assembly () = let lbl_end = Compilenv.make_symbol (Some "code_end") in ` .text\n`; - ` .global {emit_symbol lbl_end}\n`; + ` .globl {emit_symbol lbl_end}\n`; `{emit_symbol lbl_end}:\n`; let lbl_end = Compilenv.make_symbol (Some "data_end") in ` .data\n`; - ` .global {emit_symbol lbl_end}\n`; + ` .globl {emit_symbol lbl_end}\n`; `{emit_symbol lbl_end}:\n`; - ` .word 0\n`; + ` .long 0\n`; let lbl = Compilenv.make_symbol (Some "frametable") in - ` .data\n`; - ` .global {emit_symbol lbl}\n`; + ` .globl {emit_symbol lbl}\n`; `{emit_symbol lbl}:\n`; - ` .word {emit_int (List.length !frame_descriptors)}\n`; - List.iter emit_frame !frame_descriptors; - frame_descriptors := [] + emit_frames + { efa_label = (fun lbl -> + ` .type {emit_label lbl}, %function\n`; + ` .word {emit_label lbl}\n`); + efa_16 = (fun n -> ` .short {emit_int n}\n`); + efa_32 = (fun n -> ` .long {emit_int32 n}\n`); + efa_word = (fun n -> ` .word {emit_int n}\n`); + efa_align = (fun n -> ` .align {emit_int(Misc.log2 n)}\n`); + efa_label_rel = (fun lbl ofs -> + ` .word {emit_label lbl} - . + {emit_int32 ofs}\n`); + efa_def_label = (fun lbl -> `{emit_label lbl}:\n`); + efa_string = (fun s -> emit_string_directive " .asciz " s) }; + ` .type {emit_symbol lbl}, %object\n`; + ` .size {emit_symbol lbl}, .-{emit_symbol lbl}\n`; + begin match Config.system with + "linux_eabihf" | "linux_eabi" -> + (* Mark stack as non-executable *) + ` .section .note.GNU-stack,\"\",%progbits\n` + | _ -> () + end diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml index 705f8c6fe8..aed2b01a76 100644 --- a/asmcomp/arm/proc.ml +++ b/asmcomp/arm/proc.ml @@ -2,11 +2,12 @@ (* *) (* OCaml *) (* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) (* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) +(* Copyright 1998 Institut National de Recherche en Informatique *) +(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) +(* reserved. This file is distributed under the terms of the Q *) +(* Public License version 1.0. *) (* *) (***********************************************************************) @@ -26,32 +27,56 @@ let word_addressed = false (* Registers available for register allocation *) -(* Register map: - r0 - r3 general purpose (not preserved by C) - r4 - r7 general purpose (preserved) - r8 allocation pointer (preserved) - r9 platform register, usually reserved - r10 allocation limit (preserved) - r11 trap pointer (preserved) - r12 general purpose (not preserved by C) - r13 stack pointer - r14 return address - r15 program counter +(* Integer register map: + r0 - r3 general purpose (not preserved) + r4 - r7 general purpose (preserved) + r8 trap pointer (preserved) + r9 platform register, usually reserved + r10 allocation pointer (preserved) + r11 allocation limit (preserved) + r12 intra-procedural scratch register (not preserved) + r13 stack pointer + r14 return address + r15 program counter + Floatinng-point register map (VFPv3): + d0 - d7 general purpose (not preserved) + d8 - d15 general purpose (preserved) + d16 - d31 generat purpose (not preserved), VFPv3 only *) -let int_reg_name = [| - "r0"; "r1"; "r2"; "r3"; "r4"; "r5"; "r6"; "r7"; "r12" -|] +let int_reg_name = + [| "r0"; "r1"; "r2"; "r3"; "r4"; "r5"; "r6"; "r7"; "r12" |] + +let float_reg_name = + [| "d0"; "d1"; "d2"; "d3"; "d4"; "d5"; "d6"; "d7"; + "d8"; "d9"; "d10"; "d11"; "d12"; "d13"; "d14"; "d15"; + "d16"; "d17"; "d18"; "d19"; "d20"; "d21"; "d22"; "d23"; + "d24"; "d25"; "d26"; "d27"; "d28"; "d29"; "d30"; "d31" |] + +(* We have three register classes: + 0 for integer registers + 1 for VFPv3-D16 + 2 for VFPv3 + This way we can choose between VFPv3-D16 and VFPv3 + at (ocamlopt) runtime using command line switches. +*) -let num_register_classes = 1 +let num_register_classes = 3 -let register_class r = assert (r.typ <> Float); 0 +let register_class r = + match (r.typ, !fpu) with + (Int | Addr), _ -> 0 + | Float, VFPv3_D16 -> 1 + | Float, _ -> 2 -let num_available_registers = [| 9 |] +let num_available_registers = + [| 9; 16; 32 |] -let first_available_register = [| 0 |] +let first_available_register = + [| 0; 100; 100 |] -let register_name r = int_reg_name.(r) +let register_name r = + if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) let rotate_registers = true @@ -59,25 +84,34 @@ let rotate_registers = true let hard_int_reg = let v = Array.create 9 Reg.dummy in - for i = 0 to 8 do v.(i) <- Reg.at_location Int (Reg i) done; + for i = 0 to 8 do + v.(i) <- Reg.at_location Int (Reg i) + done; + v + +let hard_float_reg = + let v = Array.create 32 Reg.dummy in + for i = 0 to 31 do + v.(i) <- Reg.at_location Float (Reg(100 + i)) + done; v -let all_phys_regs = hard_int_reg +let all_phys_regs = + Array.append hard_int_reg hard_float_reg -let phys_reg n = all_phys_regs.(n) +let phys_reg n = + if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) let stack_slot slot ty = - assert (ty <> Float); Reg.at_location ty (Stack slot) (* Calling conventions *) -(* XXX float types have already been expanded into pairs of integers. - So we cannot align these floats. See if that causes a problem. *) - -let calling_conventions first_int last_int make_stack arg = +let calling_conventions + first_int last_int first_float last_float make_stack arg = let loc = Array.create (Array.length arg) Reg.dummy in let int = ref first_int in + let float = ref first_float in let ofs = ref 0 in for i = 0 to Array.length arg - 1 do match arg.(i).typ with @@ -90,37 +124,86 @@ let calling_conventions first_int last_int make_stack arg = ofs := !ofs + size_int end | Float -> - assert false + assert (abi = EABI_VFP); + assert (!fpu >= VFPv3_D16); + if !float <= last_float then begin + loc.(i) <- phys_reg !float; + incr float + end else begin + ofs := Misc.align !ofs size_float; + loc.(i) <- stack_slot (make_stack !ofs) Float; + ofs := !ofs + size_float + end done; - (loc, Misc.align !ofs 8) + (loc, Misc.align !ofs 8) (* keep stack 8-aligned *) let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs let not_supported ofs = fatal_error "Proc.loc_results: cannot call" +(* OCaml calling convention: + first integer args in r0...r7 + first float args in d0...d15 (EABI+VFP) + remaining args on stack. + Return values in r0...r7 or d0...d15. *) + let loc_arguments arg = - calling_conventions 0 7 outgoing arg + calling_conventions 0 7 100 115 outgoing arg let loc_parameters arg = - let (loc, ofs) = calling_conventions 0 7 incoming arg in loc + let (loc, _) = calling_conventions 0 7 100 115 incoming arg in loc let loc_results res = - let (loc, ofs) = calling_conventions 0 7 not_supported res in loc + let (loc, _) = calling_conventions 0 7 100 115 not_supported res in loc + +(* C calling convention: + first integer args in r0...r3 + first float args in d0...d7 (EABI+VFP) + remaining args on stack. + Return values in r0...r1 or d0. *) let loc_external_arguments arg = - calling_conventions 0 3 outgoing arg + calling_conventions 0 3 100 107 outgoing arg let loc_external_results res = - let (loc, ofs) = calling_conventions 0 1 not_supported res in loc + let (loc, _) = calling_conventions 0 1 100 100 not_supported res in loc let loc_exn_bucket = phys_reg 0 (* Registers destroyed by operations *) -let destroyed_at_c_call = (* r4-r7 preserved *) - Array.of_list(List.map phys_reg [0;1;2;3;8]) +let destroyed_at_alloc = (* r0-r6, d0-d15 preserved *) + Array.of_list (List.map + phys_reg + [7;8; + 116;116;118;119;120;121;122;123; + 124;125;126;127;128;129;130;131]) + +let destroyed_at_c_call = + Array.of_list (List.map + phys_reg + (match abi with + EABI -> (* r4-r7 preserved *) + [0;1;2;3;8; + 100;101;102;103;104;105;106;107; + 108;109;110;111;112;113;114;115; + 116;116;118;119;120;121;122;123; + 124;125;126;127;128;129;130;131] + | EABI_VFP -> (* r4-r7, d8-d15 preserved *) + [0;1;2;3;8; + 100;101;102;103;104;105;106;107; + 116;116;118;119;120;121;122;123; + 124;125;126;127;128;129;130;131])) let destroyed_at_oper = function - Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs - | Iop(Iextcall(_, false)) -> destroyed_at_c_call - | Iop(Ialloc(_)) -> [|phys_reg 8|] (* r12 destroyed *) + Iop(Icall_ind | Icall_imm _ ) + | Iop(Iextcall(_, true)) -> + all_phys_regs + | Iop(Iextcall(_, false)) -> + destroyed_at_c_call + | Iop(Ialloc n) -> + destroyed_at_alloc + | Iop(Iconst_symbol _) when !pic_code -> + [|phys_reg 3; phys_reg 8|] (* r3 and r12 destroyed *) + | Iop(Iintoffloat | Ifloatofint | Iload(Single, _) | Istore(Single, _)) -> + [|phys_reg 107|] (* d7 (s14-s15) destroyed *) | _ -> [||] let destroyed_at_raise = all_phys_regs @@ -128,15 +211,16 @@ let destroyed_at_raise = all_phys_regs (* Maximal register pressure *) let safe_register_pressure = function - Iextcall(_, _) -> 4 + Iextcall(_, _) -> 5 | _ -> 9 + let max_register_pressure = function - Iextcall(_, _) -> [| 4 |] - | _ -> [| 9 |] + Iextcall(_, _) -> [| 5; 9; 9 |] + | _ -> [| 9; 16; 32 |] (* Layout of the stack *) -let num_stack_slots = [| 0 |] +let num_stack_slots = [| 0; 0; 0 |] let contains_calls = ref false (* Calling the assembler *) @@ -144,6 +228,3 @@ let contains_calls = ref false let assemble_file infile outfile = Ccomp.command (Config.asm ^ " -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) - -open Clflags;; -open Config;; diff --git a/asmcomp/arm/scheduling.ml b/asmcomp/arm/scheduling.ml index 4b037289b9..4b47733f1f 100644 --- a/asmcomp/arm/scheduling.ml +++ b/asmcomp/arm/scheduling.ml @@ -2,50 +2,78 @@ (* *) (* OCaml *) (* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) (* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) +(* Copyright 1998 Institut National de Recherche en Informatique *) +(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) +(* reserved. This file is distributed under the terms of the Q *) +(* Public License version 1.0. *) (* *) (***********************************************************************) (* $Id$ *) +open Arch open Mach -(* Instruction scheduling for the Sparc *) +(* Instruction scheduling for the ARM *) -class scheduler = object +class scheduler = object(self) -inherit Schedgen.scheduler_generic +inherit Schedgen.scheduler_generic as super -(* Scheduling -- based roughly on the Strong ARM *) +(* Scheduling -- based roughly on the ARM11 (ARMv6) *) method oper_latency = function - Ireload -> 2 - | Iload(_, _) -> 2 - | Iconst_symbol _ -> 2 (* turned into a load *) - | Iconst_float _ -> 2 (* turned into a load *) - | Iintop(Imul) -> 3 - | Iintop_imm(Imul, _) -> 3 - (* No data available for floatops, let's make educated guesses *) - | Iaddf -> 3 - | Isubf -> 3 - | Imulf -> 5 - | Idivf -> 15 + (* Loads have a latency of two cycles in general *) + Iconst_symbol _ + | Iconst_float _ + | Iload(_, _) + | Ireload + | Ifloatofint (* mcr/mrc count as memory access *) + | Iintoffloat -> 2 + (* Multiplys have a latency of two cycles *) + | Iintop Imul + | Ispecific(Imuladd | Imulsub) -> 2 + (* VFP instructions *) + | Iaddf + | Isubf + | Idivf + | Imulf | Ispecific Inegmulf + | Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf) + | Ispecific Isqrtf + | Inegf | Iabsf when !fpu >= VFPv3_D16 -> 2 + (* Everything else *) | _ -> 1 -(* Issue cycles. Rough approximations *) +method! is_checkbound = function + Ispecific(Ishiftcheckbound _) -> true + | op -> super#is_checkbound op + +(* Issue cycles. Rough approximations *) method oper_issue_cycles = function Ialloc _ -> 4 - | Iintop(Icomp _) -> 3 - | Iintop(Icheckbound) -> 2 - | Iintop_imm(Idiv, _) -> 4 - | Iintop_imm(Imod, _) -> 6 + | Iintop(Ilsl | Ilsr | Iasr) -> 2 + | Iintop(Icomp _) | Iintop_imm(Icomp _, _) -> 3 + | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) -> 2 + | Ispecific(Ishiftcheckbound _) -> 3 + | Iintop_imm(Idiv, _) -> 4 + | Iintop_imm(Imod, _) -> 6 + | Iintop Imul + | Ispecific(Imuladd | Imulsub) -> 2 + (* VFP instructions *) + | Iaddf + | Isubf -> 7 + | Imulf + | Ispecific Inegmulf -> 9 + | Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf) -> 17 + | Idivf + | Ispecific Isqrtf -> 27 + | Inegf | Iabsf | Iconst_float _ when !fpu >= VFPv3_D16 -> 4 + (* Everything else *) | _ -> 1 end diff --git a/asmcomp/arm/selection.ml b/asmcomp/arm/selection.ml index bd165898cd..94d0367bef 100644 --- a/asmcomp/arm/selection.ml +++ b/asmcomp/arm/selection.ml @@ -2,11 +2,12 @@ (* *) (* OCaml *) (* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) (* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) +(* Copyright 1998 Institut National de Recherche en Informatique *) +(* et en Automatique. Copyright 2012 Benedikt Meurer. All rights *) +(* reserved. This file is distributed under the terms of the Q *) +(* Public License version 1.0. *) (* *) (***********************************************************************) @@ -14,41 +15,63 @@ (* Instruction selection for the ARM processor *) -open Misc -open Cmm -open Reg open Arch -open Proc +open Cmm open Mach +open Misc +open Proc +open Reg -(* Immediate operands are 8-bit immediate values, zero-extended, and rotated - right by 0, 2, 4, ... 30 bits. - To avoid problems with Caml's 31-bit arithmetic, - we check only with 8-bit values shifted left 0 to 22 bits. *) - -let rec is_immed n shift = - if shift > 22 then false - else if n land (0xFF lsl shift) = n then true - else is_immed n (shift + 2) +let is_offset chunk n = + match chunk with + (* VFPv3 load/store have -1020 to 1020 *) + Single | Double | Double_u + when !fpu >= VFPv3_D16 -> + n >= -1020 && n <= 1020 + (* ARM load/store byte/word have -4095 to 4095 *) + | Byte_unsigned | Byte_signed + | Thirtytwo_unsigned | Thirtytwo_signed + | Word | Single + when not !thumb -> + n >= -4095 && n <= 4095 + (* Thumb-2 load/store have -255 to 4095 *) + | _ when !arch > ARMv6 && !thumb -> + n >= -255 && n <= 4095 + (* Everything else has -255 to 255 *) + | _ -> + n >= -255 && n <= 255 -(* We have 12-bit + sign byte offsets for word accesses, - 8-bit + sign word offsets for float accesses, - and 8-bit + sign byte offsets for bytes and shorts. - Use lowest common denominator. *) +let is_intconst = function + Cconst_int _ -> true + | _ -> false -let is_offset n = n < 256 && n > -256 +(* Special constraints on operand and result registers *) -let is_intconst = function Cconst_int n -> true | _ -> false +exception Use_default -(* Soft emulation of float comparisons *) +let r1 = phys_reg 1 -let float_comparison_function = function - | Ceq -> "__eqdf2" - | Cne -> "__nedf2" - | Clt -> "__ltdf2" - | Cle -> "__ledf2" - | Cgt -> "__gtdf2" - | Cge -> "__gedf2" +let pseudoregs_for_operation op arg res = + match op with + (* For mul rd,rm,rs and mla rd,rm,rs,ra (pre-ARMv6) the registers rm + and rd must be different. We deal with this by pretending that rm + is also a result of the mul / mla operation. *) + Iintop Imul | Ispecific Imuladd when !arch < ARMv6 -> + (arg, [| res.(0); arg.(0) |]) + (* Soft-float Iabsf and Inegf: arg.(0) and res.(0) must be the same *) + | Iabsf | Inegf when !fpu = Soft -> + ([|res.(0); arg.(1)|], res) + (* VFPv3 Imuladdf...Inegmulsubf: arg.(0) and res.(0) must be the same *) + | Ispecific(Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf) -> + let arg' = Array.copy arg in + arg'.(0) <- res.(0); + (arg', res) + (* We use __aeabi_idivmod for Cmodi only, and hence we care only + for the remainder in r1, so fix up the destination register. *) + | Iextcall("__aeabi_idivmod", false) -> + (arg, [|r1|]) + (* Other instructions are regular *) + | _ -> raise Use_default (* Instruction selection *) class selector = object(self) @@ -56,23 +79,32 @@ class selector = object(self) inherit Selectgen.selector_generic as super method! regs_for tyv = - (* Expand floats into pairs of integer registers *) - let nty = Array.length tyv in - let rec expand i = - if i >= nty then [] else begin - match tyv.(i) with - | Float -> Int :: Int :: expand (i+1) - | ty -> ty :: expand (i+1) - end in - Reg.createv (Array.of_list (expand 0)) + Reg.createv (if !fpu = Soft then begin + (* Expand floats into pairs of integer registers *) + let rec expand = function + [] -> [] + | Float :: tyl -> Int :: Int :: expand tyl + | ty :: tyl -> ty :: expand tyl in + Array.of_list (expand (Array.to_list tyv)) + end else begin + tyv + end) method is_immediate n = - n land 0xFF = n || is_immed n 2 + is_immediate (Int32.of_int n) + +method! is_simple_expr = function + (* inlined floating-point ops are simple if their arguments are *) + | Cop(Cextcall("sqrt", _, _, _), args) when !fpu >= VFPv3_D16 -> + List.for_all self#is_simple_expr args + | e -> super#is_simple_expr e -method select_addressing = function - Cop(Cadda, [arg; Cconst_int n]) when is_offset n -> +method select_addressing chunk = function + | Cop(Cadda, [arg; Cconst_int n]) + when is_offset chunk n -> (Iindexed n, arg) - | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) when is_offset n -> + | Cop(Cadda, [arg1; Cop(Caddi, [arg2; Cconst_int n])]) + when is_offset chunk n -> (Iindexed n, Cop(Cadda, [arg1; arg2])) | arg -> (Iindexed 0, arg) @@ -91,109 +123,146 @@ method select_shift_arith op shiftop shiftrevop args = | [Cop(Casr, [arg1; Cconst_int n]); arg2] when n > 0 && n < 32 && not(is_intconst arg1) -> (Ispecific(Ishiftarith(shiftrevop, -n)), [arg2; arg1]) - | _ -> - super#select_operation op args + | args -> + begin match super#select_operation op args with + (* Recognize multiply and add *) + (Iintop Iadd, [Cop(Cmuli, args); arg3]) + | (Iintop Iadd, [arg3; Cop(Cmuli, args)]) as op_args -> + begin match self#select_operation Cmuli args with + (Iintop Imul, [arg1; arg2]) -> + (Ispecific Imuladd, [arg1; arg2; arg3]) + | _ -> op_args + end + (* Recognize multiply and subtract *) + | (Iintop Isub, [arg3; Cop(Cmuli, args)]) as op_args + when !arch > ARMv6 -> + begin match self#select_operation Cmuli args with + (Iintop Imul, [arg1; arg2]) -> + (Ispecific Imulsub, [arg1; arg2; arg3]) + | _ -> op_args + end + | op_args -> op_args + end method! select_operation op args = - match op with - Cadda | Caddi -> - begin match args with - [arg1; Cconst_int n] when n < 0 && self#is_immediate (-n) -> - (Iintop_imm(Isub, -n), [arg1]) - | _ -> - self#select_shift_arith op Ishiftadd Ishiftadd args - end - | Csuba | Csubi -> - begin match args with - [arg1; Cconst_int n] when n < 0 && self#is_immediate (-n) -> - (Iintop_imm(Iadd, -n), [arg1]) - | [Cconst_int n; arg2] when self#is_immediate n -> - (Ispecific(Irevsubimm n), [arg2]) - | _ -> - self#select_shift_arith op Ishiftsub Ishiftsubrev args - end - | Cmuli -> (* no multiply immediate *) + match (op, args) with + (* Recognize special shift arithmetic *) + ((Cadda | Caddi), [arg; Cconst_int n]) + when n < 0 && self#is_immediate (-n) -> + (Iintop_imm(Isub, -n), [arg]) + | ((Cadda | Caddi as op), args) -> + self#select_shift_arith op Ishiftadd Ishiftadd args + | ((Csuba | Csubi), [arg; Cconst_int n]) + when n < 0 && self#is_immediate (-n) -> + (Iintop_imm(Iadd, -n), [arg]) + | ((Csuba | Csubi), [Cconst_int n; arg]) + when self#is_immediate n -> + (Ispecific(Irevsubimm n), [arg]) + | ((Csuba | Csubi as op), args) -> + self#select_shift_arith op Ishiftsub Ishiftsubrev args + | (Ccheckbound _, [Cop(Clsr, [arg1; Cconst_int n]); arg2]) + when n > 0 && n < 32 && not(is_intconst arg2) -> + (Ispecific(Ishiftcheckbound n), [arg1; arg2]) + (* ARM does not support immediate operands for multiplication *) + | (Cmuli, args) -> (Iintop Imul, args) - | Cdivi -> - begin match args with - [arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Idiv, n), [arg1]) - | _ -> - (Iextcall("__divsi3", false), args) - end - | Cmodi -> - begin match args with - [arg1; Cconst_int n] when n = 1 lsl (Misc.log2 n) -> - (Iintop_imm(Imod, n), [arg1]) - | _ -> - (Iextcall("__modsi3", false), args) - end - | Ccheckbound _ -> - begin match args with - [Cop(Clsr, [arg1; Cconst_int n]); arg2] - when n > 0 && n < 32 && not(is_intconst arg2) -> - (Ispecific(Ishiftcheckbound n), [arg1; arg2]) - | _ -> - super#select_operation op args - end - (* Turn floating-point operations into library function calls *) - | Caddf -> (Iextcall("__adddf3", false), args) - | Csubf -> (Iextcall("__subdf3", false), args) - | Cmulf -> (Iextcall("__muldf3", false), args) - | Cdivf -> (Iextcall("__divdf3", false), args) - | Cfloatofint -> (Iextcall("__floatsidf", false), args) - | Cintoffloat -> (Iextcall("__fixdfsi", false), args) - | Ccmpf comp -> - (Iintop_imm(Icomp(Isigned comp), 0), - [Cop(Cextcall(float_comparison_function comp, - typ_int, false, Debuginfo.none), - args)]) + (* Turn integer division/modulus into runtime ABI calls *) + | (Cdivi, [arg; Cconst_int n]) + when n = 1 lsl Misc.log2 n -> + (Iintop_imm(Idiv, n), [arg]) + | (Cdivi, args) -> + (Iextcall("__aeabi_idiv", false), args) + | (Cmodi, [arg; Cconst_int n]) + when n = 1 lsl Misc.log2 n -> + (Iintop_imm(Imod, n), [arg]) + | (Cmodi, args) -> + (* See above for fix up of return register *) + (Iextcall("__aeabi_idivmod", false), args) + (* Turn floating-point operations into runtime ABI calls for softfp *) + | (op, args) when !fpu = Soft -> self#select_operation_softfp op args + (* Select operations for VFPv3 *) + | (op, args) -> self#select_operation_vfpv3 op args + +method private select_operation_softfp op args = + match (op, args) with + (* Turn floating-point operations into runtime ABI calls *) + | (Caddf, args) -> (Iextcall("__aeabi_dadd", false), args) + | (Csubf, args) -> (Iextcall("__aeabi_dsub", false), args) + | (Cmulf, args) -> (Iextcall("__aeabi_dmul", false), args) + | (Cdivf, args) -> (Iextcall("__aeabi_ddiv", false), args) + | (Cfloatofint, args) -> (Iextcall("__aeabi_i2d", false), args) + | (Cintoffloat, args) -> (Iextcall("__aeabi_d2iz", false), args) + | (Ccmpf comp, args) -> + let func = (match comp with + Cne (* there's no __aeabi_dcmpne *) + | Ceq -> "__aeabi_dcmpeq" + | Clt -> "__aeabi_dcmplt" + | Cle -> "__aeabi_dcmple" + | Cgt -> "__aeabi_dcmpgt" + | Cge -> "__aeabi_dcmpge") in + let comp = (match comp with + Cne -> Ceq (* eq 0 => false *) + | _ -> Cne (* ne 0 => true *)) in + (Iintop_imm(Icomp(Iunsigned comp), 0), + [Cop(Cextcall(func, typ_int, false, Debuginfo.none), args)]) (* Add coercions around loads and stores of 32-bit floats *) - | Cload Single -> - (Iextcall("__extendsfdf2", false), [Cop(Cload Word, args)]) - | Cstore Single -> - begin match args with - | [arg1; arg2] -> - let arg2' = - Cop(Cextcall("__truncdfsf2", typ_int, false, Debuginfo.none), - [arg2]) in - self#select_operation (Cstore Word) [arg1; arg2'] - | _ -> assert false - end + | (Cload Single, args) -> + (Iextcall("__aeabi_f2d", false), [Cop(Cload Word, args)]) + | (Cstore Single, [arg1; arg2]) -> + let arg2' = + Cop(Cextcall("__aeabi_d2f", typ_int, false, Debuginfo.none), + [arg2]) in + self#select_operation (Cstore Word) [arg1; arg2'] (* Other operations are regular *) - | _ -> super#select_operation op args + | (op, args) -> super#select_operation op args + +method private select_operation_vfpv3 op args = + match (op, args) with + (* Recognize floating-point negate and multiply *) + (Cnegf, [Cop(Cmulf, args)]) -> + (Ispecific Inegmulf, args) + (* Recognize floating-point multiply and add *) + | (Caddf, [arg; Cop(Cmulf, args)]) + | (Caddf, [Cop(Cmulf, args); arg]) -> + (Ispecific Imuladdf, arg :: args) + (* Recognize floating-point negate, multiply and subtract *) + | (Csubf, [Cop(Cnegf, [arg]); Cop(Cmulf, args)]) + | (Csubf, [Cop(Cnegf, [Cop(Cmulf, args)]); arg]) -> + (Ispecific Inegmulsubf, arg :: args) + (* Recognize floating-point negate, multiply and add *) + | (Csubf, [arg; Cop(Cmulf, args)]) -> + (Ispecific Inegmuladdf, arg :: args) + (* Recognize multiply and subtract *) + | (Csubf, [Cop(Cmulf, args); arg]) -> + (Ispecific Imulsubf, arg :: args) + (* Recognize floating-point square root *) + | (Cextcall("sqrt", _, false, _), args) -> + (Ispecific Isqrtf, args) + (* Other operations are regular *) + | (op, args) -> super#select_operation op args method! select_condition = function - | Cop(Ccmpf cmp, args) -> - (Iinttest_imm(Isigned cmp, 0), - Cop(Cextcall(float_comparison_function cmp, - typ_int, false, Debuginfo.none), - args)) + (* Turn floating-point comparisons into runtime ABI calls *) + Cop(Ccmpf _ as op, args) when !fpu = Soft -> + begin match self#select_operation_softfp op args with + (Iintop_imm(Icomp(Iunsigned Ceq), 0), [arg]) -> (Ifalsetest, arg) + | (Iintop_imm(Icomp(Iunsigned Cne), 0), [arg]) -> (Itruetest, arg) + | _ -> assert false + end | expr -> super#select_condition expr -(* Deal with some register irregularities: - -1- In mul rd, rm, rs, the registers rm and rd must be different. - We deal with this by pretending that rm is also a result of the mul - operation. - -2- For Inegf and Iabsf, force arguments and results in (r0, r1); - this simplifies code generation later. -*) +(* Deal with some register constraints *) method! insert_op_debug op dbg rs rd = - match op with - | Iintop(Imul) -> - self#insert_debug (Iop op) dbg rs [| rd.(0); rs.(0) |]; rd - | Iabsf | Inegf -> - let r = [| phys_reg 0; phys_reg 1 |] in - self#insert_moves rs r; - self#insert_debug (Iop op) dbg r r; - self#insert_moves r rd; - rd - | _ -> - super#insert_op_debug op dbg rs rd + try + let (rsrc, rdst) = pseudoregs_for_operation op rs rd in + self#insert_moves rs rsrc; + self#insert_debug (Iop op) dbg rsrc rdst; + self#insert_moves rdst rd; + rd + with Use_default -> + super#insert_op_debug op dbg rs rd end diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index c14c0006db..5f513db1bb 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -135,4 +135,5 @@ let compile_implementation ?toplevel prefixname ppf (size, lam) = let report_error ppf = function | Assembler_error file -> - fprintf ppf "Assembler error, input left in file %s" file + fprintf ppf "Assembler error, input left in file %a" + Location.print_filename file diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index 8a1109fd68..e99e62a397 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -342,7 +342,8 @@ let report_error ppf = function | File_not_found name -> fprintf ppf "Cannot find file %s" name | Not_an_object_file name -> - fprintf ppf "The file %s is not a compilation unit description" name + fprintf ppf "The file %a is not a compilation unit description" + Location.print_filename name | Missing_implementations l -> let print_references ppf = function | [] -> () @@ -359,27 +360,35 @@ let report_error ppf = function print_modules l | Inconsistent_interface(intf, file1, file2) -> fprintf ppf - "@[<hov>Files %s@ and %s@ make inconsistent assumptions \ + "@[<hov>Files %a@ and %a@ make inconsistent assumptions \ over interface %s@]" - file1 file2 intf + Location.print_filename file1 + Location.print_filename file2 + intf | Inconsistent_implementation(intf, file1, file2) -> fprintf ppf - "@[<hov>Files %s@ and %s@ make inconsistent assumptions \ + "@[<hov>Files %a@ and %a@ make inconsistent assumptions \ over implementation %s@]" - file1 file2 intf + Location.print_filename file1 + Location.print_filename file2 + intf | Assembler_error file -> - fprintf ppf "Error while assembling %s" file + fprintf ppf "Error while assembling %a" Location.print_filename file | Linking_error -> fprintf ppf "Error during linking" | Multiple_definition(modname, file1, file2) -> fprintf ppf - "@[<hov>Files %s@ and %s@ both define a module named %s@]" - file1 file2 modname + "@[<hov>Files %a@ and %a@ both define a module named %s@]" + Location.print_filename file1 + Location.print_filename file2 + modname | Missing_cmx(filename, name) -> fprintf ppf - "@[<hov>File %s@ was compiled without access@ \ + "@[<hov>File %a@ was compiled without access@ \ to the .cmx file@ for module %s,@ \ which was produced by `ocamlopt -for-pack'.@ \ - Please recompile %s@ with the correct `-I' option@ \ + Please recompile %a@ with the correct `-I' option@ \ so that %s.cmx@ is found.@]" - filename name filename name + Location.print_filename filename name + Location.print_filename filename + name diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index 548a0a3d5e..3f44a0a981 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -193,13 +193,14 @@ open Format let report_error ppf = function Illegal_renaming(file, id) -> - fprintf ppf "Wrong file naming: %s@ contains the code for@ %s" - file id + fprintf ppf "Wrong file naming: %a@ contains the code for@ %s" + Location.print_filename file id | Forward_reference(file, ident) -> - fprintf ppf "Forward reference to %s in file %s" ident file + fprintf ppf "Forward reference to %s in file %a" ident + Location.print_filename file | Wrong_for_pack(file, path) -> - fprintf ppf "File %s@ was not compiled with the `-for-pack %s' option" - file path + fprintf ppf "File %a@ was not compiled with the `-for-pack %s' option" + Location.print_filename file path | File_not_found file -> fprintf ppf "File %s not found" file | Assembler_error file -> diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml index 9bcb36fd16..9a01de819e 100644 --- a/asmcomp/clambda.ml +++ b/asmcomp/clambda.ml @@ -25,8 +25,7 @@ type ulambda = | Uconst of structured_constant * string option | Udirect_apply of function_label * ulambda list * Debuginfo.t | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t - | Uclosure of (function_label * int * Ident.t list * ulambda) list - * ulambda list + | Uclosure of ufunction list * ulambda list | Uoffset of ulambda * int | Ulet of Ident.t * ulambda * ulambda | Uletrec of (Ident.t * ulambda) list * ulambda @@ -42,6 +41,14 @@ type ulambda = | Uassign of Ident.t * ulambda | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t +and ufunction = { + label : function_label; + arity : int; + params : Ident.t list; + body : ulambda; + dbg : Debuginfo.t +} + and ulambda_switch = { us_index_consts: int array; us_actions_consts : ulambda array; diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli index 72ab85769f..808c1c6dae 100644 --- a/asmcomp/clambda.mli +++ b/asmcomp/clambda.mli @@ -25,8 +25,7 @@ type ulambda = | Uconst of structured_constant * string option | Udirect_apply of function_label * ulambda list * Debuginfo.t | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t - | Uclosure of (function_label * int * Ident.t list * ulambda) list - * ulambda list + | Uclosure of ufunction list * ulambda list | Uoffset of ulambda * int | Ulet of Ident.t * ulambda * ulambda | Uletrec of (Ident.t * ulambda) list * ulambda @@ -42,6 +41,14 @@ type ulambda = | Uassign of Ident.t * ulambda | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t +and ufunction = { + label : function_label; + arity : int; + params : Ident.t list; + body : ulambda; + dbg : Debuginfo.t; +} + and ulambda_switch = { us_index_consts: int array; us_actions_consts: ulambda array; diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index f37908f031..365976521f 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -121,7 +121,7 @@ let lambda_smaller lam threshold = match lam with Uvar v -> () | Uconst( - (Const_base(Const_int _ | Const_char _ | Const_float _ | + (Const_base(Const_int _ | Const_char _ | Const_float _ | Const_int32 _ | Const_int64 _ | Const_nativeint _) | Const_pointer _), _) -> incr size (* Structured Constants are now emitted during closure conversion. *) @@ -496,7 +496,7 @@ let rec close fenv cenv = function | Lfunction(kind, params, body) as funct -> close_one_function fenv cenv (Ident.create "fun") funct - (* We convert [f a] to [let a' = a in fun b c -> f a' b c] + (* We convert [f a] to [let a' = a in fun b c -> f a' b c] when fun_arity > nargs *) | Lapply(funct, args, loc) -> let nargs = List.length args in @@ -513,27 +513,27 @@ let rec close fenv cenv = function | ((ufunct, Value_closure(fundesc, approx_res)), uargs) when nargs < fundesc.fun_arity -> - let first_args = List.map (fun arg -> - (Ident.create "arg", arg) ) uargs in - let final_args = Array.to_list (Array.init (fundesc.fun_arity - nargs) (fun _ -> - Ident.create "arg")) in - let rec iter args body = - match args with - [] -> body - | (arg1, arg2) :: args -> - iter args - (Ulet ( arg1, arg2, body)) - in - let internal_args = - (List.map (fun (arg1, arg2) -> Lvar arg1) first_args) - @ (List.map (fun arg -> Lvar arg ) final_args) - in - let (new_fun, approx) = close fenv cenv - (Lfunction( - Curried, final_args, Lapply(funct, internal_args, loc))) - in - let new_fun = iter first_args new_fun in - (new_fun, approx) + let first_args = List.map (fun arg -> + (Ident.create "arg", arg) ) uargs in + let final_args = Array.to_list (Array.init (fundesc.fun_arity - nargs) (fun _ -> + Ident.create "arg")) in + let rec iter args body = + match args with + [] -> body + | (arg1, arg2) :: args -> + iter args + (Ulet ( arg1, arg2, body)) + in + let internal_args = + (List.map (fun (arg1, arg2) -> Lvar arg1) first_args) + @ (List.map (fun arg -> Lvar arg ) final_args) + in + let (new_fun, approx) = close fenv cenv + (Lfunction( + Curried, final_args, Lapply(funct, internal_args, loc))) + in + let new_fun = iter first_args new_fun in + (new_fun, approx) | ((ufunct, Value_closure(fundesc, approx_res)), uargs) when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity -> @@ -594,6 +594,9 @@ let rec close fenv cenv = function let (ubody, approx) = close fenv_body cenv body in (Uletrec(udefs, ubody), approx) end + | Lprim(Pdirapply loc,[funct;arg]) + | Lprim(Prevapply loc,[arg;funct]) -> + close fenv cenv (Lapply(funct, [arg], loc)) | Lprim(Pgetglobal id, []) as lam -> check_constant_result lam (getglobal id) @@ -745,6 +748,9 @@ and close_functions fenv cenv fun_defs = let useless_env = ref initially_closed in (* Translate each function definition *) let clos_fundef (id, params, body, fundesc) env_pos = + let dbg = match body with + | Levent (_,({lev_kind=Lev_function} as ev)) -> Debuginfo.from_call ev + | _ -> Debuginfo.none in let env_param = Ident.create "env" in let cenv_fv = build_closure_env env_param (fv_pos - env_pos) fv in @@ -756,7 +762,11 @@ and close_functions fenv cenv fun_defs = let (ubody, approx) = close fenv_rec cenv_body body in if !useless_env && occurs_var env_param ubody then useless_env := false; let fun_params = if !useless_env then params else params @ [env_param] in - ((fundesc.fun_label, fundesc.fun_arity, fun_params, ubody), + ({ label = fundesc.fun_label; + arity = fundesc.fun_arity; + params = fun_params; + body = ubody; + dbg }, (id, env_pos, Value_closure(fundesc, approx))) in (* Translate all function definitions. *) let clos_info_list = @@ -786,11 +796,12 @@ and close_functions fenv cenv fun_defs = and close_one_function fenv cenv id funct = match close_functions fenv cenv [id, funct] with - ((Uclosure([_, _, params, body], _) as clos), + ((Uclosure([f], _) as clos), [_, _, (Value_closure(fundesc, _) as approx)]) -> (* See if the function can be inlined *) - if lambda_smaller body (!Clflags.inline_threshold + List.length params) - then fundesc.fun_inline <- Some(params, body); + if lambda_smaller f.body + (!Clflags.inline_threshold + List.length f.params) + then fundesc.fun_inline <- Some(f.params, f.body); (clos, approx) | _ -> fatal_error "Closure.close_one_function" diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml index 671ce5d789..7787a22042 100644 --- a/asmcomp/cmm.ml +++ b/asmcomp/cmm.ml @@ -108,7 +108,8 @@ type fundecl = { fun_name: string; fun_args: (Ident.t * machtype) list; fun_body: expression; - fun_fast: bool } + fun_fast: bool; + fun_dbg : Debuginfo.t; } type data_item = Cdefine_symbol of string diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli index 76c50859fe..5787bcb961 100644 --- a/asmcomp/cmm.mli +++ b/asmcomp/cmm.mli @@ -94,7 +94,8 @@ type fundecl = { fun_name: string; fun_args: (Ident.t * machtype) list; fun_body: expression; - fun_fast: bool } + fun_fast: bool; + fun_dbg : Debuginfo.t; } type data_item = Cdefine_symbol of string diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 7a7bd211ad..84c967a523 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -159,13 +159,16 @@ let ignore_low_bit_int = function | Cop(Cor, [c; Cconst_int 1]) -> c | c -> c -let is_nonzero_constant = function - Cconst_int n -> n <> 0 - | Cconst_natint n -> n <> 0n +(* Division or modulo on tagged integers. The overflow case min_int / -1 + cannot occur, but we must guard against division by zero. *) + +let is_different_from x = function + Cconst_int n -> n <> x + | Cconst_natint n -> n <> Nativeint.of_int x | _ -> false let safe_divmod op c1 c2 dbg = - if !Clflags.fast || is_nonzero_constant c2 then + if !Clflags.fast || is_different_from 0 c2 then Cop(op, [c1; c2]) else bind "divisor" c2 (fun c2 -> @@ -174,6 +177,35 @@ let safe_divmod op c1 c2 dbg = Cop(Craise dbg, [Cconst_symbol "caml_bucket_Division_by_zero"]))) +(* Division or modulo on boxed integers. The overflow case min_int / -1 + can occur, in which case we force x / -1 = -x and x mod -1 = 0. (PR#5513). *) + +let safe_divmod_bi mkop mkm1 c1 c2 bi dbg = + bind "dividend" c1 (fun c1 -> + bind "divisor" c2 (fun c2 -> + let c3 = + if Arch.division_crashes_on_overflow + && (size_int = 4 || bi <> Pint32) + && not (is_different_from (-1) c2) + then + Cifthenelse(Cop(Ccmpi Cne, [c2; Cconst_int(-1)]), mkop c1 c2, mkm1 c1) + else + mkop c1 c2 in + if !Clflags.fast || is_different_from 0 c2 then + c3 + else + Cifthenelse(c2, c3, + Cop(Craise dbg, + [Cconst_symbol "caml_bucket_Division_by_zero"])))) + +let safe_div_bi = + safe_divmod_bi (fun c1 c2 -> Cop(Cdivi, [c1;c2])) + (fun c1 -> Cop(Csubi, [Cconst_int 0; c1])) + +let safe_mod_bi = + safe_divmod_bi (fun c1 c2 -> Cop(Cmodi, [c1;c2])) + (fun c1 -> Cconst_int 0) + (* Bool *) let test_bool = function @@ -382,8 +414,7 @@ let make_checkbound dbg = function let fundecls_size fundecls = let sz = ref (-1) in List.iter - (fun (label, arity, params, body) -> - sz := !sz + 1 + (if arity = 1 then 2 else 3)) + (fun f -> sz := !sz + 1 + (if f.arity = 1 then 2 else 3)) fundecls; !sz @@ -461,7 +492,7 @@ let transl_constant = function (* Translate constant closures *) let constant_closures = - ref ([] : (string * (string * int * Ident.t list * ulambda) list) list) + ref ([] : (string * ufunction list) list) (* Boxed integers *) @@ -808,7 +839,7 @@ let subst_boxed_number unbox_fn boxed_id unboxed_id exp = (* Translate an expression *) -let functions = (Queue.create() : (string * Ident.t list * ulambda) Queue.t) +let functions = (Queue.create() : ufunction Queue.t) let rec transl = function Uvar id -> @@ -820,10 +851,7 @@ let rec transl = function | Uclosure(fundecls, []) -> let lbl = Compilenv.new_const_symbol() in constant_closures := (lbl, fundecls) :: !constant_closures; - List.iter - (fun (label, arity, params, body) -> - Queue.add (label, params, body) functions) - fundecls; + List.iter (fun f -> Queue.add f functions) fundecls; Cconst_symbol lbl | Uclosure(fundecls, clos_vars) -> let block_size = @@ -831,22 +859,22 @@ let rec transl = function let rec transl_fundecls pos = function [] -> List.map transl clos_vars - | (label, arity, params, body) :: rem -> - Queue.add (label, params, body) functions; + | f :: rem -> + Queue.add f functions; let header = if pos = 0 then alloc_closure_header block_size else alloc_infix_header pos in - if arity = 1 then + if f.arity = 1 then header :: - Cconst_symbol label :: + Cconst_symbol f.label :: int_const 1 :: transl_fundecls (pos + 3) rem else header :: - Cconst_symbol(curry_function arity) :: - int_const arity :: - Cconst_symbol label :: + Cconst_symbol(curry_function f.arity) :: + int_const f.arity :: + Cconst_symbol f.label :: transl_fundecls (pos + 4) rem in Cop(Calloc, transl_fundecls 0 fundecls) | Uoffset(arg, offset) -> @@ -1245,7 +1273,7 @@ and transl_prim_2 p arg1 arg2 dbg = bind "header" (header arr) (fun hdr -> if wordsize_shift = numfloat_shift then Csequence(make_checkbound dbg [addr_array_length hdr; idx], - Cifthenelse(is_addr_array_hdr hdr, + Cifthenelse(is_addr_array_hdr hdr, addr_array_ref arr idx, float_array_ref arr idx)) else @@ -1288,13 +1316,13 @@ and transl_prim_2 p arg1 arg2 dbg = box_int bi (Cop(Cmuli, [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) | Pdivbint bi -> - box_int bi (safe_divmod Cdivi + box_int bi (safe_div_bi (transl_unbox_int bi arg1) (transl_unbox_int bi arg2) - dbg) + bi dbg) | Pmodbint bi -> - box_int bi (safe_divmod Cmodi + box_int bi (safe_mod_bi (transl_unbox_int bi arg1) (transl_unbox_int bi arg2) - dbg) + bi dbg) | Pandbint bi -> box_int bi (Cop(Cand, [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) @@ -1362,7 +1390,7 @@ and transl_prim_3 p arg1 arg2 arg3 dbg = bind "header" (header arr) (fun hdr -> if wordsize_shift = numfloat_shift then Csequence(make_checkbound dbg [addr_array_length hdr; idx], - Cifthenelse(is_addr_array_hdr hdr, + Cifthenelse(is_addr_array_hdr hdr, addr_array_set arr idx newval, float_array_set arr idx (unbox_float newval))) @@ -1374,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" @@ -1556,11 +1587,12 @@ and transl_letrec bindings cont = (* Translate a function definition *) -let transl_function lbl params body = - Cfunction {fun_name = lbl; - fun_args = List.map (fun id -> (id, typ_addr)) params; - fun_body = transl body; - fun_fast = !Clflags.optimize_for_speed} +let transl_function f = + Cfunction {fun_name = f.label; + fun_args = List.map (fun id -> (id, typ_addr)) f.params; + fun_body = transl f.body; + fun_fast = !Clflags.optimize_for_speed; + fun_dbg = f.dbg; } (* Translate all function definitions *) @@ -1572,12 +1604,13 @@ module StringSet = let rec transl_all_functions already_translated cont = try - let (lbl, params, body) = Queue.take functions in - if StringSet.mem lbl already_translated then + let f = Queue.take functions in + if StringSet.mem f.label already_translated then transl_all_functions already_translated cont else begin - transl_all_functions (StringSet.add lbl already_translated) - (transl_function lbl params body :: cont) + transl_all_functions + (StringSet.add f.label already_translated) + (transl_function f :: cont) end with Queue.Empty -> cont @@ -1709,31 +1742,31 @@ and emit_boxed_int64_constant n cont = let emit_constant_closure symb fundecls cont = match fundecls with [] -> assert false - | (label, arity, params, body) :: remainder -> + | f1 :: remainder -> let rec emit_others pos = function [] -> cont - | (label, arity, params, body) :: rem -> - if arity = 1 then + | f2 :: rem -> + if f2.arity = 1 then Cint(infix_header pos) :: - Csymbol_address label :: + Csymbol_address f2.label :: Cint 3n :: emit_others (pos + 3) rem else Cint(infix_header pos) :: - Csymbol_address(curry_function arity) :: - Cint(Nativeint.of_int (arity lsl 1 + 1)) :: - Csymbol_address label :: + Csymbol_address(curry_function f2.arity) :: + Cint(Nativeint.of_int (f2.arity lsl 1 + 1)) :: + Csymbol_address f2.label :: emit_others (pos + 4) rem in Cint(closure_header (fundecls_size fundecls)) :: Cdefine_symbol symb :: - if arity = 1 then - Csymbol_address label :: + if f1.arity = 1 then + Csymbol_address f1.label :: Cint 3n :: emit_others 3 remainder else - Csymbol_address(curry_function arity) :: - Cint(Nativeint.of_int (arity lsl 1 + 1)) :: - Csymbol_address label :: + Csymbol_address(curry_function f1.arity) :: + Cint(Nativeint.of_int (f1.arity lsl 1 + 1)) :: + Csymbol_address f1.label :: emit_others 4 remainder (* Emit all structured constants *) @@ -1741,12 +1774,12 @@ let emit_constant_closure symb fundecls cont = let emit_all_constants cont = let c = ref cont in List.iter - (fun (lbl, global, cst) -> + (fun (lbl, global, cst) -> let cst = emit_constant lbl cst [] in - let cst = if global then - Cglobal_symbol lbl :: cst + let cst = if global then + Cglobal_symbol lbl :: cst else cst in - c:= Cdata(cst):: !c) + c:= Cdata(cst):: !c) (Compilenv.structured_constants()); (* structured_constants := []; done in Compilenv.reset() *) Hashtbl.clear immstrings; (* PR#3979 *) @@ -1764,7 +1797,8 @@ let compunit size ulam = let init_code = transl ulam in let c1 = [Cfunction {fun_name = Compilenv.make_symbol (Some "entry"); fun_args = []; - fun_body = init_code; fun_fast = false}] in + fun_body = init_code; fun_fast = false; + fun_dbg = Debuginfo.none }] in let c2 = transl_all_functions StringSet.empty c1 in let c3 = emit_all_constants c2 in Cdata [Cint(block_header 0 size); @@ -1893,7 +1927,8 @@ let send_function arity = {fun_name = "caml_send" ^ string_of_int arity; fun_args = fun_args; fun_body = body; - fun_fast = true} + fun_fast = true; + fun_dbg = Debuginfo.none } let apply_function arity = let (args, clos, body) = apply_function_body arity in @@ -1902,7 +1937,8 @@ let apply_function arity = {fun_name = "caml_apply" ^ string_of_int arity; fun_args = List.map (fun id -> (id, typ_addr)) all_args; fun_body = body; - fun_fast = true} + fun_fast = true; + fun_dbg = Debuginfo.none } (* Generate tuplifying functions: (defun caml_tuplifyN (arg clos) @@ -1921,7 +1957,8 @@ let tuplify_function arity = fun_body = Cop(Capply(typ_addr, Debuginfo.none), get_field (Cvar clos) 2 :: access_components 0 @ [Cvar clos]); - fun_fast = true} + fun_fast = true; + fun_dbg = Debuginfo.none } (* Generate currying functions: (defun caml_curryN (arg clos) @@ -1955,15 +1992,15 @@ let final_curry_function arity = args @ [Cvar last_arg; Cvar clos]) else if n = arity - 1 then - begin + begin let newclos = Ident.create "clos" in Clet(newclos, get_field (Cvar clos) 3, curry_fun (get_field (Cvar clos) 2 :: args) newclos (n-1)) - end else - begin - let newclos = Ident.create "clos" in - Clet(newclos, + end else + begin + let newclos = Ident.create "clos" in + Clet(newclos, get_field (Cvar clos) 4, curry_fun (get_field (Cvar clos) 3 :: args) newclos (n-1)) end in @@ -1972,7 +2009,8 @@ let final_curry_function arity = "_" ^ string_of_int (arity-1); fun_args = [last_arg, typ_addr; last_clos, typ_addr]; fun_body = curry_fun [] last_clos (arity-1); - fun_fast = true} + fun_fast = true; + fun_dbg = Debuginfo.none } let rec intermediate_curry_functions arity num = if num = arity - 1 then @@ -1985,49 +2023,51 @@ let rec intermediate_curry_functions arity num = {fun_name = name2; fun_args = [arg, typ_addr; clos, typ_addr]; fun_body = - if arity - num > 2 then - Cop(Calloc, + if arity - num > 2 then + Cop(Calloc, [alloc_closure_header 5; Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1)); int_const (arity - num - 1); Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1) ^ "_app"); - Cvar arg; Cvar clos]) - else - Cop(Calloc, + Cvar arg; Cvar clos]) + else + Cop(Calloc, [alloc_closure_header 4; Cconst_symbol(name1 ^ "_" ^ string_of_int (num+1)); int_const 1; Cvar arg; Cvar clos]); - fun_fast = true} + fun_fast = true; + fun_dbg = Debuginfo.none } :: (if arity - num > 2 then - let rec iter i = - if i <= arity then - let arg = Ident.create (Printf.sprintf "arg%d" i) in - (arg, typ_addr) :: iter (i+1) - else [] - in - let direct_args = iter (num+2) in - let rec iter i args clos = - if i = 0 then - Cop(Capply(typ_addr, Debuginfo.none), - (get_field (Cvar clos) 2) :: args @ [Cvar clos]) - else - let newclos = Ident.create "clos" in - Clet(newclos, - get_field (Cvar clos) 4, - iter (i-1) (get_field (Cvar clos) 3 :: args) newclos) - in - let cf = - Cfunction - {fun_name = name1 ^ "_" ^ string_of_int (num+1) ^ "_app"; - fun_args = direct_args @ [clos, typ_addr]; - fun_body = iter (num+1) - (List.map (fun (arg,_) -> Cvar arg) direct_args) clos; - fun_fast = true} - in - cf :: intermediate_curry_functions arity (num+1) + let rec iter i = + if i <= arity then + let arg = Ident.create (Printf.sprintf "arg%d" i) in + (arg, typ_addr) :: iter (i+1) + else [] + in + let direct_args = iter (num+2) in + let rec iter i args clos = + if i = 0 then + Cop(Capply(typ_addr, Debuginfo.none), + (get_field (Cvar clos) 2) :: args @ [Cvar clos]) + else + let newclos = Ident.create "clos" in + Clet(newclos, + get_field (Cvar clos) 4, + iter (i-1) (get_field (Cvar clos) 3 :: args) newclos) + in + let cf = + Cfunction + {fun_name = name1 ^ "_" ^ string_of_int (num+1) ^ "_app"; + fun_args = direct_args @ [clos, typ_addr]; + fun_body = iter (num+1) + (List.map (fun (arg,_) -> Cvar arg) direct_args) clos; + fun_fast = true; + fun_dbg = Debuginfo.none } + in + cf :: intermediate_curry_functions arity (num+1) else - intermediate_curry_functions arity (num+1)) + intermediate_curry_functions arity (num+1)) end let curry_function arity = @@ -2079,7 +2119,8 @@ let entry_point namelist = Cfunction {fun_name = "caml_program"; fun_args = []; fun_body = body; - fun_fast = false} + fun_fast = false; + fun_dbg = Debuginfo.none } (* Generate the table of globals *) diff --git a/asmcomp/cmx_format.mli b/asmcomp/cmx_format.mli index 78de321d9b..db8158e66b 100644 --- a/asmcomp/cmx_format.mli +++ b/asmcomp/cmx_format.mli @@ -10,18 +10,18 @@ (* *) (***********************************************************************) -(* $Id: compilenv.mli 9547 2010-01-22 12:48:24Z doligez $ *) +(* $Id$ *) (* Format of .cmx, .cmxa and .cmxs files *) (* Each .o file has a matching .cmx file that provides the following infos on the compilation unit: - - list of other units imported, with CRCs of their .cmx files + - list of other units imported, with MD5s of their .cmx files - approximation of the structure implemented (includes descriptions of known functions: arity and direct entry points) - list of currying functions and application functions needed - The .cmx file contains these infos (as an externed record) plus a CRC + The .cmx file contains these infos (as an externed record) plus a MD5 of these infos *) type unit_infos = @@ -40,7 +40,7 @@ type unit_infos = infos on the library: *) type library_infos = - { lib_units: (unit_infos * Digest.t) list; (* List of unit infos w/ CRCs *) + { lib_units: (unit_infos * Digest.t) list; (* List of unit infos w/ MD5s *) lib_ccobjs: string list; (* C object files needed *) lib_ccopts: string list } (* Extra opts to C compiler *) @@ -60,4 +60,3 @@ type dynheader = { dynu_magic: string; dynu_units: dynunit list; } - diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml index 0b87efecf9..4c6e72d0b5 100644 --- a/asmcomp/compilenv.ml +++ b/asmcomp/compilenv.ml @@ -87,8 +87,7 @@ let make_symbol ?(unitname = current_unit.ui_symbol) idopt = let read_unit_info filename = let ic = open_in_bin filename in try - let buffer = String.create (String.length cmx_magic_number) in - really_input ic buffer 0 (String.length cmx_magic_number); + let buffer = input_bytes ic (String.length cmx_magic_number) in if buffer <> cmx_magic_number then begin close_in ic; raise(Error(Not_a_unit_info filename)) @@ -103,8 +102,7 @@ let read_unit_info filename = let read_library_info filename = let ic = open_in_bin filename in - let buffer = String.create (String.length cmxa_magic_number) in - really_input ic buffer 0 (String.length cmxa_magic_number); + let buffer = input_bytes ic (String.length cmxa_magic_number) in if buffer <> cmxa_magic_number then raise(Error(Not_a_unit_info filename)); let infos = (input_value ic : library_infos) in @@ -229,8 +227,11 @@ open Format let report_error ppf = function | Not_a_unit_info filename -> - fprintf ppf "%s@ is not a compilation unit description." filename + fprintf ppf "%a@ is not a compilation unit description." + Location.print_filename filename | Corrupted_unit_info filename -> - fprintf ppf "Corrupted compilation unit description@ %s" filename + fprintf ppf "Corrupted compilation unit description@ %a" + Location.print_filename filename | Illegal_renaming(modname, filename) -> - fprintf ppf "%s@ contains the description for unit@ %s" filename modname + fprintf ppf "%a@ contains the description for unit@ %s" + Location.print_filename filename modname diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli index ca03724efe..3e4d83e20e 100644 --- a/asmcomp/compilenv.mli +++ b/asmcomp/compilenv.mli @@ -57,7 +57,7 @@ val new_structured_constant : Lambda.structured_constant -> bool -> string val structured_constants : unit -> (string * bool * Lambda.structured_constant) list val read_unit_info: string -> unit_infos * Digest.t - (* Read infos and CRC from a [.cmx] file. *) + (* Read infos and MD5 from a [.cmx] file. *) val write_unit_info: unit_infos -> string -> unit (* Save the given infos in the given file *) val save_unit_info: string -> unit diff --git a/asmcomp/debuginfo.ml b/asmcomp/debuginfo.ml index ad676d6745..3f96049eee 100644 --- a/asmcomp/debuginfo.ml +++ b/asmcomp/debuginfo.ml @@ -31,14 +31,18 @@ let none = { dinfo_char_end = 0 } +(* PR#5643: cannot use (==) because Debuginfo values are marshalled *) +let is_none t = + 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 let from_location kind loc = - if loc.loc_ghost then none else + if loc == Location.none then none else { dinfo_kind = kind; dinfo_file = loc.loc_start.pos_fname; dinfo_line = loc.loc_start.pos_lnum; diff --git a/asmcomp/debuginfo.mli b/asmcomp/debuginfo.mli index c6e36041cf..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; @@ -22,6 +22,8 @@ type t = { val none: t +val is_none: t -> bool + val to_string: t -> string val from_location: kind -> Location.t -> t diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml index 92bda9e298..0880d2058e 100644 --- a/asmcomp/emitaux.ml +++ b/asmcomp/emitaux.ml @@ -147,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 @@ -189,3 +189,59 @@ let is_generic_function name = List.exists (fun p -> isprefix p name) ["caml_apply"; "caml_curry"; "caml_send"; "caml_tuplify"] + +(* CFI directives *) + +let is_cfi_enabled () = + Config.asm_cfi_supported + +let cfi_startproc () = + if is_cfi_enabled () then + emit_string "\t.cfi_startproc\n" + +let cfi_endproc () = + if is_cfi_enabled () then + emit_string "\t.cfi_endproc\n" + +let cfi_adjust_cfa_offset n = + if is_cfi_enabled () then + begin + emit_string "\t.cfi_adjust_cfa_offset\t"; 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 "\t.file\t"; + emit_int file_num; emit_char '\t'; + emit_string_literal file_name; emit_char '\n'; + file_pos_nums := (file_name,file_num) :: !file_pos_nums; + file_num in + emit_string "\t.loc\t"; + emit_int file_num; emit_char '\t'; + emit_int line; emit_char '\n' + end diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli index c18d8e80c3..c7fe802e51 100644 --- a/asmcomp/emitaux.mli +++ b/asmcomp/emitaux.mli @@ -29,6 +29,9 @@ 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 = { fd_lbl: int; (* Return address *) fd_frame_size: int; (* Size of stack frame *) @@ -50,3 +53,7 @@ type emit_frame_actions = val emit_frames: emit_frame_actions -> unit val is_generic_function: string -> bool + +val cfi_startproc : unit -> unit +val cfi_endproc : unit -> unit +val cfi_adjust_cfa_offset : int -> unit diff --git a/asmcomp/i386/arch.ml b/asmcomp/i386/arch.ml index 5ffbeeb237..e6fb8b9008 100644 --- a/asmcomp/i386/arch.ml +++ b/asmcomp/i386/arch.ml @@ -59,6 +59,10 @@ let size_addr = 4 let size_int = 4 let size_float = 8 +(* Behavior of division *) + +let division_crashes_on_overflow = true + (* Operations on addressing modes *) let identity_addressing = Iindexed 0 diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index b94f3794da..78edea342c 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -312,9 +312,18 @@ let output_test_zero arg = (* Deallocate the stack frame before a return or tail call *) -let output_epilogue () = +let output_epilogue f = let n = frame_size() - 4 in - if n > 0 then ` addl ${emit_int n}, %esp\n` + if n > 0 then + begin + ` addl ${emit_int n}, %esp\n`; + cfi_adjust_cfa_offset (-n); + f (); + (* reset CFA back cause function body may continue *) + cfi_adjust_cfa_offset n + end + else + f () (* Determine if the given register is the top of the floating-point stack *) @@ -418,6 +427,7 @@ let external_symbols_direct = ref StringSet.empty let external_symbols_indirect = ref StringSet.empty let emit_instr fallthrough i = + emit_debug_info i.dbg; match i.desc with Lend -> () | Lop(Imove | Ispill | Ireload) -> @@ -466,14 +476,16 @@ let emit_instr fallthrough i = ` call {emit_symbol s}\n`; record_frame i.live i.dbg | Lop(Itailcall_ind) -> - output_epilogue(); + output_epilogue begin fun () -> ` jmp *{emit_reg i.arg.(0)}\n` + end | Lop(Itailcall_imm s) -> if s = !function_name then ` jmp {emit_label !tailrec_entry_point}\n` else begin - output_epilogue(); + output_epilogue begin fun () -> ` jmp {emit_symbol s}\n` + end end | Lop(Iextcall(s, alloc)) -> if alloc then begin @@ -499,6 +511,7 @@ let emit_instr fallthrough i = if n < 0 then ` addl ${emit_int(-n)}, %esp\n` else ` subl ${emit_int(n)}, %esp\n`; + cfi_adjust_cfa_offset n; stack_offset := !stack_offset + n | Lop(Iload(chunk, addr)) -> let dest = i.res.(0) in @@ -652,6 +665,7 @@ let emit_instr fallthrough i = ` fldl {emit_reg i.arg.(0)}\n`; stack_offset := !stack_offset - 8; ` subl $8, %esp\n`; + cfi_adjust_cfa_offset 8; ` fnstcw 4(%esp)\n`; ` movw 4(%esp), %ax\n`; ` movb $12, %ah\n`; @@ -666,6 +680,7 @@ let emit_instr fallthrough i = end; ` fldcw 4(%esp)\n`; ` addl $8, %esp\n`; + cfi_adjust_cfa_offset (-8); stack_offset := !stack_offset + 8 | Lop(Ispecific(Ilea addr)) -> ` lea {emit_addressing addr i.arg 0}, {emit_reg i.res.(0)}\n` @@ -682,29 +697,36 @@ let emit_instr fallthrough i = match r with {loc = Reg _; typ = Float} -> ` subl $8, %esp\n`; + cfi_adjust_cfa_offset 8; ` fstpl 0(%esp)\n`; stack_offset := !stack_offset + 8 | {loc = Stack sl; typ = Float} -> let ofs = slot_offset sl 1 in ` pushl {emit_int(ofs + 4)}(%esp)\n`; ` pushl {emit_int(ofs + 4)}(%esp)\n`; + cfi_adjust_cfa_offset 8; stack_offset := !stack_offset + 8 | _ -> ` pushl {emit_reg r}\n`; + cfi_adjust_cfa_offset 4; stack_offset := !stack_offset + 4 done | Lop(Ispecific(Ipush_int n)) -> ` pushl ${emit_nativeint n}\n`; + cfi_adjust_cfa_offset 4; stack_offset := !stack_offset + 4 | Lop(Ispecific(Ipush_symbol s)) -> ` pushl ${emit_symbol s}\n`; + cfi_adjust_cfa_offset 4; stack_offset := !stack_offset + 4 | Lop(Ispecific(Ipush_load addr)) -> ` pushl {emit_addressing addr i.arg 0}\n`; + cfi_adjust_cfa_offset 4; stack_offset := !stack_offset + 4 | Lop(Ispecific(Ipush_load_float addr)) -> ` pushl {emit_addressing (offset_addressing addr 4) i.arg 0}\n`; ` pushl {emit_addressing addr i.arg 0}\n`; + cfi_adjust_cfa_offset 8; stack_offset := !stack_offset + 8 | Lop(Ispecific(Ifloatarithmem(double, op, addr))) -> if not (is_tos i.arg.(0)) then @@ -722,8 +744,9 @@ let emit_instr fallthrough i = | Lreloadretaddr -> () | Lreturn -> - output_epilogue(); + output_epilogue begin fun () -> ` ret\n` + end | Llabel lbl -> `{emit_Llabel fallthrough lbl}:\n` | Lbranch lbl -> @@ -787,11 +810,13 @@ let emit_instr fallthrough i = if trap_frame_size > 8 then ` subl ${emit_int (trap_frame_size - 8)}, %esp\n`; ` pushl {emit_symbol "caml_exception_pointer"}\n`; + cfi_adjust_cfa_offset trap_frame_size; ` movl %esp, {emit_symbol "caml_exception_pointer"}\n`; stack_offset := !stack_offset + trap_frame_size | Lpoptrap -> ` popl {emit_symbol "caml_exception_pointer"}\n`; ` addl ${emit_int (trap_frame_size - 4)}, %esp\n`; + cfi_adjust_cfa_offset (-trap_frame_size); stack_offset := !stack_offset - trap_frame_size | Lraise -> if !Clflags.debug then begin @@ -900,14 +925,20 @@ let fundecl fundecl = else ` .globl {emit_symbol fundecl.fun_name}\n`; `{emit_symbol fundecl.fun_name}:\n`; + emit_debug_info fundecl.fun_dbg; + cfi_startproc (); if !Clflags.gprofile then emit_profile(); let n = frame_size() - 4 in if n > 0 then + begin ` subl ${emit_int n}, %esp\n`; + cfi_adjust_cfa_offset n; + end; `{emit_label !tailrec_entry_point}:\n`; emit_all true fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; emit_call_bound_errors (); + cfi_endproc (); begin match Config.system with "linux_elf" | "bsd_elf" | "gnu" -> ` .type {emit_symbol fundecl.fun_name},@function\n`; @@ -957,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/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp index a94c7b6c31..48704ab401 100644 --- a/asmcomp/i386/emit_nt.mlp +++ b/asmcomp/i386/emit_nt.mlp @@ -884,6 +884,7 @@ let end_assembly() = add_def_symbol lbl_end; ` PUBLIC {emit_symbol lbl_end}\n`; `{emit_symbol lbl_end} LABEL DWORD\n`; + ` DWORD 0\n`; let lbl = Compilenv.make_symbol (Some "frametable") in add_def_symbol lbl; ` PUBLIC {emit_symbol lbl}\n`; diff --git a/asmcomp/i386/selection.ml b/asmcomp/i386/selection.ml index 2e0f5a737a..38c7a1d730 100644 --- a/asmcomp/i386/selection.ml +++ b/asmcomp/i386/selection.ml @@ -168,7 +168,7 @@ method! is_simple_expr e = | _ -> super#is_simple_expr e -method select_addressing exp = +method select_addressing chunk exp = match select_addr exp with (Asymbol s, d) -> (Ibased(s, d), Ctuple []) @@ -200,7 +200,7 @@ method! select_operation op args = match op with (* Recognize the LEA instruction *) Caddi | Cadda | Csubi | Csuba -> - begin match self#select_addressing (Cop(op, args)) with + begin match self#select_addressing Word (Cop(op, args)) with (Iindexed d, _) -> super#select_operation op args | (Iindexed2 0, _) -> super#select_operation op args | (addr, arg) -> (Ispecific(Ilea addr), [arg]) @@ -233,7 +233,7 @@ method! select_operation op args = begin match args with [loc; Cop(Caddi, [Cop(Cload _, [loc']); Cconst_int n])] when loc = loc' -> - let (addr, arg) = self#select_addressing loc in + let (addr, arg) = self#select_addressing Word loc in (Ispecific(Ioffset_loc(n, addr)), [arg]) | _ -> super#select_operation op args @@ -250,11 +250,11 @@ method! select_operation op args = method select_floatarith regular_op reversed_op mem_op mem_rev_op args = match args with [arg1; Cop(Cload chunk, [loc2])] -> - let (addr, arg2) = self#select_addressing loc2 in + let (addr, arg2) = self#select_addressing chunk loc2 in (Ispecific(Ifloatarithmem(chunk_double chunk, mem_op, addr)), [arg1; arg2]) | [Cop(Cload chunk, [loc1]); arg2] -> - let (addr, arg1) = self#select_addressing loc1 in + let (addr, arg1) = self#select_addressing chunk loc1 in (Ispecific(Ifloatarithmem(chunk_double chunk, mem_rev_op, addr)), [arg2; arg1]) | [arg1; arg2] -> @@ -282,9 +282,6 @@ method! insert_op_debug op dbg rs rd = with Use_default -> super#insert_op_debug op dbg rs rd -method! insert_op op rs rd = - self#insert_op_debug op Debuginfo.none rs rd - (* Selection of push instructions for external calls *) method select_push exp = @@ -295,10 +292,10 @@ method select_push exp = | Cconst_natpointer n -> (Ispecific(Ipush_int n), Ctuple []) | Cconst_symbol s -> (Ispecific(Ipush_symbol s), Ctuple []) | Cop(Cload Word, [loc]) -> - let (addr, arg) = self#select_addressing loc in + let (addr, arg) = self#select_addressing Word loc in (Ispecific(Ipush_load addr), arg) | Cop(Cload Double_u, [loc]) -> - let (addr, arg) = self#select_addressing loc in + let (addr, arg) = self#select_addressing Double_u loc in (Ispecific(Ipush_load_float addr), arg) | _ -> (Ispecific(Ipush), exp) diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml index a5c758823a..8a5411876a 100644 --- a/asmcomp/linearize.ml +++ b/asmcomp/linearize.ml @@ -54,7 +54,8 @@ let has_fallthrough = function type fundecl = { fun_name: string; fun_body: instruction; - fun_fast: bool } + fun_fast: bool; + fun_dbg : Debuginfo.t } (* Invert a test *) @@ -264,4 +265,5 @@ let rec linear i n = let fundecl f = { fun_name = f.Mach.fun_name; fun_body = linear f.Mach.fun_body end_instr; - fun_fast = f.Mach.fun_fast } + fun_fast = f.Mach.fun_fast; + fun_dbg = f.Mach.fun_dbg } diff --git a/asmcomp/linearize.mli b/asmcomp/linearize.mli index ca11006b5a..9fbe14ddb0 100644 --- a/asmcomp/linearize.mli +++ b/asmcomp/linearize.mli @@ -49,6 +49,7 @@ val invert_test: Mach.test -> Mach.test type fundecl = { fun_name: string; fun_body: instruction; - fun_fast: bool } + fun_fast: bool; + fun_dbg : Debuginfo.t } val fundecl: Mach.fundecl -> fundecl diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml index b628f76ca0..3d29bde11b 100644 --- a/asmcomp/mach.ml +++ b/asmcomp/mach.ml @@ -79,7 +79,8 @@ type fundecl = { fun_name: string; fun_args: Reg.t array; fun_body: instruction; - fun_fast: bool } + fun_fast: bool; + fun_dbg : Debuginfo.t } let rec dummy_instr = { desc = Iend; diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli index dd58b8a024..05cc999b53 100644 --- a/asmcomp/mach.mli +++ b/asmcomp/mach.mli @@ -79,7 +79,8 @@ type fundecl = { fun_name: string; fun_args: Reg.t array; fun_body: instruction; - fun_fast: bool } + fun_fast: bool; + fun_dbg : Debuginfo.t } val dummy_instr: instruction val end_instr: unit -> instruction diff --git a/asmcomp/power/arch.ml b/asmcomp/power/arch.ml index 5da85099eb..c1323234a6 100644 --- a/asmcomp/power/arch.ml +++ b/asmcomp/power/arch.ml @@ -46,6 +46,10 @@ let size_addr = if ppc64 then 8 else 4 let size_int = size_addr let size_float = 8 +(* Behavior of division *) + +let division_crashes_on_overflow = true + (* Operations on addressing modes *) let identity_addressing = Iindexed 0 diff --git a/asmcomp/power/selection.ml b/asmcomp/power/selection.ml index 7c37f53ba4..179548af5c 100644 --- a/asmcomp/power/selection.ml +++ b/asmcomp/power/selection.ml @@ -52,7 +52,7 @@ inherit Selectgen.selector_generic as super method is_immediate n = (n <= 32767) && (n >= -32768) -method select_addressing exp = +method select_addressing chunk exp = match select_addr exp with (Asymbol s, d) -> (Ibased(s, d), Ctuple []) diff --git a/asmcomp/printclambda.ml b/asmcomp/printclambda.ml new file mode 100644 index 0000000000..3d89f50202 --- /dev/null +++ b/asmcomp/printclambda.ml @@ -0,0 +1,132 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + + +open Format +open Asttypes +open Clambda +open Debuginfo + +let rec pr_idents ppf = function + | [] -> () + | h::t -> fprintf ppf "%a %a" Ident.print h pr_idents t + +let rec lam ppf = function + | Uvar id -> + Ident.print ppf id + | Uconst (cst,_) -> + Printlambda.structured_constant ppf cst + | Udirect_apply(f, largs, _) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(apply*@ %s %a)@]" f lams largs + | Ugeneric_apply(lfun, largs, _) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs + | Uclosure(clos, fv) -> + let idents ppf = + List.iter (fprintf ppf "@ %a" Ident.print)in + let one_fun ppf f = + fprintf ppf "(fun@ %s@ %d @[<2>%a@] @[<2>%a@])" + f.label f.arity idents f.params lam f.body in + let funs ppf = + List.iter (fprintf ppf "@ %a" one_fun) in + let lams ppf = + List.iter (fprintf ppf "@ %a" lam) in + fprintf ppf "@[<2>(closure@ %a %a)@]" funs clos lams fv + | Uoffset(l,i) -> fprintf ppf "@[<2>(offset %a %d)@]" lam l i + | Ulet(id, arg, body) -> + let rec letbody ul = match ul with + | Ulet(id, arg, body) -> + fprintf ppf "@ @[<2>%a@ %a@]" Ident.print id lam arg; + letbody body + | _ -> ul in + fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a@ %a@]" Ident.print id lam arg; + let expr = letbody body in + fprintf ppf ")@]@ %a)@]" lam expr + | Uletrec(id_arg_list, body) -> + let bindings ppf id_arg_list = + let spc = ref false in + List.iter + (fun (id, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[<2>%a@ %a@]" Ident.print id lam l) + id_arg_list in + fprintf ppf + "@[<2>(letrec@ (@[<hv 1>%a@])@ %a)@]" bindings id_arg_list lam body + | Uprim(prim, largs, _) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(%a%a)@]" Printlambda.primitive prim lams largs + | Uswitch(larg, sw) -> + let switch ppf sw = + let spc = ref false in + for i = 0 to Array.length sw.us_index_consts - 1 do + let n = sw.us_index_consts.(i) + and l = sw.us_actions_consts.(i) in + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[<hv 1>case int %i:@ %a@]" n lam l; + done; + for i = 0 to Array.length sw.us_index_blocks - 1 do + let n = sw.us_index_blocks.(i) + and l = sw.us_actions_blocks.(i) in + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[<hv 1>case tag %i:@ %a@]" n lam l; + done in + fprintf ppf + "@[<1>(switch %a@ @[<v 0>%a@])@]" + lam larg switch sw + | Ustaticfail (i, ls) -> + let lams ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls; + | Ucatch(i, vars, lbody, lhandler) -> + fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]" + lam lbody i + (fun ppf vars -> match vars with + | [] -> () + | _ -> + List.iter + (fun x -> fprintf ppf " %a" Ident.print x) + vars) + vars + lam lhandler + | Utrywith(lbody, param, lhandler) -> + fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" + lam lbody Ident.print param lam lhandler + | Uifthenelse(lcond, lif, lelse) -> + fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse + | Usequence(l1, l2) -> + fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 + | Uwhile(lcond, lbody) -> + fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody + | Ufor(param, lo, hi, dir, body) -> + fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" + Ident.print param lam lo + (match dir with Upto -> "to" | Downto -> "downto") + lam hi lam body + | Uassign(id, expr) -> + fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr + | Usend (k, met, obj, largs, _) -> + let args ppf largs = + List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + let kind = + if k = Lambda.Self then "self" else if k = Lambda.Cached then "cache" else "" in + fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs + +and sequence ppf ulam = match ulam with + | Usequence(l1, l2) -> + fprintf ppf "%a@ %a" sequence l1 sequence l2 + | _ -> lam ppf ulam + +let clambda = lam diff --git a/asmcomp/printclambda.mli b/asmcomp/printclambda.mli new file mode 100644 index 0000000000..ddc233af06 --- /dev/null +++ b/asmcomp/printclambda.mli @@ -0,0 +1,16 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +open Clambda +open Format + +val clambda: formatter -> ulambda -> unit diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml index 996eaa21c1..ca1c0f11c3 100644 --- a/asmcomp/printcmm.ml +++ b/asmcomp/printcmm.ml @@ -176,8 +176,9 @@ let fundecl ppf f = if !first then first := false else fprintf ppf "@ "; fprintf ppf "%a: %a" Ident.print id machtype ty) cases in - fprintf ppf "@[<1>(function %s@;<1 4>@[<1>(%a)@]@ @[%a@])@]@." - f.fun_name print_cases f.fun_args sequence f.fun_body + fprintf ppf "@[<1>(function%s %s@;<1 4>@[<1>(%a)@]@ @[%a@])@]@." + (Debuginfo.to_string f.fun_dbg) f.fun_name + print_cases f.fun_args sequence f.fun_body let data_item ppf = function | Cdefine_symbol s -> fprintf ppf "\"%s\":" s diff --git a/asmcomp/printlinear.ml b/asmcomp/printlinear.ml index 0e6f37b699..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 = @@ -74,4 +74,9 @@ let rec all_instr ppf i = | _ -> fprintf ppf "%a@,%a" instr i all_instr i.next let fundecl ppf f = - fprintf ppf "@[<v 2>%s:@,%a@]" f.fun_name all_instr f.fun_body + let dbg = + if Debuginfo.is_none f.fun_dbg then + "" + else + " " ^ Debuginfo.to_string f.fun_dbg in + fprintf ppf "@[<v 2>%s:%s@,%a@]" f.fun_name dbg all_instr f.fun_body diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml index 339deb7eed..93d0a02247 100644 --- a/asmcomp/printmach.ml +++ b/asmcomp/printmach.ml @@ -182,16 +182,21 @@ let rec instr ppf i = | Iraise -> fprintf ppf "raise %a" reg i.arg.(0) end; - if i.dbg != Debuginfo.none then - fprintf ppf " %s" (Debuginfo.to_string i.dbg); + if not (Debuginfo.is_none i.dbg) then + fprintf ppf "%s" (Debuginfo.to_string i.dbg); begin match i.next.desc with Iend -> () | _ -> fprintf ppf "@,%a" instr i.next end let fundecl ppf f = - fprintf ppf "@[<v 2>%s(%a)@,%a@]" - f.fun_name regs f.fun_args instr f.fun_body + let dbg = + if Debuginfo.is_none f.fun_dbg then + "" + else + " " ^ Debuginfo.to_string f.fun_dbg in + fprintf ppf "@[<v 2>%s(%a)%s@,%a@]" + f.fun_name regs f.fun_args dbg instr f.fun_body let phase msg ppf f = fprintf ppf "*** %s@.%a@." msg fundecl f diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml index fc28acde4f..9da79587a2 100644 --- a/asmcomp/reloadgen.ml +++ b/asmcomp/reloadgen.ml @@ -134,7 +134,8 @@ method fundecl f = redo_regalloc <- false; let new_body = self#reload f.fun_body in ({fun_name = f.fun_name; fun_args = f.fun_args; - fun_body = new_body; fun_fast = f.fun_fast}, + fun_body = new_body; fun_fast = f.fun_fast; + fun_dbg = f.fun_dbg}, redo_regalloc) end diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml index a5dfcfdbf3..89c031d1b7 100644 --- a/asmcomp/schedgen.ml +++ b/asmcomp/schedgen.ml @@ -349,7 +349,8 @@ method schedule_fundecl f = clear_code_dag(); { fun_name = f.fun_name; fun_body = new_body; - fun_fast = f.fun_fast } + fun_fast = f.fun_fast; + fun_dbg = f.fun_dbg } end else f diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index 106d42bc2b..e2ffd34ac8 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -204,7 +204,7 @@ method virtual is_immediate : int -> bool (* Selection of addressing modes *) method virtual select_addressing : - Cmm.expression -> Arch.addressing_mode * Cmm.expression + Cmm.memory_chunk -> Cmm.expression -> Arch.addressing_mode * Cmm.expression (* Default instruction selection for stores (of words) *) @@ -219,10 +219,10 @@ method select_operation op args = | (Capply(ty, dbg), _) -> (Icall_ind, args) | (Cextcall(s, ty, alloc, dbg), _) -> (Iextcall(s, alloc), args) | (Cload chunk, [arg]) -> - let (addr, eloc) = self#select_addressing arg in + let (addr, eloc) = self#select_addressing chunk arg in (Iload(chunk, addr), [eloc]) | (Cstore chunk, [arg1; arg2]) -> - let (addr, eloc) = self#select_addressing arg1 in + let (addr, eloc) = self#select_addressing chunk arg1 in if chunk = Word then begin let (op, newarg2) = self#select_store addr arg2 in (op, [newarg2; eloc]) @@ -366,7 +366,7 @@ method insert_move src dst = self#insert (Iop Imove) [|src|] [|dst|] method insert_moves src dst = - for i = 0 to Array.length src - 1 do + for i = 0 to min (Array.length src) (Array.length dst) - 1 do self#insert_move src.(i) dst.(i) done @@ -389,8 +389,7 @@ method insert_op_debug op dbg rs rd = rd method insert_op op rs rd = - self#insert (Iop op) rs rd; - rd + self#insert_op_debug op Debuginfo.none rs rd (* Add the instructions for the given expression at the end of the self sequence *) @@ -490,9 +489,8 @@ method emit_expr env exp = let (loc_arg, stack_ofs) = self#emit_extcall_args env new_args in let rd = self#regs_for ty in - let loc_res = Proc.loc_external_results rd in - self#insert_debug (Iop(Iextcall(lbl, alloc))) dbg - loc_arg loc_res; + let loc_res = self#insert_op_debug (Iextcall(lbl, alloc)) dbg + loc_arg (Proc.loc_external_results rd) in self#insert_move_results loc_res rd stack_ofs; Some rd | Ialloc _ -> @@ -821,12 +819,13 @@ method emit_fundecl f = { fun_name = f.Cmm.fun_name; fun_args = loc_arg; fun_body = self#extract; - fun_fast = f.Cmm.fun_fast } + fun_fast = f.Cmm.fun_fast; + fun_dbg = f.Cmm.fun_dbg } end (* Tail call criterion (estimated). Assumes: -- all arguments are of type "int" (always the case for Caml function calls) +- all arguments are of type "int" (always the case for OCaml function calls) - one extra argument representing the closure environment (conservative). *) diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli index 73309bf7b8..058f9e73e1 100644 --- a/asmcomp/selectgen.mli +++ b/asmcomp/selectgen.mli @@ -26,7 +26,7 @@ class virtual selector_generic : object (* Must be defined to indicate whether a constant is a suitable immediate operand to arithmetic instructions *) method virtual select_addressing : - Cmm.expression -> Arch.addressing_mode * Cmm.expression + Cmm.memory_chunk -> Cmm.expression -> Arch.addressing_mode * Cmm.expression (* Must be defined to select addressing modes *) method is_simple_expr: Cmm.expression -> bool (* Can be overridden to reflect special extcalls known to be pure *) diff --git a/asmcomp/sparc/arch.ml b/asmcomp/sparc/arch.ml index b42557c97d..beaf33a912 100644 --- a/asmcomp/sparc/arch.ml +++ b/asmcomp/sparc/arch.ml @@ -47,6 +47,10 @@ let size_addr = 4 let size_int = 4 let size_float = 8 +(* Behavior of division *) + +let division_crashes_on_overflow = false + (* Operations on addressing modes *) let identity_addressing = Iindexed 0 diff --git a/asmcomp/sparc/selection.ml b/asmcomp/sparc/selection.ml index 1dfc06f273..e82cc670ae 100644 --- a/asmcomp/sparc/selection.ml +++ b/asmcomp/sparc/selection.ml @@ -26,7 +26,7 @@ inherit Selectgen.selector_generic as super method is_immediate n = (n <= 4095) && (n >= -4096) -method select_addressing = function +method select_addressing chunk = function Cconst_symbol s -> (Ibased(s, 0), Ctuple []) | Cop(Cadda, [Cconst_symbol s; Cconst_int n]) -> diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml index 874f73579b..7b055959e8 100644 --- a/asmcomp/spill.ml +++ b/asmcomp/spill.ml @@ -399,4 +399,5 @@ let fundecl f = { fun_name = f.fun_name; fun_args = f.fun_args; fun_body = new_body; - fun_fast = f.fun_fast } + fun_fast = f.fun_fast; + fun_dbg = f.fun_dbg } diff --git a/asmcomp/split.ml b/asmcomp/split.ml index 8c5e22703d..da5cdf1f5e 100644 --- a/asmcomp/split.ml +++ b/asmcomp/split.ml @@ -207,4 +207,5 @@ let fundecl f = { fun_name = f.fun_name; fun_args = new_args; fun_body = new_body; - fun_fast = f.fun_fast } + fun_fast = f.fun_fast; + fun_dbg = f.fun_dbg } diff --git a/asmrun/.depend b/asmrun/.depend index aa0e69e1a3..1bbfddcded 100644 --- a/asmrun/.depend +++ b/asmrun/.depend @@ -37,9 +37,10 @@ custom.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h -debugger.o: debugger.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/debugger.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/misc.h +debugger.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ + ../byterun/misc.h dynlink.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \ @@ -51,9 +52,9 @@ extern.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/reverse.h + ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h fail.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ @@ -96,14 +97,14 @@ hash.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h + ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h intern.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/reverse.h ../byterun/md5.h + ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ + ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ + ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h ints.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ @@ -174,7 +175,8 @@ natdynlink.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ - natdynlink.h ../byterun/osdeps.h ../byterun/fail.h + ../byterun/intext.h ../byterun/io.h natdynlink.h ../byterun/osdeps.h \ + ../byterun/fail.h obj.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ @@ -216,8 +218,9 @@ signals_asm.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ startup.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ + ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h \ + ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ ../byterun/printexc.h stack.h ../byterun/sys.h natdynlink.h @@ -284,9 +287,10 @@ custom.d.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h -debugger.d.o: debugger.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/debugger.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/misc.h +debugger.d.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ + ../byterun/misc.h dynlink.d.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \ @@ -298,9 +302,9 @@ extern.d.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/reverse.h + ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h fail.d.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ @@ -343,14 +347,14 @@ hash.d.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h + ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h intern.d.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/reverse.h ../byterun/md5.h + ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ + ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ + ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h ints.d.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ @@ -421,7 +425,8 @@ natdynlink.d.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ - natdynlink.h ../byterun/osdeps.h ../byterun/fail.h + ../byterun/intext.h ../byterun/io.h natdynlink.h ../byterun/osdeps.h \ + ../byterun/fail.h obj.d.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ @@ -463,8 +468,9 @@ signals_asm.d.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ startup.d.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ + ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h \ + ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ ../byterun/printexc.h stack.h ../byterun/sys.h natdynlink.h @@ -531,9 +537,10 @@ custom.p.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h -debugger.p.o: debugger.c ../byterun/config.h ../byterun/../config/m.h \ - ../byterun/../config/s.h ../byterun/debugger.h ../byterun/misc.h \ - ../byterun/config.h ../byterun/mlvalues.h ../byterun/misc.h +debugger.p.o: debugger.c ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/debugger.h \ + ../byterun/misc.h dynlink.p.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \ ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/mlvalues.h ../byterun/dynlink.h \ @@ -545,9 +552,9 @@ extern.p.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/misc.h \ - ../byterun/mlvalues.h ../byterun/reverse.h + ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h fail.p.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ @@ -590,14 +597,14 @@ hash.p.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/custom.h ../byterun/mlvalues.h ../byterun/memory.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h + ../byterun/minor_gc.h ../byterun/hash.h ../byterun/int64_native.h intern.p.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/mlvalues.h ../byterun/custom.h ../byterun/fail.h \ - ../byterun/gc.h ../byterun/intext.h ../byterun/io.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/reverse.h ../byterun/md5.h + ../byterun/mlvalues.h ../byterun/callback.h ../byterun/custom.h \ + ../byterun/fail.h ../byterun/gc.h ../byterun/intext.h ../byterun/io.h \ + ../byterun/io.h ../byterun/md5.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/reverse.h ints.p.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/custom.h ../byterun/fail.h ../byterun/intext.h \ @@ -668,7 +675,8 @@ natdynlink.p.o: natdynlink.c ../byterun/misc.h ../byterun/config.h \ ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ ../byterun/minor_gc.h stack.h ../byterun/callback.h ../byterun/alloc.h \ - natdynlink.h ../byterun/osdeps.h ../byterun/fail.h + ../byterun/intext.h ../byterun/io.h natdynlink.h ../byterun/osdeps.h \ + ../byterun/fail.h obj.p.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/fail.h ../byterun/gc.h ../byterun/interp.h \ @@ -710,8 +718,9 @@ signals_asm.p.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ startup.p.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/misc.h ../byterun/backtrace.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/freelist.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/memory.h ../byterun/gc.h \ + ../byterun/debugger.h ../byterun/fail.h ../byterun/freelist.h \ + ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/intext.h \ + ../byterun/io.h ../byterun/memory.h ../byterun/gc.h \ ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ ../byterun/printexc.h stack.h ../byterun/sys.h natdynlink.h diff --git a/asmrun/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 791b2f411f..f3220e706a 100644 --- a/asmrun/amd64.S +++ b/asmrun/amd64.S @@ -18,9 +18,11 @@ /* PIC mode support based on contribution by Paul Stravers (see PR#4795) */ +#include "../config/m.h" + #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 @@ -33,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 @@ -48,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 @@ -63,6 +65,16 @@ #endif +#ifdef ASM_CFI_SUPPORTED +#define CFI_STARTPROC .cfi_startproc +#define CFI_ENDPROC .cfi_endproc +#define CFI_ADJUST(n) .cfi_adjust_cfa_offset n +#else +#define CFI_STARTPROC +#define CFI_ENDPROC +#define CFI_ADJUST(n) +#endif + #if defined(__PIC__) && !defined(SYS_mingw64) /* Position-independent operations on global variables. */ @@ -99,15 +111,15 @@ /* Record lowest stack address and return address. Clobbers %rax. */ #define RECORD_STACK_FRAME(OFFSET) \ - pushq %r11 ; \ + pushq %r11 ; \ movq 8+OFFSET(%rsp), %rax ; \ - STORE_VAR(%rax,caml_last_return_address) ; \ + STORE_VAR(%rax,caml_last_return_address) ; \ leaq 16+OFFSET(%rsp), %rax ; \ - STORE_VAR(%rax,caml_bottom_of_stack) ; \ - popq %r11 + STORE_VAR(%rax,caml_bottom_of_stack) ; \ + popq %r11 #else - + /* Non-PIC operations on global variables. Slightly faster. */ #define STORE_VAR(srcreg,dstlabel) \ @@ -130,16 +142,16 @@ #define RECORD_STACK_FRAME(OFFSET) \ movq OFFSET(%rsp), %rax ; \ - STORE_VAR(%rax,caml_last_return_address) ; \ + STORE_VAR(%rax,caml_last_return_address) ; \ leaq 8+OFFSET(%rsp), %rax ; \ - STORE_VAR(%rax,caml_bottom_of_stack) + STORE_VAR(%rax,caml_bottom_of_stack) #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 */ @@ -152,8 +164,8 @@ pushq %r13; \ pushq %r14; \ pushq %r15; \ - subq $(8+10*16), %rsp; \ - movupd %xmm6, 0*16(%rsp); \ + subq $(8+10*16), %rsp; \ + movupd %xmm6, 0*16(%rsp); \ movupd %xmm7, 1*16(%rsp); \ movupd %xmm8, 2*16(%rsp); \ movupd %xmm9, 3*16(%rsp); \ @@ -196,10 +208,10 @@ pushq %r13; \ pushq %r14; \ pushq %r15; \ - subq $8, %rsp + subq $8, %rsp #define POP_CALLEE_SAVE_REGS \ - addq $8, %rsp; \ + addq $8, %rsp; \ popq %r15; \ popq %r14; \ popq %r13; \ @@ -207,11 +219,11 @@ popq %rbp; \ popq %rbx -#endif +#endif #ifdef SYS_mingw64 - /* Calls from Caml to C must reserve 32 bytes of extra stack space */ -# define PREPARE_FOR_C_CALL subq $32, %rsp + /* Calls from OCaml to C must reserve 32 bytes of extra stack space */ +# define PREPARE_FOR_C_CALL subq $32, %rsp # define CLEANUP_AFTER_C_CALL addq $32, %rsp #else # define PREPARE_FOR_C_CALL @@ -220,11 +232,22 @@ .text + .globl G(caml_system__code_begin) +G(caml_system__code_begin): + /* Allocation */ FUNCTION(G(caml_call_gc)) + CFI_STARTPROC RECORD_STACK_FRAME(0) LBL(caml_call_gc): +#ifndef SYS_mingw64 + /* Touch the stack to trigger a recoverable segfault + if insufficient space remains */ + subq $32768, %rsp + movq %rax, 0(%rsp) + addq $32768, %rsp +#endif /* Build array of registers, save it into caml_gc_regs */ pushq %r13 pushq %r12 @@ -241,10 +264,11 @@ LBL(caml_call_gc): pushq %rax STORE_VAR(%rsp, caml_gc_regs) /* Save caml_young_ptr, caml_exception_pointer */ - STORE_VAR(%r15, caml_young_ptr) - STORE_VAR(%r14, caml_exception_pointer) + STORE_VAR(%r15, caml_young_ptr) + STORE_VAR(%r14, caml_exception_pointer) /* Save floating-point registers */ subq $(16*8), %rsp + CFI_ADJUST(232) movsd %xmm0, 0*8(%rsp) movsd %xmm1, 1*8(%rsp) movsd %xmm2, 2*8(%rsp) @@ -262,12 +286,12 @@ LBL(caml_call_gc): movsd %xmm14, 14*8(%rsp) movsd %xmm15, 15*8(%rsp) /* Call the garbage collector */ - PREPARE_FOR_C_CALL + PREPARE_FOR_C_CALL call GCALL(caml_garbage_collection) - CLEANUP_AFTER_C_CALL + CLEANUP_AFTER_C_CALL /* Restore caml_young_ptr, caml_exception_pointer */ - LOAD_VAR(caml_young_ptr, %r15) - LOAD_VAR(caml_exception_pointer, %r14) + LOAD_VAR(caml_young_ptr, %r15) + LOAD_VAR(caml_exception_pointer, %r14) /* Restore all regs used by the code generator */ movsd 0*8(%rsp), %xmm0 movsd 1*8(%rsp), %xmm1 @@ -299,8 +323,10 @@ LBL(caml_call_gc): popq %rbp popq %r12 popq %r13 + CFI_ADJUST(-232) /* Return to caller */ ret + CFI_ENDPROC FUNCTION(G(caml_alloc1)) LBL(caml_alloc1): @@ -310,9 +336,9 @@ LBL(caml_alloc1): ret LBL(100): RECORD_STACK_FRAME(0) - subq $8, %rsp + subq $8, %rsp call LBL(caml_call_gc) - addq $8, %rsp + addq $8, %rsp jmp LBL(caml_alloc1) FUNCTION(G(caml_alloc2)) @@ -323,9 +349,9 @@ LBL(caml_alloc2): ret LBL(101): RECORD_STACK_FRAME(0) - subq $8, %rsp + subq $8, %rsp call LBL(caml_call_gc) - addq $8, %rsp + addq $8, %rsp jmp LBL(caml_alloc2) FUNCTION(G(caml_alloc3)) @@ -336,9 +362,9 @@ LBL(caml_alloc3): ret LBL(102): RECORD_STACK_FRAME(0) - subq $8, %rsp + subq $8, %rsp call LBL(caml_call_gc) - addq $8, %rsp + addq $8, %rsp jmp LBL(caml_alloc3) FUNCTION(G(caml_allocN)) @@ -355,7 +381,7 @@ LBL(103): popq %rax /* recover desired size */ jmp LBL(caml_allocN) -/* Call a C function from Caml */ +/* Call a C function from OCaml */ FUNCTION(G(caml_c_call)) LBL(caml_c_call): @@ -363,56 +389,64 @@ 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 */ + subq $32768, %rsp + movq %rax, 0(%rsp) + addq $32768, %rsp +#endif /* Make the exception handler and alloc ptr available to the C code */ - STORE_VAR(%r15, caml_young_ptr) - STORE_VAR(%r14, caml_exception_pointer) + STORE_VAR(%r15, caml_young_ptr) + STORE_VAR(%r14, caml_exception_pointer) /* Call the function (address in %rax) */ /* No need to PREPARE_FOR_C_CALL since the caller already reserved the stack space if needed (cf. amd64/proc.ml) */ - call *%rax - /* Reload alloc ptr */ - LOAD_VAR(caml_young_ptr, %r15) - /* Return to caller */ - pushq %r12 - ret + jmp *%rax -/* Start the Caml program */ +/* Start the OCaml program */ FUNCTION(G(caml_start_program)) + CFI_STARTPROC /* Save callee-save registers */ PUSH_CALLEE_SAVE_REGS + CFI_ADJUST(56) /* Initial entry point is G(caml_program) */ leaq GCALL(caml_program)(%rip), %r12 /* Common code for caml_start_program and caml_callback* */ LBL(caml_start_program): /* Build a callback link */ - subq $8, %rsp /* stack 16-aligned */ + subq $8, %rsp /* stack 16-aligned */ PUSH_VAR(caml_gc_regs) PUSH_VAR(caml_last_return_address) PUSH_VAR(caml_bottom_of_stack) + CFI_ADJUST(32) /* Setup alloc ptr and exception ptr */ - LOAD_VAR(caml_young_ptr, %r15) - LOAD_VAR(caml_exception_pointer, %r14) + LOAD_VAR(caml_young_ptr, %r15) + LOAD_VAR(caml_exception_pointer, %r14) /* Build an exception handler */ lea LBL(108)(%rip), %r13 pushq %r13 pushq %r14 + CFI_ADJUST(16) movq %rsp, %r14 - /* Call the Caml code */ + /* Call the OCaml code */ call *%r12 LBL(107): /* Pop the exception handler */ popq %r14 popq %r12 /* dummy register */ + CFI_ADJUST(-16) LBL(109): /* Update alloc ptr and exception ptr */ - STORE_VAR(%r15,caml_young_ptr) - STORE_VAR(%r14,caml_exception_pointer) + STORE_VAR(%r15,caml_young_ptr) + STORE_VAR(%r14,caml_exception_pointer) /* Pop the callback link, restoring the global variables */ - POP_VAR(caml_bottom_of_stack) + POP_VAR(caml_bottom_of_stack) POP_VAR(caml_last_return_address) POP_VAR(caml_gc_regs) - addq $8, %rsp + addq $8, %rsp /* Restore callee-save registers. */ POP_CALLEE_SAVE_REGS /* Return to caller. */ @@ -422,6 +456,7 @@ LBL(108): /* Mark the bucket as an exception result and return it */ orq $2, %rax jmp LBL(109) + CFI_ENDPROC /* Registers holding arguments of C functions. */ @@ -437,7 +472,7 @@ LBL(108): #define C_ARG_4 %rcx #endif -/* Raise an exception from Caml */ +/* Raise an exception from OCaml */ FUNCTION(G(caml_raise_exn)) TESTL_VAR($1, caml_backtrace_active) @@ -448,10 +483,11 @@ FUNCTION(G(caml_raise_exn)) LBL(110): movq %rax, %r12 /* Save exception bucket */ movq %rax, C_ARG_1 /* arg 1: exception bucket */ - movq 0(%rsp), C_ARG_2 /* arg 2: pc of raise */ - leaq 8(%rsp), C_ARG_3 /* arg 3: sp of raise */ + popq C_ARG_2 /* arg 2: pc of raise */ + movq %rsp, C_ARG_3 /* arg 3: sp at raise */ movq %r14, C_ARG_4 /* arg 4: sp of handler */ - PREPARE_FOR_C_CALL /* no need to cleanup after */ + /* PR#5700: thanks to popq above, stack is now 16-aligned */ + PREPARE_FOR_C_CALL /* no need to cleanup after */ call GCALL(caml_stash_backtrace) movq %r12, %rax /* Recover exception bucket */ movq %r14, %rsp @@ -471,18 +507,19 @@ FUNCTION(G(caml_raise_exception)) LBL(111): movq C_ARG_1, %r12 /* Save exception bucket */ /* arg 1: exception bucket */ - LOAD_VAR(caml_last_return_address,C_ARG_2) /* arg 2: pc of raise */ + LOAD_VAR(caml_last_return_address,C_ARG_2) /* arg 2: pc of raise */ LOAD_VAR(caml_bottom_of_stack,C_ARG_3) /* arg 3: sp of raise */ LOAD_VAR(caml_exception_pointer,C_ARG_4) /* arg 4: sp of handler */ - PREPARE_FOR_C_CALL /* no need to cleanup after */ + subq $8, %rsp /* PR#5700: maintain stack alignment */ + PREPARE_FOR_C_CALL /* no need to cleanup after */ call GCALL(caml_stash_backtrace) movq %r12, %rax /* Recover exception bucket */ - LOAD_VAR(caml_exception_pointer,%rsp) + LOAD_VAR(caml_exception_pointer,%rsp) popq %r14 /* Recover previous exception handler */ - LOAD_VAR(caml_young_ptr,%r15) /* Reload alloc ptr */ + LOAD_VAR(caml_young_ptr,%r15) /* Reload alloc ptr */ ret -/* Callback from C to Caml */ +/* Callback from C to OCaml */ FUNCTION(G(caml_callback_exn)) /* Save callee-save registers */ @@ -518,6 +555,9 @@ FUNCTION(G(caml_ml_array_bound_error)) leaq GCALL(caml_array_bound_error)(%rip), %rax jmp LBL(caml_c_call) + .globl G(caml_system__code_end) +G(caml_system__code_end): + .data .globl G(caml_system__frametable) .align EIGHT_ALIGN @@ -529,20 +569,20 @@ G(caml_system__frametable): .align EIGHT_ALIGN #if defined(SYS_macosx) - .literal16 + .literal16 #elif defined(SYS_mingw64) - .section .rdata,"dr" + .section .rdata,"dr" #else - .section .rodata.cst8,"a",@progbits + .section .rodata.cst8,"a",@progbits #endif .globl G(caml_negf_mask) .align SIXTEEN_ALIGN G(caml_negf_mask): - .quad 0x8000000000000000, 0 + .quad 0x8000000000000000, 0 .globl G(caml_absf_mask) .align SIXTEEN_ALIGN G(caml_absf_mask): - .quad 0x7FFFFFFFFFFFFFFF, 0xFFFFFFFFFFFFFFFF + .quad 0x7FFFFFFFFFFFFFFF, 0xFFFFFFFFFFFFFFFF #if defined(SYS_linux) /* Mark stack as non-executable, PR#4564 */ diff --git a/asmrun/amd64nt.asm b/asmrun/amd64nt.asm index 2a38fd9f38..b262a01986 100644 --- a/asmrun/amd64nt.asm +++ b/asmrun/amd64nt.asm @@ -30,7 +30,7 @@ EXTRN caml_bottom_of_stack: QWORD EXTRN caml_last_return_address: QWORD EXTRN caml_gc_regs: QWORD - EXTRN caml_exception_pointer: QWORD + EXTRN caml_exception_pointer: QWORD EXTRN caml_backtrace_active: DWORD EXTRN caml_stash_backtrace: NEAR @@ -48,8 +48,8 @@ caml_call_gc: mov caml_bottom_of_stack, rax L105: ; Save caml_young_ptr, caml_exception_pointer - mov caml_young_ptr, r15 - mov caml_exception_pointer, r14 + mov caml_young_ptr, r15 + mov caml_exception_pointer, r14 ; Build array of registers, save it into caml_gc_regs push r13 push r12 @@ -119,8 +119,8 @@ L105: pop r12 pop r13 ; Restore caml_young_ptr, caml_exception_pointer - mov r15, caml_young_ptr - mov r14, caml_exception_pointer + mov r15, caml_young_ptr + mov r14, caml_exception_pointer ; Return to caller ret @@ -136,9 +136,9 @@ L100: mov caml_last_return_address, rax lea rax, [rsp + 8] mov caml_bottom_of_stack, rax - sub rsp, 8 + sub rsp, 8 call L105 - add rsp, 8 + add rsp, 8 jmp caml_alloc1 PUBLIC caml_alloc2 @@ -153,9 +153,9 @@ L101: mov caml_last_return_address, rax lea rax, [rsp + 8] mov caml_bottom_of_stack, rax - sub rsp, 8 + sub rsp, 8 call L105 - add rsp, 8 + add rsp, 8 jmp caml_alloc2 PUBLIC caml_alloc3 @@ -170,9 +170,9 @@ L102: mov caml_last_return_address, rax lea rax, [rsp + 8] mov caml_bottom_of_stack, rax - sub rsp, 8 + sub rsp, 8 call L105 - add rsp, 8 + add rsp, 8 jmp caml_alloc3 PUBLIC caml_allocN @@ -192,7 +192,7 @@ L103: pop rax ; recover desired size jmp caml_allocN -; Call a C function from Caml +; Call a C function from OCaml PUBLIC caml_c_call ALIGN 16 @@ -202,17 +202,17 @@ caml_c_call: mov caml_last_return_address, r12 mov caml_bottom_of_stack, rsp ; Make the exception handler and alloc ptr available to the C code - mov caml_young_ptr, r15 - mov caml_exception_pointer, r14 + mov caml_young_ptr, r15 + mov caml_exception_pointer, r14 ; Call the function (address in rax) call rax ; Reload alloc ptr - mov r15, caml_young_ptr + mov r15, caml_young_ptr ; Return to caller - push r12 - ret + push r12 + ret -; Start the Caml program +; Start the OCaml program PUBLIC caml_start_program ALIGN 16 @@ -242,19 +242,19 @@ caml_start_program: ; Common code for caml_start_program and caml_callback* L106: ; Build a callback link - sub rsp, 8 ; stack 16-aligned + sub rsp, 8 ; stack 16-aligned push caml_gc_regs push caml_last_return_address push caml_bottom_of_stack ; Setup alloc ptr and exception ptr - mov r15, caml_young_ptr - mov r14, caml_exception_pointer + mov r15, caml_young_ptr + mov r14, caml_exception_pointer ; Build an exception handler lea r13, L108 push r13 push r14 mov r14, rsp - ; Call the Caml code + ; Call the OCaml code call r12 L107: ; Pop the exception handler @@ -262,13 +262,13 @@ L107: pop r12 ; dummy register L109: ; Update alloc ptr and exception ptr - mov caml_young_ptr, r15 - mov caml_exception_pointer, r14 + mov caml_young_ptr, r15 + mov caml_exception_pointer, r14 ; Pop the callback restoring, link the global variables pop caml_bottom_of_stack pop caml_last_return_address pop caml_gc_regs - add rsp, 8 + add rsp, 8 ; Restore callee-save registers. movapd xmm6, OWORD PTR [rsp + 0*16] movapd xmm7, OWORD PTR [rsp + 1*16] @@ -297,7 +297,7 @@ L108: or rax, 2 jmp L109 -; Raise an exception from Caml +; Raise an exception from OCaml PUBLIC caml_raise_exn ALIGN 16 @@ -346,7 +346,7 @@ L111: mov r15, caml_young_ptr ; Reload alloc ptr ret -; Callback from C to Caml +; Callback from C to OCaml PUBLIC caml_callback_exn ALIGN 16 @@ -441,8 +441,8 @@ caml_callback3_exn: PUBLIC caml_ml_array_bound_error ALIGN 16 caml_ml_array_bound_error: - lea rax, caml_array_bound_error - jmp caml_c_call + lea rax, caml_array_bound_error + jmp caml_c_call .DATA PUBLIC caml_system__frametable @@ -456,11 +456,11 @@ caml_system__frametable LABEL QWORD PUBLIC caml_negf_mask ALIGN 16 caml_negf_mask LABEL QWORD - QWORD 8000000000000000H, 0 + QWORD 8000000000000000H, 0 PUBLIC caml_absf_mask ALIGN 16 caml_absf_mask LABEL QWORD - QWORD 7FFFFFFFFFFFFFFFH, 0FFFFFFFFFFFFFFFFH + QWORD 7FFFFFFFFFFFFFFFH, 0FFFFFFFFFFFFFFFFH END diff --git a/asmrun/arm.S b/asmrun/arm.S index 395d0a136a..3af6e6f17a 100644 --- a/asmrun/arm.S +++ b/asmrun/arm.S @@ -2,285 +2,410 @@ /* */ /* OCaml */ /* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* Benedikt Meurer, University of Siegen */ /* */ -/* Copyright 1998 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ +/* Copyright 1998 Institut National de Recherche en Informatique */ +/* et en Automatique. Copyright 2012 Benedikt Meurer. All rights */ +/* reserved. This file is distributed under the terms of the GNU */ +/* Library General Public License, with the special exception on */ +/* linking described in file ../LICENSE. */ /* */ /***********************************************************************/ /* $Id$ */ /* Asm part of the runtime system, ARM processor */ +/* Must be preprocessed by cpp */ -trap_ptr .req r11 -alloc_ptr .req r8 -alloc_limit .req r10 - + .syntax unified .text +#if defined(SYS_linux_eabihf) + .arch armv7-a + .fpu vfpv3-d16 + .thumb +#elif defined(SYS_linux_eabi) + .arch armv4t + .arm + + /* Compatibility macros */ + .macro blx reg + mov lr, pc + bx \reg + .endm + .macro cbz reg, lbl + cmp \reg, #0 + beq \lbl + .endm + .macro vpop regs + .endm + .macro vpush regs + .endm +#endif + +trap_ptr .req r8 +alloc_ptr .req r10 +alloc_limit .req r11 + +/* Support for profiling with gprof */ + +#if defined(PROFILING) && (defined(SYS_linux_eabihf) || defined(SYS_linux_eabi)) +#define PROFILE \ + push {lr}; \ + bl __gnu_mcount_nc +#else +#define PROFILE +#endif /* Allocation functions and GC interface */ - .globl caml_call_gc + .globl caml_system__code_begin +caml_system__code_begin: + + .align 2 + .globl caml_call_gc .type caml_call_gc, %function caml_call_gc: - /* Record return address and desired size */ - /* Can use alloc_limit as a temporary since it will be reloaded by - invoke_gc */ - ldr alloc_limit, .Lcaml_last_return_address - str lr, [alloc_limit, #0] - ldr alloc_limit, .Lcaml_requested_size - str r12, [alloc_limit, #0] - /* Branch to shared GC code */ - bl .Linvoke_gc - /* Finish allocation */ - ldr r12, .Lcaml_requested_size - ldr r12, [r12, #0] - sub alloc_ptr, alloc_ptr, r12 + PROFILE + /* Record return address */ + ldr r12, =caml_last_return_address + str lr, [r12] +.Lcaml_call_gc: + /* Record lowest stack address */ + ldr r12, =caml_bottom_of_stack + str sp, [r12] + /* Save caller floating-point registers on the stack */ + vpush {d0-d7} + /* Save integer registers and return address on the stack */ + push {r0-r7,r12,lr} + /* Store pointer to saved integer registers in caml_gc_regs */ + ldr r12, =caml_gc_regs + str sp, [r12] + /* Save current allocation pointer for debugging purposes */ + ldr alloc_limit, =caml_young_ptr + str alloc_ptr, [alloc_limit] + /* Save trap pointer in case an exception is raised during GC */ + ldr r12, =caml_exception_pointer + str trap_ptr, [r12] + /* Call the garbage collector */ + bl caml_garbage_collection + /* Restore integer registers and return address from the stack */ + pop {r0-r7,r12,lr} + /* Restore floating-point registers from the stack */ + vpop {d0-d7} + /* Reload new allocation pointer and limit */ + /* alloc_limit still points to caml_young_ptr */ + ldr r12, =caml_young_limit + ldr alloc_ptr, [alloc_limit] + ldr alloc_limit, [r12] + /* Return to caller */ bx lr + .type caml_call_gc, %function + .size caml_call_gc, .-caml_call_gc - .globl caml_alloc1 + .align 2 + .globl caml_alloc1 .type caml_alloc1, %function caml_alloc1: - sub alloc_ptr, alloc_ptr, #8 + PROFILE +.Lcaml_alloc1: + sub alloc_ptr, alloc_ptr, 8 cmp alloc_ptr, alloc_limit - movcs pc, lr /* Return if alloc_ptr >= alloc_limit */ - /* Record return address */ - ldr r12, .Lcaml_last_return_address - str lr, [r12, #0] - /* Invoke GC */ - bl .Linvoke_gc + bcc 1f + bx lr +1: /* Record return address */ + ldr r7, =caml_last_return_address + str lr, [r7] + /* Call GC (preserves r7) */ + bl .Lcaml_call_gc + /* Restore return address */ + ldr lr, [r7] /* Try again */ - b caml_alloc1 + b .Lcaml_alloc1 + .type caml_alloc1, %function + .size caml_alloc1, .-caml_alloc1 - .globl caml_alloc2 + .align 2 + .globl caml_alloc2 .type caml_alloc2, %function caml_alloc2: - sub alloc_ptr, alloc_ptr, #12 + PROFILE +.Lcaml_alloc2: + sub alloc_ptr, alloc_ptr, 12 cmp alloc_ptr, alloc_limit - movcs pc, lr /* Return if alloc_ptr >= alloc_limit */ - /* Record return address */ - ldr r12, .Lcaml_last_return_address - str lr, [r12, #0] - /* Invoke GC */ - bl .Linvoke_gc + bcc 1f + bx lr +1: /* Record return address */ + ldr r7, =caml_last_return_address + str lr, [r7] + /* Call GC (preserves r7) */ + bl .Lcaml_call_gc + /* Restore return address */ + ldr lr, [r7] /* Try again */ - b caml_alloc2 + b .Lcaml_alloc2 + .type caml_alloc2, %function + .size caml_alloc2, .-caml_alloc2 - .globl caml_alloc3 + .align 2 + .globl caml_alloc3 .type caml_alloc3, %function caml_alloc3: - sub alloc_ptr, alloc_ptr, #16 + PROFILE +.Lcaml_alloc3: + sub alloc_ptr, alloc_ptr, 16 cmp alloc_ptr, alloc_limit - movcs pc, lr /* Return if alloc_ptr >= alloc_limit */ - /* Record return address */ - ldr r12, .Lcaml_last_return_address - str lr, [r12, #0] - /* Invoke GC */ - bl .Linvoke_gc + bcc 1f + bx lr +1: /* Record return address */ + ldr r7, =caml_last_return_address + str lr, [r7] + /* Call GC (preserves r7) */ + bl .Lcaml_call_gc + /* Restore return address */ + ldr lr, [r7] /* Try again */ - b caml_alloc3 + b .Lcaml_alloc3 + .type caml_alloc3, %function + .size caml_alloc3, .-caml_alloc3 - .globl caml_allocN + .align 2 + .globl caml_allocN .type caml_allocN, %function caml_allocN: - sub alloc_ptr, alloc_ptr, r12 + PROFILE +.Lcaml_allocN: + sub alloc_ptr, alloc_ptr, r7 cmp alloc_ptr, alloc_limit - movcs pc, lr /* Return if alloc_ptr >= alloc_limit */ - /* Record return address and desired size */ - /* Can use alloc_limit as a temporary since it will be reloaded by - invoke_gc */ - ldr alloc_limit, .Lcaml_last_return_address - str lr, [alloc_limit, #0] - ldr alloc_limit, .Lcaml_requested_size - str r12, [alloc_limit, #0] - /* Invoke GC */ - bl .Linvoke_gc + bcc 1f + bx lr +1: /* Record return address */ + ldr r12, =caml_last_return_address + str lr, [r12] + /* Call GC (preserves r7) */ + bl .Lcaml_call_gc + /* Restore return address */ + ldr r12, =caml_last_return_address + ldr lr, [r12] /* Try again */ - ldr r12, .Lcaml_requested_size - ldr r12, [r12, #0] - b caml_allocN + b .Lcaml_allocN + .type caml_allocN, %function + .size caml_allocN, .-caml_allocN -/* Shared code to invoke the GC */ -.Linvoke_gc: - /* Record lowest stack address */ - ldr r12, .Lcaml_bottom_of_stack - str sp, [r12, #0] - /* Save integer registers and return address on stack */ - stmfd sp!, {r0,r1,r2,r3,r4,r5,r6,r7,r12,lr} - /* Store pointer to saved integer registers in caml_gc_regs */ - ldr r12, .Lcaml_gc_regs - str sp, [r12, #0] - /* Save current allocation pointer for debugging purposes */ - ldr r12, .Lcaml_young_ptr - str alloc_ptr, [r12, #0] - /* Save trap pointer in case an exception is raised during GC */ - ldr r12, .Lcaml_exception_pointer - str trap_ptr, [r12, #0] - /* Call the garbage collector */ - bl caml_garbage_collection - /* Restore the registers from the stack */ - ldmfd sp!, {r0,r1,r2,r3,r4,r5,r6,r7,r12} - /* Reload return address */ - ldr r12, .Lcaml_last_return_address - ldr lr, [r12, #0] - /* Reload new allocation pointer and allocation limit */ - ldr r12, .Lcaml_young_ptr - ldr alloc_ptr, [r12, #0] - ldr r12, .Lcaml_young_limit - ldr alloc_limit, [r12, #0] - /* Return to caller */ - ldr r12, [sp], #4 - bx r12 - -/* Call a C function from Caml */ -/* Function to call is in r12 */ +/* Call a C function from OCaml */ +/* Function to call is in r7 */ - .globl caml_c_call + .align 2 + .globl caml_c_call .type caml_c_call, %function caml_c_call: + PROFILE + /* Record lowest stack address and return address */ + ldr r5, =caml_last_return_address + ldr r6, =caml_bottom_of_stack + str lr, [r5] + str sp, [r6] /* Preserve return address in callee-save register r4 */ mov r4, lr - /* Record lowest stack address and return address */ - ldr r5, .Lcaml_last_return_address - ldr r6, .Lcaml_bottom_of_stack - str lr, [r5, #0] - str sp, [r6, #0] - /* Make the exception handler and alloc ptr available to the C code */ - ldr r6, .Lcaml_young_ptr - ldr r7, .Lcaml_exception_pointer - str alloc_ptr, [r6, #0] - str trap_ptr, [r7, #0] + /* Make the exception handler alloc ptr available to the C code */ + ldr r5, =caml_young_ptr + ldr r6, =caml_exception_pointer + str alloc_ptr, [r5] + str trap_ptr, [r6] /* Call the function */ - mov lr, pc - bx r12 + blx r7 /* Reload alloc ptr and alloc limit */ - ldr r5, .Lcaml_young_limit - ldr alloc_ptr, [r6, #0] /* r6 still points to caml_young_ptr */ - ldr alloc_limit, [r5, #0] + ldr r6, =caml_young_limit + ldr alloc_ptr, [r5] /* r5 still points to caml_young_ptr */ + ldr alloc_limit, [r6] /* Return */ bx r4 + .type caml_c_call, %function + .size caml_c_call, .-caml_c_call -/* Start the Caml program */ +/* Start the OCaml program */ - .globl caml_start_program + .align 2 + .globl caml_start_program .type caml_start_program, %function caml_start_program: - ldr r12, .Lcaml_program + PROFILE + ldr r12, =caml_program /* Code shared with caml_callback* */ -/* Address of Caml code to call is in r12 */ -/* Arguments to the Caml code are in r0...r3 */ +/* Address of OCaml code to call is in r12 */ +/* Arguments to the OCaml code are in r0...r3 */ .Ljump_to_caml: /* Save return address and callee-save registers */ - stmfd sp!, {r4,r5,r6,r7,r8,r10,r11,lr} /* 8-alignment */ + vpush {d8-d15} + push {r4-r8,r10,r11,lr} /* 8-byte alignment */ /* Setup a callback link on the stack */ - sub sp, sp, #4*4 /* 8-alignment */ - ldr r4, .Lcaml_bottom_of_stack - ldr r4, [r4, #0] - str r4, [sp, #0] - ldr r4, .Lcaml_last_return_address - ldr r4, [r4, #0] - str r4, [sp, #4] - ldr r4, .Lcaml_gc_regs - ldr r4, [r4, #0] - str r4, [sp, #8] - /* Setup a trap frame to catch exceptions escaping the Caml code */ - sub sp, sp, #4*2 - ldr r4, .Lcaml_exception_pointer - ldr r4, [r4, #0] - str r4, [sp, #0] - ldr r4, .LLtrap_handler - str r4, [sp, #4] + sub sp, sp, 4*4 /* 8-byte alignment */ + ldr r4, =caml_bottom_of_stack + ldr r5, =caml_last_return_address + ldr r6, =caml_gc_regs + ldr r4, [r4] + ldr r5, [r5] + ldr r6, [r6] + str r4, [sp, 0] + str r5, [sp, 4] + str r6, [sp, 8] + /* Setup a trap frame to catch exceptions escaping the OCaml code */ + sub sp, sp, 2*4 + ldr r6, =caml_exception_pointer + ldr r5, =.Ltrap_handler + ldr r4, [r6] + str r4, [sp, 0] + str r5, [sp, 4] mov trap_ptr, sp /* Reload allocation pointers */ - ldr r4, .Lcaml_young_ptr - ldr alloc_ptr, [r4, #0] - ldr r4, .Lcaml_young_limit - ldr alloc_limit, [r4, #0] - /* Call the Caml code */ - mov lr, pc - bx r12 + ldr r4, =caml_young_ptr + ldr alloc_ptr, [r4] + ldr r4, =caml_young_limit + ldr alloc_limit, [r4] + /* Call the OCaml code */ + blx r12 .Lcaml_retaddr: /* Pop the trap frame, restoring caml_exception_pointer */ - ldr r4, .Lcaml_exception_pointer - ldr r5, [sp, #0] - str r5, [r4, #0] - add sp, sp, #2 * 4 + ldr r4, =caml_exception_pointer + ldr r5, [sp, 0] + str r5, [r4] + add sp, sp, 2*4 /* Pop the callback link, restoring the global variables */ .Lreturn_result: - ldr r4, .Lcaml_bottom_of_stack - ldr r5, [sp, #0] - str r5, [r4, #0] - ldr r4, .Lcaml_last_return_address - ldr r5, [sp, #4] - str r5, [r4, #0] - ldr r4, .Lcaml_gc_regs - ldr r5, [sp, #8] - str r5, [r4, #0] - add sp, sp, #4*4 + ldr r4, =caml_bottom_of_stack + ldr r5, [sp, 0] + str r5, [r4] + ldr r4, =caml_last_return_address + ldr r5, [sp, 4] + str r5, [r4] + ldr r4, =caml_gc_regs + ldr r5, [sp, 8] + str r5, [r4] + add sp, sp, 4*4 /* Update allocation pointer */ - ldr r4, .Lcaml_young_ptr - str alloc_ptr, [r4, #0] + ldr r4, =caml_young_ptr + str alloc_ptr, [r4] /* Reload callee-save registers and return */ - ldmfd sp!, {r4,r5,r6,r7,r8,r10,r11,lr} - bx lr + pop {r4-r8,r10,r11,lr} + vpop {d8-d15} + bx lr + .type .Lcaml_retaddr, %function + .size .Lcaml_retaddr, .-.Lcaml_retaddr + .type caml_start_program, %function + .size caml_start_program, .-caml_start_program + +/* The trap handler */ - /* The trap handler */ + .align 2 .Ltrap_handler: /* Save exception pointer */ - ldr r4, .Lcaml_exception_pointer - str trap_ptr, [r4, #0] + ldr r12, =caml_exception_pointer + str trap_ptr, [r12] /* Encode exception bucket as an exception result */ - orr r0, r0, #2 + orr r0, r0, 2 /* Return it */ b .Lreturn_result + .type .Ltrap_handler, %function + .size .Ltrap_handler, .-.Ltrap_handler + +/* Raise an exception from OCaml */ + + .align 2 + .globl caml_raise_exn +caml_raise_exn: + PROFILE + /* Test if backtrace is active */ + ldr r1, =caml_backtrace_active + ldr r1, [r1] + cbz r1, 1f + /* Preserve exception bucket in callee-save register r4 */ + mov r4, r0 + /* Stash the backtrace */ + mov r1, lr /* arg2: pc of raise */ + mov r2, sp /* arg3: sp of raise */ + mov r3, trap_ptr /* arg4: sp of handler */ + bl caml_stash_backtrace + /* Restore exception bucket */ + mov r0, r4 +1: /* Cut stack at current trap handler */ + mov sp, trap_ptr + /* Pop previous handler and addr of trap, and jump to it */ + pop {trap_ptr, pc} + .type caml_raise_exn, %function + .size caml_raise_exn, .-caml_raise_exn /* Raise an exception from C */ - .globl caml_raise_exception + .align 2 + .globl caml_raise_exception .type caml_raise_exception, %function caml_raise_exception: - /* Reload Caml allocation pointers */ - ldr r12, .Lcaml_young_ptr - ldr alloc_ptr, [r12, #0] - ldr r12, .Lcaml_young_limit - ldr alloc_limit, [r12, #0] - /* Cut stack at current trap handler */ - ldr r12, .Lcaml_exception_pointer - ldr sp, [r12, #0] + PROFILE + /* Reload trap ptr, alloc ptr and alloc limit */ + ldr trap_ptr, =caml_exception_pointer + ldr alloc_ptr, =caml_young_ptr + ldr alloc_limit, =caml_young_limit + ldr trap_ptr, [trap_ptr] + ldr alloc_ptr, [alloc_ptr] + ldr alloc_limit, [alloc_limit] + /* Test if backtrace is active */ + ldr r1, =caml_backtrace_active + ldr r1, [r1] + cbz r1, 1f + /* Preserve exception bucket in callee-save register r4 */ + mov r4, r0 + ldr r1, =caml_last_return_address /* arg2: pc of raise */ + ldr r1, [r1] + ldr r2, =caml_bottom_of_stack /* arg3: sp of raise */ + ldr r2, [r2] + mov r3, trap_ptr /* arg4: sp of handler */ + bl caml_stash_backtrace + /* Restore exception bucket */ + mov r0, r4 +1: /* Cut stack at current trap handler */ + mov sp, trap_ptr /* Pop previous handler and addr of trap, and jump to it */ - ldmfd sp!, {trap_ptr, pc} + pop {trap_ptr, pc} + .type caml_raise_exception, %function + .size caml_raise_exception, .-caml_raise_exception -/* Callback from C to Caml */ +/* Callback from C to OCaml */ - .globl caml_callback_exn + .align 2 + .globl caml_callback_exn .type caml_callback_exn, %function caml_callback_exn: + PROFILE /* Initial shuffling of arguments (r0 = closure, r1 = first arg) */ mov r12, r0 - mov r0, r1 /* r0 = first arg */ - mov r1, r12 /* r1 = closure environment */ - ldr r12, [r12, #0] /* code pointer */ + mov r0, r1 /* r0 = first arg */ + mov r1, r12 /* r1 = closure environment */ + ldr r12, [r12] /* code pointer */ b .Ljump_to_caml + .type caml_callback_exn, %function + .size caml_callback_exn, .-caml_callback_exn - .globl caml_callback2_exn + .align 2 + .globl caml_callback2_exn .type caml_callback2_exn, %function caml_callback2_exn: + PROFILE /* Initial shuffling of arguments (r0 = closure, r1 = arg1, r2 = arg2) */ mov r12, r0 - mov r0, r1 /* r0 = first arg */ - mov r1, r2 /* r1 = second arg */ - mov r2, r12 /* r2 = closure environment */ - ldr r12, .Lcaml_apply2 + mov r0, r1 /* r0 = first arg */ + mov r1, r2 /* r1 = second arg */ + mov r2, r12 /* r2 = closure environment */ + ldr r12, =caml_apply2 b .Ljump_to_caml + .type caml_callback2_exn, %function + .size caml_callback2_exn, .-caml_callback2_exn - .globl caml_callback3_exn + .align 2 + .globl caml_callback3_exn .type caml_callback3_exn, %function caml_callback3_exn: + PROFILE /* Initial shuffling of arguments */ /* (r0 = closure, r1 = arg1, r2 = arg2, r3 = arg3) */ mov r12, r0 @@ -288,43 +413,36 @@ caml_callback3_exn: mov r1, r2 /* r1 = second arg */ mov r2, r3 /* r2 = third arg */ mov r3, r12 /* r3 = closure environment */ - ldr r12, .Lcaml_apply3 + ldr r12, =caml_apply3 b .Ljump_to_caml + .type caml_callback3_exn, %function + .size caml_callback3_exn, .-caml_callback3_exn - .globl caml_ml_array_bound_error + .align 2 + .globl caml_ml_array_bound_error .type caml_ml_array_bound_error, %function caml_ml_array_bound_error: - /* Load address of [caml_array_bound_error] in r12 */ - ldr r12, .Lcaml_array_bound_error + PROFILE + /* Load address of [caml_array_bound_error] in r7 */ + ldr r7, =caml_array_bound_error /* Call that function */ b caml_c_call + .type caml_ml_array_bound_error, %function + .size caml_ml_array_bound_error, .-caml_ml_array_bound_error -/* Global references */ - -.Lcaml_last_return_address: .word caml_last_return_address -.Lcaml_bottom_of_stack: .word caml_bottom_of_stack -.Lcaml_gc_regs: .word caml_gc_regs -.Lcaml_young_ptr: .word caml_young_ptr -.Lcaml_young_limit: .word caml_young_limit -.Lcaml_exception_pointer: .word caml_exception_pointer -.Lcaml_program: .word caml_program -.LLtrap_handler: .word .Ltrap_handler -.Lcaml_apply2: .word caml_apply2 -.Lcaml_apply3: .word caml_apply3 -.Lcaml_array_bound_error: .word caml_array_bound_error -.Lcaml_requested_size: .word caml_requested_size - - .data -caml_requested_size: - .word 0 + .globl caml_system__code_end +caml_system__code_end: /* GC roots for callback */ .data - .globl caml_system__frametable + .align 2 + .globl caml_system__frametable caml_system__frametable: .word 1 /* one descriptor */ .word .Lcaml_retaddr /* return address into callback */ .short -1 /* negative frame size => use callback link */ .short 0 /* no roots */ .align 2 + .type caml_system__frametable, %object + .size caml_system__frametable, .-caml_system__frametable diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c index c9581dd27f..7b47c0bfc9 100644 --- a/asmrun/backtrace.c +++ b/asmrun/backtrace.c @@ -193,7 +193,7 @@ void caml_print_exception_backtrace(void) } } -/* Convert the backtrace to a data structure usable from Caml */ +/* Convert the backtrace to a data structure usable from OCaml */ CAMLprim value caml_get_exception_backtrace(value unit) { diff --git a/asmrun/fail.c b/asmrun/fail.c index f6ac13e1b5..77cf4246cb 100644 --- a/asmrun/fail.c +++ b/asmrun/fail.c @@ -209,7 +209,7 @@ void caml_array_bound_error(void) } int caml_is_special_exception(value exn) { - return exn == caml_exn_Match_failure - || exn == caml_exn_Assert_failure - || exn == caml_exn_Undefined_recursive_module; + return exn == (value) caml_exn_Match_failure + || exn == (value) caml_exn_Assert_failure + || exn == (value) caml_exn_Undefined_recursive_module; } diff --git a/asmrun/i386.S b/asmrun/i386.S index fc91d393fc..177dc81452 100644 --- a/asmrun/i386.S +++ b/asmrun/i386.S @@ -16,6 +16,8 @@ /* Asm part of the runtime system, Intel 386 processor */ /* Must be preprocessed by cpp */ +#include "../config/m.h" + /* Linux/BSD with ELF binaries and Solaris do not prefix identifiers with _. Linux/BSD with a.out binaries and NextStep do. */ @@ -42,6 +44,16 @@ #define FUNCTION_ALIGN 2 #endif +#ifdef ASM_CFI_SUPPORTED +#define CFI_STARTPROC .cfi_startproc +#define CFI_ENDPROC .cfi_endproc +#define CFI_ADJUST(n) .cfi_adjust_cfa_offset n +#else +#define CFI_STARTPROC +#define CFI_ENDPROC +#define CFI_ADJUST(n) +#endif + #if defined(PROFILING) #if defined(SYS_linux_elf) || defined(SYS_gnu) #define PROFILE_CAML \ @@ -81,6 +93,9 @@ /* Allocation */ .text + .globl G(caml_system__code_begin) +G(caml_system__code_begin): + .globl G(caml_call_gc) .globl G(caml_alloc1) .globl G(caml_alloc2) @@ -89,14 +104,22 @@ .align FUNCTION_ALIGN G(caml_call_gc): + CFI_STARTPROC PROFILE_CAML /* Record lowest stack address and return address */ movl 0(%esp), %eax movl %eax, G(caml_last_return_address) leal 4(%esp), %eax movl %eax, G(caml_bottom_of_stack) - /* Build array of registers, save it into caml_gc_regs */ LBL(105): +#if !defined(SYS_mingw) && !defined(SYS_cygwin) + /* Touch the stack to trigger a recoverable segfault + if insufficient space remains */ + subl $16384, %esp + movl %eax, 0(%esp) + addl $16384, %esp +#endif + /* Build array of registers, save it into caml_gc_regs */ pushl %ebp pushl %edi pushl %esi @@ -104,6 +127,7 @@ LBL(105): pushl %ecx pushl %ebx pushl %eax + CFI_ADJUST(28) movl %esp, G(caml_gc_regs) /* MacOSX note: 16-alignment of stack preserved at this point */ /* Call the garbage collector */ @@ -116,8 +140,10 @@ LBL(105): popl %esi popl %edi popl %ebp + CFI_ADJUST(-28) /* Return to caller */ ret + CFI_ENDPROC .align FUNCTION_ALIGN G(caml_alloc1): @@ -200,7 +226,7 @@ LBL(103): popl %eax /* recover desired size */ jmp G(caml_allocN) -/* Call a C function from Caml */ +/* Call a C function from OCaml */ .globl G(caml_c_call) .align FUNCTION_ALIGN @@ -211,20 +237,29 @@ G(caml_c_call): movl %edx, G(caml_last_return_address) leal 4(%esp), %edx movl %edx, G(caml_bottom_of_stack) +#if !defined(SYS_mingw) && !defined(SYS_cygwin) + /* Touch the stack to trigger a recoverable segfault + if insufficient space remains */ + subl $16384, %esp + movl %eax, 0(%esp) + addl $16384, %esp +#endif /* Call the function (address in %eax) */ jmp *%eax -/* Start the Caml program */ +/* Start the OCaml program */ .globl G(caml_start_program) .align FUNCTION_ALIGN G(caml_start_program): + CFI_STARTPROC PROFILE_C /* Save callee-save registers */ pushl %ebx pushl %esi pushl %edi pushl %ebp + CFI_ADJUST(16) /* Initial entry point is caml_program */ movl $ G(caml_program), %esi /* Common code for caml_start_program and caml_callback* */ @@ -238,17 +273,19 @@ LBL(106): pushl $ LBL(108) ALIGN_STACK(8) pushl G(caml_exception_pointer) + CFI_ADJUST(20) movl %esp, G(caml_exception_pointer) - /* Call the Caml code */ + /* Call the OCaml code */ call *%esi LBL(107): /* Pop the exception handler */ popl G(caml_exception_pointer) #ifdef SYS_macosx - addl $12, %esp + addl $12, %esp #else - addl $4, %esp + addl $4, %esp #endif + CFI_ADJUST(-8) LBL(109): /* Pop the callback link, restoring the global variables */ popl G(caml_bottom_of_stack) @@ -266,8 +303,9 @@ LBL(108): /* Mark the bucket as an exception result and return it */ orl $2, %eax jmp LBL(109) + CFI_ENDPROC -/* Raise an exception from Caml */ +/* Raise an exception from OCaml */ .globl G(caml_raise_exn) .align FUNCTION_ALIGN @@ -301,7 +339,7 @@ LBL(110): .align FUNCTION_ALIGN G(caml_raise_exception): PROFILE_C - testl $1, G(caml_backtrace_active) + testl $1, G(caml_backtrace_active) jne LBL(111) movl 4(%esp), %eax movl G(caml_exception_pointer), %esp @@ -322,7 +360,7 @@ LBL(111): UNDO_ALIGN_STACK(8) ret -/* Callback from C to Caml */ +/* Callback from C to OCaml */ .globl G(caml_callback_exn) .align FUNCTION_ALIGN @@ -391,11 +429,14 @@ G(caml_ml_array_bound_error): movl %edx, G(caml_bottom_of_stack) /* For MacOS X: re-align the stack */ #ifdef SYS_macosx - andl $-16, %esp + andl $-16, %esp #endif /* Branch to [caml_array_bound_error] (never returns) */ call G(caml_array_bound_error) + .globl G(caml_system__code_end) +G(caml_system__code_end): + .data .globl G(caml_system__frametable) G(caml_system__frametable): diff --git a/asmrun/i386nt.asm b/asmrun/i386nt.asm index 02c6ff564d..23d341dae6 100644 --- a/asmrun/i386nt.asm +++ b/asmrun/i386nt.asm @@ -15,8 +15,8 @@ ; Asm part of the runtime system, Intel 386 processor, Intel syntax - .386 - .MODEL FLAT + .386 + .MODEL FLAT EXTERN _caml_garbage_collection: PROC EXTERN _caml_apply2: PROC @@ -25,10 +25,10 @@ EXTERN _caml_array_bound_error: PROC EXTERN _caml_young_limit: DWORD EXTERN _caml_young_ptr: DWORD - EXTERN _caml_bottom_of_stack: DWORD - EXTERN _caml_last_return_address: DWORD - EXTERN _caml_gc_regs: DWORD - EXTERN _caml_exception_pointer: DWORD + EXTERN _caml_bottom_of_stack: DWORD + EXTERN _caml_last_return_address: DWORD + EXTERN _caml_gc_regs: DWORD + EXTERN _caml_exception_pointer: DWORD EXTERN _caml_backtrace_active: DWORD EXTERN _caml_stash_backtrace: PROC @@ -39,11 +39,11 @@ PUBLIC _caml_alloc2 PUBLIC _caml_alloc3 PUBLIC _caml_allocN - PUBLIC _caml_call_gc + PUBLIC _caml_call_gc _caml_call_gc: ; Record lowest stack address and return address - mov eax, [esp] + mov eax, [esp] mov _caml_last_return_address, eax lea eax, [esp+4] mov _caml_bottom_of_stack, eax @@ -57,9 +57,9 @@ L105: push ebp push eax mov _caml_gc_regs, esp ; Call the garbage collector - call _caml_garbage_collection + call _caml_garbage_collection ; Restore all regs used by the code generator - pop eax + pop eax pop ebx pop ecx pop edx @@ -71,13 +71,13 @@ L105: push ebp ALIGN 4 _caml_alloc1: - mov eax, _caml_young_ptr - sub eax, 8 - mov _caml_young_ptr, eax - cmp eax, _caml_young_limit - jb L100 + mov eax, _caml_young_ptr + sub eax, 8 + mov _caml_young_ptr, eax + cmp eax, _caml_young_limit + jb L100 ret -L100: mov eax, [esp] +L100: mov eax, [esp] mov _caml_last_return_address, eax lea eax, [esp+4] mov _caml_bottom_of_stack, eax @@ -86,13 +86,13 @@ L100: mov eax, [esp] ALIGN 4 _caml_alloc2: - mov eax, _caml_young_ptr - sub eax, 12 - mov _caml_young_ptr, eax - cmp eax, _caml_young_limit - jb L101 + mov eax, _caml_young_ptr + sub eax, 12 + mov _caml_young_ptr, eax + cmp eax, _caml_young_limit + jb L101 ret -L101: mov eax, [esp] +L101: mov eax, [esp] mov _caml_last_return_address, eax lea eax, [esp+4] mov _caml_bottom_of_stack, eax @@ -101,13 +101,13 @@ L101: mov eax, [esp] ALIGN 4 _caml_alloc3: - mov eax, _caml_young_ptr - sub eax, 16 - mov _caml_young_ptr, eax - cmp eax, _caml_young_limit - jb L102 + mov eax, _caml_young_ptr + sub eax, 16 + mov _caml_young_ptr, eax + cmp eax, _caml_young_limit + jb L102 ret -L102: mov eax, [esp] +L102: mov eax, [esp] mov _caml_last_return_address, eax lea eax, [esp+4] mov _caml_bottom_of_stack, eax @@ -126,7 +126,7 @@ L103: sub eax, _caml_young_ptr ; eax = - size neg eax ; eax = size push eax ; save desired size sub _caml_young_ptr, eax ; must update young_ptr - mov eax, [esp+4] + mov eax, [esp+4] mov _caml_last_return_address, eax lea eax, [esp+8] mov _caml_bottom_of_stack, eax @@ -134,29 +134,29 @@ L103: sub eax, _caml_young_ptr ; eax = - size pop eax ; recover desired size jmp _caml_allocN -; Call a C function from Caml +; Call a C function from OCaml PUBLIC _caml_c_call ALIGN 4 _caml_c_call: ; Record lowest stack address and return address - mov edx, [esp] - mov _caml_last_return_address, edx - lea edx, [esp+4] - mov _caml_bottom_of_stack, edx + mov edx, [esp] + mov _caml_last_return_address, edx + lea edx, [esp+4] + mov _caml_bottom_of_stack, edx ; Call the function (address in %eax) - jmp eax + jmp eax -; Start the Caml program +; Start the OCaml program PUBLIC _caml_start_program ALIGN 4 _caml_start_program: ; Save callee-save registers - push ebx - push esi - push edi - push ebp + push ebx + push esi + push edi + push ebp ; Initial code pointer is caml_program mov esi, offset _caml_program @@ -165,29 +165,29 @@ _caml_start_program: L106: ; Build a callback link push _caml_gc_regs - push _caml_last_return_address - push _caml_bottom_of_stack + push _caml_last_return_address + push _caml_bottom_of_stack ; Build an exception handler - push L108 - push _caml_exception_pointer - mov _caml_exception_pointer, esp - ; Call the Caml code - call esi + push L108 + push _caml_exception_pointer + mov _caml_exception_pointer, esp + ; Call the OCaml code + call esi L107: ; Pop the exception handler - pop _caml_exception_pointer - pop esi ; dummy register + pop _caml_exception_pointer + pop esi ; dummy register L109: ; Pop the callback link, restoring the global variables ; used by caml_c_call - pop _caml_bottom_of_stack - pop _caml_last_return_address + pop _caml_bottom_of_stack + pop _caml_last_return_address pop _caml_gc_regs ; Restore callee-save registers. - pop ebp - pop edi - pop esi - pop ebx + pop ebp + pop edi + pop esi + pop ebx ; Return to caller. ret L108: @@ -196,15 +196,15 @@ L108: or eax, 2 jmp L109 -; Raise an exception for Caml +; Raise an exception for OCaml PUBLIC _caml_raise_exn ALIGN 4 _caml_raise_exn: test _caml_backtrace_active, 1 jne L110 - mov esp, _caml_exception_pointer - pop _caml_exception_pointer + mov esp, _caml_exception_pointer + pop _caml_exception_pointer ret L110: mov esi, eax ; Save exception bucket in esi @@ -228,9 +228,9 @@ L110: _caml_raise_exception: test _caml_backtrace_active, 1 jne L111 - mov eax, [esp+4] - mov esp, _caml_exception_pointer - pop _caml_exception_pointer + mov eax, [esp+4] + mov esp, _caml_exception_pointer + pop _caml_exception_pointer ret L111: mov esi, [esp+4] ; Save exception bucket in esi @@ -244,52 +244,52 @@ L111: pop _caml_exception_pointer ret -; Callback from C to Caml +; Callback from C to OCaml PUBLIC _caml_callback_exn ALIGN 4 _caml_callback_exn: ; Save callee-save registers - push ebx - push esi - push edi - push ebp + push ebx + push esi + push edi + push ebp ; Initial loading of arguments - mov ebx, [esp+20] ; closure - mov eax, [esp+24] ; argument - mov esi, [ebx] ; code pointer + mov ebx, [esp+20] ; closure + mov eax, [esp+24] ; argument + mov esi, [ebx] ; code pointer jmp L106 PUBLIC _caml_callback2_exn ALIGN 4 _caml_callback2_exn: ; Save callee-save registers - push ebx - push esi - push edi - push ebp + push ebx + push esi + push edi + push ebp ; Initial loading of arguments - mov ecx, [esp+20] ; closure - mov eax, [esp+24] ; first argument - mov ebx, [esp+28] ; second argument - mov esi, offset _caml_apply2 ; code pointer - jmp L106 + mov ecx, [esp+20] ; closure + mov eax, [esp+24] ; first argument + mov ebx, [esp+28] ; second argument + mov esi, offset _caml_apply2 ; code pointer + jmp L106 PUBLIC _caml_callback3_exn - ALIGN 4 + ALIGN 4 _caml_callback3_exn: ; Save callee-save registers - push ebx - push esi - push edi - push ebp + push ebx + push esi + push edi + push ebp ; Initial loading of arguments - mov edx, [esp+20] ; closure - mov eax, [esp+24] ; first argument - mov ebx, [esp+28] ; second argument - mov ecx, [esp+32] ; third argument - mov esi, offset _caml_apply3 ; code pointer - jmp L106 + mov edx, [esp+20] ; closure + mov eax, [esp+24] ; first argument + mov ebx, [esp+28] ; second argument + mov ecx, [esp+32] ; third argument + mov esi, offset _caml_apply3 ; code pointer + jmp L106 PUBLIC _caml_ml_array_bound_error ALIGN 4 diff --git a/asmrun/ia64.S b/asmrun/ia64.S deleted file mode 100644 index 4680aa932b..0000000000 --- a/asmrun/ia64.S +++ /dev/null @@ -1,524 +0,0 @@ -/***********************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id$ */ - -/* Asm part of the runtime system, IA64 processor */ - -#undef BROKEN_POSTINCREMENT - -#define ADDRGLOBAL(reg,symb) \ - add reg = @ltoff(symb), gp;; ld8 reg = [reg] -#define LOADGLOBAL(reg,symb) \ - add r3 = @ltoff(symb), gp;; ld8 r3 = [r3];; ld8 reg = [r3] -#define STOREGLOBAL(reg,symb) \ - add r3 = @ltoff(symb), gp;; ld8 r3 = [r3];; st8 [r3] = reg - -#define ST8OFF(a,b,d) st8 [a] = b, d -#define LD8OFF(a,b,d) ld8 a = [b], d -#define STFDOFF(a,b,d) stfd [a] = b, d -#define LDFDOFF(a,b,d) ldfd a = [b], d -#define STFSPILLOFF(a,b,d) stf.spill [a] = b, d -#define LDFFILLOFF(a,b,d) ldf.fill a = [b], d - -#define SAVE2(a,b) ST8OFF(r2, a, 16); ST8OFF(r3, b, 16) -#define SAVE4(a,b,c,d) SAVE2(a,b);; SAVE2(c,d) -#define SAVE8(a,b,c,d,e,f,g,h) SAVE4(a,b,c,d);; SAVE4(e,f,g,h) - -#define LOAD2(a,b) LD8OFF(a, r2, 16); LD8OFF(b, r3, 16) -#define LOAD4(a,b,c,d) LOAD2(a,b);; LOAD2(c,d) -#define LOAD8(a,b,c,d,e,f,g,h) LOAD4(a,b,c,d);; LOAD4(e,f,g,h) - -#define FSAVE2(a,b) STFDOFF(r2, a, 16); STFDOFF(r3, b, 16) -#define FSAVE4(a,b,c,d) FSAVE2(a,b);; FSAVE2(c,d) -#define FSAVE8(a,b,c,d,e,f,g,h) FSAVE4(a,b,c,d);; FSAVE4(e,f,g,h) - -#define FLOAD2(a,b) LDFDOFF(a, r2, 16); LDFDOFF(b, r3, 16) -#define FLOAD4(a,b,c,d) FLOAD2(a,b);; FLOAD2(c,d) -#define FLOAD8(a,b,c,d,e,f,g,h) FLOAD4(a,b,c,d);; FLOAD4(e,f,g,h) - -#define FSPILL2(a,b) STFSPILLOFF(r2, a, 32); STFSPILLOFF(r3, b, 32) -#define FSPILL4(a,b,c,d) FSPILL2(a,b);; FSPILL2(c,d) -#define FSPILL8(a,b,c,d,e,f,g,h) FSPILL4(a,b,c,d);; FSPILL4(e,f,g,h) - -#define FFILL2(a,b) LDFFILLOFF(a, r2, 32); LDFFILLOFF(b, r3, 32) -#define FFILL4(a,b,c,d) FFILL2(a,b);; FFILL2(c,d) -#define FFILL8(a,b,c,d,e,f,g,h) FFILL4(a,b,c,d);; FFILL4(e,f,g,h) - -/* Allocation */ - .text - - .global caml_allocN# - .proc caml_allocN# - .align 16 - -/* caml_allocN: all code generator registers preserved, - gp preserved, r2 = requested size */ - -caml_allocN: - sub r4 = r4, r2 ;; - cmp.ltu p0, p6 = r4, r5 - (p6) br.ret.sptk b0 ;; - /* Fall through caml_call_gc */ - br.sptk.many caml_call_gc# - - .endp caml_allocN# - -/* caml_call_gc: all code generator registers preserved, - gp preserved, r2 = requested size */ - - .global caml_call_gc# - .proc caml_call_gc# - .align 16 -caml_call_gc: - /* Allocate stack frame */ - add sp = -(16 + 16 + 80*8 + 42*8), sp ;; - - /* Save requested size and GP on stack */ - add r3 = 16, sp ;; - ST8OFF(r3, r2, 8) ;; - st8 [r3] = gp - - /* Record lowest stack address, return address, GC regs */ - mov r2 = b0 ;; - STOREGLOBAL(r2, caml_last_return_address#) - add r2 = (16 + 16 + 80*8 + 42*8), sp ;; - STOREGLOBAL(r2, caml_bottom_of_stack#) - add r2 = (16 + 16), sp ;; - STOREGLOBAL(r2, caml_gc_regs#) - - /* Save all integer regs used by the code generator in the context */ -.L100: add r3 = 8, r2 ;; - SAVE4(r8,r9,r10,r11) ;; - SAVE8(r16,r17,r18,r19,r20,r21,r22,r23) ;; - SAVE8(r24,r25,r26,r27,r28,r29,r30,r31) ;; - SAVE8(r32,r33,r34,r35,r36,r37,r38,r39) ;; - SAVE8(r40,r41,r42,r43,r44,r45,r46,r47) ;; - SAVE8(r48,r49,r50,r51,r52,r53,r54,r55) ;; - SAVE8(r56,r57,r58,r59,r60,r61,r62,r63) ;; - SAVE8(r64,r65,r66,r67,r68,r69,r70,r71) ;; - SAVE8(r72,r73,r74,r75,r76,r77,r78,r79) ;; - SAVE8(r80,r81,r82,r83,r84,r85,r86,r87) ;; - SAVE4(r88,r89,r90,r91) ;; - - /* Save all floating-point registers not preserved by C */ - FSAVE2(f6,f7) ;; - FSAVE8(f8,f9,f10,f11,f12,f13,f14,f15) ;; - FSAVE8(f32,f33,f34,f35,f36,f37,f38,f39) ;; - FSAVE8(f40,f41,f42,f43,f44,f45,f46,f47) ;; - FSAVE8(f48,f49,f50,f51,f52,f53,f54,f55) ;; - FSAVE8(f56,f57,f58,f59,f60,f61,f62,f63) ;; - - /* Save current allocation pointer for debugging purposes */ - STOREGLOBAL(r4, caml_young_ptr#) - - /* Save trap pointer in case an exception is raised */ - STOREGLOBAL(r6, caml_exception_pointer#) - - /* Call the garbage collector */ - br.call.sptk b0 = caml_garbage_collection# ;; - - /* Restore gp */ - add r3 = 24, sp ;; - ld8 gp = [r3] - - /* Restore all integer regs from GC context */ - add r2 = (16 + 16), sp ;; - add r3 = 8, r2 ;; - LOAD4(r8,r9,r10,r11) ;; - LOAD8(r16,r17,r18,r19,r20,r21,r22,r23) ;; - LOAD8(r24,r25,r26,r27,r28,r29,r30,r31) ;; - LOAD8(r32,r33,r34,r35,r36,r37,r38,r39) ;; - LOAD8(r40,r41,r42,r43,r44,r45,r46,r47) ;; - LOAD8(r48,r49,r50,r51,r52,r53,r54,r55) ;; - LOAD8(r56,r57,r58,r59,r60,r61,r62,r63) ;; - LOAD8(r64,r65,r66,r67,r68,r69,r70,r71) ;; - LOAD8(r72,r73,r74,r75,r76,r77,r78,r79) ;; - LOAD8(r80,r81,r82,r83,r84,r85,r86,r87) ;; - LOAD4(r88,r89,r90,r91) ;; - - /* Restore all floating-point registers not preserved by C */ - FLOAD2(f6,f7) ;; - FLOAD8(f8,f9,f10,f11,f12,f13,f14,f15) ;; - FLOAD8(f32,f33,f34,f35,f36,f37,f38,f39) ;; - FLOAD8(f40,f41,f42,f43,f44,f45,f46,f47) ;; - FLOAD8(f48,f49,f50,f51,f52,f53,f54,f55) ;; - FLOAD8(f56,f57,f58,f59,f60,f61,f62,f63) ;; - - /* Reload new allocation pointer and allocation limit */ - LOADGLOBAL(r4, caml_young_ptr#) - LOADGLOBAL(r5, caml_young_limit#) - - /* Allocate space for the block */ - add r3 = 16, sp ;; - ld8 r2 = [r3] ;; - sub r4 = r4, r2 ;; - cmp.ltu p6, p0 = r4, r5 /* enough space? */ - (p6) br.cond.spnt .L100 ;; /* no: call GC again */ - - /* Reload return address and say that we are back into Caml code */ - ADDRGLOBAL(r3, caml_last_return_address#) ;; - ld8 r2 = [r3] - st8 [r3] = r0 ;; - - /* Return to caller */ - mov b0 = r2 - add sp = (16 + 16 + 80*8 + 42*8), sp ;; - br.ret.sptk b0 - - .endp caml_call_gc# - -/* Call a C function from Caml */ -/* Function to call is in r2 */ - - .global caml_c_call# - .proc caml_c_call# - .align 16 - -caml_c_call: - /* The Caml code that called us does not expect any - code-generator registers to be preserved */ - - /* Recover entry point from the function pointer in r2 */ - LD8OFF(r3, r2, 8) ;; - mov b6 = r3 - - /* Preserve gp in r7 */ - mov r7 = gp - - /* Record lowest stack address and return address */ - mov r14 = b0 - STOREGLOBAL(sp, caml_bottom_of_stack#) ;; - STOREGLOBAL(r14, caml_last_return_address#) - - /* Make the exception handler and alloc ptr available to the C code */ - STOREGLOBAL(r4, caml_young_ptr#) - STOREGLOBAL(r6, caml_exception_pointer#) - - /* Recover gp from the function pointer in r2 */ - ld8 gp = [r2] - - /* Call the function */ - br.call.sptk b0 = b6 ;; - - /* Restore gp */ - mov gp = r7 ;; - - /* Reload alloc ptr and alloc limit */ - LOADGLOBAL(r4, caml_young_ptr#) - LOADGLOBAL(r5, caml_young_limit#) - - /* Reload return address and say that we are back into Caml code */ - ADDRGLOBAL(r3, caml_last_return_address#) ;; - ld8 r2 = [r3] - st8 [r3] = r0 ;; - - /* Return to caller */ - mov b0 = r2 ;; - br.ret.sptk b0 - - .endp caml_c_call# - -/* Start the Caml program */ - - .global caml_start_program# - .proc caml_start_program# - .align 16 - -caml_start_program: - ADDRGLOBAL(r2, caml_program#) ;; - mov b6 = r2 - - /* Code shared with caml_callback* */ -.L103: - /* Allocate 64 "out" registers (for the Caml code) and no locals */ - alloc r3 = ar.pfs, 0, 0, 64, 0 - add sp = -(56 * 8), sp ;; - - /* Save all callee-save registers on stack */ - add r2 = 16, sp ;; - ST8OFF(r2, r3, 8) /* 0 : ar.pfs */ - mov r3 = b0 ;; - ST8OFF(r2, r3, 8) ;; /* 1 : return address */ - ST8OFF(r2, gp, 8) /* 2 : gp */ - mov r3 = pr ;; - ST8OFF(r2, r3, 8) /* 3 : predicates */ - mov r3 = ar.fpsr ;; - ST8OFF(r2, r3, 8) /* 4 : ar.fpsr */ - mov r3 = ar.unat ;; - ST8OFF(r2, r3, 8) /* 5 : ar.unat */ - mov r3 = ar.lc ;; - ST8OFF(r2, r3, 8) /* 6 : ar.lc */ - mov r3 = b1 ;; - ST8OFF(r2, r3, 8) /* 7 - 11 : b1 - b5 */ - mov r3 = b2 ;; - ST8OFF(r2, r3, 8) - mov r3 = b3 ;; - ST8OFF(r2, r3, 8) - mov r3 = b4 ;; - ST8OFF(r2, r3, 8) - mov r3 = b5 ;; - ST8OFF(r2, r3, 8) ;; - - add r3 = 8, r2 ;; - SAVE4(r4,r5,r6,r7) ;; /* 12 - 15 : r4 - r7 */ - - add r3 = 16, r2 ;; /* 16 - 55 : f2 - f5, f16 - f31 */ - FSPILL4(f2,f3,f4,f5) ;; - FSPILL8(f16,f17,f18,f19,f20,f21,f22,f23) ;; - FSPILL8(f24,f25,f26,f27,f28,f29,f30,f31) ;; - - /* Set up a callback link on the stack. In addition to - the normal callback link contents (saved values of - caml_bottom_of_stack, caml_last_return_address and - caml_gc_regs), we also save there caml_saved_bsp - and caml_saved_rnat */ - add sp = -48, sp - LOADGLOBAL(r3, caml_bottom_of_stack#) - add r2 = 16, sp ;; - ST8OFF(r2, r3, 8) - LOADGLOBAL(r3, caml_last_return_address#) ;; - ST8OFF(r2, r3, 8) - LOADGLOBAL(r3, caml_gc_regs#) ;; - ST8OFF(r2, r3, 8) - LOADGLOBAL(r3, caml_saved_bsp#) ;; - ST8OFF(r2, r3, 8) - LOADGLOBAL(r3, caml_saved_rnat#) ;; - ST8OFF(r2, r3, 8) - - /* Set up a trap frame to catch exceptions escaping the Caml code */ - mov r6 = sp - add sp = -16, sp ;; - LOADGLOBAL(r3, caml_exception_pointer#) - add r2 = 16, sp ;; - ST8OFF(r2, r3, 8) -.L110: mov r3 = ip ;; - add r3 = .L101 - .L110, r3 ;; - ST8OFF(r2, r3, 8) ;; - - /* Save ar.bsp, flush register window, and save ar.rnat */ - mov r2 = ar.bsp ;; - STOREGLOBAL(r2, caml_saved_bsp#) ;; - mov r14 = ar.rsc ;; - and r2 = ~0x3, r14;; /* set rsc.mode = 0 */ - mov ar.rsc = r2 ;; /* RSE is in enforced lazy mode */ - flushrs ;; /* must be first instr in group */ - mov r2 = ar.rnat ;; - STOREGLOBAL(r2, caml_saved_rnat#) - mov ar.rsc = r14 /* restore original RSE mode */ - - /* Reload allocation pointers */ - LOADGLOBAL(r4, caml_young_ptr#) - LOADGLOBAL(r5, caml_young_limit#) - - /* We are back into Caml code */ - STOREGLOBAL(r0, caml_last_return_address#) - - /* Call the Caml code */ - br.call.sptk b0 = b6 ;; -.L102: - - /* Pop the trap frame, restoring caml_exception_pointer */ - add sp = 16, sp ;; - ld8 r2 = [sp] ;; - STOREGLOBAL(r2, caml_exception_pointer#) - -.L104: - /* Pop the callback link, restoring the global variables */ - add r14 = 16, sp ;; - LD8OFF(r2, r14, 8) ;; - STOREGLOBAL(r2, caml_bottom_of_stack#) - LD8OFF(r2, r14, 8) ;; - STOREGLOBAL(r2, caml_last_return_address#) - LD8OFF(r2, r14, 8) ;; - STOREGLOBAL(r2, caml_gc_regs#) - LD8OFF(r2, r14, 8) ;; - STOREGLOBAL(r2, caml_saved_bsp#) - LD8OFF(r2, r14, 8) ;; - STOREGLOBAL(r2, caml_saved_rnat#) - add sp = 48, sp - - /* Update allocation pointer */ - STOREGLOBAL(r4, caml_young_ptr#) - - /* Restore all callee-save registers from stack */ - add r2 = 16, sp ;; - LD8OFF(r3, r2, 8) ;; /* 0 : ar.pfs */ - mov ar.pfs = r3 - LD8OFF(r3, r2, 8) ;; /* 1 : return address */ - mov b0 = r3 - LD8OFF(gp, r2, 8) ;; /* 2 : gp */ - LD8OFF(r3, r2, 8) ;; /* 3 : predicates */ - mov pr = r3, -1 - LD8OFF(r3, r2, 8) ;; /* 4 : ar.fpsr */ - mov ar.fpsr = r3 - LD8OFF(r3, r2, 8) ;; /* 5 : ar.unat */ - mov ar.unat = r3 - LD8OFF(r3, r2, 8) ;; /* 6 : ar.lc */ - mov ar.lc = r3 - LD8OFF(r3, r2, 8) ;; /* 7 - 11 : b1 - b5 */ - mov b1 = r3 - LD8OFF(r3, r2, 8) ;; - mov b2 = r3 - LD8OFF(r3, r2, 8) ;; - mov b3 = r3 - LD8OFF(r3, r2, 8) ;; - mov b4 = r3 - LD8OFF(r3, r2, 8) ;; - mov b5 = r3 - - add r3 = 8, r2 ;; - LOAD4(r4,r5,r6,r7) ;; /* 12 - 15 : r4 - r7 */ - - add r3 = 16, r2 ;; /* 16 - 55 : f2 - f5, f16 - f31 */ - FFILL4(f2,f3,f4,f5) ;; - FFILL8(f16,f17,f18,f19,f20,f21,f22,f23) ;; - FFILL8(f24,f25,f26,f27,f28,f29,f30,f31) ;; - - /* Pop stack frame and return */ - add sp = (56 * 8), sp - br.ret.sptk.many b0 ;; - - /* The trap handler */ -.L101: - /* Save exception pointer */ - STOREGLOBAL(r6, caml_exception_pointer#) - - /* Encode exception bucket as exception result */ - or r8 = 2, r8 - - /* Return it */ - br.sptk .L104 ;; - - .endp caml_start_program# - -/* Raise an exception from C */ - - .global caml_raise_exception# - .proc caml_raise_exception# - .align 16 -caml_raise_exception: - /* Allocate 64 "out" registers (for the Caml code) and no locals */ - /* Since we don't return, don't bother saving the PFS */ - alloc r2 = ar.pfs, 0, 0, 64, 0 - - /* Move exn bucket where Caml expects it */ - mov r8 = r32 ;; - - /* Perform "context switch" as per the Software Conventions Guide, - chapter 10 */ - flushrs ;; /* flush dirty registers to stack */ - mov r14 = ar.rsc ;; - and r2 = ~0x3, r14;; /* set rsc.mode = 0 */ - dep r2 = r0, r2, 16, 4 ;; /* clear rsc.loadrs */ - mov ar.rsc = r2 ;; /* RSE is in enforced lazy mode */ - invala ;; /* Invalidate ALAT */ - LOADGLOBAL(r2, caml_saved_bsp#) ;; - mov ar.bspstore = r2 /* Restore ar.bspstore */ - LOADGLOBAL(r2, caml_saved_rnat#) ;; - mov ar.rnat = r2 /* Restore ar.rnat */ - mov ar.rsc = r14 ;; /* Restore original RSE mode */ - - /* Reload allocation pointers and exception pointer */ - LOADGLOBAL(r4, caml_young_ptr#) - LOADGLOBAL(r5, caml_young_limit#) - LOADGLOBAL(r6, caml_exception_pointer#) - - /* Say that we're back into Caml */ - STOREGLOBAL(r0, caml_last_return_address#) - - /* Raise the exception proper */ - mov sp = r6 - add r2 = 8, r6 ;; - ld8 r6 = [r6] - ld8 r2 = [r2] ;; - mov b6 = r2 ;; - - /* Branch to handler. Must use a call so as to set up the - CFM and PFS correctly. */ - br.call.sptk.many b0 = b6 - - .endp caml_raise_exception - -/* Callbacks from C to Caml */ - - .global caml_callback_exn# - .proc caml_callback_exn# - .align 16 -caml_callback_exn: - /* Initial shuffling of arguments */ - ld8 r3 = [r32] /* code pointer */ - mov r2 = r32 - mov r32 = r33 ;; /* first arg */ - mov r33 = r2 /* environment */ - mov b6 = r3 - br.sptk .L103 ;; - - .endp caml_callback_exn# - - .global caml_callback2_exn# - .proc caml_callback2_exn# - .align 16 -caml_callback2_exn: - /* Initial shuffling of arguments */ - ADDRGLOBAL(r3, caml_apply2) /* code pointer */ - mov r2 = r32 - mov r32 = r33 /* first arg */ - mov r33 = r34 ;; /* second arg */ - mov r34 = r2 /* environment */ - mov b6 = r3 - br.sptk .L103 ;; - - .endp caml_callback2_exn# - - .global caml_callback3_exn# - .proc caml_callback3_exn# - .align 16 -caml_callback3_exn: - /* Initial shuffling of arguments */ - ADDRGLOBAL(r3, caml_apply3) /* code pointer */ - mov r2 = r32 - mov r32 = r33 /* first arg */ - mov r33 = r34 /* second arg */ - mov r34 = r35 ;; /* third arg */ - mov r35 = r2 /* environment */ - mov b6 = r3 - br.sptk .L103 ;; - - .endp caml_callback3_exn# - -/* Glue code to call [caml_array_bound_error] */ - - .global caml_ml_array_bound_error# - .proc caml_ml_array_bound_error# - .align 16 -caml_ml_array_bound_error: - ADDRGLOBAL(r2, @fptr(caml_array_bound_error#)) - br.sptk caml_c_call /* never returns */ - - .rodata - - .global caml_system__frametable# - .type caml_system__frametable#, @object - .size caml_system__frametable#, 8 -caml_system__frametable: - data8 1 /* one descriptor */ - data8 .L102 /* return address into callback */ - data2 -1 /* negative frame size => use callback link */ - data2 0 /* no roots here */ - .align 8 - -/* Global variables used by caml_raise_exception */ - - .common caml_saved_bsp#, 8, 8 - .common caml_saved_rnat#, 8, 8 diff --git a/asmrun/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/power-elf.S b/asmrun/power-elf.S index 34ef6cc21f..8935335b80 100644 --- a/asmrun/power-elf.S +++ b/asmrun/power-elf.S @@ -27,13 +27,16 @@ /* Invoke the garbage collector. */ + .globl caml_system__code_begin +caml_system__code_begin: + .globl caml_call_gc .type caml_call_gc, @function caml_call_gc: /* Set up stack frame */ stwu 1, -0x1A0(1) /* 0x1A0 = 4*32 (int regs) + 8*32 (float regs) + 32 (space for C call) */ - /* Record return address into Caml code */ + /* Record return address into OCaml code */ mflr 0 Storeglobal(0, caml_last_return_address, 11) /* Record lowest stack address */ @@ -169,7 +172,7 @@ caml_call_gc: Loadglobal(0, caml_last_return_address, 11) addic 0, 0, -16 /* Restart the allocation (4 instructions) */ mtlr 0 - /* Say we are back into Caml code */ + /* Say we are back into OCaml code */ li 12, 0 Storeglobal(12, caml_last_return_address, 11) /* Deallocate stack frame */ @@ -177,7 +180,7 @@ caml_call_gc: /* Return */ blr -/* Call a C function from Caml */ +/* Call a C function from OCaml */ .globl caml_c_call .type caml_c_call, @function @@ -185,21 +188,21 @@ caml_c_call: /* Save return address */ mflr 25 /* Get ready to call C function (address in 11) */ - mtlr 11 + mtctr 11 /* Record lowest stack address and return address */ Storeglobal(1, caml_bottom_of_stack, 12) Storeglobal(25, caml_last_return_address, 12) /* Make the exception handler and alloc ptr available to the C code */ Storeglobal(31, caml_young_ptr, 11) Storeglobal(29, caml_exception_pointer, 11) - /* Call the function (address in link register) */ - blrl + /* Call the function (address in CTR register) */ + bctrl /* Restore return address (in 25, preserved by the C function) */ mtlr 25 /* Reload allocation pointer and allocation limit*/ Loadglobal(31, caml_young_ptr, 11) Loadglobal(30, caml_young_limit, 11) - /* Say we are back into Caml code */ + /* Say we are back into OCaml code */ li 12, 0 Storeglobal(12, caml_last_return_address, 11) /* Return to caller */ @@ -210,11 +213,11 @@ caml_c_call: .globl caml_raise_exception .type caml_raise_exception, @function caml_raise_exception: - /* Reload Caml global registers */ + /* Reload OCaml global registers */ Loadglobal(1, caml_exception_pointer, 11) Loadglobal(31, caml_young_ptr, 11) Loadglobal(30, caml_young_limit, 11) - /* Say we are back into Caml code */ + /* Say we are back into OCaml code */ li 0, 0 Storeglobal(0, caml_last_return_address, 11) /* Pop trap frame */ @@ -225,7 +228,7 @@ caml_raise_exception: /* Branch to handler */ blr -/* Start the Caml program */ +/* Start the OCaml program */ .globl caml_start_program .type caml_start_program, @function @@ -287,7 +290,7 @@ caml_start_program: stw 9, 0(1) stw 10, 4(1) stw 11, 8(1) - /* Build an exception handler to catch exceptions escaping out of Caml */ + /* Build an exception handler to catch exceptions escaping out of OCaml */ bl .L103 b .L104 .L103: @@ -300,10 +303,10 @@ caml_start_program: /* Reload allocation pointers */ Loadglobal(31, caml_young_ptr, 11) Loadglobal(30, caml_young_limit, 11) - /* Say we are back into Caml code */ + /* Say we are back into OCaml code */ li 0, 0 Storeglobal(0, caml_last_return_address, 11) - /* Call the Caml code */ + /* Call the OCaml code */ mtlr 12 .L105: blrl @@ -375,7 +378,7 @@ caml_start_program: ori 3, 3, 2 b .L106 -/* Callback from C to Caml */ +/* Callback from C to OCaml */ .globl caml_callback_exn .type caml_callback_exn, @function @@ -408,6 +411,9 @@ caml_callback3_exn: Addrglobal(12, caml_apply3) b .L102 + .globl caml_system__code_end +caml_system__code_end: + /* Frame table */ .section ".data" diff --git a/asmrun/power-rhapsody.S b/asmrun/power-rhapsody.S index ab7f5384cd..3bf3e19fea 100644 --- a/asmrun/power-rhapsody.S +++ b/asmrun/power-rhapsody.S @@ -41,6 +41,9 @@ .text + .globl _caml_system__code_begin +_caml_system__code_begin: + /* Invoke the garbage collector. */ .globl _caml_call_gc @@ -48,12 +51,17 @@ _caml_call_gc: /* Set up stack frame */ #define FRAMESIZE (32*WORD + 32*8 + 32) stwu r1, -FRAMESIZE(r1) - /* Record return address into Caml code */ + /* Record return address into OCaml code */ mflr r0 Storeglobal r0, _caml_last_return_address, r11 /* Record lowest stack address */ addi r0, r1, FRAMESIZE Storeglobal r0, _caml_bottom_of_stack, r11 + /* Touch the stack to trigger a recoverable segfault + if insufficient space remains */ + addi r1, r1, -4096*WORD + stg r0, 0(r1) + addi r1, r1, 4096*WORD /* Record pointer to register array */ addi r0, r1, 8*32 + 32 Storeglobal r0, _caml_gc_regs, r11 @@ -184,7 +192,7 @@ _caml_call_gc: Loadglobal r0, _caml_last_return_address, r11 addic r0, r0, -16 /* Restart the allocation (4 instructions) */ mtlr r0 - /* Say we are back into Caml code */ + /* Say we are back into OCaml code */ li r12, 0 Storeglobal r12, _caml_last_return_address, r11 /* Deallocate stack frame */ @@ -193,7 +201,7 @@ _caml_call_gc: blr #undef FRAMESIZE -/* Call a C function from Caml */ +/* Call a C function from OCaml */ .globl _caml_c_call _caml_c_call: @@ -204,6 +212,11 @@ _caml_c_call: /* Record lowest stack address and return address */ Storeglobal r1, _caml_bottom_of_stack, r12 Storeglobal r25, _caml_last_return_address, r12 + /* Touch the stack to trigger a recoverable segfault + if insufficient space remains */ + addi r1, r1, -4096*WORD + stg r0, 0(r1) + addi r1, r1, 4096*WORD /* Make the exception handler and alloc ptr available to the C code */ Storeglobal r31, _caml_young_ptr, r11 Storeglobal r29, _caml_exception_pointer, r11 @@ -214,13 +227,13 @@ _caml_c_call: /* Reload allocation pointer and allocation limit*/ Loadglobal r31, _caml_young_ptr, r11 Loadglobal r30, _caml_young_limit, r11 - /* Say we are back into Caml code */ + /* Say we are back into OCaml code */ li r12, 0 Storeglobal r12, _caml_last_return_address, r11 /* Return to caller */ blr -/* Raise an exception from Caml */ +/* Raise an exception from OCaml */ .globl _caml_raise_exn _caml_raise_exn: addis r11, 0, ha16(_caml_backtrace_active) @@ -257,11 +270,11 @@ _caml_raise_exception: cmpwi r11, 0 bne L112 L113: - /* Reload Caml global registers */ + /* Reload OCaml global registers */ Loadglobal r1, _caml_exception_pointer, r11 Loadglobal r31, _caml_young_ptr, r11 Loadglobal r30, _caml_young_limit, r11 - /* Say we are back into Caml code */ + /* Say we are back into OCaml code */ li r0, 0 Storeglobal r0, _caml_last_return_address, r11 /* Pop trap frame */ @@ -274,15 +287,15 @@ L113: L112: mr r28, r3 /* preserve exn bucket in callee-save */ /* arg 1: exception bucket (already in r3) */ - Loadglobal r4, _caml_last_return_address, r11 /* arg 2: PC of raise */ - Loadglobal r5, _caml_bottom_of_stack, r11 /* arg 3: SP of raise */ + Loadglobal r4, _caml_last_return_address, r11 /* arg 2: PC of raise */ + Loadglobal r5, _caml_bottom_of_stack, r11 /* arg 3: SP of raise */ Loadglobal r6, _caml_exception_pointer, r11 /* arg 4: SP of handler */ addi r1, r1, -(16*WORD) /* reserve stack space for C call */ bl _caml_stash_backtrace mr r3, r28 b L113 -/* Start the Caml program */ +/* Start the OCaml program */ .globl _caml_start_program _caml_start_program: @@ -343,7 +356,7 @@ L102: stg r9, 0(r1) stg r10, WORD(r1) stg r11, 2*WORD(r1) - /* Build an exception handler to catch exceptions escaping out of Caml */ + /* Build an exception handler to catch exceptions escaping out of OCaml */ bl L103 b L104 L103: @@ -356,10 +369,10 @@ L103: /* Reload allocation pointers */ Loadglobal r31, _caml_young_ptr, r11 Loadglobal r30, _caml_young_limit, r11 - /* Say we are back into Caml code */ + /* Say we are back into OCaml code */ li r0, 0 Storeglobal r0, _caml_last_return_address, r11 - /* Call the Caml code */ + /* Call the OCaml code */ mtctr r12 L105: bctrl @@ -432,7 +445,7 @@ L104: b L106 #undef FRAMESIZE -/* Callback from C to Caml */ +/* Callback from C to OCaml */ .globl _caml_callback_exn _caml_callback_exn: @@ -462,6 +475,9 @@ _caml_callback3_exn: Addrglobal r12, _caml_apply3 b L102 + .globl _caml_system__code_end +_caml_system__code_end: + /* Frame table */ .const @@ -471,4 +487,4 @@ _caml_system__frametable: gdata L105 + 4 /* return address into callback */ .short -1 /* negative size count => use callback link */ .short 0 /* no roots here */ - .align X(2,3) + .align X(2,3) diff --git a/asmrun/roots.c b/asmrun/roots.c index 4a495e2c14..b46df1dbc0 100644 --- a/asmrun/roots.c +++ b/asmrun/roots.c @@ -129,7 +129,7 @@ void caml_init_frame_descriptors(void) char * caml_top_of_stack; char * caml_bottom_of_stack = NULL; /* no stack initially */ -uintnat caml_last_return_address = 1; /* not in Caml code initially */ +uintnat caml_last_return_address = 1; /* not in OCaml code initially */ value * caml_gc_regs; intnat caml_globals_inited = 0; static intnat caml_globals_scanned = 0; @@ -369,5 +369,3 @@ uintnat caml_stack_usage (void) sz += (*caml_stack_usage_hook)(); return sz; } - - diff --git a/asmrun/signals_asm.c b/asmrun/signals_asm.c index 556bd945b5..9d42718b8f 100644 --- a/asmrun/signals_asm.c +++ b/asmrun/signals_asm.c @@ -46,14 +46,17 @@ extern void caml_win32_overflow_detection(); #endif extern char * caml_code_area_start, * caml_code_area_end; +extern char caml_system__code_begin, caml_system__code_end; #define Is_in_code_area(pc) \ ( ((char *)(pc) >= caml_code_area_start && \ (char *)(pc) <= caml_code_area_end) \ - || (Classify_addr(pc) & In_code_area) ) +|| ((char *)(pc) >= &caml_system__code_begin && \ + (char *)(pc) <= &caml_system__code_end) \ +|| (Classify_addr(pc) & In_code_area) ) /* This routine is the common entry point for garbage collection - and signal handling. It can trigger a callback to Caml code. + and signal handling. It can trigger a callback to OCaml code. With system threads, this callback can cause a context switch. Hence [caml_garbage_collection] must not be called from regular C code (e.g. the [caml_alloc] function) because the context of the call @@ -83,7 +86,7 @@ DECLARE_SIGNAL_HANDLER(handle_signal) caml_record_signal(sig); /* Some ports cache [caml_young_limit] in a register. Use the signal context to modify that register too, but only if - we are inside Caml code (not inside C code). */ + we are inside OCaml code (not inside C code). */ #if defined(CONTEXT_PC) && defined(CONTEXT_YOUNG_LIMIT) if (Is_in_code_area(CONTEXT_PC)) CONTEXT_YOUNG_LIMIT = (context_reg) caml_young_limit; @@ -193,7 +196,7 @@ DECLARE_SIGNAL_HANDLER(segv_handler) /* Sanity checks: - faulting address is word-aligned - faulting address is within the stack - - we are in Caml code */ + - we are in OCaml code */ fault_addr = CONTEXT_FAULTING_ADDRESS; if (((uintnat) fault_addr & (sizeof(intnat) - 1)) == 0 && getrlimit(RLIMIT_STACK, &limit) == 0 diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h index cacebd1a26..830c43b386 100644 --- a/asmrun/signals_osdep.h +++ b/asmrun/signals_osdep.h @@ -61,7 +61,7 @@ /****************** ARM, Linux */ -#elif defined(TARGET_arm) && defined (SYS_linux) +#elif defined(TARGET_arm) && (defined(SYS_linux_eabi) || defined(SYS_linux_eabihf)) #include <sys/ucontext.h> diff --git a/asmrun/sparc.S b/asmrun/sparc.S index dd1e5844ac..907ebc01e3 100644 --- a/asmrun/sparc.S +++ b/asmrun/sparc.S @@ -16,60 +16,6 @@ /* Asm part of the runtime system for the Sparc processor. */ /* Must be preprocessed by cpp */ -/* SunOS 4 prefixes identifiers with _ */ - -#if defined(SYS_sunos) - -#define Caml_young_limit _caml_young_limit -#define Caml_young_ptr _caml_young_ptr -#define Caml_bottom_of_stack _caml_bottom_of_stack -#define Caml_last_return_address _caml_last_return_address -#define Caml_gc_regs _caml_gc_regs -#define Caml_exception_pointer _caml_exception_pointer -#define Caml_allocN _caml_allocN -#define Caml_call_gc _caml_call_gc -#define Caml_garbage_collection _caml_garbage_collection -#define Caml_c_call _caml_c_call -#define Caml_start_program _caml_start_program -#define Caml_program _caml_program -#define Caml_raise_exception _caml_raise_exception -#define Caml_callback_exn _caml_callback_exn -#define Caml_callback2_exn _caml_callback2_exn -#define Caml_callback3_exn _caml_callback3_exn -#define Caml_apply2 _caml_apply2 -#define Caml_apply3 _caml_apply3 -#define Caml_raise _caml_raise -#define Caml_system__frametable _caml_system__frametable -#define Caml_ml_array_bound_error _caml_ml_array_bound_error -#define Caml_array_bound_error _caml_array_bound_error - -#else - -#define Caml_young_limit caml_young_limit -#define Caml_young_ptr caml_young_ptr -#define Caml_bottom_of_stack caml_bottom_of_stack -#define Caml_last_return_address caml_last_return_address -#define Caml_gc_regs caml_gc_regs -#define Caml_exception_pointer caml_exception_pointer -#define Caml_allocN caml_allocN -#define Caml_call_gc caml_call_gc -#define Caml_garbage_collection caml_garbage_collection -#define Caml_c_call caml_c_call -#define Caml_start_program caml_start_program -#define Caml_program caml_program -#define Caml_raise_exception caml_raise_exception -#define Caml_callback_exn caml_callback_exn -#define Caml_callback2_exn caml_callback2_exn -#define Caml_callback3_exn caml_callback3_exn -#define Caml_apply2 caml_apply2 -#define Caml_apply3 caml_apply3 -#define Caml_raise caml_raise -#define Caml_system__frametable caml_system__frametable -#define Caml_ml_array_bound_error caml_ml_array_bound_error -#define Caml_array_bound_error caml_array_bound_error - -#endif - #ifndef SYS_solaris #define INDIRECT_LIMIT #endif @@ -85,11 +31,15 @@ /* Allocation functions */ .text - .global Caml_allocN - .global Caml_call_gc + + .global caml_system__code_begin +caml_system__code_begin: + + .global caml_allocN + .global caml_call_gc /* Required size in %g2 */ -Caml_allocN: +caml_allocN: #ifdef INDIRECT_LIMIT ld [Alloc_limit], %g1 sub Alloc_ptr, %g2, Alloc_ptr @@ -98,22 +48,22 @@ Caml_allocN: sub Alloc_ptr, %g2, Alloc_ptr cmp Alloc_ptr, Alloc_limit #endif - /*blu,pt %icc, Caml_call_gc*/ - blu Caml_call_gc + /*blu,pt %icc, caml_call_gc*/ + blu caml_call_gc nop retl nop /* Required size in %g2 */ -Caml_call_gc: +caml_call_gc: /* Save exception pointer if GC raises */ - Store(Exn_ptr, Caml_exception_pointer) + Store(Exn_ptr, caml_exception_pointer) /* Save current allocation pointer for debugging purposes */ - Store(Alloc_ptr, Caml_young_ptr) + Store(Alloc_ptr, caml_young_ptr) /* Record lowest stack address */ - Store(%sp, Caml_bottom_of_stack) + Store(%sp, caml_bottom_of_stack) /* Record last return address */ - Store(%o7, Caml_last_return_address) + Store(%o7, caml_last_return_address) /* Allocate space on stack for caml_context structure and float regs */ sub %sp, 20*4 + 15*8, %sp /* Save int regs on stack and save it into caml_gc_regs */ @@ -139,7 +89,7 @@ L100: add %sp, 96 + 15*8, %g1 st %g4, [%g1 + 0x48] st %g2, [%g1 + 0x4C] /* Save required size */ mov %g1, %g2 - Store(%g2, Caml_gc_regs) + Store(%g2, caml_gc_regs) /* Save the floating-point registers */ add %sp, 96, %g1 std %f0, [%g1] @@ -158,7 +108,7 @@ L100: add %sp, 96 + 15*8, %g1 std %f26, [%g1 + 0x68] std %f28, [%g1 + 0x70] /* Call the garbage collector */ - call Caml_garbage_collection + call caml_garbage_collection nop /* Restore all regs used by the code generator */ add %sp, 96 + 15*8, %g1 @@ -199,116 +149,116 @@ L100: add %sp, 96 + 15*8, %g1 ldd [%g1 + 0x68], %f26 ldd [%g1 + 0x70], %f28 /* Reload alloc ptr */ - Load(Caml_young_ptr, Alloc_ptr) + Load(caml_young_ptr, Alloc_ptr) /* Allocate space for block */ #ifdef INDIRECT_LIMIT ld [Alloc_limit], %g1 sub Alloc_ptr, %g2, Alloc_ptr cmp Alloc_ptr, %g1 /* Check that we have enough free space */ #else - Load(Caml_young_limit,Alloc_limit) + Load(caml_young_limit,Alloc_limit) sub Alloc_ptr, %g2, Alloc_ptr cmp Alloc_ptr, Alloc_limit #endif blu L100 /* If not, call GC again */ nop /* Return to caller */ - Load(Caml_last_return_address, %o7) + Load(caml_last_return_address, %o7) retl add %sp, 20*4 + 15*8, %sp /* in delay slot */ -/* Call a C function from Caml */ +/* Call a C function from Ocaml */ - .global Caml_c_call + .global caml_c_call /* Function to call is in %g2 */ -Caml_c_call: +caml_c_call: /* Record lowest stack address and return address */ - Store(%sp, Caml_bottom_of_stack) - Store(%o7, Caml_last_return_address) + Store(%sp, caml_bottom_of_stack) + Store(%o7, caml_last_return_address) /* Save the exception handler and alloc pointer */ - Store(Exn_ptr, Caml_exception_pointer) - sethi %hi(Caml_young_ptr), %g1 + Store(Exn_ptr, caml_exception_pointer) + sethi %hi(caml_young_ptr), %g1 /* Call the C function */ call %g2 - st Alloc_ptr, [%g1 + %lo(Caml_young_ptr)] /* in delay slot */ + st Alloc_ptr, [%g1 + %lo(caml_young_ptr)] /* in delay slot */ /* Reload return address */ - Load(Caml_last_return_address, %o7) + Load(caml_last_return_address, %o7) /* Reload alloc pointer */ - sethi %hi(Caml_young_ptr), %g1 + sethi %hi(caml_young_ptr), %g1 /* Return to caller */ retl - ld [%g1 + %lo(Caml_young_ptr)], Alloc_ptr /* in delay slot */ + ld [%g1 + %lo(caml_young_ptr)], Alloc_ptr /* in delay slot */ -/* Start the Caml program */ +/* Start the Ocaml program */ - .global Caml_start_program -Caml_start_program: + .global caml_start_program +caml_start_program: /* Save all callee-save registers */ save %sp, -96, %sp /* Address of code to call */ - Address(Caml_program, %l2) + Address(caml_program, %l2) /* Code shared with caml_callback* */ L108: /* Set up a callback link on the stack. */ sub %sp, 16, %sp - Load(Caml_bottom_of_stack, %l0) - Load(Caml_last_return_address, %l1) - Load(Caml_gc_regs, %l3) + Load(caml_bottom_of_stack, %l0) + Load(caml_last_return_address, %l1) + Load(caml_gc_regs, %l3) st %l0, [%sp + 96] st %l1, [%sp + 100] - /* Set up a trap frame to catch exceptions escaping the Caml code */ + /* Set up a trap frame to catch exceptions escaping the Ocaml code */ call L111 st %l3, [%sp + 104] b L110 nop L111: sub %sp, 8, %sp - Load(Caml_exception_pointer, Exn_ptr) + Load(caml_exception_pointer, Exn_ptr) st %o7, [%sp + 96] st Exn_ptr, [%sp + 100] mov %sp, Exn_ptr /* Reload allocation pointers */ - Load(Caml_young_ptr, Alloc_ptr) + Load(caml_young_ptr, Alloc_ptr) #ifdef INDIRECT_LIMIT - Address(Caml_young_limit, Alloc_limit) + Address(caml_young_limit, Alloc_limit) #else - Load(Caml_young_limit, Alloc_limit) + Load(caml_young_limit, Alloc_limit) #endif - /* Call the Caml code */ + /* Call the Ocaml code */ L109: call %l2 nop /* Pop trap frame and restore caml_exception_pointer */ ld [%sp + 100], Exn_ptr add %sp, 8, %sp - Store(Exn_ptr, Caml_exception_pointer) + Store(Exn_ptr, caml_exception_pointer) /* Pop callback link, restoring the global variables */ L112: ld [%sp + 96], %l0 ld [%sp + 100], %l1 ld [%sp + 104], %l2 - Store(%l0, Caml_bottom_of_stack) - Store(%l1, Caml_last_return_address) - Store(%l2, Caml_gc_regs) + Store(%l0, caml_bottom_of_stack) + Store(%l1, caml_last_return_address) + Store(%l2, caml_gc_regs) add %sp, 16, %sp /* Save allocation pointer */ - Store(Alloc_ptr, Caml_young_ptr) + Store(Alloc_ptr, caml_young_ptr) /* Reload callee-save registers and return */ ret restore %o0, 0, %o0 /* copy %o0 in this window to caller's %o0 */ L110: /* The trap handler */ - Store(Exn_ptr, Caml_exception_pointer) + Store(Exn_ptr, caml_exception_pointer) /* Encode exception bucket as an exception result */ b L112 or %o0, 2, %o0 /* Raise an exception from C */ - .global Caml_raise_exception -Caml_raise_exception: + .global caml_raise_exception +caml_raise_exception: /* Save exception bucket in a register outside the reg windows */ mov %o0, %g2 /* Load exception pointer in a register outside the reg windows */ - Load(Caml_exception_pointer, %g3) + Load(caml_exception_pointer, %g3) /* Pop some frames until the trap pointer is in the current frame. */ cmp %g3, %fp blt L107 /* if Exn_ptr < %fp, over */ @@ -319,11 +269,11 @@ L106: restore nop L107: /* Reload allocation registers */ - Load(Caml_young_ptr, Alloc_ptr) + Load(caml_young_ptr, Alloc_ptr) #ifdef INDIRECT_LIMIT - Address(Caml_young_limit, Alloc_limit) + Address(caml_young_limit, Alloc_limit) #else - Load(Caml_young_limit, Alloc_limit) + Load(caml_young_limit, Alloc_limit) #endif /* Branch to exception handler */ mov %g3, %sp @@ -336,8 +286,8 @@ L107: /* Callbacks C -> ML */ - .global Caml_callback_exn -Caml_callback_exn: + .global caml_callback_exn +caml_callback_exn: /* Save callee-save registers and return address */ save %sp, -96, %sp /* Initial shuffling of arguments */ @@ -347,8 +297,8 @@ Caml_callback_exn: b L108 ld [%g1], %l2 /* code pointer */ - .global Caml_callback2_exn -Caml_callback2_exn: + .global caml_callback2_exn +caml_callback2_exn: /* Save callee-save registers and return address */ save %sp, -104, %sp /* Initial shuffling of arguments */ @@ -356,12 +306,12 @@ Caml_callback2_exn: mov %i1, %i0 /* first arg */ mov %i2, %i1 /* second arg */ mov %g1, %i2 /* environment */ - sethi %hi(Caml_apply2), %l2 + sethi %hi(caml_apply2), %l2 b L108 - or %l2, %lo(Caml_apply2), %l2 + or %l2, %lo(caml_apply2), %l2 - .global Caml_callback3_exn -Caml_callback3_exn: + .global caml_callback3_exn +caml_callback3_exn: /* Save callee-save registers and return address */ save %sp, -104, %sp /* Initial shuffling of arguments */ @@ -370,38 +320,41 @@ Caml_callback3_exn: mov %i2, %i1 /* second arg */ mov %i3, %i2 /* third arg */ mov %g1, %i3 /* environment */ - sethi %hi(Caml_apply3), %l2 + sethi %hi(caml_apply3), %l2 b L108 - or %l2, %lo(Caml_apply3), %l2 + or %l2, %lo(caml_apply3), %l2 #ifndef SYS_solaris /* Glue code to call [caml_array_bound_error] */ - .global Caml_ml_array_bound_error -Caml_ml_array_bound_error: - Address(Caml_array_bound_error, %g2) - b Caml_c_call + .global caml_ml_array_bound_error +caml_ml_array_bound_error: + Address(caml_array_bound_error, %g2) + b caml_c_call nop #endif + .global caml_system__code_end +caml_system__code_end: + #ifdef SYS_solaris .section ".rodata" #else .data #endif - .global Caml_system__frametable + .global caml_system__frametable .align 4 /* required for gas? */ -Caml_system__frametable: +caml_system__frametable: .word 1 /* one descriptor */ .word L109 /* return address into callback */ .half -1 /* negative frame size => use callback link */ .half 0 /* no roots */ #ifdef SYS_solaris - .type Caml_allocN, #function - .type Caml_call_gc, #function - .type Caml_c_call, #function - .type Caml_start_program, #function - .type Caml_raise_exception, #function - .type Caml_system__frametable, #object + .type caml_allocN, #function + .type caml_call_gc, #function + .type caml_c_call, #function + .type caml_start_program, #function + .type caml_raise_exception, #function + .type caml_system__frametable, #object #endif diff --git a/asmrun/stack.h b/asmrun/stack.h index 2609d391c2..9b575cb70c 100644 --- a/asmrun/stack.h +++ b/asmrun/stack.h @@ -19,13 +19,6 @@ #define CAML_STACK_H /* Macros to access the stack frame */ -#ifdef TARGET_alpha -#define Saved_return_address(sp) *((intnat *)((sp) - 8)) -#define Already_scanned(sp, retaddr) ((retaddr) & 1L) -#define Mark_scanned(sp, retaddr) (*((intnat *)((sp) - 8)) = (retaddr) | 1L) -#define Mask_already_scanned(retaddr) ((retaddr) & ~1L) -#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) -#endif #ifdef TARGET_sparc #define Saved_return_address(sp) *((intnat *)((sp) + 92)) @@ -41,17 +34,6 @@ #endif #endif -#ifdef TARGET_mips -#define Saved_return_address(sp) *((intnat *)((sp) - 4)) -#define Callback_link(sp) ((struct caml_context *)((sp) + 16)) -#endif - -#ifdef TARGET_hppa -#define Stack_grows_upwards -#define Saved_return_address(sp) *((intnat *)(sp)) -#define Callback_link(sp) ((struct caml_context *)((sp) - 24)) -#endif - #ifdef TARGET_power #define Saved_return_address(sp) *((intnat *)((sp) - SIZEOF_PTR)) #define Already_scanned(sp, retaddr) ((retaddr) & 1) @@ -65,34 +47,21 @@ #define Callback_link(sp) ((struct caml_context *)((sp) + Trap_frame_size)) #endif -#ifdef TARGET_m68k -#define Saved_return_address(sp) *((intnat *)((sp) - 4)) -#define Callback_link(sp) ((struct caml_context *)((sp) + 8)) -#endif - #ifdef TARGET_arm #define Saved_return_address(sp) *((intnat *)((sp) - 4)) #define Callback_link(sp) ((struct caml_context *)((sp) + 8)) #endif -#ifdef TARGET_ia64 -#define Saved_return_address(sp) *((intnat *)((sp) + 8)) -#define Already_scanned(sp, retaddr) ((retaddr) & 1L) -#define Mark_scanned(sp, retaddr) (*((intnat *)((sp) + 8)) = (retaddr) | 1L) -#define Mask_already_scanned(retaddr) ((retaddr) & ~1L) -#define Callback_link(sp) ((struct caml_context *)((sp) + 32)) -#endif - #ifdef TARGET_amd64 #define Saved_return_address(sp) *((intnat *)((sp) - 8)) #define Callback_link(sp) ((struct caml_context *)((sp) + 16)) #endif -/* Structure of Caml callback contexts */ +/* Structure of OCaml callback contexts */ struct caml_context { - char * bottom_of_stack; /* beginning of Caml stack chunk */ - uintnat last_retaddr; /* last return address in Caml code */ + char * bottom_of_stack; /* beginning of OCaml stack chunk */ + uintnat last_retaddr; /* last return address in OCaml code */ value * gc_regs; /* pointer to register block */ }; diff --git a/asmrun/startup.c b/asmrun/startup.c index 0f8ed10f70..a04fa84fcb 100644 --- a/asmrun/startup.c +++ b/asmrun/startup.c @@ -20,10 +20,12 @@ #include "callback.h" #include "backtrace.h" #include "custom.h" +#include "debugger.h" #include "fail.h" #include "freelist.h" #include "gc.h" #include "gc_ctrl.h" +#include "intext.h" #include "memory.h" #include "misc.h" #include "mlvalues.h" @@ -48,6 +50,7 @@ static void init_atoms(void) { extern struct segment caml_data_segments[], caml_code_segments[]; int i; + struct code_fragment * cf; for (i = 0; i < 256; i++) { caml_atom_table[i] = Make_header(0, i, Caml_white); @@ -57,9 +60,11 @@ static void init_atoms(void) caml_fatal_error("Fatal error: not enough memory for the initial page table"); for (i = 0; caml_data_segments[i].begin != 0; i++) { + /* PR#5509: we must include the zero word at end of data segment, + because pointers equal to caml_data_segments[i].end are static data. */ if (caml_page_table_add(In_static_data, caml_data_segments[i].begin, - caml_data_segments[i].end) != 0) + caml_data_segments[i].end + sizeof(value)) != 0) caml_fatal_error("Fatal error: not enough memory for the initial page table"); } @@ -71,6 +76,13 @@ static void init_atoms(void) if (caml_code_segments[i].end > caml_code_area_end) caml_code_area_end = caml_code_segments[i].end; } + /* Register the code in the table of code fragments */ + cf = caml_stat_alloc(sizeof(struct code_fragment)); + cf->code_start = caml_code_area_start; + cf->code_end = caml_code_area_end; + cf->digest_computed = 0; + caml_ext_table_init(&caml_code_fragments_table, 8); + caml_ext_table_add(&caml_code_fragments_table, cf); } /* Configuration parameters and flags */ diff --git a/boot/.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/myocamlbuild.boot b/boot/myocamlbuild.boot Binary files differindex 0db6ddb845..cbb279dd10 100755 --- a/boot/myocamlbuild.boot +++ b/boot/myocamlbuild.boot diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex 5523d650ef..4e629c7da4 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex c49532f415..6d545b57db 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 9b34eda4bb..da09cbc051 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/build/partial-install.sh b/build/partial-install.sh index 1573fa94d5..81c0e116d7 100755 --- a/build/partial-install.sh +++ b/build/partial-install.sh @@ -131,26 +131,28 @@ installbin camlp4/camlp4orf.native$EXE $BINDIR/camlp4orf.opt$EXE installbin camlp4/camlp4r.native$EXE $BINDIR/camlp4r.opt$EXE installbin camlp4/camlp4rf.native$EXE $BINDIR/camlp4rf.opt$EXE -cd camlp4 -CAMLP4DIR=$LIBDIR/camlp4 -for dir in Camlp4Parsers Camlp4Printers Camlp4Filters Camlp4Top; do - echo "Installing $dir..." - mkdir -p $CAMLP4DIR/$dir - installdir \ - $dir/*.cm* \ - $dir/*.$O \ - $CAMLP4DIR/$dir -done -installdir \ - camlp4lib.cma camlp4lib.cmxa Camlp4.cmi \ - camlp4fulllib.cma camlp4fulllib.cmxa \ - camlp4o.cma camlp4of.cma camlp4oof.cma \ - camlp4orf.cma camlp4r.cma camlp4rf.cma \ - Camlp4Bin.cm[iox] Camlp4Bin.$O Camlp4Top.cm[io] \ - Camlp4_config.cmi camlp4prof.cm[iox] camlp4prof.$O Camlp4_import.cmi \ - $CAMLP4DIR -installlibdir camlp4lib.$A camlp4fulllib.$A $CAMLP4DIR -cd .. +if test -d camlp4; then + cd camlp4 + CAMLP4DIR=$LIBDIR/camlp4 + for dir in Camlp4Parsers Camlp4Printers Camlp4Filters Camlp4Top; do + echo "Installing $dir..." + mkdir -p $CAMLP4DIR/$dir + installdir \ + $dir/*.cm* \ + $dir/*.$O \ + $CAMLP4DIR/$dir + done + installdir \ + camlp4lib.cma camlp4lib.cmxa Camlp4.cmi \ + camlp4fulllib.cma camlp4fulllib.cmxa \ + camlp4o.cma camlp4of.cma camlp4oof.cma \ + camlp4orf.cma camlp4r.cma camlp4rf.cma \ + Camlp4Bin.cm[iox] Camlp4Bin.$O Camlp4Top.cm[io] \ + Camlp4_config.cmi camlp4prof.cm[iox] camlp4prof.$O Camlp4_import.cmi \ + $CAMLP4DIR + installlibdir camlp4lib.$A camlp4fulllib.$A $CAMLP4DIR + cd .. +fi echo "Installing ocamlbuild..." cd ocamlbuild diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 9773f0b7c9..105be62d12 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -524,6 +524,10 @@ let rec comp_expr env exp sz cont = comp_expr env arg sz cont | Lprim(Pignore, [arg]) -> comp_expr env arg sz (add_const_unit cont) + | Lprim(Pdirapply loc, [func;arg]) + | Lprim(Prevapply loc, [arg;func]) -> + let exp = Lapply(func, [arg], loc) in + comp_expr env exp sz cont | Lprim(Pnot, [arg]) -> let newcont = match cont with diff --git a/bytecomp/bytelibrarian.ml b/bytecomp/bytelibrarian.ml index 767a3dca68..21427c8440 100644 --- a/bytecomp/bytelibrarian.ml +++ b/bytecomp/bytelibrarian.ml @@ -63,8 +63,7 @@ let copy_object_file ppf oc name = raise(Error(File_not_found name)) in let ic = open_in_bin file_name in try - let buffer = String.create (String.length cmo_magic_number) in - really_input ic buffer 0 (String.length cmo_magic_number); + let buffer = input_bytes ic (String.length cmo_magic_number) in if buffer = cmo_magic_number then begin let compunit_pos = input_binary_int ic in seek_in ic compunit_pos; @@ -118,4 +117,5 @@ let report_error ppf = function | File_not_found name -> fprintf ppf "Cannot find file %s" name | Not_an_object_file name -> - fprintf ppf "The file %s is not a bytecode object file" name + fprintf ppf "The file %a is not a bytecode object file" + Location.print_filename name diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index aa4c3d45a4..4f93f0c2b5 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -116,8 +116,7 @@ let scan_file obj_name tolink = raise(Error(File_not_found obj_name)) in let ic = open_in_bin file_name in try - let buffer = String.create (String.length cmo_magic_number) in - really_input ic buffer 0 (String.length cmo_magic_number); + let buffer = input_bytes ic (String.length cmo_magic_number) in if buffer = cmo_magic_number then begin (* This is a .cmo file. It must be linked in any case. Read the relocation information to see which modules it @@ -178,7 +177,7 @@ let check_consistency ppf file_name cu = begin try let source = List.assoc cu.cu_name !implementations_defined in Location.print_warning (Location.in_file file_name) ppf - (Warnings.Multiple_definition(cu.cu_name, file_name, source)) + (Warnings.Multiple_definition(cu.cu_name, Location.show_filename file_name, Location.show_filename source)) with Not_found -> () end; implementations_defined := @@ -196,13 +195,11 @@ let debug_info = ref ([] : (int * string) list) let link_compunit ppf output_fun currpos_fun inchan file_name compunit = check_consistency ppf file_name compunit; seek_in inchan compunit.cu_pos; - let code_block = String.create compunit.cu_codesize in - really_input inchan code_block 0 compunit.cu_codesize; + let code_block = input_bytes inchan compunit.cu_codesize in Symtable.patch_object code_block compunit.cu_reloc; if !Clflags.debug && compunit.cu_debug > 0 then begin seek_in inchan compunit.cu_debug; - let buffer = String.create compunit.cu_debugsize in - really_input inchan buffer 0 compunit.cu_debugsize; + let buffer = input_bytes inchan compunit.cu_debugsize in debug_info := (currpos_fun(), buffer) :: !debug_info end; output_fun code_block; @@ -469,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 @@ -581,20 +579,25 @@ open Format let report_error ppf = function | File_not_found name -> - fprintf ppf "Cannot find file %s" name + fprintf ppf "Cannot find file %a" Location.print_filename name | Not_an_object_file name -> - fprintf ppf "The file %s is not a bytecode object file" name + fprintf ppf "The file %a is not a bytecode object file" + Location.print_filename name | Symbol_error(name, err) -> - fprintf ppf "Error while linking %s:@ %a" name + fprintf ppf "Error while linking %a:@ %a" Location.print_filename name Symtable.report_error err | Inconsistent_import(intf, file1, file2) -> fprintf ppf - "@[<hov>Files %s@ and %s@ \ + "@[<hov>Files %a@ and %a@ \ make inconsistent assumptions over interface %s@]" - file1 file2 intf + Location.print_filename file1 + Location.print_filename file2 + intf | Custom_runtime -> fprintf ppf "Error while building custom runtime system" | File_exists file -> - fprintf ppf "Cannot overwrite existing file %s" file + fprintf ppf "Cannot overwrite existing file %a" + Location.print_filename file | Cannot_open_dll file -> - fprintf ppf "Error on dynamically loaded library: %s" file + fprintf ppf "Error on dynamically loaded library: %a" + Location.print_filename file diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index fc53d54d6d..eea183f029 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -68,7 +68,7 @@ let rename_relocation packagename objfile mapping defined base (rel, ofs) = (* PR#5276, as above *) let name = Ident.name id in if String.contains name '.' then - Reloc_setglobal (Ident.create_persistent (packagename ^ "." ^ name)) + Reloc_setglobal (Ident.create_persistent (packagename ^ "." ^ name)) else rel end @@ -100,8 +100,7 @@ let read_member_info file = if Filename.check_suffix file ".cmo" then begin let ic = open_in_bin file in try - let buffer = String.create (String.length Config.cmo_magic_number) in - really_input ic buffer 0 (String.length Config.cmo_magic_number); + let buffer = input_bytes ic (String.length Config.cmo_magic_number) in if buffer <> Config.cmo_magic_number then raise(Error(Not_an_object_file file)); let compunit_pos = input_binary_int ic in @@ -236,10 +235,10 @@ let package_object_files ppf files targetfile targetname coercion = let package_files ppf files targetfile = let files = List.map - (fun f -> + (fun f -> try find_in_path !Config.load_path f with Not_found -> raise(Error(File_not_found f))) - files in + files in let prefix = chop_extensions targetfile in let targetcmi = prefix ^ ".cmi" in let targetname = String.capitalize(Filename.basename prefix) in @@ -256,13 +255,17 @@ open Format let report_error ppf = function Forward_reference(file, ident) -> - fprintf ppf "Forward reference to %s in file %s" (Ident.name ident) file + fprintf ppf "Forward reference to %s in file %a" (Ident.name ident) + Location.print_filename file | Multiple_definition(file, ident) -> - fprintf ppf "File %s redefines %s" file (Ident.name ident) + fprintf ppf "File %a redefines %s" + Location.print_filename file + (Ident.name ident) | Not_an_object_file file -> - fprintf ppf "%s is not a bytecode object file" file + fprintf ppf "%a is not a bytecode object file" + Location.print_filename file | Illegal_renaming(file, id) -> - fprintf ppf "Wrong file naming: %s@ contains the code for@ %s" - file id + fprintf ppf "Wrong file naming: %a@ contains the code for@ %s" + Location.print_filename file id | File_not_found file -> fprintf ppf "File %s not found" file diff --git a/bytecomp/bytesections.ml b/bytecomp/bytesections.ml index 342f071414..518e2254fb 100644 --- a/bytecomp/bytesections.ml +++ b/bytecomp/bytesections.ml @@ -48,14 +48,12 @@ let read_toc ic = let pos_trailer = in_channel_length ic - 16 in seek_in ic pos_trailer; let num_sections = input_binary_int ic in - let header = String.create(String.length Config.exec_magic_number) in - really_input ic header 0 (String.length Config.exec_magic_number); + let header = Misc.input_bytes ic (String.length Config.exec_magic_number) in if header <> Config.exec_magic_number then raise Bad_magic_number; seek_in ic (pos_trailer - 8 * num_sections); section_table := []; for i = 1 to num_sections do - let name = String.create 4 in - really_input ic name 0 4; + let name = Misc.input_bytes ic 4 in let len = input_binary_int ic in section_table := (name, len) :: !section_table done @@ -81,10 +79,7 @@ let seek_section ic name = (* Return the contents of a section, as a string *) let read_section_string ic name = - let len = seek_section ic name in - let res = String.create len in - really_input ic res 0 len; - res + Misc.input_bytes ic (seek_section ic name) (* Return the contents of a section, as marshalled data *) diff --git a/bytecomp/dll.ml b/bytecomp/dll.ml index 6109028fc5..3dc84ea27c 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/instruct.ml b/bytecomp/instruct.ml index a26c094588..7757c7d484 100644 --- a/bytecomp/instruct.ml +++ b/bytecomp/instruct.ml @@ -107,5 +107,5 @@ let immed_min = -0x40000000 and immed_max = 0x3FFFFFFF (* Actually the abstract machine accomodates -0x80000000 to 0x7FFFFFFF, - but these numbers overflow the Caml type int if the compiler runs on + but these numbers overflow the OCaml type int if the compiler runs on a 32-bit processor. *) diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index b1e6f16eb6..2e2875d82b 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -19,6 +19,8 @@ open Asttypes type primitive = Pidentity | Pignore + | Prevapply of Location.t + | Pdirapply of Location.t (* Globals *) | Pgetglobal of Ident.t | Psetglobal of Ident.t diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index d09a8c6f6b..c228d36d41 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -19,6 +19,8 @@ open Asttypes type primitive = Pidentity | Pignore + | Prevapply of Location.t + | Pdirapply of Location.t (* Globals *) | Pgetglobal of Ident.t | Psetglobal of Ident.t diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index a464590e4b..f7c88b48af 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 @@ -2037,7 +2037,7 @@ let combine_constructor arg ex_pat cstr partial ctx def List.fold_right (fun (ex, act) rem -> match ex with - | Cstr_exception path -> + | Cstr_exception (path, _) -> Lifthenelse(Lprim(Pintcomp Ceq, [Lprim(Pfield 0, [arg]); transl_path path]), act, rem) @@ -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) @@ -2591,7 +2591,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/printlambda.ml b/bytecomp/printlambda.ml index 38182db7eb..cb99003b29 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -92,6 +92,8 @@ let record_rep ppf r = let primitive ppf = function | Pidentity -> fprintf ppf "id" | Pignore -> fprintf ppf "ignore" + | Prevapply _ -> fprintf ppf "revapply" + | Pdirapply _ -> fprintf ppf "dirapply" | Pgetglobal id -> fprintf ppf "global %a" Ident.print id | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id | Pmakeblock(tag, Immutable) -> fprintf ppf "makeblock %i" tag @@ -297,7 +299,10 @@ let rec lam ppf = function | Lev_before -> "before" | Lev_after _ -> "after" | Lev_function -> "funct-body" in - fprintf ppf "@[<2>(%s %i-%i@ %a)@]" kind + fprintf ppf "@[<2>(%s %s(%i)%s:%i-%i@ %a)@]" kind + ev.lev_loc.Location.loc_start.Lexing.pos_fname + ev.lev_loc.Location.loc_start.Lexing.pos_lnum + (if ev.lev_loc.Location.loc_ghost then "<ghost>" else "") ev.lev_loc.Location.loc_start.Lexing.pos_cnum ev.lev_loc.Location.loc_end.Lexing.pos_cnum lam expr diff --git a/bytecomp/printlambda.mli b/bytecomp/printlambda.mli index 16618350ce..0cbd59ed60 100644 --- a/bytecomp/printlambda.mli +++ b/bytecomp/printlambda.mli @@ -18,3 +18,4 @@ open Format val structured_constant: formatter -> structured_constant -> unit val lambda: formatter -> lambda -> unit +val primitive: formatter -> primitive -> unit diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml index d5f85fc3a8..1883f71518 100644 --- a/bytecomp/simplif.ml +++ b/bytecomp/simplif.ml @@ -190,7 +190,23 @@ let simplify_exits lam = | Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2) | Lletrec(bindings, body) -> Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body) - | Lprim(p, ll) -> Lprim(p, List.map simplif ll) + | Lprim(p, ll) -> begin + let ll = List.map simplif ll in + match p, ll with + (* Simplify %revapply, for n-ary functions with n > 1 *) + | Prevapply loc, [x; Lapply(f, args, _)] + | Prevapply loc, [x; Levent (Lapply(f, args, _),_)] -> + Lapply(f, args@[x], loc) + | Prevapply loc, [x; f] -> Lapply(f, [x], loc) + + (* Simplify %apply, for n-ary functions with n > 1 *) + | Pdirapply loc, [Lapply(f, args, _); x] + | Pdirapply loc, [Levent (Lapply(f, args, _),_); x] -> + Lapply(f, args@[x], loc) + | Pdirapply loc, [f; x] -> Lapply(f, [x], loc) + + | _ -> Lprim(p, ll) + end | Lswitch(l, sw) -> let new_l = simplif l and new_consts = List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts @@ -256,6 +272,18 @@ let simplify_exits lam = in simplif lam +(* Compile-time beta-reduction of functions immediately applied: + Lapply(Lfunction(Curried, params, body), args, loc) -> + let paramN = argN in ... let param1 = arg1 in body + Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock(args))], loc) -> + let paramN = argN in ... let param1 = arg1 in body + Assumes |args| = |params|. +*) + +let beta_reduce params body args = + List.fold_left2 (fun l param arg -> Llet(Strict, param, arg, l)) + body params args + (* Simplification of lets *) let simplify_lets lam = @@ -306,6 +334,12 @@ let simplify_lets lam = | Lconst cst -> () | Lvar v -> use_var bv v 1 + | Lapply(Lfunction(Curried, params, body), args, _) + when optimize && List.length params = List.length args -> + count bv (beta_reduce params body args) + | Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock _, args)], _) + when optimize && List.length params = List.length args -> + count bv (beta_reduce params body args) | Lapply(l1, ll, _) -> count bv l1; List.iter (count bv) ll | Lfunction(kind, params, l) -> @@ -381,6 +415,12 @@ let simplify_lets lam = l end | Lconst cst as l -> l + | Lapply(Lfunction(Curried, params, body), args, _) + when optimize && List.length params = List.length args -> + simplif (beta_reduce params body args) + | Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock _, args)], _) + when optimize && List.length params = List.length args -> + simplif (beta_reduce params body args) | Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc) | Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l) | Llet(str, v, Lvar w, l2) when optimize -> 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 843ef5a90a..f27be6974f 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 @@ -167,22 +168,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 @@ -231,8 +234,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 @@ -240,11 +243,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 @@ -256,23 +259,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 @@ -282,34 +289,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 @@ -320,7 +327,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" @@ -357,7 +364,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)) | _ -> @@ -365,13 +372,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 : @@ -379,13 +386,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 @@ -397,18 +404,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; @@ -416,7 +423,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) | _ -> @@ -579,7 +586,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 @@ -789,12 +796,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 edf24e4b87..586863abdb 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -28,6 +28,7 @@ type error = Illegal_letrec_pat | Illegal_letrec_expr | Free_super_var + | Unknown_builtin_primitive of string exception Error of Location.t * error @@ -285,17 +286,18 @@ let prim_obj_dup = { prim_name = "caml_obj_dup"; prim_arity = 1; prim_alloc = true; prim_native_name = ""; prim_native_float = false } -let transl_prim prim args = +let transl_prim loc prim args = + let prim_name = prim.prim_name in try let (gencomp, intcomp, floatcomp, stringcomp, nativeintcomp, int32comp, int64comp, simplify_constant_constructor) = - Hashtbl.find comparisons_table prim.prim_name in + Hashtbl.find comparisons_table prim_name in begin match args with - [arg1; {exp_desc = Texp_construct({cstr_tag = Cstr_constant _}, _)}] + [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)}] @@ -322,7 +324,11 @@ let transl_prim prim args = end with Not_found -> try - let p = Hashtbl.find primitives_table prim.prim_name in + let p = + match prim_name with + "%revapply" -> Prevapply loc + | "%apply" -> Pdirapply loc + | name -> Hashtbl.find primitives_table name in (* Try strength reduction based on the type of the argument *) begin match (p, args) with (Psetfield(n, _), [arg1; arg2]) -> Psetfield(n, maybe_pointer arg2) @@ -342,6 +348,8 @@ let transl_prim prim args = | _ -> p end with Not_found -> + if String.length prim_name > 0 && prim_name.[0] = '%' then + raise(Error(loc, Unknown_builtin_primitive prim_name)); Pccall prim @@ -452,17 +460,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 @@ -476,18 +484,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 @@ -563,7 +572,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 @@ -576,16 +585,16 @@ 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, {val_kind = Val_reg | Val_self _}) -> + | Texp_ident(path, _, {val_kind = Val_reg | Val_self _}) -> transl_path path | Texp_ident _ -> fatal_error "Translcore.transl_exp: bad Texp_ident" | Texp_constant cst -> Lconst(Const_base cst) | Texp_let(rec_flag, pat_expr_list, body) -> transl_let rec_flag pat_expr_list (event_before body (transl_exp body)) - | Texp_function (pat_expr_list, partial) -> + | Texp_function (_, pat_expr_list, partial) -> let ((kind, params), body) = event_function e (function repr -> @@ -593,9 +602,9 @@ and transl_exp0 e = transl_function e.exp_loc !Clflags.native_code repr partial pl) in Lfunction(kind, params, body) - | Texp_apply({exp_desc = Texp_ident(path, {val_kind = Val_prim p})}, oargs) + | Texp_apply({exp_desc = Texp_ident(path, _, {val_kind = Val_prim p})}, 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' = [] @@ -604,7 +613,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 args in let public_send = p.prim_name = "%send" || not !Clflags.native_code && p.prim_name = "%sendcache"in @@ -617,7 +626,7 @@ and transl_exp0 e = wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc)) | _ -> assert false else begin - let prim = transl_prim p args in + let prim = transl_prim e.exp_loc p args in match (prim, args) with (Praise, [arg1]) -> wrap0 (Lprim(Praise, [event_after arg1 (List.hd argl)])) @@ -649,7 +658,7 @@ and transl_exp0 e = with Not_constant -> Lprim(Pmakeblock(0, Immutable), ll) end - | Texp_construct(cstr, args) -> + | Texp_construct(_, _, cstr, args, _) -> let ll = transl_list args in begin match cstr.cstr_tag with Cstr_constant n -> @@ -660,7 +669,7 @@ and transl_exp0 e = with Not_constant -> Lprim(Pmakeblock(n, Immutable), ll) end - | Cstr_exception path -> + | Cstr_exception (path, _) -> Lprim(Pmakeblock(0, Immutable), transl_path path :: ll) end | Texp_variant(l, arg) -> @@ -676,17 +685,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) @@ -723,14 +732,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 @@ -741,11 +751,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 @@ -753,11 +763,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 @@ -775,12 +785,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 (* the following may represent a float/forward/lazy: need a forward_tag *) @@ -816,12 +826,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 } and transl_list expr_list = @@ -883,11 +894,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) = @@ -929,9 +940,9 @@ and transl_let rec_flag pat_expr_list body = | Recursive -> let idlist = List.map - (fun (pat, expr) -> - match pat.pat_desc with - Tpat_var 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 = @@ -966,11 +977,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 = @@ -995,7 +1006,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) @@ -1046,3 +1057,5 @@ let report_error ppf = function | Free_super_var -> fprintf ppf "Ancestor names can only be used to select inherited methods" + | Unknown_builtin_primitive prim_name -> + fprintf ppf "Unknown builtin primitive \"%s\"" prim_name diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli index 1bc5ce613d..dd13c14493 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 @@ -37,6 +37,7 @@ type error = Illegal_letrec_pat | Illegal_letrec_expr | Free_super_var + | Unknown_builtin_primitive of string exception Error of Location.t * error diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 38eab85431..8667fb80de 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,48 +285,52 @@ 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) - | 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 [] -> @@ -345,7 +353,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 @@ -371,29 +379,31 @@ 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) - | 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 @@ -404,8 +414,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 @@ -414,23 +424,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 @@ -476,23 +488,26 @@ 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 - | 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)], @@ -533,13 +548,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 @@ -590,50 +605,53 @@ 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) -> let idents = let_bound_idents pat_expr_list in transl_let rec_flag pat_expr_list (make_sequence toploop_setvalue_id idents) - | 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 @@ -650,7 +668,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 b92cc6de2a..68adc27b32 100644 --- a/byterun/.depend +++ b/byterun/.depend @@ -6,7 +6,7 @@ array.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ minor_gc.h backtrace.o: backtrace.c config.h ../config/m.h ../config/s.h \ compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ - fix_code.h exec.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ startup.h stacks.h sys.h backtrace.h callback.o: callback.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ @@ -20,15 +20,15 @@ compare.o: compare.c custom.h compatibility.h mlvalues.h config.h \ custom.o: custom.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h -debugger.o: debugger.c config.h ../config/m.h ../config/s.h \ - compatibility.h debugger.h misc.h mlvalues.h fail.h fix_code.h \ +debugger.o: debugger.c alloc.h compatibility.h misc.h config.h \ + ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \ instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h sys.h dynlink.o: dynlink.c config.h ../config/m.h ../config/s.h compatibility.h \ alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h osdeps.h prims.h extern.o: extern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \ + ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \ memory.h major_gc.h freelist.h minor_gc.h reverse.h fail.o: fail.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h \ @@ -38,7 +38,8 @@ finalise.o: finalise.c callback.h compatibility.h mlvalues.h config.h \ major_gc.h freelist.h minor_gc.h signals.h fix_code.o: fix_code.c config.h ../config/m.h ../config/s.h \ compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ - md5.h io.h memory.h gc.h major_gc.h freelist.h minor_gc.h reverse.h + intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + reverse.h floats.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h reverse.h stacks.h @@ -54,18 +55,18 @@ globroots.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ roots.h globroots.h hash.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h + minor_gc.h hash.h int64_native.h instrtrace.o: instrtrace.c intern.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \ - memory.h major_gc.h freelist.h minor_gc.h reverse.h + ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ + md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h interp.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \ fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \ memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h ints.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h intext.h io.h fix_code.h \ - memory.h gc.h major_gc.h freelist.h minor_gc.h int64_native.h + ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h int64_native.h io.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h signals.h sys.h @@ -142,7 +143,7 @@ array.d.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ minor_gc.h backtrace.d.o: backtrace.c config.h ../config/m.h ../config/s.h \ compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ - fix_code.h exec.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ startup.h stacks.h sys.h backtrace.h callback.d.o: callback.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ @@ -156,15 +157,15 @@ compare.d.o: compare.c custom.h compatibility.h mlvalues.h config.h \ custom.d.o: custom.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h -debugger.d.o: debugger.c config.h ../config/m.h ../config/s.h \ - compatibility.h debugger.h misc.h mlvalues.h fail.h fix_code.h \ +debugger.d.o: debugger.c alloc.h compatibility.h misc.h config.h \ + ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \ instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h sys.h dynlink.d.o: dynlink.c config.h ../config/m.h ../config/s.h compatibility.h \ alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h osdeps.h prims.h extern.d.o: extern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \ + ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \ memory.h major_gc.h freelist.h minor_gc.h reverse.h fail.d.o: fail.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h \ @@ -174,7 +175,8 @@ finalise.d.o: finalise.c callback.h compatibility.h mlvalues.h config.h \ major_gc.h freelist.h minor_gc.h signals.h fix_code.d.o: fix_code.c config.h ../config/m.h ../config/s.h \ compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ - md5.h io.h memory.h gc.h major_gc.h freelist.h minor_gc.h reverse.h + intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + reverse.h floats.d.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h reverse.h stacks.h @@ -190,20 +192,20 @@ globroots.d.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ roots.h globroots.h hash.d.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h + minor_gc.h hash.h int64_native.h instrtrace.d.o: instrtrace.c instruct.h misc.h compatibility.h config.h \ ../config/m.h ../config/s.h mlvalues.h opnames.h prims.h stacks.h \ memory.h gc.h major_gc.h freelist.h minor_gc.h intern.d.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \ - memory.h major_gc.h freelist.h minor_gc.h reverse.h + ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ + md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h interp.d.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \ fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \ memory.h gc.h minor_gc.h prims.h signals.h stacks.h ints.d.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h intext.h io.h fix_code.h \ - memory.h gc.h major_gc.h freelist.h minor_gc.h int64_native.h + ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h int64_native.h io.d.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h signals.h sys.h @@ -280,7 +282,7 @@ array.pic.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ minor_gc.h backtrace.pic.o: backtrace.c config.h ../config/m.h ../config/s.h \ compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ - fix_code.h exec.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + exec.h fix_code.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ startup.h stacks.h sys.h backtrace.h callback.pic.o: callback.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ @@ -294,15 +296,15 @@ compare.pic.o: compare.c custom.h compatibility.h mlvalues.h config.h \ custom.pic.o: custom.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h -debugger.pic.o: debugger.c config.h ../config/m.h ../config/s.h \ - compatibility.h debugger.h misc.h mlvalues.h fail.h fix_code.h \ +debugger.pic.o: debugger.c alloc.h compatibility.h misc.h config.h \ + ../config/m.h ../config/s.h mlvalues.h debugger.h fail.h fix_code.h \ instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h sys.h dynlink.pic.o: dynlink.c config.h ../config/m.h ../config/s.h compatibility.h \ alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h osdeps.h prims.h extern.pic.o: extern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \ + ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h md5.h \ memory.h major_gc.h freelist.h minor_gc.h reverse.h fail.pic.o: fail.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h \ @@ -312,7 +314,8 @@ finalise.pic.o: finalise.c callback.h compatibility.h mlvalues.h config.h \ major_gc.h freelist.h minor_gc.h signals.h fix_code.pic.o: fix_code.c config.h ../config/m.h ../config/s.h \ compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ - md5.h io.h memory.h gc.h major_gc.h freelist.h minor_gc.h reverse.h + intext.h io.h md5.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + reverse.h floats.pic.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h reverse.h stacks.h @@ -328,18 +331,18 @@ globroots.pic.o: globroots.c memory.h compatibility.h config.h ../config/m.h \ roots.h globroots.h hash.pic.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ - minor_gc.h + minor_gc.h hash.h int64_native.h instrtrace.pic.o: instrtrace.c intern.pic.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \ - memory.h major_gc.h freelist.h minor_gc.h reverse.h + ../config/s.h mlvalues.h callback.h custom.h fail.h gc.h intext.h io.h \ + md5.h memory.h major_gc.h freelist.h minor_gc.h reverse.h interp.pic.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \ fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \ memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h ints.pic.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h custom.h fail.h intext.h io.h fix_code.h \ - memory.h gc.h major_gc.h freelist.h minor_gc.h int64_native.h + ../config/s.h mlvalues.h custom.h fail.h intext.h io.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h int64_native.h io.pic.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h signals.h sys.h diff --git a/byterun/.ignore b/byterun/.ignore 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 bf64e78c1f..7f21fd8d7d 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/backtrace.c b/byterun/backtrace.c index 7b8ddca885..b5efdc3db6 100644 --- a/byterun/backtrace.c +++ b/byterun/backtrace.c @@ -118,7 +118,7 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp) } /* Read the debugging info contained in the current bytecode executable. - Return a Caml array of Caml lists of debug_event records in "events", + Return an OCaml array of OCaml lists of debug_event records in "events", or Val_false on failure. */ #ifndef O_BINARY @@ -274,7 +274,7 @@ CAMLexport void caml_print_exception_backtrace(void) } } -/* Convert the backtrace to a data structure usable from Caml */ +/* Convert the backtrace to a data structure usable from OCaml */ CAMLprim value caml_get_exception_backtrace(value unit) { diff --git a/byterun/callback.c b/byterun/callback.c index 0d781259af..c7fc772208 100644 --- a/byterun/callback.c +++ b/byterun/callback.c @@ -13,7 +13,7 @@ /* $Id$ */ -/* Callbacks from C to Caml */ +/* Callbacks from C to OCaml */ #include <string.h> #include "callback.h" @@ -195,7 +195,7 @@ CAMLexport value caml_callbackN (value closure, int narg, value args[]) return res; } -/* Naming of Caml values */ +/* Naming of OCaml values */ struct named_value { value val; diff --git a/byterun/callback.h b/byterun/callback.h index 829f6b8841..dd094c4dec 100644 --- a/byterun/callback.h +++ b/byterun/callback.h @@ -13,7 +13,7 @@ /* $Id$ */ -/* Callbacks from C to Caml */ +/* Callbacks from C to OCaml */ #ifndef CAML_CALLBACK_H #define CAML_CALLBACK_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/compare.c b/byterun/compare.c index 79f71ef61d..c0ee65a260 100644 --- a/byterun/compare.c +++ b/byterun/compare.c @@ -106,7 +106,7 @@ static intnat compare_val(value v1, value v2, int total) /* Subtraction above cannot overflow and cannot result in UNORDERED */ if (Is_in_value_area(v2)) { switch (Tag_val(v2)) { - case Forward_tag: + case Forward_tag: v2 = Forward_val(v2); continue; case Custom_tag: { diff --git a/byterun/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/debugger.c b/byterun/debugger.c index c69b1edd14..a114b46cbc 100644 --- a/byterun/debugger.c +++ b/byterun/debugger.c @@ -21,6 +21,7 @@ #include <string.h> +#include "alloc.h" #include "config.h" #include "debugger.h" #include "misc.h" @@ -28,6 +29,7 @@ int caml_debugger_in_use = 0; uintnat caml_event_count; int caml_debugger_fork_mode = 1; /* parent by default */ +value marshal_flags = Val_emptylist; #if !defined(HAS_SOCKETS) || defined(NATIVE_CODE) @@ -162,6 +164,11 @@ void caml_debugger_init(void) struct hostent * host; int n; + caml_register_global_root(&marshal_flags); + marshal_flags = caml_alloc(2, Tag_cons); + Store_field(marshal_flags, 0, Val_int(1)); /* Marshal.Closures */ + Store_field(marshal_flags, 1, Val_emptylist); + address = getenv("CAML_DEBUG_SOCKET"); if (address == NULL) return; dbg_addr = address; @@ -230,7 +237,7 @@ static void safe_output_value(struct channel *chan, value val) saved_external_raise = caml_external_raise; if (sigsetjmp(raise_buf.buf, 0) == 0) { caml_external_raise = &raise_buf; - caml_output_val(chan, val, Val_unit); + caml_output_val(chan, val, marshal_flags); } else { /* Send wrong magic number, will cause [caml_input_value] to fail */ caml_really_putblock(chan, "\000\000\000\000", 4); diff --git a/byterun/dynlink.c b/byterun/dynlink.c index ddd406babf..343ebde57a 100644 --- a/byterun/dynlink.c +++ b/byterun/dynlink.c @@ -184,8 +184,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 ef07f9c949..22187e9585 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,62 @@ 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_invalid_argument(char *msg); +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 */ @@ -161,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) @@ -169,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) @@ -216,6 +269,21 @@ static 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) \ @@ -289,7 +357,11 @@ static void writecode64(int code, intnat val) 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) { @@ -304,7 +376,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); @@ -319,7 +391,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 @@ -330,7 +402,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) { @@ -342,7 +414,7 @@ static void extern_rec(value v) } else { writecode32(CODE_SHARED32, d); } - return; + goto next_item; } /* Output the contents of the object */ @@ -413,7 +485,6 @@ static void extern_rec(value v) } default: { value field0; - mlsize_t i; if (tag < 16 && sz < 8) { Write(PREFIX_SMALL_BLOCK + tag + (sz << 4)); #ifdef ARCH_SIXTYFOUR @@ -427,26 +498,38 @@ 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) { 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 }; @@ -724,3 +807,19 @@ 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 2871220435..2ae3165d9f 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -133,7 +133,7 @@ static value heap_stats (int returnstats) header_t cur_hd; #ifdef DEBUG - caml_gc_message (-1, "### O'Caml runtime: heap check ###\n", 0); + caml_gc_message (-1, "### OCaml runtime: heap check ###\n", 0); #endif while (chunk != NULL){ @@ -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/hash.c b/byterun/hash.c index 5b8955df71..26a1bf5979 100644 --- a/byterun/hash.c +++ b/byterun/hash.c @@ -55,7 +55,7 @@ CAMLexport uint32 caml_hash_mix_uint32(uint32 h, uint32 d) return h; } -/* Mix a platform-native integer. */ +/* Mix a platform-native integer. */ CAMLexport uint32 caml_hash_mix_intnat(uint32 h, intnat d) { @@ -146,7 +146,7 @@ CAMLexport uint32 caml_hash_mix_float(uint32 hash, float d) return hash; } -/* Mix a Caml string */ +/* Mix an OCaml string */ CAMLexport uint32 caml_hash_mix_string(uint32 h, value s) { @@ -230,7 +230,7 @@ CAMLprim value caml_hash(value count, value limit, value seed, value obj) /* Block contents unknown. Do nothing. */ break; case Infix_tag: - /* Mix in the offset to distinguish different functions from + /* Mix in the offset to distinguish different functions from the same mutually-recursive definition */ h = caml_hash_mix_uint32(h, Infix_offset_val(v)); v = v - Infix_offset_val(v); @@ -271,7 +271,7 @@ CAMLprim value caml_hash(value count, value limit, value seed, value obj) /* Final mixing of bits */ FINAL_MIX(h); /* Fold result to the range [0, 2^30-1] so that it is a nonnegative - Caml integer both on 32 and 64-bit platforms. */ + OCaml integer both on 32 and 64-bit platforms. */ return Val_int(h & 0x3FFFFFFFU); } diff --git a/byterun/hash.h b/byterun/hash.h index 56eeec1131..037c9c5a3d 100644 --- a/byterun/hash.h +++ b/byterun/hash.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: hash.c 9547 2010-01-22 12:48:24Z doligez $ */ +/* $Id$ */ /* Auxiliary functions for custom hash functions */ @@ -29,4 +29,3 @@ CAMLextern uint32 caml_hash_mix_string(uint32 h, value s); #endif - diff --git a/byterun/intern.c b/byterun/intern.c index 35d293b603..774aff9faa 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,20 +122,200 @@ 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 +} + +/* 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; - - 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) { @@ -139,30 +327,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 */ @@ -240,68 +422,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: @@ -309,18 +445,30 @@ static void intern_rec(value *dest) goto read_double_array; case CODE_CODEPOINTER: ofs = read32u(); - readblock(cksum, 16); - if (memcmp(cksum, caml_code_checksum(), 16) != 0) { - intern_cleanup(); - caml_failwith("input_value: code mismatch"); + readblock(digest, 16); + codeptr = intern_resolve_code_pointer(digest, ofs); + if (codeptr != NULL) { + v = (value) codeptr; + } else { + value * function_placeholder = + caml_named_value ("Debugger.function_placeholder"); + if (function_placeholder != NULL) { + v = *function_placeholder; + } else { + intern_cleanup(); + intern_bad_code_pointer(digest); + } } - v = (value) (caml_code_area_start + ofs); break; case CODE_INFIXPOINTER: ofs = read32u(); - 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: ops = caml_find_custom_operations((char *) intern_src); if (ops == NULL) { @@ -342,7 +490,15 @@ static void intern_rec(value *dest) } } } + /* 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) @@ -574,40 +730,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 +/* Resolution of code pointers */ -#include "md5.h" - -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 b771a34ad8..b287e5cdb4 100644 --- a/byterun/intext.h +++ b/byterun/intext.h @@ -104,7 +104,7 @@ value caml_input_val (struct channel * chan); /* </private> */ CAMLextern value caml_input_val_from_string (value str, intnat ofs); - /* Read a structured value from the Caml string [str], starting + /* Read a structured value from the OCaml string [str], starting at offset [ofs]. */ CAMLextern value caml_input_value_from_malloc(char * data, intnat ofs); /* Read a structured value from a malloced buffer. [data] points @@ -151,15 +151,15 @@ 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> */ diff --git a/byterun/ints.c b/byterun/ints.c index 4fa1657beb..34b5db238a 100644 --- a/byterun/ints.c +++ b/byterun/ints.c @@ -142,7 +142,7 @@ static char * parse_format(value fmt, char lastletter; mlsize_t len, len_suffix; - /* Copy Caml format fmt to format_string, + /* Copy OCaml format fmt to format_string, adding the suffix before the last letter of the format */ len = caml_string_length(fmt); len_suffix = strlen(suffix); diff --git a/byterun/io.c b/byterun/io.c index 90a3995108..ae9e397065 100644 --- a/byterun/io.c +++ b/byterun/io.c @@ -117,7 +117,7 @@ CAMLexport file_offset caml_channel_size(struct channel *channel) file_offset end; int fd; - /* We extract data from [channel] before dropping the Caml lock, in case + /* We extract data from [channel] before dropping the OCaml lock, in case someone else touches the block. */ fd = channel->fd; offset = channel->offset; @@ -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); @@ -411,7 +416,7 @@ CAMLexport intnat caml_input_scan_line(struct channel *channel) return (p - channel->curr); } -/* Caml entry points for the I/O functions. Wrap struct channel * +/* OCaml entry points for the I/O functions. Wrap struct channel * objects into a heap-allocated object. Perform locking and unlocking around the I/O operations. */ /* FIXME CAMLexport, but not in io.h exported for Cash ? */ 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..ad0b1fbf02 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..06b9ab62b1 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/memory.h b/byterun/memory.h index cbeeb756fa..69f5ff91c8 100644 --- a/byterun/memory.h +++ b/byterun/memory.h @@ -173,15 +173,15 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ If you need local variables of type [value], declare them with one or more calls to the [CAMLlocal] macros at the beginning of the - function. Use [CAMLlocalN] (at the beginning of the function) to - declare an array of [value]s. + function, after the call to CAMLparam. Use [CAMLlocalN] (at the + beginning of the function) to declare an array of [value]s. Your function may raise an exception or return a [value] with the [CAMLreturn] macro. Its argument is simply the [value] returned by your function. Do NOT directly return a [value] with the [return] keyword. If your function returns void, use [CAMLreturn0]. - All the identifiers beginning with "caml__" are reserved by Caml. + All the identifiers beginning with "caml__" are reserved by OCaml. Do not use them for anything (local or global variables, struct or union tags, macros, etc.) */ @@ -346,7 +346,7 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ It must contain all values in C local variables and function parameters at the time the minor GC is called. Usage: - After initialising your local variables to legal Caml values, but before + After initialising your local variables to legal OCaml values, but before calling allocation functions, insert [Begin_roots_n(v1, ... vn)], where v1 ... vn are your variables of type [value] that you want to be updated across allocations. @@ -440,7 +440,7 @@ CAMLextern void caml_remove_global_root (value *); the value of this variable, it must do so by calling [caml_modify_generational_global_root]. The [value *] pointer passed to [caml_register_generational_global_root] must contain - a valid Caml value before the call. + a valid OCaml value before the call. In return for these constraints, scanning of memory roots during minor collection is made more efficient. */ 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/minor_gc.c b/byterun/minor_gc.c index 2cab6d2b11..8b8b8ff0ed 100644 --- a/byterun/minor_gc.c +++ b/byterun/minor_gc.c @@ -160,9 +160,14 @@ void caml_oldify_one (value v, value *p) Assert (tag == Forward_tag); if (Is_block (f)){ - vv = Is_in_value_area(f); - if (vv) { + if (Is_young (f)){ + vv = 1; ft = Tag_val (Hd_val (f) == 0 ? Field (f, 0) : f); + }else{ + vv = Is_in_value_area(f); + if (vv){ + ft = Tag_val (f); + } } } if (!vv || ft == Forward_tag || ft == Lazy_tag || ft == Double_tag){ diff --git a/byterun/obj.c b/byterun/obj.c index f095df5ae6..7d09105b78 100644 --- a/byterun/obj.c +++ b/byterun/obj.c @@ -171,7 +171,7 @@ CAMLprim value caml_obj_add_offset (value v, value offset) } /* The following functions are used in stdlib/lazy.ml. - They are not written in O'Caml because they must be atomic with respect + They are not written in OCaml because they must be atomic with respect to the GC. */ diff --git a/byterun/startup.c b/byterun/startup.c index 6117ff7a37..8298fe83ff 100644 --- a/byterun/startup.c +++ b/byterun/startup.c @@ -370,12 +370,12 @@ CAMLexport void caml_main(char **argv) fd = caml_attempt_open(&exe_name, &trail, 1); switch(fd) { case FILE_NOT_FOUND: - caml_fatal_error_arg("Fatal error: cannot find file %s\n", argv[pos]); + caml_fatal_error_arg("Fatal error: cannot find file '%s'\n", argv[pos]); break; case BAD_BYTECODE: caml_fatal_error_arg( - "Fatal error: the file %s is not a bytecode executable file\n", - argv[pos]); + "Fatal error: the file '%s' is not a bytecode executable file\n", + exe_name); break; } } @@ -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 0b18cc0c0a..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) @@ -320,9 +342,14 @@ CAMLprim value caml_sys_get_config(value unit) CAMLlocal2 (result, ostype); ostype = caml_copy_string(OCAML_OS_TYPE); - result = caml_alloc_small (2, 0); + result = caml_alloc_small (3, 0); Field(result, 0) = ostype; Field(result, 1) = Val_long (8 * sizeof(value)); +#ifdef ARCH_BIG_ENDIAN + Field(result, 2) = Val_true; +#else + Field(result, 2) = Val_false; +#endif CAMLreturn (result); } diff --git a/byterun/win32.c b/byterun/win32.c index e958fd6f24..c6ff3985e3 100644 --- a/byterun/win32.c +++ b/byterun/win32.c @@ -205,7 +205,6 @@ static int argvsize; static void store_argument(char * arg); static void expand_argument(char * arg); static void expand_pattern(char * arg); -static void expand_diversion(char * filename); static void out_of_memory(void) { @@ -227,10 +226,6 @@ static void expand_argument(char * arg) { char * p; - if (arg[0] == '@') { - expand_diversion(arg + 1); - return; - } for (p = arg; *p != 0; p++) { if (*p == '*' || *p == '?') { expand_pattern(arg); @@ -265,62 +260,6 @@ static void expand_pattern(char * pat) _findclose(handle); } -static void expand_diversion(char * filename) -{ - struct _stat stat; - int fd; - char * buf, * endbuf, * p, * q, * s; - int inquote; - - if (_stat(filename, &stat) == -1 || - (fd = _open(filename, O_RDONLY | O_BINARY, 0)) == -1) { - fprintf(stderr, "Cannot open file %s\n", filename); - exit(2); - } - buf = (char *) malloc(stat.st_size + 1); - if (buf == NULL) out_of_memory(); - _read(fd, buf, stat.st_size); - endbuf = buf + stat.st_size; - _close(fd); - for (p = buf; p < endbuf; /*nothing*/) { - /* Skip leading blanks */ - while (p < endbuf && isspace(*p)) p++; - if (p >= endbuf) break; - s = p; - /* Skip to end of argument, taking quotes into account */ - q = s; - inquote = 0; - while (p < endbuf) { - if (! inquote) { - if (isspace(*p)) break; - if (*p == '"') { inquote = 1; p++; continue; } - *q++ = *p++; - } else { - switch (*p) { - case '"': - inquote = 0; p++; continue; - case '\\': - if (p + 4 <= endbuf && strncmp(p, "\\\\\\\"", 4) == 0) { - p += 4; *q++ = '\\'; *q++ = '"'; continue; - } - if (p + 3 <= endbuf && strncmp(p, "\\\\\"", 3) == 0) { - p += 3; *q++ = '\\'; inquote = 0; continue; - } - if (p + 2 <= endbuf && p[1] == '"') { - p += 2; *q++ = '"'; continue; - } - /* fallthrough */ - default: - *q++ = *p++; - } - } - } - /* Delimit argument and expand it */ - *q++ = 0; - expand_argument(s); - p++; - } -} CAMLexport void caml_expand_command_line(int * argcp, char *** argvp) { @@ -528,18 +467,15 @@ void caml_win32_overflow_detection() /* Seeding of pseudo-random number generators */ -intnat caml_win32_random_seed (void) +int caml_win32_random_seed (intnat data[16]) { - intnat seed; - SYSTEMTIME t; - - GetLocalTime(&t); - seed = t.wMonth; - seed = (seed << 5) ^ t.wDay; - seed = (seed << 4) ^ t.wHour; - seed = (seed << 5) ^ t.wMinute; - seed = (seed << 5) ^ t.wSecond; - seed = (seed << 9) ^ t.wMilliseconds; - seed ^= GetCurrentProcessId(); - return seed; + /* For better randomness, consider: + http://msdn.microsoft.com/library/en-us/seccrypto/security/rtlgenrandom.asp + */ + FILETIME t; + GetSystemTimeAsFileTime(&t); + data[0] = t.dwLowDateTime; + data[1] = t.dwHighDateTime; + data[2] = GetCurrentProcessId(); + return 3; } diff --git a/camlp4/CHANGES b/camlp4/CHANGES index ef48fc4251..0251cd1638 100644 --- a/camlp4/CHANGES +++ b/camlp4/CHANGES @@ -497,7 +497,7 @@ Camlp4 Version 3.00: - [Apr 17, 00] Added support for labels and variants. - [Mar 28, 00] Improved the grammars: now the rules starting with n terminals are locally LL(n), i.e. if any of the terminal fails, it is - not Error but just Failure. Allows to write the Ocaml syntax case: + not Error but just Failure. Allows to write the OCaml syntax case: ( operator ) ( expr ) with the problem of "( - )" as: @@ -518,7 +518,7 @@ Camlp4 Version 2.04: - [Nov 23, 99] Changed the module name Config into Oconfig, because of conflict problem when applications want to link with the module Config of - Ocaml. + OCaml. Camlp4 Version 2.03: -------------------- @@ -534,9 +534,9 @@ Camlp4 Version 2.03: - [Mar 9, 99] Added missing case in pr_depend.ml. * Other: - - [Sep 10, 99] Updated from current Ocaml new interfaces. + - [Sep 10, 99] Updated from current OCaml new interfaces. - [Jul 9, 99] Added stream type constraint in pa_oop.ml to reflect the same - change in Ocaml. + change in OCaml. - [Jun 24, 99] Added missing "constraint" construction in types - [Jun 15, 99] Added option -I for command "mkcamlp4". - [May 14, 99] Added man pages (links) for camlp4o, camlp4r, mkcamlp4, ocpp @@ -555,11 +555,11 @@ Camlp4 Version 2.02: -------------------- * Parsing: - - [Feb 27, 99] Fixed 2 bugs, resulting of incorrect Ocaml parsing of the + - [Feb 27, 99] Fixed 2 bugs, resulting of incorrect OCaml parsing of the program example: "type t = F(B).t" - [Jan 30, 99] Fixed bug "pa_op.ml", could not parse "parser | [<>] -> ()". - [Jan 16, 99] Added "define" and "undef" in "pa_ifdef.cmo". - - [Dec 22, 98] Fixed precedence of "!=" in Ocaml syntax + - [Dec 22, 98] Fixed precedence of "!=" in OCaml syntax * Printing: - [Mar 4, 99] Added pr_depend.cmo for printing file dependencies. @@ -603,7 +603,7 @@ Grammar interface Missing features added * Added "lazy" statement (pa_r.cmo, pa_o.cmo, pr_r.cmo, pr_o.cmo) * Added print "assert" statement (pr_o.cmo, pr_r.cmo) -* Added parsing of infix operators like in Ocaml (e.g. |||) in pa_o.cmo +* Added parsing of infix operators like in OCaml (e.g. |||) in pa_o.cmo Compilation * Added "make scratch" @@ -636,20 +636,20 @@ Camlp4 Version 2.00: -------------------- * Designation "righteous" has been renamed "revised". -* Added class and objects in Ocaml printing (pr_o.cmo), revised parsing +* Added class and objects in OCaml printing (pr_o.cmo), revised parsing (pa_r.cmo) and printing (pr_r.cmo). -* Fixed bug in Ocaml syntax: let _, x = 1, 2;; was refused. +* Fixed bug in OCaml syntax: let _, x = 1, 2;; was refused. Camlp4 Version 2.00--1: ----------------------- -* Added classes and objects in Ocaml syntax (pa_o.cmo) +* Added classes and objects in OCaml syntax (pa_o.cmo) * Fixed pr_r.cmo et pr_r.cmo which wrote on stdout, even when option -o Camlp4 Version 2.00--: ---------------------- -* Adapted for Ocaml 2.00. +* Adapted for OCaml 2.00. * No objects and classes in this version. * Added "let module" parsing and printing. @@ -672,7 +672,7 @@ Camlp4 Version 2.00--: * Added missing statement "include" in signature item in normal and righteous syntaxes * Changed precedence of ":=" and "<-" in normal syntax (pa_o et pr_o): - now before "or", like in Ocaml compiler. + now before "or", like in OCaml compiler. * Same change in righteous syntax, by symmetry. Camlp4 Version 1.07.2: @@ -684,8 +684,8 @@ Errors and missings in normal and righteous syntaxes. * Added missing syntax (normal): type foo = bar = {......} * Added missing syntax (normal): did not accept separators before ending constructions (many of them). -* Fixed bug: "assert false" is now of type 'a, like in Ocaml. -* Fixed to match Ocaml feature: "\^" is "\^" in Ocaml, but just "^" in Camlp4. +* Fixed bug: "assert false" is now of type 'a, like in OCaml. +* Fixed to match OCaml feature: "\^" is "\^" in OCaml, but just "^" in Camlp4. * Fixed bug in Windows NT/95: problem in backslash before newlines in strings Grammars, EXTEND, DELETE_RULE @@ -736,7 +736,7 @@ Camlp4 Version 1.07.1: * Environment variable CAMLP4LIB to change camlp4 library directory * Grammar: empty rules have a correct location instead of (-1, -1) * Compilation possible in Windows NT/95 -* String constants no more shared while parsing Ocaml +* String constants no more shared while parsing OCaml * Fixed bug in antiquotations in q_MLast.cmo (bad errors locations) * Fixed bug in antiquotations in q_MLast.cmo (EOI not checked) * Fixed bug in Plexer: could not create keywords with iso 8859 characters @@ -748,17 +748,17 @@ Camlp4 Version 1.07: * Added iso 8859 uppercase characters for uidents in plexer.ml * Fixed bug factorization IDENT in grammars * Fixed bug pr_o.cmo was printing "declare" -* Fixed bug constructor arity in Ocaml syntax (pa_o.cmo). +* Fixed bug constructor arity in OCaml syntax (pa_o.cmo). * Changed "lazy" into "slazy". * Completed pa_ifdef.cmo. Camlp4 Version 1.06: -------------------- -* Adapted to Ocaml 1.06. -* Changed version number to match Ocaml's => 1.06 too. -* Deleted module Gstream, using Ocaml's Stream. -* Generate different AST for C(x,y) and C x y (change done in Ocaml's compiler) +* Adapted to OCaml 1.06. +* Changed version number to match OCaml's => 1.06 too. +* Deleted module Gstream, using OCaml's Stream. +* Generate different AST for C(x,y) and C x y (change done in OCaml's compiler) * No more message "Interrupted" in toplevel in case of syntax error. * Added flag to suppress warnings while extending grammars. * Completed some missing statements and declarations (objects) @@ -832,7 +832,7 @@ Camlp4 Version 0.6: when the quotation is in a context of a pattern. These expanders, returning strings which are parsed afterwards, may work for some language syntax and/or language extensions used (e.g. may work for - Righteous syntax and not for Ocaml syntax). + Righteous syntax and not for OCaml syntax). - A new type of expander returning directly syntax trees. A pair of functions, for expressions and for patterns must be provided. These expanders are independant from the language syntax and/or @@ -842,12 +842,12 @@ Camlp4 Version 0.6: been deleted; one can use "ctyp", "patt", and "expr" in position of pattern or expression. ---- Ocaml and Righteous syntaxes +--- OCaml and Righteous syntaxes * Fixed bug: "open Foo.Bar" was converted (pr_dump.cmo) into "open Bar.Foo" -* Corrected behavior different from Ocaml's: "^" and "@" were at the same - level than "=": now, like Ocaml, they have a separated right associative +* Corrected behavior different from OCaml's: "^" and "@" were at the same + level than "=": now, like OCaml, they have a separated right associative level. --- Grammars behavior @@ -881,7 +881,7 @@ Camlp4 Version 0.5: * Possible creation of native code library (make opt) -* Ocaml and Righteous Syntax more complete +* OCaml and Righteous Syntax more complete * Added pa_ru.cmo for compiling sequences of type unit (Righteous) diff --git a/camlp4/Camlp4/Camlp4Ast.partial.ml b/camlp4/Camlp4/Camlp4Ast.partial.ml index 718d9eebbc..228743734d 100644 --- a/camlp4/Camlp4/Camlp4Ast.partial.ml +++ b/camlp4/Camlp4/Camlp4Ast.partial.ml @@ -12,6 +12,9 @@ (* *) (****************************************************************************) +(* Note: when you modify these types you must increment + ast magic numbers defined in Camlp4_config.ml. *) + type loc = Loc.t and meta_bool = [ BTrue diff --git a/camlp4/Camlp4/Printers/OCaml.ml b/camlp4/Camlp4/Printers/OCaml.ml index def7f196a2..338655f0cc 100644 --- a/camlp4/Camlp4/Printers/OCaml.ml +++ b/camlp4/Camlp4/Printers/OCaml.ml @@ -106,7 +106,8 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct "Cannot print %S this identifier does not respect OCaml lexing rules (%s)" str (Lexer.Error.to_string exn)) ]; - value ocaml_char x = x; + (* This is to be sure character literals are always escaped. *) + value ocaml_char x = Char.escaped (Struct.Token.Eval.char x); value rec get_expr_args a al = match a with @@ -300,16 +301,19 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:binding< $b1$ and $b2$ >> -> do { o#binding f b1; pp f o#andsep; o#binding f b2 } | <:binding< $p$ = $e$ >> -> - let (pl, e) = + let (pl, e') = match p with [ <:patt< ($_$ : $_$) >> -> ([], e) | _ -> expr_fun_args e ] in - match (p, e) with - [ (<:patt< $lid:_$ >>, <:expr< ($e$ : $t$) >>) -> + match (p, e') with + [ (<:patt< $lid:_$ >>, <:expr< ($e'$ : $t$) >>) -> pp f "%a :@ %a =@ %a" - (list o#fun_binding "@ ") [`patt p::pl] o#ctyp t o#expr e - | _ -> pp f "%a @[<0>%a=@]@ %a" o#simple_patt - p (list' o#fun_binding "" "@ ") pl o#expr e ] + (list o#fun_binding "@ ") [`patt p::pl] o#ctyp t o#expr e' + | (<:patt< $lid:_$ >>, _) -> + pp f "%a @[<0>%a=@]@ %a" o#simple_patt + p (list' o#fun_binding "" "@ ") pl o#expr e' + | _ -> + pp f "%a =@ %a" o#simple_patt p o#expr e ] | <:binding< $anti:s$ >> -> o#anti f s ]; method record_binding f bi = @@ -556,7 +560,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:expr< $int64:s$ >> -> o#numeric f s "L" | <:expr< $int32:s$ >> -> o#numeric f s "l" | <:expr< $flo:s$ >> -> o#numeric f s "" - | <:expr< $chr:s$ >> -> pp f "'%s'" s + | <:expr< $chr:s$ >> -> pp f "'%s'" (ocaml_char s) | <:expr< $id:i$ >> -> o#var_ident f i | <:expr< { $b$ } >> -> pp f "@[<hv0>@[<hv2>{%a@]@ }@]" o#record_binding b @@ -666,7 +670,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:patt< $int32:s$ >> -> o#numeric f s "l" | <:patt< $int:s$ >> -> o#numeric f s "" | <:patt< $flo:s$ >> -> o#numeric f s "" - | <:patt< $chr:s$ >> -> pp f "'%s'" s + | <:patt< $chr:s$ >> -> pp f "'%s'" (ocaml_char s) | <:patt< ~ $s$ >> -> pp f "~%s" s | <:patt< ` $uid:s$ >> -> pp f "`%a" o#var s | <:patt< # $i$ >> -> pp f "@[<2>#%a@]" o#ident i diff --git a/camlp4/Camlp4/Printers/OCamlr.ml b/camlp4/Camlp4/Printers/OCamlr.ml index b91f8ea7c9..33a85f3d0f 100644 --- a/camlp4/Camlp4/Printers/OCamlr.ml +++ b/camlp4/Camlp4/Printers/OCamlr.ml @@ -190,6 +190,8 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct } | <:ctyp< $t1$ : mutable $t2$ >> -> pp f "@[%a :@ mutable %a@]" o#ctyp t1 o#ctyp t2 + | <:ctyp< $t1$ == $t2$ >> -> + pp f "@[<2>%a ==@ %a@]" o#simple_ctyp t1 o#ctyp t2 | t -> super#ctyp f t ]; method simple_ctyp f t = diff --git a/camlp4/Camlp4/Sig.ml b/camlp4/Camlp4/Sig.ml index 507fb7008c..bae3da5ad1 100644 --- a/camlp4/Camlp4/Sig.ml +++ b/camlp4/Camlp4/Sig.ml @@ -64,6 +64,16 @@ end; (** A signature for locations. *) module type Loc = sig + (** The type of locations. Note that, as for OCaml locations, + character numbers in locations refer to character numbers in the + parsed character stream, while line numbers refer to line + numbers in the source file. The source file and the parsed + character stream differ, for instance, when the parsed character + stream contains a line number directive. The line number + directive will only update the file-name field and the + line-number field of the position. It makes therefore no sense + to use character numbers with the source file if the sources + contain line number directives. *) type t; (** Return a start location for the given file name. @@ -96,7 +106,8 @@ module type Loc = sig stop_line, stop_bol, stop_off, ghost)]. *) value to_tuple : t -> (string * int * int * int * int * int * int * bool); - (** [merge loc1 loc2] Return a location that starts at [loc1] and end at [loc2]. *) + (** [merge loc1 loc2] Return a location that starts at [loc1] and end at + [loc2]. *) value merge : t -> t -> t; (** The stop pos becomes equal to the start pos. *) @@ -128,19 +139,19 @@ module type Loc = sig (** Return the line number of the ending of this location. *) value stop_line : t -> int; - (** Returns the number of characters from the begining of the file + (** Returns the number of characters from the begining of the stream to the begining of the line of location's begining. *) value start_bol : t -> int; - (** Returns the number of characters from the begining of the file + (** Returns the number of characters from the begining of the stream to the begining of the line of location's ending. *) value stop_bol : t -> int; - (** Returns the number of characters from the begining of the file + (** Returns the number of characters from the begining of the stream of the begining of this location. *) value start_off : t -> int; - (** Return the number of characters from the begining of the file + (** Return the number of characters from the begining of the stream of the ending of this location. *) value stop_off : t -> int; diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml index 0200d18969..c9e94154af 100644 --- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml +++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml @@ -57,6 +57,8 @@ module Make (Ast : Sig.Camlp4Ast) = struct value mkloc = Loc.to_ocaml_location; value mkghloc loc = Loc.to_ocaml_location (Loc.ghostify loc); + value with_loc txt loc = Camlp4_import.Location.mkloc txt (mkloc loc); + value mktyp loc d = {ptyp_desc = d; ptyp_loc = mkloc loc}; value mkpat loc d = {ppat_desc = d; ppat_loc = mkloc loc}; value mkghpat loc d = {ppat_desc = d; ppat_loc = mkghloc loc}; @@ -67,7 +69,10 @@ module Make (Ast : Sig.Camlp4Ast) = struct value mkstr loc d = {pstr_desc = d; pstr_loc = mkloc loc}; value mkfield loc d = {pfield_desc = d; pfield_loc = mkloc loc}; value mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc}; - value mkpcl loc d = {pcl_desc = d; pcl_loc = mkloc loc}; + value mkcl loc d = {pcl_desc = d; pcl_loc = mkloc loc}; + value mkcf loc d = { pcf_desc = d; pcf_loc = mkloc loc; }; + value mkctf loc d = { pctf_desc = d; pctf_loc = mkloc loc; }; + value mkpolytype t = match t.ptyp_desc with [ Ptyp_poly _ _ -> t @@ -85,6 +90,9 @@ module Make (Ast : Sig.Camlp4Ast) = struct | _ -> assert False ]; value lident s = Lident s; + value lident_with_loc s loc = with_loc (Lident s) loc; + + value ldot l s = Ldot l s; value lapply l s = Lapply l s; @@ -106,17 +114,17 @@ module Make (Ast : Sig.Camlp4Ast) = struct } ; - value array_function str name = + value array_function_no_loc str name = ldot (lident str) (if Camlp4_config.unsafe.val then "unsafe_" ^ name else name) ; - + value array_function loc str name = with_loc (array_function_no_loc str name) loc; value mkrf = fun [ <:rec_flag< rec >> -> Recursive | <:rec_flag<>> -> Nonrecursive | _ -> assert False ]; - value mkli s = loop lident + value mkli sloc s list = with_loc (loop lident list) sloc where rec loop f = fun [ [i :: il] -> loop (ldot (f i)) il @@ -133,7 +141,9 @@ module Make (Ast : Sig.Camlp4Ast) = struct let rec self i acc = match i with - [ <:ident< $i1$.$i2$ >> -> + [ <:ident< $lid:"*predef*"$.$lid:"option"$ >> -> + (ldot (lident "*predef*") "option", `lident) + | <:ident< $i1$.$i2$ >> -> self i2 (Some (self i1 acc)) | <:ident< $i1$ $i2$ >> -> let i' = Lapply (fst (self i1 None)) (fst (self i2 None)) in @@ -159,18 +169,20 @@ module Make (Ast : Sig.Camlp4Ast) = struct | _ -> error (loc_of_ident i) "invalid long identifier" ] in self i None; - value ident ?conv_lid i = fst (ident_tag ?conv_lid i); + value ident_noloc ?conv_lid i = fst (ident_tag ?conv_lid i); + value ident ?conv_lid i = + with_loc (ident_noloc ?conv_lid i) (loc_of_ident i); - value long_lident msg i = - match ident_tag i with - [ (i, `lident) -> i - | _ -> error (loc_of_ident i) msg ] + value long_lident msg id = + match ident_tag id with + [ (i, `lident) -> with_loc i (loc_of_ident id) + | _ -> error (loc_of_ident id) msg ] ; value long_type_ident = long_lident "invalid long identifier type"; value long_class_ident = long_lident "invalid class name"; - value long_uident ?(conv_con = fun x -> x) i = + value long_uident_noloc ?(conv_con = fun x -> x) i = match ident_tag i with [ (Ldot i s, `uident) -> ldot i (conv_con s) | (Lident s, `uident) -> lident (conv_con s) @@ -178,9 +190,12 @@ module Make (Ast : Sig.Camlp4Ast) = struct | _ -> error (loc_of_ident i) "uppercase identifier expected" ] ; + value long_uident ?conv_con i = + with_loc (long_uident_noloc ?conv_con i) (loc_of_ident i); + value rec ctyp_long_id_prefix t = match t with - [ <:ctyp< $id:i$ >> -> ident i + [ <:ctyp< $id:i$ >> -> ident_noloc i | <:ctyp< $m1$ $m2$ >> -> let li1 = ctyp_long_id_prefix m1 in let li2 = ctyp_long_id_prefix m2 in @@ -204,6 +219,9 @@ module Make (Ast : Sig.Camlp4Ast) = struct | <:ctyp< '$s$ >> -> [s] | _ -> assert False ]; + value predef_option loc = + TyId (loc, IdAcc (loc, IdLid (loc, "*predef*"), IdLid (loc, "option"))); + value rec ctyp = fun [ TyId loc i -> @@ -226,7 +244,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct | TyArr loc (TyLab _ lab t1) t2 -> mktyp loc (Ptyp_arrow lab (ctyp t1) (ctyp t2)) | TyArr loc (TyOlb loc1 lab t1) t2 -> - let t1 = TyApp loc1 <:ctyp@loc1< option >> t1 in + let t1 = TyApp loc1 (predef_option loc1) t1 in mktyp loc (Ptyp_arrow ("?" ^ lab) (ctyp t1) (ctyp t2)) | TyArr loc t1 t2 -> mktyp loc (Ptyp_arrow "" (ctyp t1) (ctyp t2)) | <:ctyp@loc< < $fl$ > >> -> mktyp loc (Ptyp_object (meth_list fl [])) @@ -261,7 +279,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct | TyAnt loc _ -> error loc "antiquotation not allowed here" | TyOfAmp _ _ _ |TyAmp _ _ _ |TySta _ _ _ | TyCom _ _ _ |TyVrn _ _ |TyQuM _ _ |TyQuP _ _ |TyDcl _ _ _ _ _ | - TyAnP _ | TyAnM _ | TyTypePol _ _ _ | + TyAnP _ | TyAnM _ | TyTypePol _ _ _ | TyObj _ _ (RvAnt _) | TyNil _ | TyTup _ _ -> assert False ] and row_field = fun @@ -313,20 +331,21 @@ module Make (Ast : Sig.Camlp4Ast) = struct | _ -> assert False ]; value mktrecord = fun - [ <:ctyp@loc< $lid:s$ : mutable $t$ >> -> - (s, Mutable, mkpolytype (ctyp t), mkloc loc) - | <:ctyp@loc< $lid:s$ : $t$ >> -> - (s, Immutable, mkpolytype (ctyp t), mkloc loc) + [ <:ctyp@loc< $id:(<:ident@sloc< $lid:s$ >>)$ : mutable $t$ >> -> + (with_loc s sloc, Mutable, mkpolytype (ctyp t), mkloc loc) + | <:ctyp@loc< $id:(<:ident@sloc< $lid:s$ >>)$ : $t$ >> -> + (with_loc s sloc, Immutable, mkpolytype (ctyp t), mkloc loc) | _ -> assert False (*FIXME*) ]; value mkvariant = fun - [ <:ctyp@loc< $uid:s$ >> -> (conv_con s, [], None, mkloc loc) - | <:ctyp@loc< $uid:s$ of $t$ >> -> - (conv_con s, List.map ctyp (list_of_ctyp t []), None, mkloc loc) - | <:ctyp@loc< $uid:s$ : ($t$ -> $u$) >> -> - (conv_con s, List.map ctyp (list_of_ctyp t []), Some (ctyp u), mkloc loc) - | <:ctyp@loc< $uid:s$ : $t$ >> -> - (conv_con s, [], Some (ctyp t), mkloc loc) + [ <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ >> -> + (with_loc (conv_con s) sloc, [], None, mkloc loc) + | <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ of $t$ >> -> + (with_loc (conv_con s) sloc, List.map ctyp (list_of_ctyp t []), None, mkloc loc) + | <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ : ($t$ -> $u$) >> -> + (with_loc (conv_con s) sloc, List.map ctyp (list_of_ctyp t []), Some (ctyp u), mkloc loc) + | <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ : $t$ >> -> + (with_loc (conv_con s) sloc, [], Some (ctyp t), mkloc loc) | _ -> assert False (*FIXME*) ]; value rec type_decl tl cl loc m pflag = @@ -354,7 +373,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct value type_decl tl cl t loc = type_decl tl cl loc None False t; - value mkvalue_desc t p = {pval_type = ctyp t; pval_prim = p}; + value mkvalue_desc loc t p = {pval_type = ctyp t; pval_prim = p; pval_loc = mkloc loc}; value rec list_of_meta_list = fun @@ -390,20 +409,20 @@ module Make (Ast : Sig.Camlp4Ast) = struct value rec optional_type_parameters t acc = match t with [ <:ctyp< $t1$ $t2$ >> -> optional_type_parameters t1 (optional_type_parameters t2 acc) - | <:ctyp< +'$s$ >> -> [(Some s, (True, False)) :: acc] + | <:ctyp@loc< +'$s$ >> -> [(Some (with_loc s loc), (True, False)) :: acc] | Ast.TyAnP _loc -> [(None, (True, False)) :: acc] - | <:ctyp< -'$s$ >> -> [(Some s, (False, True)) :: acc] + | <:ctyp@loc< -'$s$ >> -> [(Some (with_loc s loc), (False, True)) :: acc] | Ast.TyAnM _loc -> [(None, (False, True)) :: acc] - | <:ctyp< '$s$ >> -> [(Some s, (False, False)) :: acc] + | <:ctyp@loc< '$s$ >> -> [(Some (with_loc s loc), (False, False)) :: acc] | Ast.TyAny _loc -> [(None, (False, False)) :: acc] | _ -> assert False ]; value rec class_parameters t acc = match t with [ <:ctyp< $t1$, $t2$ >> -> class_parameters t1 (class_parameters t2 acc) - | <:ctyp< +'$s$ >> -> [(s, (True, False)) :: acc] - | <:ctyp< -'$s$ >> -> [(s, (False, True)) :: acc] - | <:ctyp< '$s$ >> -> [(s, (False, False)) :: acc] + | <:ctyp@loc< +'$s$ >> -> [(with_loc s loc, (True, False)) :: acc] + | <:ctyp@loc< -'$s$ >> -> [(with_loc s loc, (False, True)) :: acc] + | <:ctyp@loc< '$s$ >> -> [(with_loc s loc, (False, False)) :: acc] | _ -> assert False ]; value rec type_parameters_and_type_name t acc = @@ -465,7 +484,8 @@ module Make (Ast : Sig.Camlp4Ast) = struct value rec patt = fun - [ <:patt@loc< $lid:s$ >> -> mkpat loc (Ppat_var s) + [ <:patt@loc< $id:(<:ident@sloc< $lid:s$ >>)$ >> -> + mkpat loc (Ppat_var (with_loc s sloc)) | <:patt@loc< $id:i$ >> -> let p = Ppat_construct (long_uident ~conv_con i) None (constructors_arity ()) @@ -473,15 +493,15 @@ module Make (Ast : Sig.Camlp4Ast) = struct | PaAli loc p1 p2 -> let (p, i) = match (p1, p2) with - [ (p, <:patt< $lid:s$ >>) -> (p, s) - | (<:patt< $lid:s$ >>, p) -> (p, s) + [ (p, <:patt< $id:(<:ident@sloc< $lid:s$ >>)$ >>) -> (p, with_loc s sloc) + | (<:patt< $id:(<:ident@sloc< $lid:s$ >>)$ >>, p) -> (p, with_loc s sloc) | _ -> error loc "invalid alias pattern" ] in mkpat loc (Ppat_alias (patt p) i) | PaAnt loc _ -> error loc "antiquotation not allowed here" | PaAny loc -> mkpat loc Ppat_any - | <:patt@loc< $uid:s$ ($tup:<:patt@loc_any< _ >>$) >> -> - mkpat loc (Ppat_construct (lident (conv_con s)) + | <:patt@loc< $id:(<:ident@sloc< $uid:s$ >>)$ ($tup:<:patt@loc_any< _ >>$) >> -> + mkpat loc (Ppat_construct (lident_with_loc (conv_con s) sloc) (Some (mkpat loc_any Ppat_any)) False) | PaApp loc _ _ as f -> let (f, al) = patt_fa [] f in @@ -553,9 +573,9 @@ module Make (Ast : Sig.Camlp4Ast) = struct | <:patt@loc< ($tup:_$) >> -> error loc "singleton tuple pattern" | PaTyc loc p t -> mkpat loc (Ppat_constraint (patt p) (ctyp t)) | PaTyp loc i -> mkpat loc (Ppat_type (long_type_ident i)) - | PaVrn loc s -> mkpat loc (Ppat_variant s None) + | PaVrn loc s -> mkpat loc (Ppat_variant (conv_con s) None) | PaLaz loc p -> mkpat loc (Ppat_lazy (patt p)) - | PaMod loc m -> mkpat loc (Ppat_unpack m) + | PaMod loc m -> mkpat loc (Ppat_unpack (with_loc m loc)) | PaEq _ _ _ | PaSem _ _ _ | PaCom _ _ _ | PaNil _ as p -> error (loc_of_patt p) "invalid pattern" ] and mklabpat = @@ -607,50 +627,50 @@ module Make (Ast : Sig.Camlp4Ast) = struct [ <:ctyp<>> -> acc | t -> list_of_ctyp t acc ]; -value varify_constructors var_names = - let rec loop t = - let desc = +value varify_constructors var_names = + let rec loop t = + let desc = match t.ptyp_desc with - [ + [ Ptyp_any -> Ptyp_any | Ptyp_var x -> Ptyp_var x | Ptyp_arrow label core_type core_type' -> - Ptyp_arrow label (loop core_type) (loop core_type') + Ptyp_arrow label (loop core_type) (loop core_type') | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) - | Ptyp_constr (Lident s) [] when List.mem s var_names -> - Ptyp_var ("&" ^ s) + | Ptyp_constr ({ txt = Lident s }) [] when List.mem s var_names -> + Ptyp_var ("&" ^ s) | Ptyp_constr longident lst -> - Ptyp_constr longident (List.map loop lst) + Ptyp_constr longident (List.map loop lst) | Ptyp_object lst -> - Ptyp_object (List.map loop_core_field lst) + Ptyp_object (List.map loop_core_field lst) | Ptyp_class longident lst lbl_list -> - Ptyp_class (longident, List.map loop lst, lbl_list) + Ptyp_class (longident, List.map loop lst, lbl_list) | Ptyp_alias core_type string -> - Ptyp_alias(loop core_type, string) - | Ptyp_variant row_field_list flag lbl_lst_option -> - Ptyp_variant(List.map loop_row_field row_field_list, flag, lbl_lst_option) + Ptyp_alias(loop core_type, string) + | Ptyp_variant row_field_list flag lbl_lst_option -> + Ptyp_variant(List.map loop_row_field row_field_list, flag, lbl_lst_option) | Ptyp_poly string_lst core_type -> - Ptyp_poly(string_lst, loop core_type) + Ptyp_poly(string_lst, loop core_type) | Ptyp_package longident lst -> - Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) + Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) ] in {(t) with ptyp_desc = desc} - and loop_core_field t = - let desc = + and loop_core_field t = + let desc = match t.pfield_desc with [ Pfield(n,typ) -> - Pfield(n,loop typ) + Pfield(n,loop typ) | Pfield_var -> - Pfield_var] + Pfield_var] in { (t) with pfield_desc=desc} - and loop_row_field x = + and loop_row_field x = match x with [ Rtag(label,flag,lst) -> - Rtag(label,flag,List.map loop lst) + Rtag(label,flag,List.map loop lst) | Rinherit t -> - Rinherit (loop t) ] + Rinherit (loop t) ] in loop; @@ -660,15 +680,15 @@ value varify_constructors var_names = fun [ <:expr@loc< $x$.val >> -> mkexp loc - (Pexp_apply (mkexp loc (Pexp_ident (Lident "!"))) [("", expr x)]) + (Pexp_apply (mkexp loc (Pexp_ident (lident_with_loc "!" loc))) [("", expr x)]) | ExAcc loc _ _ | <:expr@loc< $id:<:ident< $_$ . $_$ >>$ >> as e -> let (e, l) = match sep_expr_acc [] e with - [ [(loc, ml, <:expr< $uid:s$ >>) :: l] -> + [ [(loc, ml, <:expr@sloc< $uid:s$ >>) :: l] -> let ca = constructors_arity () in - (mkexp loc (Pexp_construct (mkli (conv_con s) ml) None ca), l) - | [(loc, ml, <:expr< $lid:s$ >>) :: l] -> - (mkexp loc (Pexp_ident (mkli s ml)), l) + (mkexp loc (Pexp_construct (mkli sloc (conv_con s) ml) None ca), l) + | [(loc, ml, <:expr@sloc< $lid:s$ >>) :: l] -> + (mkexp loc (Pexp_ident (mkli sloc s ml)), l) | [(_, [], e) :: l] -> (expr e, l) | _ -> error loc "bad ast in expression" ] in @@ -676,9 +696,9 @@ value varify_constructors var_names = List.fold_left (fun (loc_bp, e1) (loc_ep, ml, e2) -> match e2 with - [ <:expr< $lid:s$ >> -> + [ <:expr@sloc< $lid:s$ >> -> let loc = Loc.merge loc_bp loc_ep - in (loc, mkexp loc (Pexp_field e1 (mkli (conv_lab s) ml))) + in (loc, mkexp loc (Pexp_field e1 (mkli sloc (conv_lab s) ml))) | _ -> error (loc_of_expr e2) "lowercase identifier expected" ]) (loc, e) l in @@ -712,7 +732,7 @@ value varify_constructors var_names = | _ -> mkexp loc (Pexp_apply (expr f) al) ] | ExAre loc e1 e2 -> mkexp loc - (Pexp_apply (mkexp loc (Pexp_ident (array_function "Array" "get"))) + (Pexp_apply (mkexp loc (Pexp_ident (array_function loc "Array" "get"))) [("", expr e1); ("", expr e2)]) | ExArr loc e -> mkexp loc (Pexp_array (List.map expr (list_of_expr e []))) | ExAsf loc -> mkexp loc Pexp_assertfalse @@ -720,19 +740,19 @@ value varify_constructors var_names = let e = match e with [ <:expr@loc< $x$.val >> -> - Pexp_apply (mkexp loc (Pexp_ident (Lident ":="))) + Pexp_apply (mkexp loc (Pexp_ident (lident_with_loc ":=" loc))) [("", expr x); ("", expr v)] | ExAcc loc _ _ -> match (expr e).pexp_desc with [ Pexp_field e lab -> Pexp_setfield e lab (expr v) | _ -> error loc "bad record access" ] - | ExAre _ e1 e2 -> - Pexp_apply (mkexp loc (Pexp_ident (array_function "Array" "set"))) + | ExAre loc e1 e2 -> + Pexp_apply (mkexp loc (Pexp_ident (array_function loc "Array" "set"))) [("", expr e1); ("", expr e2); ("", expr v)] - | <:expr< $lid:lab$ >> -> Pexp_setinstvar lab (expr v) - | ExSte _ e1 e2 -> + | <:expr< $id:(<:ident@lloc< $lid:lab$ >>)$ >> -> Pexp_setinstvar (with_loc lab lloc) (expr v) + | ExSte loc e1 e2 -> Pexp_apply - (mkexp loc (Pexp_ident (array_function "String" "set"))) + (mkexp loc (Pexp_ident (array_function loc "String" "set"))) [("", expr e1); ("", expr e2); ("", expr v)] | _ -> error loc "bad left part of assignment" ] in @@ -749,7 +769,7 @@ value varify_constructors var_names = | ExFlo loc s -> mkexp loc (Pexp_constant (Const_float (remove_underscores s))) | ExFor loc i e1 e2 df el -> let e3 = ExSeq loc el in - mkexp loc (Pexp_for i (expr e1) (expr e2) (mkdirection df) (expr e3)) + mkexp loc (Pexp_for (with_loc i loc) (expr e1) (expr e2) (mkdirection df) (expr e3)) | <:expr@loc< fun [ $PaLab _ lab po$ when $w$ -> $e$ ] >> -> mkexp loc (Pexp_function lab None @@ -785,7 +805,7 @@ value varify_constructors var_names = | ExLaz loc e -> mkexp loc (Pexp_lazy (expr e)) | ExLet loc rf bi e -> mkexp loc (Pexp_let (mkrf rf) (binding bi []) (expr e)) - | ExLmd loc i me e -> mkexp loc (Pexp_letmodule i (module_expr me) (expr e)) + | ExLmd loc i me e -> mkexp loc (Pexp_letmodule (with_loc i loc) (module_expr me) (expr e)) | ExMat loc e a -> mkexp loc (Pexp_match (expr e) (match_case a [])) | ExNew loc id -> mkexp loc (Pexp_new (long_type_ident id)) | ExObj loc po cfl -> @@ -795,7 +815,7 @@ value varify_constructors var_names = | p -> p ] in let cil = class_str_item cfl [] in - mkexp loc (Pexp_object (patt p, cil)) + mkexp loc (Pexp_object { pcstr_pat = patt p; pcstr_fields = cil }) | ExOlb loc _ _ -> error loc "labeled expression not allowed here" | ExOvr loc iel -> mkexp loc (Pexp_override (mkideexp iel [])) | ExRec loc lel eo -> @@ -820,7 +840,7 @@ value varify_constructors var_names = | ExSnd loc e s -> mkexp loc (Pexp_send (expr e) s) | ExSte loc e1 e2 -> mkexp loc - (Pexp_apply (mkexp loc (Pexp_ident (array_function "String" "get"))) + (Pexp_apply (mkexp loc (Pexp_ident (array_function loc "String" "get"))) [("", expr e1); ("", expr e2)]) | ExStr loc s -> mkexp loc (Pexp_constant (Const_string (string_of_string_token loc s))) @@ -830,13 +850,13 @@ value varify_constructors var_names = | <:expr@loc< ($tup:_$) >> -> error loc "singleton tuple" | ExTyc loc e t -> mkexp loc (Pexp_constraint (expr e) (Some (ctyp t)) None) | <:expr@loc< () >> -> - mkexp loc (Pexp_construct (lident "()") None True) + mkexp loc (Pexp_construct (lident_with_loc "()" loc) None True) | <:expr@loc< $lid:s$ >> -> - mkexp loc (Pexp_ident (lident s)) + mkexp loc (Pexp_ident (lident_with_loc s loc)) | <:expr@loc< $uid:s$ >> -> (* let ca = constructors_arity () in *) - mkexp loc (Pexp_construct (lident (conv_con s)) None True) - | ExVrn loc s -> mkexp loc (Pexp_variant s None) + mkexp loc (Pexp_construct (lident_with_loc (conv_con s) loc) None True) + | ExVrn loc s -> mkexp loc (Pexp_variant (conv_con s) None) | ExWhi loc e1 el -> let e2 = ExSeq loc el in mkexp loc (Pexp_while (expr e1) (expr e2)) @@ -870,13 +890,13 @@ value varify_constructors var_names = match x with [ <:binding< $x$ and $y$ >> -> binding x (binding y acc) - | <:binding@_loc< $lid:bind_name$ = ($e$ : $TyTypePol _ vs ty$) >> -> + | <:binding@_loc< $pat:( <:patt@sloc< $lid:bind_name$ >> )$ = ($e$ : $TyTypePol _ vs ty$) >> -> (* this code is not pretty because it is temporary *) - let rec id_to_string x = - match x with - [ <:ctyp< $lid:x$ >> -> [x] - | <:ctyp< $x$ $y$ >> -> (id_to_string x) @ (id_to_string y) - | _ -> assert False] + let rec id_to_string x = + match x with + [ <:ctyp< $lid:x$ >> -> [x] + | <:ctyp< $x$ $y$ >> -> (id_to_string x) @ (id_to_string y) + | _ -> assert False] in let vars = id_to_string vs in let ampersand_vars = List.map (fun x -> "&" ^ x) vars in @@ -884,15 +904,16 @@ value varify_constructors var_names = let mkexp = mkexp _loc in let mkpat = mkpat _loc in let e = mkexp (Pexp_constraint (expr e) (Some (ctyp ty)) None) in - let rec mk_newtypes x = - match x with - [ [newtype :: []] -> mkexp (Pexp_newtype(newtype, e)) - | [newtype :: newtypes] -> - mkexp(Pexp_newtype (newtype,mk_newtypes newtypes)) - | [] -> assert False] + let rec mk_newtypes x = + match x with + [ [newtype :: []] -> mkexp (Pexp_newtype(newtype, e)) + | [newtype :: newtypes] -> + mkexp(Pexp_newtype (newtype,mk_newtypes newtypes)) + | [] -> assert False] in - let pat = - mkpat (Ppat_constraint (mkpat (Ppat_var bind_name), mktyp _loc (Ptyp_poly ampersand_vars ty'))) + let pat = + mkpat (Ppat_constraint (mkpat (Ppat_var (with_loc bind_name sloc)), + mktyp _loc (Ptyp_poly ampersand_vars ty'))) in let e = mk_newtypes vars in [( pat, e) :: acc] @@ -923,13 +944,13 @@ value varify_constructors var_names = [ <:rec_binding<>> -> acc | <:rec_binding< $x$; $y$ >> -> mkideexp x (mkideexp y acc) - | <:rec_binding< $lid:s$ = $e$ >> -> [(s, expr e) :: acc] + | <:rec_binding< $id:( <:ident@sloc< $lid:s$ >>)$ = $e$ >> -> [(with_loc s sloc, expr e) :: acc] | _ -> assert False ] and mktype_decl x acc = match x with [ <:ctyp< $x$ and $y$ >> -> mktype_decl x (mktype_decl y acc) - | Ast.TyDcl loc c tl td cl -> + | Ast.TyDcl cloc c tl td cl -> let cl = List.map (fun (t1, t2) -> @@ -937,14 +958,15 @@ value varify_constructors var_names = (ctyp t1, ctyp t2, mkloc loc)) cl in - [(c, type_decl (List.fold_right optional_type_parameters tl []) cl td loc) :: acc] + [(with_loc c cloc, + type_decl (List.fold_right optional_type_parameters tl []) cl td cloc) :: acc] | _ -> assert False ] and module_type = fun [ <:module_type@loc<>> -> error loc "abstract/nil module type not allowed here" | <:module_type@loc< $id:i$ >> -> mkmty loc (Pmty_ident (long_uident i)) | <:module_type@loc< functor ($n$ : $nt$) -> $mt$ >> -> - mkmty loc (Pmty_functor n (module_type nt) (module_type mt)) + mkmty loc (Pmty_functor (with_loc n loc) (module_type nt) (module_type mt)) | <:module_type@loc< '$_$ >> -> error loc "module type variable not allowed here" | <:module_type@loc< sig $sl$ end >> -> mkmty loc (Pmty_signature (sig_item sl [])) @@ -965,14 +987,14 @@ value varify_constructors var_names = | <:sig_item< $sg1$; $sg2$ >> -> sig_item sg1 (sig_item sg2 l) | SgDir _ _ _ -> l | <:sig_item@loc< exception $uid:s$ >> -> - [mksig loc (Psig_exception (conv_con s) []) :: l] + [mksig loc (Psig_exception (with_loc (conv_con s) loc) []) :: l] | <:sig_item@loc< exception $uid:s$ of $t$ >> -> - [mksig loc (Psig_exception (conv_con s) + [mksig loc (Psig_exception (with_loc (conv_con s) loc) (List.map ctyp (list_of_ctyp t []))) :: l] | SgExc _ _ -> assert False (*FIXME*) - | SgExt loc n t sl -> [mksig loc (Psig_value n (mkvalue_desc t (list_of_meta_list sl))) :: l] + | SgExt loc n t sl -> [mksig loc (Psig_value (with_loc n loc) (mkvalue_desc loc t (list_of_meta_list sl))) :: l] | SgInc loc mt -> [mksig loc (Psig_include (module_type mt)) :: l] - | SgMod loc n mt -> [mksig loc (Psig_module n (module_type mt)) :: l] + | SgMod loc n mt -> [mksig loc (Psig_module (with_loc n loc) (module_type mt)) :: l] | SgRecMod loc mb -> [mksig loc (Psig_recmodule (module_sig_binding mb [])) :: l] | SgMty loc n mt -> @@ -981,25 +1003,25 @@ value varify_constructors var_names = [ MtQuo _ _ -> Pmodtype_abstract | _ -> Pmodtype_manifest (module_type mt) ] in - [mksig loc (Psig_modtype n si) :: l] + [mksig loc (Psig_modtype (with_loc n loc) si) :: l] | SgOpn loc id -> [mksig loc (Psig_open (long_uident id)) :: l] | SgTyp loc tdl -> [mksig loc (Psig_type (mktype_decl tdl [])) :: l] - | SgVal loc n t -> [mksig loc (Psig_value n (mkvalue_desc t [])) :: l] + | SgVal loc n t -> [mksig loc (Psig_value (with_loc n loc) (mkvalue_desc loc t [])) :: l] | <:sig_item@loc< $anti:_$ >> -> error loc "antiquotation in sig_item" ] and module_sig_binding x acc = match x with [ <:module_binding< $x$ and $y$ >> -> module_sig_binding x (module_sig_binding y acc) - | <:module_binding< $s$ : $mt$ >> -> - [(s, module_type mt) :: acc] + | <:module_binding@loc< $s$ : $mt$ >> -> + [(with_loc s loc, module_type mt) :: acc] | _ -> assert False ] and module_str_binding x acc = match x with [ <:module_binding< $x$ and $y$ >> -> module_str_binding x (module_str_binding y acc) - | <:module_binding< $s$ : $mt$ = $me$ >> -> - [(s, module_type mt, module_expr me) :: acc] + | <:module_binding@loc< $s$ : $mt$ = $me$ >> -> + [(with_loc s loc, module_type mt, module_expr me) :: acc] | _ -> assert False ] and module_expr = fun @@ -1008,7 +1030,7 @@ value varify_constructors var_names = | <:module_expr@loc< $me1$ $me2$ >> -> mkmod loc (Pmod_apply (module_expr me1) (module_expr me2)) | <:module_expr@loc< functor ($n$ : $mt$) -> $me$ >> -> - mkmod loc (Pmod_functor n (module_type mt) (module_expr me)) + mkmod loc (Pmod_functor (with_loc n loc) (module_type mt) (module_expr me)) | <:module_expr@loc< struct $sl$ end >> -> mkmod loc (Pmod_structure (str_item sl [])) | <:module_expr@loc< ($me$ : $mt$) >> -> @@ -1033,22 +1055,22 @@ value varify_constructors var_names = | <:str_item< $st1$; $st2$ >> -> str_item st1 (str_item st2 l) | StDir _ _ _ -> l | <:str_item@loc< exception $uid:s$ >> -> - [mkstr loc (Pstr_exception (conv_con s) []) :: l ] + [mkstr loc (Pstr_exception (with_loc (conv_con s) loc) []) :: l ] | <:str_item@loc< exception $uid:s$ of $t$ >> -> - [mkstr loc (Pstr_exception (conv_con s) + [mkstr loc (Pstr_exception (with_loc (conv_con s) loc) (List.map ctyp (list_of_ctyp t []))) :: l ] | <:str_item@loc< exception $uid:s$ = $i$ >> -> - [mkstr loc (Pstr_exn_rebind (conv_con s) (ident i)) :: l ] + [mkstr loc (Pstr_exn_rebind (with_loc (conv_con s) loc) (ident i)) :: l ] | <:str_item@loc< exception $uid:_$ of $_$ = $_$ >> -> error loc "type in exception alias" | StExc _ _ _ -> assert False (*FIXME*) | StExp loc e -> [mkstr loc (Pstr_eval (expr e)) :: l] - | StExt loc n t sl -> [mkstr loc (Pstr_primitive n (mkvalue_desc t (list_of_meta_list sl))) :: l] + | StExt loc n t sl -> [mkstr loc (Pstr_primitive (with_loc n loc) (mkvalue_desc loc t (list_of_meta_list sl))) :: l] | StInc loc me -> [mkstr loc (Pstr_include (module_expr me)) :: l] - | StMod loc n me -> [mkstr loc (Pstr_module n (module_expr me)) :: l] + | StMod loc n me -> [mkstr loc (Pstr_module (with_loc n loc) (module_expr me)) :: l] | StRecMod loc mb -> [mkstr loc (Pstr_recmodule (module_str_binding mb [])) :: l] - | StMty loc n mt -> [mkstr loc (Pstr_modtype n (module_type mt)) :: l] + | StMty loc n mt -> [mkstr loc (Pstr_modtype (with_loc n loc) (module_type mt)) :: l] | StOpn loc id -> [mkstr loc (Pstr_open (long_uident id)) :: l] | StTyp loc tdl -> [mkstr loc (Pstr_type (mktype_decl tdl [])) :: l] @@ -1063,7 +1085,7 @@ value varify_constructors var_names = | CtFun loc (TyLab _ lab t) ct -> mkcty loc (Pcty_fun lab (ctyp t) (class_type ct)) | CtFun loc (TyOlb loc1 lab t) ct -> - let t = TyApp loc1 <:ctyp@loc1< option >> t in + let t = TyApp loc1 (predef_option loc1) t in mkcty loc (Pcty_fun ("?" ^ lab) (ctyp t) (class_type ct)) | CtFun loc t ct -> mkcty loc (Pcty_fun "" (ctyp t) (class_type ct)) | CtSig loc t_o ctfl -> @@ -1073,7 +1095,11 @@ value varify_constructors var_names = | t -> t ] in let cil = class_sig_item ctfl [] in - mkcty loc (Pcty_signature (ctyp t, cil)) + mkcty loc (Pcty_signature { + pcsig_self = ctyp t; + pcsig_fields = cil; + pcsig_loc = mkloc loc; + }) | CtCon loc _ _ _ -> error loc "invalid virtual class inside a class type" | CtAnt _ _ | CtEq _ _ _ | CtCol _ _ _ | CtAnd _ _ _ | CtNil _ -> @@ -1081,7 +1107,7 @@ value varify_constructors var_names = and class_info_class_expr ci = match ci with - [ CeEq _ (CeCon loc vir (IdLid _ name) params) ce -> + [ CeEq _ (CeCon loc vir (IdLid nloc name) params) ce -> let (loc_params, (params, variance)) = match params with [ <:ctyp<>> -> (loc, ([], [])) @@ -1089,15 +1115,15 @@ value varify_constructors var_names = in {pci_virt = mkvirtual vir; pci_params = (params, mkloc loc_params); - pci_name = name; + pci_name = with_loc name nloc; pci_expr = class_expr ce; pci_loc = mkloc loc; pci_variance = variance} | ce -> error (loc_of_class_expr ce) "bad class definition" ] and class_info_class_type ci = match ci with - [ CtEq _ (CtCon loc vir (IdLid _ name) params) ct | - CtCol _ (CtCon loc vir (IdLid _ name) params) ct -> + [ CtEq _ (CtCon loc vir (IdLid nloc name) params) ct | + CtCol _ (CtCon loc vir (IdLid nloc name) params) ct -> let (loc_params, (params, variance)) = match params with [ <:ctyp<>> -> (loc, ([], [])) @@ -1105,7 +1131,7 @@ value varify_constructors var_names = in {pci_virt = mkvirtual vir; pci_params = (params, mkloc loc_params); - pci_name = name; + pci_name = with_loc name nloc; pci_expr = class_type ct; pci_loc = mkloc loc; pci_variance = variance} @@ -1114,39 +1140,39 @@ value varify_constructors var_names = and class_sig_item c l = match c with [ <:class_sig_item<>> -> l - | CgCtr loc t1 t2 -> [Pctf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l] + | CgCtr loc t1 t2 -> [mkctf loc (Pctf_cstr (ctyp t1, ctyp t2)) :: l] | <:class_sig_item< $csg1$; $csg2$ >> -> class_sig_item csg1 (class_sig_item csg2 l) - | CgInh _ ct -> [Pctf_inher (class_type ct) :: l] + | CgInh loc ct -> [mkctf loc (Pctf_inher (class_type ct)) :: l] | CgMth loc s pf t -> - [Pctf_meth (s, mkprivate pf, mkpolytype (ctyp t), mkloc loc) :: l] + [mkctf loc (Pctf_meth (s, mkprivate pf, mkpolytype (ctyp t))) :: l] | CgVal loc s b v t -> - [Pctf_val (s, mkmutable b, mkvirtual v, ctyp t, mkloc loc) :: l] + [mkctf loc (Pctf_val (s, mkmutable b, mkvirtual v, ctyp t)) :: l] | CgVir loc s b t -> - [Pctf_virt (s, mkprivate b, mkpolytype (ctyp t), mkloc loc) :: l] + [mkctf loc (Pctf_virt (s, mkprivate b, mkpolytype (ctyp t))) :: l] | CgAnt _ _ -> assert False ] and class_expr = fun [ CeApp loc _ _ as c -> let (ce, el) = class_expr_fa [] c in let el = List.map label_expr el in - mkpcl loc (Pcl_apply (class_expr ce) el) + mkcl loc (Pcl_apply (class_expr ce) el) | CeCon loc ViNil id tl -> - mkpcl loc + mkcl loc (Pcl_constr (long_class_ident id) (List.map ctyp (list_of_opt_ctyp tl []))) | CeFun loc (PaLab _ lab po) ce -> - mkpcl loc + mkcl loc (Pcl_fun lab None (patt_of_lab loc lab po) (class_expr ce)) | CeFun loc (PaOlbi _ lab p e) ce -> let lab = paolab lab p in - mkpcl loc (Pcl_fun ("?" ^ lab) (Some (expr e)) (patt p) (class_expr ce)) + mkcl loc (Pcl_fun ("?" ^ lab) (Some (expr e)) (patt p) (class_expr ce)) | CeFun loc (PaOlb _ lab p) ce -> let lab = paolab lab p in - mkpcl loc + mkcl loc (Pcl_fun ("?" ^ lab) None (patt_of_lab loc lab p) (class_expr ce)) - | CeFun loc p ce -> mkpcl loc (Pcl_fun "" None (patt p) (class_expr ce)) + | CeFun loc p ce -> mkcl loc (Pcl_fun "" None (patt p) (class_expr ce)) | CeLet loc rf bi ce -> - mkpcl loc (Pcl_let (mkrf rf) (binding bi []) (class_expr ce)) + mkcl loc (Pcl_let (mkrf rf) (binding bi []) (class_expr ce)) | CeStr loc po cfl -> let p = match po with @@ -1154,35 +1180,38 @@ value varify_constructors var_names = | p -> p ] in let cil = class_str_item cfl [] in - mkpcl loc (Pcl_structure (patt p, cil)) + mkcl loc (Pcl_structure { + pcstr_pat = patt p; + pcstr_fields = cil; + }) | CeTyc loc ce ct -> - mkpcl loc (Pcl_constraint (class_expr ce) (class_type ct)) + mkcl loc (Pcl_constraint (class_expr ce) (class_type ct)) | CeCon loc _ _ _ -> error loc "invalid virtual class inside a class expression" | CeAnt _ _ | CeEq _ _ _ | CeAnd _ _ _ | CeNil _ -> assert False ] and class_str_item c l = match c with [ CrNil _ -> l - | CrCtr loc t1 t2 -> [Pcf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l] + | CrCtr loc t1 t2 -> [mkcf loc (Pcf_constr (ctyp t1, ctyp t2)) :: l] | <:class_str_item< $cst1$; $cst2$ >> -> class_str_item cst1 (class_str_item cst2 l) | CrInh loc ov ce pb -> let opb = if pb = "" then None else Some pb in - [Pcf_inher (override_flag loc ov) (class_expr ce) opb :: l] - | CrIni _ e -> [Pcf_init (expr e) :: l] + [mkcf loc (Pcf_inher (override_flag loc ov) (class_expr ce) opb) :: l] + | CrIni loc e -> [mkcf loc (Pcf_init (expr e)) :: l] | CrMth loc s ov pf e t -> let t = match t with [ <:ctyp<>> -> None | t -> Some (mkpolytype (ctyp t)) ] in let e = mkexp loc (Pexp_poly (expr e) t) in - [Pcf_meth (s, mkprivate pf, override_flag loc ov, e, mkloc loc) :: l] + [mkcf loc (Pcf_meth (with_loc s loc, mkprivate pf, override_flag loc ov, e)) :: l] | CrVal loc s ov mf e -> - [Pcf_val (s, mkmutable mf, override_flag loc ov, expr e, mkloc loc) :: l] + [mkcf loc (Pcf_val (with_loc s loc, mkmutable mf, override_flag loc ov, expr e)) :: l] | CrVir loc s pf t -> - [Pcf_virt (s, mkprivate pf, mkpolytype (ctyp t), mkloc loc) :: l] + [mkcf loc (Pcf_virt (with_loc s loc, mkprivate pf, mkpolytype (ctyp t))) :: l] | CrVvr loc s mf t -> - [Pcf_valvirt (s, mkmutable mf, ctyp t, mkloc loc) :: l] + [mkcf loc (Pcf_valvirt (with_loc s loc, mkmutable mf, ctyp t)) :: l] | CrAnt _ _ -> assert False ]; value sig_item ast = sig_item ast []; @@ -1195,7 +1224,7 @@ value varify_constructors var_names = | ExInt _ i -> Pdir_int (int_of_string i) | <:expr< True >> -> Pdir_bool True | <:expr< False >> -> Pdir_bool False - | e -> Pdir_ident (ident (ident_of_expr e)) ] + | e -> Pdir_ident (ident_noloc (ident_of_expr e)) ] ; value phrase = diff --git a/camlp4/Camlp4/Struct/Grammar/Parser.ml b/camlp4/Camlp4/Struct/Grammar/Parser.ml index 2c639b2a1c..48054e4df7 100644 --- a/camlp4/Camlp4/Struct/Grammar/Parser.ml +++ b/camlp4/Camlp4/Struct/Grammar/Parser.ml @@ -34,16 +34,14 @@ module Make (Structure : Structure.S) = struct value drop_prev_loc = Tools.drop_prev_loc; value add_loc bp parse_fun strm = - let count1 = Stream.count strm in let x = parse_fun strm in - let count2 = Stream.count strm in + let ep = loc_ep strm in let loc = - if count1 < count2 then - let ep = loc_ep strm in - Loc.merge bp ep - else + if Loc.start_off bp > Loc.stop_off ep then (* If nothing has been consumed, create a 0-length location. *) Loc.join bp + else + Loc.merge bp ep in (x, loc); diff --git a/camlp4/Camlp4/Struct/Lexer.mll b/camlp4/Camlp4/Struct/Lexer.mll index c73369959d..6d5099a8d0 100644 --- a/camlp4/Camlp4/Struct/Lexer.mll +++ b/camlp4/Camlp4/Struct/Lexer.mll @@ -180,9 +180,9 @@ module Make (Token : Sig.Camlp4Token) pos_lnum = if absolute then line else pos.pos_lnum + line; pos_bol = pos.pos_cnum - chars; } - + (* To convert integer literals, copied from "../parsing/lexer.mll" *) - + let cvt_int_literal s = - int_of_string ("-" ^ s) let cvt_int32_literal s = diff --git a/camlp4/Camlp4/Struct/Token.ml b/camlp4/Camlp4/Struct/Token.ml index 2620729728..701e990d55 100644 --- a/camlp4/Camlp4/Struct/Token.ml +++ b/camlp4/Camlp4/Struct/Token.ml @@ -211,7 +211,7 @@ module Eval = struct | [: `'b' :] -> '\b' | [: `'\\' :] -> '\\' | [: `'"' :] -> '"' - | [: `''' :] -> ''' + | [: `'\'' :] -> '\'' | [: `' ' :] -> ' ' | [: `('0'..'9' as c1); `('0'..'9' as c2); `('0'..'9' as c3) :] -> chr (100 * (valch c1) + 10 * (valch c2) + (valch c3)) diff --git a/camlp4/Camlp4Filters/Camlp4MetaGenerator.ml b/camlp4/Camlp4Filters/Camlp4MetaGenerator.ml index b716d5afdc..af338a2a16 100644 --- a/camlp4/Camlp4Filters/Camlp4MetaGenerator.ml +++ b/camlp4/Camlp4Filters/Camlp4MetaGenerator.ml @@ -161,10 +161,10 @@ value filter st = let bi = mk_meta m in <:module_expr< struct - value meta_string _loc s = $m.str$ _loc s; + value meta_string _loc s = $m.str$ _loc (safe_string_escaped s); value meta_int _loc s = $m.int$ _loc s; value meta_float _loc s = $m.flo$ _loc s; - value meta_char _loc s = $m.chr$ _loc s; + value meta_char _loc s = $m.chr$ _loc (String.escaped s); value meta_bool _loc = fun [ False -> $m_uid m "False"$ diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml index 3d841516e4..4a2f8d90c0 100644 --- a/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml @@ -107,13 +107,13 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | _ -> 1 ]) ; - value lident_colon = - Gram.Entry.of_parser "lident_colon" - (fun strm -> - match Stream.npeek 2 strm with - [ [(LIDENT i, _); (KEYWORD ":", _)] -> - do { Stream.junk strm; Stream.junk strm; i } - | _ -> raise Stream.Failure ]) + value lident_colon = + Gram.Entry.of_parser "lident_colon" + (fun strm -> + match Stream.npeek 2 strm with + [ [(LIDENT i, _); (KEYWORD ":", _)] -> + do { Stream.junk strm; Stream.junk strm; i } + | _ -> raise Stream.Failure ]) ; value rec is_ident_constr_call = @@ -158,6 +158,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct DELETE_RULE Gram expr: SELF; ":="; SELF; dummy END; DELETE_RULE Gram expr: "~"; a_LIDENT; ":"; SELF END; DELETE_RULE Gram expr: "?"; a_LIDENT; ":"; SELF END; + DELETE_RULE Gram constructor_declarations: a_UIDENT; ":"; ctyp END; (* Some other DELETE_RULE are after the grammar *) value clear = Gram.Entry.clear; @@ -541,6 +542,15 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | t = ctyp LEVEL "ctyp1" -> t ] ] ; + constructor_declarations: + [ [ s = a_UIDENT; ":"; t = constructor_arg_list ; "->" ; ret = ctyp -> + <:ctyp< $uid:s$ : ($t$ -> $ret$) >> + | s = a_UIDENT; ":"; ret = constructor_arg_list -> + match Ast.list_of_ctyp ret [] with + [ [c] -> <:ctyp< $uid:s$ : $c$ >> + | _ -> raise (Stream.Error "invalid generalized constructor type") ] + ] ] + ; semi: [ [ ";;" -> () | -> () ] ] ; @@ -566,7 +576,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct optional_type_parameter: [ [ `ANTIQUOT (""|"typ"|"anti" as n) s -> <:ctyp< $anti:mk_anti n s$ >> | `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.ctyp_tag - | "+"; "_" -> Ast.TyAnP _loc + | "+"; "_" -> Ast.TyAnP _loc | "+"; "'"; i = a_ident -> <:ctyp< +'$lid:i$ >> | "-"; "_" -> Ast.TyAnM _loc | "-"; "'"; i = a_ident -> <:ctyp< -'$lid:i$ >> diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml index 52dab40f45..328e00f953 100644 --- a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml @@ -303,6 +303,15 @@ New syntax:\ value stopped_at _loc = Some (Loc.move_line 1 _loc) (* FIXME be more precise *); + value rec generalized_type_of_type = + fun + [ <:ctyp< $t1$ -> $t2$ >> -> + let (tl, rt) = generalized_type_of_type t2 in + ([t1 :: tl], rt) + | t -> + ([], t) ] + ; + value symbolchar = let list = ['$'; '!'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?'; @@ -361,7 +370,7 @@ New syntax:\ parser [ [: `((KEYWORD "(", _) as tok); xs :] -> match xs with parser - [ [: `(KEYWORD ("mod"|"land"|"lor"|"lxor"|"lsl"|"lsr"|"asr" as i), _loc); + [ [: `(KEYWORD ("or"|"mod"|"land"|"lor"|"lxor"|"lsl"|"lsr"|"asr" as i), _loc); `(KEYWORD ")", _); xs :] -> [: `(LIDENT i, _loc); infix_kwds_filter xs :] | [: xs :] -> @@ -984,6 +993,8 @@ New syntax:\ ; label_ipatt_list: [ [ p1 = label_ipatt; ";"; p2 = SELF -> <:patt< $p1$ ; $p2$ >> + | p1 = label_ipatt; ";"; "_" -> <:patt< $p1$ ; _ >> + | p1 = label_ipatt; ";"; "_"; ";" -> <:patt< $p1$ ; _ >> | p1 = label_ipatt; ";" -> p1 | p1 = label_ipatt -> p1 ] ]; @@ -1044,7 +1055,7 @@ New syntax:\ | "'"; i = a_ident -> <:ctyp< '$lid:i$ >> | "+"; "'"; i = a_ident -> <:ctyp< +'$lid:i$ >> | "-"; "'"; i = a_ident -> <:ctyp< -'$lid:i$ >> - | "+"; "_" -> Ast.TyAnP _loc + | "+"; "_" -> Ast.TyAnP _loc | "-"; "_" -> Ast.TyAnM _loc | "_" -> Ast.TyAny _loc @@ -1133,14 +1144,11 @@ New syntax:\ <:ctyp< $t1$ | $t2$ >> | s = a_UIDENT; "of"; t = constructor_arg_list -> <:ctyp< $uid:s$ of $t$ >> - | s = a_UIDENT; ":"; t = constructor_arg_list ; "->" ; ret = ctyp -> - <:ctyp< $uid:s$ : ($t$ -> $ret$) >> - | s = a_UIDENT; ":"; ret = constructor_arg_list -> - match Ast.list_of_ctyp ret [] with - [ [c] -> <:ctyp< $uid:s$ : $c$ >> - | _ -> raise (Stream.Error "invalid generalized constructor type") ] + | s = a_UIDENT; ":"; t = ctyp -> + let (tl, rt) = generalized_type_of_type t in + <:ctyp< $uid:s$ : ($Ast.tyAnd_of_list tl$ -> $rt$) >> | s = a_UIDENT -> - <:ctyp< $uid:s$ >> + <:ctyp< $uid:s$ >> ] ] ; constructor_declaration: @@ -1392,9 +1400,9 @@ New syntax:\ ; cvalue_binding: [ [ "="; e = expr -> e - | ":"; "type"; t1 = unquoted_typevars; "." ; t2 = ctyp ; "="; e = expr -> - let u = Ast.TyTypePol _loc t1 t2 in - <:expr< ($e$ : $u$) >> + | ":"; "type"; t1 = unquoted_typevars; "." ; t2 = ctyp ; "="; e = expr -> + let u = Ast.TyTypePol _loc t1 t2 in + <:expr< ($e$ : $u$) >> | ":"; t = poly_type; "="; e = expr -> <:expr< ($e$ : $t$) >> | ":"; t = poly_type; ":>"; t2 = ctyp; "="; e = expr -> match t with diff --git a/camlp4/Camlp4Top/Rprint.ml b/camlp4/Camlp4Top/Rprint.ml index d913efcca0..9e49aa0f51 100644 --- a/camlp4/Camlp4Top/Rprint.ml +++ b/camlp4/Camlp4Top/Rprint.ml @@ -301,7 +301,9 @@ and print_ty_label ppf lab = ; value type_parameter ppf (ty, (co, cn)) = - fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "") + fprintf ppf "%s%s%s" + (if not cn then "+" else if not co then "-" else "") + (if ty = "_" then "" else "'") ty ; @@ -451,8 +453,13 @@ and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) = print_kind ty2 | ty -> print_kind ppf ty ] in - fprintf ppf "@[<2>@[<hv 2>@[%s %t@] =%a@]%a@]" kwd type_defined - print_types ty print_constraints constraints + match ty with + [ Otyp_abstract -> + fprintf ppf "@[<2>@[<hv 2>@[%s %t@]@]%a@]" kwd type_defined + print_constraints constraints + | _ -> + fprintf ppf "@[<2>@[<hv 2>@[%s %t@] =%a@]%a@]" kwd type_defined + print_types ty print_constraints constraints ] ; (* Phrases *) diff --git a/camlp4/Camlp4Top/Top.ml b/camlp4/Camlp4Top/Top.ml index 1ff0ef8210..0e07eb21e6 100644 --- a/camlp4/Camlp4Top/Top.ml +++ b/camlp4/Camlp4Top/Top.ml @@ -60,45 +60,31 @@ value initialization = lazy begin else () end; -value lookup x xs = try Some (List.assq x xs) with [ Not_found -> None ]; - -value wrap parse_fun = - let token_streams = ref [] in - let cleanup lb = - try token_streams.val := List.remove_assq lb token_streams.val - with [ Not_found -> () ] - in - fun lb -> - let () = Lazy.force initialization in - let () = Register.iter_and_take_callbacks (fun (_, f) -> f ()) in - let token_stream = - match lookup lb token_streams.val with - [ None -> - let not_filtered_token_stream = Lexer.from_lexbuf lb in - let token_stream = Gram.filter (not_filtered not_filtered_token_stream) in - do { token_streams.val := [ (lb,token_stream) :: token_streams.val ]; token_stream } - | Some token_stream -> token_stream ] - in try - match token_stream with parser - [ [: `(EOI, _) :] -> raise End_of_file - | [: :] -> parse_fun token_stream ] - with - [ End_of_file | Sys.Break | (Loc.Exc_located _ (End_of_file | Sys.Break)) - as x -> (cleanup lb; raise x) - | x -> - let x = - match x with - [ Loc.Exc_located loc x -> do { +value wrap parse_fun lb = + let () = Lazy.force initialization in + let () = Register.iter_and_take_callbacks (fun (_, f) -> f ()) in + let not_filtered_token_stream = Lexer.from_lexbuf lb in + let token_stream = Gram.filter (not_filtered not_filtered_token_stream) in + try + match token_stream with parser + [ [: `(EOI, _) :] -> raise End_of_file + | [: :] -> parse_fun token_stream ] + with + [ End_of_file | Sys.Break | (Loc.Exc_located _ (End_of_file | Sys.Break)) + as x -> raise x + | x -> + let x = + match x with + [ Loc.Exc_located loc x -> do { Toploop.print_location Format.err_formatter (Loc.to_ocaml_location loc); x } - | x -> x ] - in - do { - cleanup lb; - Format.eprintf "@[<0>%a@]@." Camlp4.ErrorHandler.print x; - raise Exit - } ]; + | x -> x ] + in + do { + Format.eprintf "@[<0>%a@]@." Camlp4.ErrorHandler.print x; + raise Exit + } ]; value toplevel_phrase token_stream = match Gram.parse_tokens_after_filter Syntax.top_phrase token_stream with diff --git a/camlp4/Camlp4_config.ml b/camlp4/Camlp4_config.ml index bb4d4cfd26..a055e6ca47 100644 --- a/camlp4/Camlp4_config.ml +++ b/camlp4/Camlp4_config.ml @@ -32,8 +32,8 @@ let verbose = ref false;; let antiquotations = ref false;; let quotations = ref true;; let inter_phrases = ref None;; -let camlp4_ast_impl_magic_number = "Camlp42006M001";; -let camlp4_ast_intf_magic_number = "Camlp42006N001";; +let camlp4_ast_impl_magic_number = "Camlp42006M002";; +let camlp4_ast_intf_magic_number = "Camlp42006N002";; let ocaml_ast_intf_magic_number = Camlp4_import.Config.ast_intf_magic_number;; let ocaml_ast_impl_magic_number = Camlp4_import.Config.ast_impl_magic_number;; let current_input_file = ref "";; diff --git a/camlp4/boot/.ignore b/camlp4/boot/.ignore index 03db148713..9a5f19e1e3 100644 --- a/camlp4/boot/.ignore +++ b/camlp4/boot/.ignore @@ -2,3 +2,4 @@ camlp4 camlp4o camlp4r SAVED +*.old diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml index 3967ba21b5..9e8309b668 100644 --- a/camlp4/boot/Camlp4.ml +++ b/camlp4/boot/Camlp4.ml @@ -81,25 +81,15 @@ module Debug : let formatter = let header = "camlp4-debug: " in - let normal s = - let rec self from accu = - try - let i = String.index_from s from '\n' - in self (i + 1) ((String.sub s from ((i - from) + 1)) :: accu) - with - | Not_found -> - (String.sub s from ((String.length s) - from)) :: accu - in String.concat header (List.rev (self 0 [])) in - let after_new_line str = header ^ (normal str) in - let f = ref after_new_line in - let output str chr = - (output_string out_channel (!f str); - output_char out_channel chr; - f := if chr = '\n' then after_new_line else normal) + let at_bol = ref true in make_formatter (fun buf pos len -> - let p = pred len in output (String.sub buf pos p) buf.[pos + p]) + for i = pos to (pos + len) - 1 do + if !at_bol then output_string out_channel header else (); + let ch = buf.[i] + in (output_char out_channel ch; at_bol := ch = '\n') + done) (fun () -> flush out_channel) let printf section fmt = fprintf formatter ("%s: " ^^ fmt) section @@ -424,6 +414,16 @@ module Sig = (** A signature for locations. *) module type Loc = sig + (** The type of locations. Note that, as for OCaml locations, + character numbers in locations refer to character numbers in the + parsed character stream, while line numbers refer to line + numbers in the source file. The source file and the parsed + character stream differ, for instance, when the parsed character + stream contains a line number directive. The line number + directive will only update the file-name field and the + line-number field of the position. It makes therefore no sense + to use character numbers with the source file if the sources + contain line number directives. *) type t (** Return a start location for the given file name. @@ -457,7 +457,8 @@ module Sig = val to_tuple : t -> (string * int * int * int * int * int * int * bool) - (** [merge loc1 loc2] Return a location that starts at [loc1] and end at [loc2]. *) + (** [merge loc1 loc2] Return a location that starts at [loc1] and end at + [loc2]. *) val merge : t -> t -> t (** The stop pos becomes equal to the start pos. *) @@ -488,19 +489,19 @@ module Sig = (** Return the line number of the ending of this location. *) val stop_line : t -> int - (** Returns the number of characters from the begining of the file + (** Returns the number of characters from the begining of the stream to the begining of the line of location's begining. *) val start_bol : t -> int - (** Returns the number of characters from the begining of the file + (** Returns the number of characters from the begining of the stream to the begining of the line of location's ending. *) val stop_bol : t -> int - (** Returns the number of characters from the begining of the file + (** Returns the number of characters from the begining of the stream of the begining of this location. *) val start_off : t -> int - (** Return the number of characters from the begining of the file + (** Return the number of characters from the begining of the stream of the ending of this location. *) val stop_off : t -> int @@ -801,6 +802,8 @@ module Sig = (* source tree. *) (* *) (****************************************************************************) + (* Note: when you modify these types you must increment + ast magic numbers defined in Camlp4_config.ml. *) type loc = Loc. t @@ -3528,7 +3531,7 @@ module Struct = let skip_opt_linefeed (__strm : _ Stream.t) = match Stream.peek __strm with - | Some '\010' -> (Stream.junk __strm; ()) + | Some '\n' -> (Stream.junk __strm; ()) | _ -> () let chr c = @@ -3538,8 +3541,8 @@ module Struct = let rec backslash (__strm : _ Stream.t) = match Stream.peek __strm with - | Some '\010' -> (Stream.junk __strm; '\010') - | Some '\013' -> (Stream.junk __strm; '\013') + | Some '\n' -> (Stream.junk __strm; '\n') + | Some '\r' -> (Stream.junk __strm; '\r') | Some 'n' -> (Stream.junk __strm; '\n') | Some 'r' -> (Stream.junk __strm; '\r') | Some 't' -> (Stream.junk __strm; '\t') @@ -3578,8 +3581,8 @@ module Struct = let rec backslash_in_string strict store (__strm : _ Stream.t) = match Stream.peek __strm with - | Some '\010' -> (Stream.junk __strm; skip_indent __strm) - | Some '\013' -> + | Some '\n' -> (Stream.junk __strm; skip_indent __strm) + | Some '\r' -> (Stream.junk __strm; let s = __strm in (skip_opt_linefeed s; skip_indent s)) | _ -> @@ -7415,13 +7418,15 @@ module Struct = module Expr = struct - let meta_string _loc s = Ast.ExStr (_loc, s) + let meta_string _loc s = + Ast.ExStr (_loc, (safe_string_escaped s)) let meta_int _loc s = Ast.ExInt (_loc, s) let meta_float _loc s = Ast.ExFlo (_loc, s) - let meta_char _loc s = Ast.ExChr (_loc, s) + let meta_char _loc s = + Ast.ExChr (_loc, (String.escaped s)) let meta_bool _loc = function @@ -9744,13 +9749,15 @@ module Struct = module Patt = struct - let meta_string _loc s = Ast.PaStr (_loc, s) + let meta_string _loc s = + Ast.PaStr (_loc, (safe_string_escaped s)) let meta_int _loc s = Ast.PaInt (_loc, s) let meta_float _loc s = Ast.PaFlo (_loc, s) - let meta_char _loc s = Ast.PaChr (_loc, s) + let meta_char _loc s = + Ast.PaChr (_loc, (String.escaped s)) let meta_bool _loc = function @@ -14159,6 +14166,9 @@ module Struct = let mkghloc loc = Loc.to_ocaml_location (Loc.ghostify loc) + let with_loc txt loc = + Camlp4_import.Location.mkloc txt (mkloc loc) + let mktyp loc d = { ptyp_desc = d; ptyp_loc = mkloc loc; } let mkpat loc d = { ppat_desc = d; ppat_loc = mkloc loc; } @@ -14179,7 +14189,11 @@ module Struct = let mkcty loc d = { pcty_desc = d; pcty_loc = mkloc loc; } - let mkpcl loc d = { pcl_desc = d; pcl_loc = mkloc loc; } + let mkcl loc d = { pcl_desc = d; pcl_loc = mkloc loc; } + + let mkcf loc d = { pcf_desc = d; pcf_loc = mkloc loc; } + + let mkctf loc d = { pctf_desc = d; pctf_loc = mkloc loc; } let mkpolytype t = match t.ptyp_desc with @@ -14200,6 +14214,8 @@ module Struct = let lident s = Lident s + let lident_with_loc s loc = with_loc (Lident s) loc + let ldot l s = Ldot (l, s) let lapply l s = Lapply (l, s) @@ -14219,20 +14235,23 @@ module Struct = [ ("val", "contents") ]; fun s -> try Hashtbl.find t s with | Not_found -> s) - let array_function str name = + let array_function_no_loc str name = ldot (lident str) (if !Camlp4_config.unsafe then "unsafe_" ^ name else name) + let array_function loc str name = + with_loc (array_function_no_loc str name) loc + let mkrf = function | Ast.ReRecursive -> Recursive | Ast.ReNil -> Nonrecursive | _ -> assert false - let mkli s = + let mkli sloc s list = let rec loop f = function | i :: il -> loop (ldot (f i)) il | [] -> f s - in loop lident + in with_loc (loop lident list) sloc let rec ctyp_fa al = function @@ -14242,6 +14261,9 @@ module Struct = let ident_tag ?(conv_lid = fun x -> x) i = let rec self i acc = match i with + | Ast.IdAcc (_, (Ast.IdLid (_, "*predef*")), + (Ast.IdLid (_, "option"))) -> + ((ldot (lident "*predef*") "option"), `lident) | Ast.IdAcc (_, i1, i2) -> self i2 (Some (self i1 acc)) | Ast.IdApp (_, i1, i2) -> let i' = @@ -14272,27 +14294,33 @@ module Struct = | _ -> error (loc_of_ident i) "invalid long identifier" in self i None - let ident ?conv_lid i = fst (ident_tag ?conv_lid i) + let ident_noloc ?conv_lid i = fst (ident_tag ?conv_lid i) - let long_lident msg i = - match ident_tag i with - | (i, `lident) -> i - | _ -> error (loc_of_ident i) msg + let ident ?conv_lid i = + with_loc (ident_noloc ?conv_lid i) (loc_of_ident i) + + let long_lident msg id = + match ident_tag id with + | (i, `lident) -> with_loc i (loc_of_ident id) + | _ -> error (loc_of_ident id) msg let long_type_ident = long_lident "invalid long identifier type" let long_class_ident = long_lident "invalid class name" - let long_uident ?(conv_con = fun x -> x) i = + let long_uident_noloc ?(conv_con = fun x -> x) i = match ident_tag i with | (Ldot (i, s), `uident) -> ldot i (conv_con s) | (Lident s, `uident) -> lident (conv_con s) | (i, `app) -> i | _ -> error (loc_of_ident i) "uppercase identifier expected" + let long_uident ?conv_con i = + with_loc (long_uident_noloc ?conv_con i) (loc_of_ident i) + let rec ctyp_long_id_prefix t = match t with - | Ast.TyId (_, i) -> ident i + | Ast.TyId (_, i) -> ident_noloc i | Ast.TyApp (_, m1, m2) -> let li1 = ctyp_long_id_prefix m1 in let li2 = ctyp_long_id_prefix m2 in Lapply (li1, li2) @@ -14312,6 +14340,13 @@ module Struct = | Ast.TyQuo (_, s) -> [ s ] | _ -> assert false + let predef_option loc = + TyId + ((loc, + (IdAcc + ((loc, (IdLid ((loc, "*predef*"))), + (IdLid ((loc, "option")))))))) + let rec ctyp = function | TyId (loc, i) -> @@ -14335,9 +14370,7 @@ module Struct = | TyArr (loc, (TyLab (_, lab, t1)), t2) -> mktyp loc (Ptyp_arrow (lab, (ctyp t1), (ctyp t2))) | TyArr (loc, (TyOlb (loc1, lab, t1)), t2) -> - let t1 = - TyApp (loc1, - (Ast.TyId (loc1, (Ast.IdLid (loc1, "option")))), t1) + let t1 = TyApp (loc1, (predef_option loc1), t1) in mktyp loc (Ptyp_arrow (("?" ^ lab), (ctyp t1), (ctyp t2))) @@ -14421,8 +14454,8 @@ module Struct = and package_type_constraints wc acc = match wc with | Ast.WcNil _ -> acc - | Ast.WcTyp (_, (Ast.TyId (_, (Ast.IdLid (_, id)))), ct) -> - (Lident id, (ctyp ct)) :: acc + | Ast.WcTyp (_, (Ast.TyId (_, id)), ct) -> + ((ident id), (ctyp ct)) :: acc | Ast.WcAnd (_, wc1, wc2) -> package_type_constraints wc1 (package_type_constraints wc2 acc) @@ -14459,26 +14492,30 @@ module Struct = let mktrecord = function - | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (_, s)))), + | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (sloc, s)))), (Ast.TyMut (_, t))) -> - (s, Mutable, (mkpolytype (ctyp t)), (mkloc loc)) - | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (_, s)))), t) -> - (s, Immutable, (mkpolytype (ctyp t)), (mkloc loc)) + ((with_loc s sloc), Mutable, (mkpolytype (ctyp t)), + (mkloc loc)) + | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (sloc, s)))), t) -> + ((with_loc s sloc), Immutable, (mkpolytype (ctyp t)), + (mkloc loc)) | _ -> assert false let mkvariant = function - | Ast.TyId (loc, (Ast.IdUid (_, s))) -> - ((conv_con s), [], None, (mkloc loc)) - | Ast.TyOf (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), t) -> - ((conv_con s), (List.map ctyp (list_of_ctyp t [])), None, - (mkloc loc)) - | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), + | Ast.TyId (loc, (Ast.IdUid (sloc, s))) -> + ((with_loc (conv_con s) sloc), [], None, (mkloc loc)) + | Ast.TyOf (loc, (Ast.TyId (_, (Ast.IdUid (sloc, s)))), t) -> + ((with_loc (conv_con s) sloc), + (List.map ctyp (list_of_ctyp t [])), None, (mkloc loc)) + | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdUid (sloc, s)))), (Ast.TyArr (_, t, u))) -> - ((conv_con s), (List.map ctyp (list_of_ctyp t [])), - (Some (ctyp u)), (mkloc loc)) - | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), t) -> - ((conv_con s), [], (Some (ctyp t)), (mkloc loc)) + ((with_loc (conv_con s) sloc), + (List.map ctyp (list_of_ctyp t [])), (Some (ctyp u)), + (mkloc loc)) + | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdUid (sloc, s)))), t) -> + ((with_loc (conv_con s) sloc), [], (Some (ctyp t)), + (mkloc loc)) | _ -> assert false let rec type_decl tl cl loc m pflag = @@ -14505,10 +14542,10 @@ module Struct = | _ -> Some (ctyp t) in mktype loc tl cl Ptype_abstract (mkprivate' pflag) m) - let type_decl tl cl t = - type_decl tl cl (loc_of_ctyp t) None false t + let type_decl tl cl t loc = type_decl tl cl loc None false t - let mkvalue_desc t p = { pval_type = ctyp t; pval_prim = p; } + let mkvalue_desc loc t p = + { pval_type = ctyp t; pval_prim = p; pval_loc = mkloc loc; } let rec list_of_meta_list = function @@ -14550,11 +14587,14 @@ module Struct = | Ast.TyApp (_, t1, t2) -> optional_type_parameters t1 (optional_type_parameters t2 acc) - | Ast.TyQuP (_, s) -> ((Some s), (true, false)) :: acc + | Ast.TyQuP (loc, s) -> + ((Some (with_loc s loc)), (true, false)) :: acc | Ast.TyAnP _loc -> (None, (true, false)) :: acc - | Ast.TyQuM (_, s) -> ((Some s), (false, true)) :: acc + | Ast.TyQuM (loc, s) -> + ((Some (with_loc s loc)), (false, true)) :: acc | Ast.TyAnM _loc -> (None, (false, true)) :: acc - | Ast.TyQuo (_, s) -> ((Some s), (false, false)) :: acc + | Ast.TyQuo (loc, s) -> + ((Some (with_loc s loc)), (false, false)) :: acc | Ast.TyAny _loc -> (None, (false, false)) :: acc | _ -> assert false @@ -14562,9 +14602,12 @@ module Struct = match t with | Ast.TyCom (_, t1, t2) -> class_parameters t1 (class_parameters t2 acc) - | Ast.TyQuP (_, s) -> (s, (true, false)) :: acc - | Ast.TyQuM (_, s) -> (s, (false, true)) :: acc - | Ast.TyQuo (_, s) -> (s, (false, false)) :: acc + | Ast.TyQuP (loc, s) -> + ((with_loc s loc), (true, false)) :: acc + | Ast.TyQuM (loc, s) -> + ((with_loc s loc), (false, true)) :: acc + | Ast.TyQuo (loc, s) -> + ((with_loc s loc), (false, false)) :: acc | _ -> assert false let rec type_parameters_and_type_name t acc = @@ -14636,7 +14679,8 @@ module Struct = let rec patt = function - | Ast.PaId (loc, (Ast.IdLid (_, s))) -> mkpat loc (Ppat_var s) + | Ast.PaId (loc, (Ast.IdLid (sloc, s))) -> + mkpat loc (Ppat_var (with_loc s sloc)) | Ast.PaId (loc, i) -> let p = Ppat_construct ((long_uident ~conv_con i), None, @@ -14645,16 +14689,18 @@ module Struct = | PaAli (loc, p1, p2) -> let (p, i) = (match (p1, p2) with - | (p, Ast.PaId (_, (Ast.IdLid (_, s)))) -> (p, s) - | (Ast.PaId (_, (Ast.IdLid (_, s))), p) -> (p, s) + | (p, Ast.PaId (_, (Ast.IdLid (sloc, s)))) -> + (p, (with_loc s sloc)) + | (Ast.PaId (_, (Ast.IdLid (sloc, s))), p) -> + (p, (with_loc s sloc)) | _ -> error loc "invalid alias pattern") in mkpat loc (Ppat_alias ((patt p), i)) | PaAnt (loc, _) -> error loc "antiquotation not allowed here" | PaAny loc -> mkpat loc Ppat_any - | Ast.PaApp (loc, (Ast.PaId (_, (Ast.IdUid (_, s)))), + | Ast.PaApp (loc, (Ast.PaId (_, (Ast.IdUid (sloc, s)))), (Ast.PaTup (_, (Ast.PaAny loc_any)))) -> mkpat loc - (Ppat_construct ((lident (conv_con s)), + (Ppat_construct ((lident_with_loc (conv_con s) sloc), (Some (mkpat loc_any Ppat_any)), false)) | (PaApp (loc, _, _) as f) -> let (f, al) = patt_fa [] f in @@ -14762,9 +14808,10 @@ module Struct = | PaTyc (loc, p, t) -> mkpat loc (Ppat_constraint ((patt p), (ctyp t))) | PaTyp (loc, i) -> mkpat loc (Ppat_type (long_type_ident i)) - | PaVrn (loc, s) -> mkpat loc (Ppat_variant (s, None)) + | PaVrn (loc, s) -> + mkpat loc (Ppat_variant ((conv_con s), None)) | PaLaz (loc, p) -> mkpat loc (Ppat_lazy (patt p)) - | PaMod (loc, m) -> mkpat loc (Ppat_unpack m) + | PaMod (loc, m) -> mkpat loc (Ppat_unpack (with_loc m loc)) | (PaEq (_, _, _) | PaSem (_, _, _) | PaCom (_, _, _) | PaNil _ as p) -> error (loc_of_patt p) "invalid pattern" and mklabpat = @@ -14824,8 +14871,8 @@ module Struct = | Ptyp_arrow (label, core_type, core_type') -> Ptyp_arrow (label, (loop core_type), (loop core_type')) | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) - | Ptyp_constr ((Lident s), []) when List.mem s var_names -> - Ptyp_var ("&" ^ s) + | Ptyp_constr ({ 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 -> @@ -14862,33 +14909,35 @@ module Struct = function | Ast.ExAcc (loc, x, (Ast.ExId (_, (Ast.IdLid (_, "val"))))) -> mkexp loc - (Pexp_apply ((mkexp loc (Pexp_ident (Lident "!"))), + (Pexp_apply + ((mkexp loc (Pexp_ident (lident_with_loc "!" loc))), [ ("", (expr x)) ])) | (ExAcc (loc, _, _) | Ast.ExId (loc, (Ast.IdAcc (_, _, _))) as e) -> let (e, l) = (match sep_expr_acc [] e with - | (loc, ml, Ast.ExId (_, (Ast.IdUid (_, s)))) :: l -> + | (loc, ml, Ast.ExId (sloc, (Ast.IdUid (_, s)))) :: l -> let ca = constructors_arity () in ((mkexp loc - (Pexp_construct ((mkli (conv_con s) ml), None, - ca))), + (Pexp_construct ((mkli sloc (conv_con s) ml), + None, ca))), l) - | (loc, ml, Ast.ExId (_, (Ast.IdLid (_, s)))) :: l -> - ((mkexp loc (Pexp_ident (mkli s ml))), l) + | (loc, ml, Ast.ExId (sloc, (Ast.IdLid (_, s)))) :: l -> + ((mkexp loc (Pexp_ident (mkli sloc s ml))), l) | (_, [], e) :: l -> ((expr e), l) | _ -> error loc "bad ast in expression") in let (_, e) = List.fold_left (fun (loc_bp, e1) (loc_ep, ml, e2) -> match e2 with - | Ast.ExId (_, (Ast.IdLid (_, s))) -> + | Ast.ExId (sloc, (Ast.IdLid (_, s))) -> let loc = Loc.merge loc_bp loc_ep in (loc, (mkexp loc - (Pexp_field (e1, (mkli (conv_lab s) ml))))) + (Pexp_field (e1, + (mkli sloc (conv_lab s) ml))))) | _ -> error (loc_of_expr e2) "lowercase identifier expected") @@ -14931,7 +14980,7 @@ module Struct = mkexp loc (Pexp_apply ((mkexp loc - (Pexp_ident (array_function "Array" "get"))), + (Pexp_ident (array_function loc "Array" "get"))), [ ("", (expr e1)); ("", (expr e2)) ])) | ExArr (loc, e) -> mkexp loc (Pexp_array (List.map expr (list_of_expr e []))) @@ -14941,24 +14990,27 @@ module Struct = (match e with | Ast.ExAcc (loc, x, (Ast.ExId (_, (Ast.IdLid (_, "val"))))) -> - Pexp_apply ((mkexp loc (Pexp_ident (Lident ":="))), + Pexp_apply + ((mkexp loc + (Pexp_ident (lident_with_loc ":=" loc))), [ ("", (expr x)); ("", (expr v)) ]) | ExAcc (loc, _, _) -> (match (expr e).pexp_desc with | Pexp_field (e, lab) -> Pexp_setfield (e, lab, (expr v)) | _ -> error loc "bad record access") - | ExAre (_, e1, e2) -> + | ExAre (loc, e1, e2) -> Pexp_apply ((mkexp loc - (Pexp_ident (array_function "Array" "set"))), + (Pexp_ident (array_function loc "Array" "set"))), [ ("", (expr e1)); ("", (expr e2)); ("", (expr v)) ]) - | Ast.ExId (_, (Ast.IdLid (_, lab))) -> - Pexp_setinstvar (lab, (expr v)) - | ExSte (_, e1, e2) -> + | Ast.ExId (_, (Ast.IdLid (lloc, lab))) -> + Pexp_setinstvar ((with_loc lab lloc), (expr v)) + | ExSte (loc, e1, e2) -> Pexp_apply ((mkexp loc - (Pexp_ident (array_function "String" "set"))), + (Pexp_ident + (array_function loc "String" "set"))), [ ("", (expr e1)); ("", (expr e2)); ("", (expr v)) ]) | _ -> error loc "bad left part of assignment") in mkexp loc e @@ -14979,8 +15031,8 @@ module Struct = let e3 = ExSeq (loc, el) in mkexp loc - (Pexp_for (i, (expr e1), (expr e2), (mkdirection df), - (expr e3))) + (Pexp_for ((with_loc i loc), (expr e1), (expr e2), + (mkdirection df), (expr e3))) | Ast.ExFun (loc, (Ast.McArr (_, (PaLab (_, lab, po)), w, e))) -> mkexp loc @@ -15043,7 +15095,9 @@ module Struct = | ExLet (loc, rf, bi, e) -> mkexp loc (Pexp_let ((mkrf rf), (binding bi []), (expr e))) | ExLmd (loc, i, me, e) -> - mkexp loc (Pexp_letmodule (i, (module_expr me), (expr e))) + mkexp loc + (Pexp_letmodule ((with_loc i loc), (module_expr me), + (expr e))) | ExMat (loc, e, a) -> mkexp loc (Pexp_match ((expr e), (match_case a []))) | ExNew (loc, id) -> mkexp loc (Pexp_new (long_type_ident id)) @@ -15051,7 +15105,10 @@ module Struct = let p = (match po with | Ast.PaNil _ -> Ast.PaAny loc | p -> p) in let cil = class_str_item cfl [] - in mkexp loc (Pexp_object (((patt p), cil))) + in + mkexp loc + (Pexp_object + { pcstr_pat = patt p; pcstr_fields = cil; }) | ExOlb (loc, _, _) -> error loc "labeled expression not allowed here" | ExOvr (loc, iel) -> @@ -15079,7 +15136,7 @@ module Struct = mkexp loc (Pexp_apply ((mkexp loc - (Pexp_ident (array_function "String" "get"))), + (Pexp_ident (array_function loc "String" "get"))), [ ("", (expr e1)); ("", (expr e2)) ])) | ExStr (loc, s) -> mkexp loc @@ -15096,13 +15153,16 @@ module Struct = mkexp loc (Pexp_constraint ((expr e), (Some (ctyp t)), None)) | Ast.ExId (loc, (Ast.IdUid (_, "()"))) -> - mkexp loc (Pexp_construct ((lident "()"), None, true)) + mkexp loc + (Pexp_construct ((lident_with_loc "()" loc), None, true)) | Ast.ExId (loc, (Ast.IdLid (_, s))) -> - mkexp loc (Pexp_ident (lident s)) + mkexp loc (Pexp_ident (lident_with_loc s loc)) | Ast.ExId (loc, (Ast.IdUid (_, s))) -> mkexp loc - (Pexp_construct ((lident (conv_con s)), None, true)) - | ExVrn (loc, s) -> mkexp loc (Pexp_variant (s, None)) + (Pexp_construct ((lident_with_loc (conv_con s) loc), + None, true)) + | ExVrn (loc, s) -> + mkexp loc (Pexp_variant ((conv_con s), None)) | ExWhi (loc, e1, el) -> let e2 = ExSeq (loc, el) in mkexp loc (Pexp_while ((expr e1), (expr e2))) @@ -15142,7 +15202,8 @@ module Struct = and binding x acc = match x with | Ast.BiAnd (_, x, y) -> binding x (binding y acc) - | Ast.BiEq (_loc, (Ast.PaId (_, (Ast.IdLid (_, bind_name)))), + | Ast.BiEq (_loc, + (Ast.PaId (sloc, (Ast.IdLid (_, bind_name)))), (Ast.ExTyc (_, e, (TyTypePol (_, vs, ty))))) -> let rec id_to_string x = (match x with @@ -15152,11 +15213,6 @@ module Struct = | _ -> assert false) in let vars = id_to_string vs in let ampersand_vars = List.map (fun x -> "&" ^ x) vars in - let rec merge_quoted_vars lst = - (match lst with - | [ x ] -> x - | x :: y -> Ast.TyApp (_loc, x, (merge_quoted_vars y)) - | [] -> assert false) in let ty' = varify_constructors vars (ctyp ty) in let mkexp = mkexp _loc in let mkpat = mkpat _loc in @@ -15173,7 +15229,7 @@ module Struct = let pat = mkpat (Ppat_constraint - (((mkpat (Ppat_var bind_name)), + (((mkpat (Ppat_var (with_loc bind_name sloc))), (mktyp _loc (Ptyp_poly (ampersand_vars, ty')))))) in let e = mk_newtypes vars in (pat, e) :: acc | Ast.BiEq (_loc, p, @@ -15203,12 +15259,13 @@ module Struct = match x with | Ast.RbNil _ -> acc | Ast.RbSem (_, x, y) -> mkideexp x (mkideexp y acc) - | Ast.RbEq (_, (Ast.IdLid (_, s)), e) -> (s, (expr e)) :: acc + | Ast.RbEq (_, (Ast.IdLid (sloc, s)), e) -> + ((with_loc s sloc), (expr e)) :: acc | _ -> assert false and mktype_decl x acc = match x with | Ast.TyAnd (_, x, y) -> mktype_decl x (mktype_decl y acc) - | Ast.TyDcl (_, c, tl, td, cl) -> + | Ast.TyDcl (cloc, c, tl, td, cl) -> let cl = List.map (fun (t1, t2) -> @@ -15217,10 +15274,10 @@ module Struct = in ((ctyp t1), (ctyp t2), (mkloc loc))) cl in - (c, + ((with_loc c cloc), (type_decl (List.fold_right optional_type_parameters tl []) cl - td)) :: + td cloc)) :: acc | _ -> assert false and module_type = @@ -15230,7 +15287,8 @@ module Struct = | Ast.MtId (loc, i) -> mkmty loc (Pmty_ident (long_uident i)) | Ast.MtFun (loc, n, nt, mt) -> mkmty loc - (Pmty_functor (n, (module_type nt), (module_type mt))) + (Pmty_functor ((with_loc n loc), (module_type nt), + (module_type mt))) | Ast.MtQuo (loc, _) -> error loc "module type variable not allowed here" | Ast.MtSig (loc, sl) -> @@ -15258,22 +15316,27 @@ module Struct = | Ast.SgSem (_, sg1, sg2) -> sig_item sg1 (sig_item sg2 l) | SgDir (_, _, _) -> l | Ast.SgExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s))))) -> - (mksig loc (Psig_exception ((conv_con s), []))) :: l + (mksig loc + (Psig_exception ((with_loc (conv_con s) loc), []))) :: + l | Ast.SgExc (loc, (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, s)))), t))) -> (mksig loc - (Psig_exception ((conv_con s), + (Psig_exception ((with_loc (conv_con s) loc), (List.map ctyp (list_of_ctyp t []))))) :: l | SgExc (_, _) -> assert false | SgExt (loc, n, t, sl) -> (mksig loc - (Psig_value (n, (mkvalue_desc t (list_of_meta_list sl))))) :: + (Psig_value ((with_loc n loc), + (mkvalue_desc loc t (list_of_meta_list sl))))) :: l | SgInc (loc, mt) -> (mksig loc (Psig_include (module_type mt))) :: l | SgMod (loc, n, mt) -> - (mksig loc (Psig_module (n, (module_type mt)))) :: l + (mksig loc + (Psig_module ((with_loc n loc), (module_type mt)))) :: + l | SgRecMod (loc, mb) -> (mksig loc (Psig_recmodule (module_sig_binding mb []))) :: l @@ -15282,26 +15345,30 @@ module Struct = (match mt with | MtQuo (_, _) -> Pmodtype_abstract | _ -> Pmodtype_manifest (module_type mt)) - in (mksig loc (Psig_modtype (n, si))) :: l + in (mksig loc (Psig_modtype ((with_loc n loc), si))) :: l | SgOpn (loc, id) -> (mksig loc (Psig_open (long_uident id))) :: l | SgTyp (loc, tdl) -> (mksig loc (Psig_type (mktype_decl tdl []))) :: l | SgVal (loc, n, t) -> - (mksig loc (Psig_value (n, (mkvalue_desc t [])))) :: l + (mksig loc + (Psig_value ((with_loc n loc), (mkvalue_desc loc t [])))) :: + l | Ast.SgAnt (loc, _) -> error loc "antiquotation in sig_item" and module_sig_binding x acc = match x with | Ast.MbAnd (_, x, y) -> module_sig_binding x (module_sig_binding y acc) - | Ast.MbCol (_, s, mt) -> (s, (module_type mt)) :: acc + | Ast.MbCol (loc, s, mt) -> + ((with_loc s loc), (module_type mt)) :: acc | _ -> assert false and module_str_binding x acc = match x with | Ast.MbAnd (_, x, y) -> module_str_binding x (module_str_binding y acc) - | Ast.MbColEq (_, s, mt, me) -> - (s, (module_type mt), (module_expr me)) :: acc + | Ast.MbColEq (loc, s, mt, me) -> + ((with_loc s loc), (module_type mt), (module_expr me)) :: + acc | _ -> assert false and module_expr = function @@ -15312,7 +15379,8 @@ module Struct = (Pmod_apply ((module_expr me1), (module_expr me2))) | Ast.MeFun (loc, n, mt, me) -> mkmod loc - (Pmod_functor (n, (module_type mt), (module_expr me))) + (Pmod_functor ((with_loc n loc), (module_type mt), + (module_expr me))) | Ast.MeStr (loc, sl) -> mkmod loc (Pmod_structure (str_item sl [])) | Ast.MeTyc (loc, me, mt) -> @@ -15349,17 +15417,21 @@ module Struct = | StDir (_, _, _) -> l | Ast.StExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), Ast. ONone) -> - (mkstr loc (Pstr_exception ((conv_con s), []))) :: l + (mkstr loc + (Pstr_exception ((with_loc (conv_con s) loc), []))) :: + l | Ast.StExc (loc, (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, s)))), t)), Ast. ONone) -> (mkstr loc - (Pstr_exception ((conv_con s), + (Pstr_exception ((with_loc (conv_con s) loc), (List.map ctyp (list_of_ctyp t []))))) :: l | Ast.StExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), (Ast.OSome i)) -> - (mkstr loc (Pstr_exn_rebind ((conv_con s), (ident i)))) :: + (mkstr loc + (Pstr_exn_rebind ((with_loc (conv_con s) loc), + (ident i)))) :: l | Ast.StExc (loc, (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, _)))), _)), @@ -15368,18 +15440,22 @@ module Struct = | StExp (loc, e) -> (mkstr loc (Pstr_eval (expr e))) :: l | StExt (loc, n, t, sl) -> (mkstr loc - (Pstr_primitive (n, - (mkvalue_desc t (list_of_meta_list sl))))) :: + (Pstr_primitive ((with_loc n loc), + (mkvalue_desc loc t (list_of_meta_list sl))))) :: l | StInc (loc, me) -> (mkstr loc (Pstr_include (module_expr me))) :: l | StMod (loc, n, me) -> - (mkstr loc (Pstr_module (n, (module_expr me)))) :: l + (mkstr loc + (Pstr_module ((with_loc n loc), (module_expr me)))) :: + l | StRecMod (loc, mb) -> (mkstr loc (Pstr_recmodule (module_str_binding mb []))) :: l | StMty (loc, n, mt) -> - (mkstr loc (Pstr_modtype (n, (module_type mt)))) :: l + (mkstr loc + (Pstr_modtype ((with_loc n loc), (module_type mt)))) :: + l | StOpn (loc, id) -> (mkstr loc (Pstr_open (long_uident id))) :: l | StTyp (loc, tdl) -> @@ -15396,9 +15472,7 @@ module Struct = | CtFun (loc, (TyLab (_, lab, t)), ct) -> mkcty loc (Pcty_fun (lab, (ctyp t), (class_type ct))) | CtFun (loc, (TyOlb (loc1, lab, t)), ct) -> - let t = - TyApp (loc1, - (Ast.TyId (loc1, (Ast.IdLid (loc1, "option")))), t) + let t = TyApp (loc1, (predef_option loc1), t) in mkcty loc (Pcty_fun (("?" ^ lab), (ctyp t), (class_type ct))) @@ -15408,15 +15482,22 @@ module Struct = let t = (match t_o with | Ast.TyNil _ -> Ast.TyAny loc | t -> t) in let cil = class_sig_item ctfl [] - in mkcty loc (Pcty_signature (((ctyp t), cil))) + in + mkcty loc + (Pcty_signature + { + pcsig_self = ctyp t; + pcsig_fields = cil; + pcsig_loc = mkloc loc; + }) | CtCon (loc, _, _, _) -> error loc "invalid virtual class inside a class type" | CtAnt (_, _) | CtEq (_, _, _) | CtCol (_, _, _) | CtAnd (_, _, _) | CtNil _ -> assert false and class_info_class_expr ci = match ci with - | CeEq (_, (CeCon (loc, vir, (IdLid (_, name)), params)), ce) - -> + | CeEq (_, (CeCon (loc, vir, (IdLid (nloc, name)), params)), + ce) -> let (loc_params, (params, variance)) = (match params with | Ast.TyNil _ -> (loc, ([], [])) @@ -15427,7 +15508,7 @@ module Struct = { pci_virt = mkvirtual vir; pci_params = (params, (mkloc loc_params)); - pci_name = name; + pci_name = with_loc name nloc; pci_expr = class_expr ce; pci_loc = mkloc loc; pci_variance = variance; @@ -15435,8 +15516,9 @@ module Struct = | ce -> error (loc_of_class_expr ce) "bad class definition" and class_info_class_type ci = match ci with - | CtEq (_, (CtCon (loc, vir, (IdLid (_, name)), params)), ct) | - CtCol (_, (CtCon (loc, vir, (IdLid (_, name)), params)), + | CtEq (_, (CtCon (loc, vir, (IdLid (nloc, name)), params)), + ct) | + CtCol (_, (CtCon (loc, vir, (IdLid (nloc, name)), params)), ct) -> let (loc_params, (params, variance)) = @@ -15449,7 +15531,7 @@ module Struct = { pci_virt = mkvirtual vir; pci_params = (params, (mkloc loc_params)); - pci_name = name; + pci_name = with_loc name nloc; pci_expr = class_type ct; pci_loc = mkloc loc; pci_variance = variance; @@ -15461,22 +15543,22 @@ module Struct = match c with | Ast.CgNil _ -> l | CgCtr (loc, t1, t2) -> - (Pctf_cstr (((ctyp t1), (ctyp t2), (mkloc loc)))) :: l + (mkctf loc (Pctf_cstr (((ctyp t1), (ctyp t2))))) :: l | Ast.CgSem (_, csg1, csg2) -> class_sig_item csg1 (class_sig_item csg2 l) - | CgInh (_, ct) -> (Pctf_inher (class_type ct)) :: l + | CgInh (loc, ct) -> + (mkctf loc (Pctf_inher (class_type ct))) :: l | CgMth (loc, s, pf, t) -> - (Pctf_meth - ((s, (mkprivate pf), (mkpolytype (ctyp t)), (mkloc loc)))) :: + (mkctf loc + (Pctf_meth ((s, (mkprivate pf), (mkpolytype (ctyp t)))))) :: l | CgVal (loc, s, b, v, t) -> - (Pctf_val - ((s, (mkmutable b), (mkvirtual v), (ctyp t), - (mkloc loc)))) :: + (mkctf loc + (Pctf_val ((s, (mkmutable b), (mkvirtual v), (ctyp t))))) :: l | CgVir (loc, s, b, t) -> - (Pctf_virt - ((s, (mkprivate b), (mkpolytype (ctyp t)), (mkloc loc)))) :: + (mkctf loc + (Pctf_virt ((s, (mkprivate b), (mkpolytype (ctyp t)))))) :: l | CgAnt (_, _) -> assert false and class_expr = @@ -15484,39 +15566,42 @@ module Struct = | (CeApp (loc, _, _) as c) -> let (ce, el) = class_expr_fa [] c in let el = List.map label_expr el - in mkpcl loc (Pcl_apply ((class_expr ce), el)) + in mkcl loc (Pcl_apply ((class_expr ce), el)) | CeCon (loc, ViNil, id, tl) -> - mkpcl loc + mkcl loc (Pcl_constr ((long_class_ident id), (List.map ctyp (list_of_opt_ctyp tl [])))) | CeFun (loc, (PaLab (_, lab, po)), ce) -> - mkpcl loc + mkcl loc (Pcl_fun (lab, None, (patt_of_lab loc lab po), (class_expr ce))) | CeFun (loc, (PaOlbi (_, lab, p, e)), ce) -> let lab = paolab lab p in - mkpcl loc + mkcl loc (Pcl_fun (("?" ^ lab), (Some (expr e)), (patt p), (class_expr ce))) | CeFun (loc, (PaOlb (_, lab, p)), ce) -> let lab = paolab lab p in - mkpcl loc + mkcl loc (Pcl_fun (("?" ^ lab), None, (patt_of_lab loc lab p), (class_expr ce))) | CeFun (loc, p, ce) -> - mkpcl loc (Pcl_fun ("", None, (patt p), (class_expr ce))) + mkcl loc (Pcl_fun ("", None, (patt p), (class_expr ce))) | CeLet (loc, rf, bi, ce) -> - mkpcl loc + mkcl loc (Pcl_let ((mkrf rf), (binding bi []), (class_expr ce))) | CeStr (loc, po, cfl) -> let p = (match po with | Ast.PaNil _ -> Ast.PaAny loc | p -> p) in let cil = class_str_item cfl [] - in mkpcl loc (Pcl_structure (((patt p), cil))) + in + mkcl loc + (Pcl_structure + { pcstr_pat = patt p; pcstr_fields = cil; }) | CeTyc (loc, ce, ct) -> - mkpcl loc + mkcl loc (Pcl_constraint ((class_expr ce), (class_type ct))) | CeCon (loc, _, _, _) -> error loc "invalid virtual class inside a class expression" @@ -15526,15 +15611,17 @@ module Struct = match c with | CrNil _ -> l | CrCtr (loc, t1, t2) -> - (Pcf_cstr (((ctyp t1), (ctyp t2), (mkloc loc)))) :: l + (mkcf loc (Pcf_constr (((ctyp t1), (ctyp t2))))) :: l | Ast.CrSem (_, cst1, cst2) -> class_str_item cst1 (class_str_item cst2 l) | CrInh (loc, ov, ce, pb) -> let opb = if pb = "" then None else Some pb in - (Pcf_inher ((override_flag loc ov), (class_expr ce), opb)) :: + (mkcf loc + (Pcf_inher ((override_flag loc ov), (class_expr ce), + opb))) :: l - | CrIni (_, e) -> (Pcf_init (expr e)) :: l + | CrIni (loc, e) -> (mkcf loc (Pcf_init (expr e))) :: l | CrMth (loc, s, ov, pf, e, t) -> let t = (match t with @@ -15542,21 +15629,27 @@ module Struct = | t -> Some (mkpolytype (ctyp t))) in let e = mkexp loc (Pexp_poly ((expr e), t)) in - (Pcf_meth - ((s, (mkprivate pf), (override_flag loc ov), e, - (mkloc loc)))) :: + (mkcf loc + (Pcf_meth + (((with_loc s loc), (mkprivate pf), + (override_flag loc ov), e)))) :: l | CrVal (loc, s, ov, mf, e) -> - (Pcf_val - ((s, (mkmutable mf), (override_flag loc ov), (expr e), - (mkloc loc)))) :: + (mkcf loc + (Pcf_val + (((with_loc s loc), (mkmutable mf), + (override_flag loc ov), (expr e))))) :: l | CrVir (loc, s, pf, t) -> - (Pcf_virt - ((s, (mkprivate pf), (mkpolytype (ctyp t)), (mkloc loc)))) :: + (mkcf loc + (Pcf_virt + (((with_loc s loc), (mkprivate pf), + (mkpolytype (ctyp t)))))) :: l | CrVvr (loc, s, mf, t) -> - (Pcf_valvirt ((s, (mkmutable mf), (ctyp t), (mkloc loc)))) :: + (mkcf loc + (Pcf_valvirt + (((with_loc s loc), (mkmutable mf), (ctyp t))))) :: l | CrAnt (_, _) -> assert false @@ -15571,7 +15664,7 @@ module Struct = | ExInt (_, i) -> Pdir_int (int_of_string i) | Ast.ExId (_, (Ast.IdUid (_, "True"))) -> Pdir_bool true | Ast.ExId (_, (Ast.IdUid (_, "False"))) -> Pdir_bool false - | e -> Pdir_ident (ident (ident_of_expr e)) + | e -> Pdir_ident (ident_noloc (ident_of_expr e)) let phrase = function @@ -16988,7 +17081,11 @@ module Struct = let add_loc bp parse_fun strm = let x = parse_fun strm in let ep = loc_ep strm in - let loc = Loc.merge bp ep in (x, loc) + let loc = + if (Loc.start_off bp) > (Loc.stop_off ep) + then Loc.join bp + else Loc.merge bp ep + in (x, loc) let stream_peek_nth strm n = let rec loop i = @@ -17799,13 +17896,6 @@ module Struct = in Some t | None -> None) | LocAct (_, _) | DeadEnd -> None - and insert_new = - function - | s :: sl -> - Node - { node = s; son = insert_new sl; brother = DeadEnd; - } - | [] -> LocAct (action, []) in insert gsymbols tree let insert_level entry e1 symbols action slev = @@ -18868,7 +18958,7 @@ module Printers = "Cannot print %S this identifier does not respect OCaml lexing rules (%s)" str (Lexer.Error.to_string exn)) - let ocaml_char = function | "'" -> "\\'" | c -> c + let ocaml_char x = Char.escaped (Struct.Token.Eval.char x) let rec get_expr_args a al = match a with @@ -19067,20 +19157,21 @@ module Printers = | Ast.BiAnd (_, b1, b2) -> (o#binding f b1; pp f o#andsep; o#binding f b2) | Ast.BiEq (_, p, e) -> - let (pl, e) = + let (pl, e') = (match p with | Ast.PaTyc (_, _, _) -> ([], e) | _ -> expr_fun_args e) in - (match (p, e) with + (match (p, e') with | (Ast.PaId (_, (Ast.IdLid (_, _))), - Ast.ExTyc (_, e, t)) -> + Ast.ExTyc (_, e', t)) -> pp f "%a :@ %a =@ %a" (list o#fun_binding "@ ") - ((`patt p) :: pl) o#ctyp t o#expr e - | _ -> + ((`patt p) :: pl) o#ctyp t o#expr e' + | (Ast.PaId (_, (Ast.IdLid (_, _))), _) -> pp f "%a @[<0>%a=@]@ %a" o#simple_patt p - (list' o#fun_binding "" "@ ") pl o#expr e) + (list' o#fun_binding "" "@ ") pl o#expr e' + | _ -> pp f "%a =@ %a" o#simple_patt p o#expr e) | Ast.BiAnt (_, s) -> o#anti f s method record_binding = fun f bi -> @@ -19150,7 +19241,16 @@ module Printers = fun f t -> match Ast.list_of_ctyp t [] with | [] -> () - | ts -> pp f "@[<hv0>| %a@]" (list o#ctyp "@ | ") ts + | ts -> + pp f "@[<hv0>| %a@]" + (list o#constructor_declaration "@ | ") ts + method private constructor_declaration = + fun f t -> + match t with + | Ast.TyCol (_, t1, (Ast.TyArr (_, t2, t3))) -> + pp f "@[<2>%a :@ @[<2>%a@ ->@ %a@]@]" o#ctyp t1 + o#constructor_type t2 o#ctyp t3 + | t -> o#ctyp f t method string = fun f -> pp f "%s" method quoted_string = fun f -> pp f "%S" method numeric = @@ -19889,7 +19989,7 @@ module Printers = in match ce with | Ast.CeApp (_, ce, e) -> - pp f "@[<2>%a@ %a@]" o#class_expr ce o#expr e + pp f "@[<2>%a@ %a@]" o#class_expr ce o#apply_expr e | Ast.CeCon (_, Ast.ViNil, i, (Ast.TyNil _)) -> pp f "@[<2>%a@]" o#ident i | Ast.CeCon (_, Ast.ViNil, i, t) -> @@ -20391,6 +20491,8 @@ module Printers = else ()) | Ast.TyCol (_, t1, (Ast.TyMut (_, t2))) -> pp f "@[%a :@ mutable %a@]" o#ctyp t1 o#ctyp t2 + | Ast.TyMan (_, t1, t2) -> + pp f "@[<2>%a ==@ %a@]" o#simple_ctyp t1 o#ctyp t2 | t -> super#ctyp f t method simple_ctyp = fun f t -> diff --git a/camlp4/boot/Camlp4Ast.ml b/camlp4/boot/Camlp4Ast.ml index da35700cd2..0b9a3de0a7 100644 --- a/camlp4/boot/Camlp4Ast.ml +++ b/camlp4/boot/Camlp4Ast.ml @@ -471,7 +471,8 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = value meta_loc = meta_loc_expr; module Expr = struct - value meta_string _loc s = Ast.ExStr _loc (safe_string_escaped s); + value meta_string _loc s = + Ast.ExStr _loc (safe_string_escaped s); value meta_int _loc s = Ast.ExInt _loc s; value meta_float _loc s = Ast.ExFlo _loc s; value meta_char _loc s = Ast.ExChr _loc (String.escaped s); @@ -2577,10 +2578,11 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = value meta_loc = meta_loc_patt; module Patt = struct - value meta_string _loc s = Ast.PaStr _loc s; + value meta_string _loc s = + Ast.PaStr _loc (safe_string_escaped s); value meta_int _loc s = Ast.PaInt _loc s; value meta_float _loc s = Ast.PaFlo _loc s; - value meta_char _loc s = Ast.PaChr _loc s; + value meta_char _loc s = Ast.PaChr _loc (String.escaped s); value meta_bool _loc = fun [ False -> Ast.PaId _loc (Ast.IdUid _loc "False") @@ -5047,6 +5049,8 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = (* source tree. *) (* *) (****************************************************************************) + (* Note: when you modify these types you must increment + ast magic numbers defined in Camlp4_config.ml. *) 'a 'a_out. ('self_type -> 'a -> 'a_out) -> meta_option 'a -> meta_option 'a_out = diff --git a/camlp4/boot/camlp4boot.ml b/camlp4/boot/camlp4boot.ml index 6cc5466c0e..9f7a6d7b01 100644 --- a/camlp4/boot/camlp4boot.ml +++ b/camlp4/boot/camlp4boot.ml @@ -588,6 +588,12 @@ New syntax:\ let stopped_at _loc = Some (Loc.move_line 1 _loc) (* FIXME be more precise *) + let rec generalized_type_of_type = + function + | Ast.TyArr (_, t1, t2) -> + let (tl, rt) = generalized_type_of_type t2 in ((t1 :: tl), rt) + | t -> ([], t) + let symbolchar = let list = [ '$'; '!'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; @@ -676,8 +682,8 @@ New syntax:\ (match Stream.peek __strm with | Some ((KEYWORD - (("mod" | "land" | "lor" | "lxor" | "lsl" | "lsr" | - "asr" + (("or" | "mod" | "land" | "lor" | "lxor" | "lsl" | + "lsr" | "asr" as i)), _loc)) -> @@ -4294,6 +4300,25 @@ New syntax:\ ([ Gram.Snterm (Gram.Entry.obj (label_ipatt : 'label_ipatt Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Skeyword "_"; + Gram.Skeyword ";" ], + (Gram.Action.mk + (fun _ _ _ (p1 : 'label_ipatt) + (_loc : Gram.Loc.t) -> + (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) : + 'label_ipatt_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_ipatt : 'label_ipatt Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Skeyword "_" ], + (Gram.Action.mk + (fun _ _ (p1 : 'label_ipatt) (_loc : Gram.Loc.t) + -> + (Ast.PaSem (_loc, p1, (Ast.PaAny _loc)) : + 'label_ipatt_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_ipatt : 'label_ipatt Gram.Entry.t)); Gram.Skeyword ";"; Gram.Sself ], (Gram.Action.mk (fun (p2 : 'label_ipatt_list) _ @@ -5037,40 +5062,16 @@ New syntax:\ (a_UIDENT : 'a_UIDENT Gram.Entry.t)); Gram.Skeyword ":"; Gram.Snterm - (Gram.Entry.obj - (constructor_arg_list : - 'constructor_arg_list Gram.Entry.t)) ], - (Gram.Action.mk - (fun (ret : 'constructor_arg_list) _ - (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (match Ast.list_of_ctyp ret [] with - | [ c ] -> - Ast.TyCol (_loc, - (Ast.TyId (_loc, - (Ast.IdUid (_loc, s)))), - c) - | _ -> - raise - (Stream.Error - "invalid generalized constructor type") : - 'constructor_declarations)))); - ([ Gram.Snterm - (Gram.Entry.obj - (a_UIDENT : 'a_UIDENT Gram.Entry.t)); - Gram.Skeyword ":"; - Gram.Snterm - (Gram.Entry.obj - (constructor_arg_list : - 'constructor_arg_list Gram.Entry.t)); - Gram.Skeyword "->"; - Gram.Snterm (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], (Gram.Action.mk - (fun (ret : 'ctyp) _ (t : 'constructor_arg_list) - _ (s : 'a_UIDENT) (_loc : Gram.Loc.t) -> - (Ast.TyCol (_loc, - (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))), - (Ast.TyArr (_loc, t, ret))) : + (fun (t : 'ctyp) _ (s : 'a_UIDENT) + (_loc : Gram.Loc.t) -> + (let (tl, rt) = generalized_type_of_type t + in + Ast.TyCol (_loc, + (Ast.TyId (_loc, (Ast.IdUid (_loc, s)))), + (Ast.TyArr (_loc, + (Ast.tyAnd_of_list tl), rt))) : 'constructor_declarations)))); ([ Gram.Snterm (Gram.Entry.obj @@ -8756,7 +8757,10 @@ New syntax:\ (Gram.Action.mk (fun (st2 : 'str_item_quot) _ (st1 : 'str_item) (_loc : Gram.Loc.t) -> - (Ast.StSem (_loc, st1, st2) : 'str_item_quot)))); + (match st2 with + | Ast.StNil _ -> st1 + | _ -> Ast.StSem (_loc, st1, st2) : + 'str_item_quot)))); ([ Gram.Skeyword "#"; Gram.Snterm (Gram.Entry.obj @@ -8792,7 +8796,10 @@ New syntax:\ (Gram.Action.mk (fun (sg2 : 'sig_item_quot) _ (sg1 : 'sig_item) (_loc : Gram.Loc.t) -> - (Ast.SgSem (_loc, sg1, sg2) : 'sig_item_quot)))); + (match sg2 with + | Ast.SgNil _ -> sg1 + | _ -> Ast.SgSem (_loc, sg1, sg2) : + 'sig_item_quot)))); ([ Gram.Skeyword "#"; Gram.Snterm (Gram.Entry.obj @@ -9232,7 +9239,9 @@ New syntax:\ (Gram.Action.mk (fun (x2 : 'class_str_item_quot) _ (x1 : 'class_str_item) (_loc : Gram.Loc.t) -> - (Ast.CrSem (_loc, x1, x2) : + (match x2 with + | Ast.CrNil _ -> x1 + | _ -> Ast.CrSem (_loc, x1, x2) : 'class_str_item_quot)))) ]) ])) ()); Gram.extend @@ -9261,7 +9270,9 @@ New syntax:\ (Gram.Action.mk (fun (x2 : 'class_sig_item_quot) _ (x1 : 'class_sig_item) (_loc : Gram.Loc.t) -> - (Ast.CgSem (_loc, x1, x2) : + (match x2 with + | Ast.CgNil _ -> x1 + | _ -> Ast.CgSem (_loc, x1, x2) : 'class_sig_item_quot)))) ]) ])) ()); Gram.extend (with_constr_quot : 'with_constr_quot Gram.Entry.t) @@ -13692,6 +13703,7 @@ Added statements: DEFINE <lident> = <expression> IN <expression> __FILE__ __LOCATION__ + LOCATION_OF <parameter> In patterns: @@ -13724,6 +13736,10 @@ Added statements: The expression __FILE__ returns the current compiled file name. The expression __LOCATION__ returns the current location of itself. + If used inside a macro, it returns the location where the macro is + called. + The expression (LOCATION_OF parameter) returns the location of the given + macro parameter. It cannot be used outside a macro definition. *) open Camlp4 @@ -13794,6 +13810,48 @@ Added statements: Ast.ExId (_, (Ast.IdUid (_, x))) as e) -> (try List.assoc x env with | Not_found -> super#expr e) + | (Ast.ExApp (_loc, + (Ast.ExId (_, (Ast.IdUid (_, "LOCATION_OF")))), + (Ast.ExId (_, (Ast.IdLid (_, x))))) | + Ast.ExApp (_loc, + (Ast.ExId (_, (Ast.IdUid (_, "LOCATION_OF")))), + (Ast.ExId (_, (Ast.IdUid (_, x))))) + as e) -> + (try + let loc = Ast.loc_of_expr (List.assoc x env) in + let (a, b, c, d, e, f, g, h) = Loc.to_tuple loc + in + Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Loc")), + (Ast.IdLid (_loc, "of_tuple")))))), + (Ast.ExTup (_loc, + (Ast.ExCom (_loc, + (Ast.ExStr (_loc, (Ast.safe_string_escaped a))), + (Ast.ExCom (_loc, + (Ast.ExCom (_loc, + (Ast.ExCom (_loc, + (Ast.ExCom (_loc, + (Ast.ExCom (_loc, + (Ast.ExCom (_loc, + (Ast.ExInt (_loc, + (string_of_int b))), + (Ast.ExInt (_loc, + (string_of_int c))))), + (Ast.ExInt (_loc, + (string_of_int d))))), + (Ast.ExInt (_loc, + (string_of_int e))))), + (Ast.ExInt (_loc, (string_of_int f))))), + (Ast.ExInt (_loc, (string_of_int g))))), + (if h + then + Ast.ExId (_loc, + (Ast.IdUid (_loc, "True"))) + else + Ast.ExId (_loc, + (Ast.IdUid (_loc, "False"))))))))))) + with | Not_found -> super#expr e) | e -> super#expr e method patt = function @@ -14541,87 +14599,6 @@ Added statements: (i : 'uident) _ (_loc : Gram.Loc.t) -> (if is_defined i then e1 else e2 : 'expr)))) ]) ])) ()); - Gram.extend (expr : 'expr Gram.Entry.t) - ((fun () -> - ((Some (Camlp4.Sig.Grammar.Level "simple")), - [ (None, None, - [ ([ Gram.Stoken - (((function - | LIDENT "__LOCATION__" -> true - | _ -> false), - "LIDENT \"__LOCATION__\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT "__LOCATION__" -> - (let (a, b, c, d, e, f, g, h) = - Loc.to_tuple _loc - in - Ast.ExApp (_loc, - (Ast.ExId (_loc, - (Ast.IdAcc (_loc, - (Ast.IdUid (_loc, "Loc")), - (Ast.IdLid (_loc, "of_tuple")))))), - (Ast.ExTup (_loc, - (Ast.ExCom (_loc, - (Ast.ExStr (_loc, - (Ast.safe_string_escaped a))), - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom (_loc, - (Ast.ExCom - (_loc, - (Ast.ExInt - (_loc, - ( - string_of_int - b))), - (Ast.ExInt - (_loc, - ( - string_of_int - c))))), - (Ast.ExInt - (_loc, - (string_of_int - d))))), - (Ast.ExInt (_loc, - (string_of_int - e))))), - (Ast.ExInt (_loc, - (string_of_int f))))), - (Ast.ExInt (_loc, - (string_of_int g))))), - (if h - then - Ast.ExId (_loc, - (Ast.IdUid (_loc, - "True"))) - else - Ast.ExId (_loc, - (Ast.IdUid (_loc, - "False"))))))))))) : - 'expr) - | _ -> assert false))); - ([ Gram.Stoken - (((function - | LIDENT "__FILE__" -> true - | _ -> false), - "LIDENT \"__FILE__\"")) ], - (Gram.Action.mk - (fun (__camlp4_0 : Gram.Token.t) - (_loc : Gram.Loc.t) -> - match __camlp4_0 with - | LIDENT "__FILE__" -> - (Ast.ExStr (_loc, - (Ast.safe_string_escaped - (Loc.file_name _loc))) : - 'expr) - | _ -> assert false))) ]) ])) - ()); Gram.extend (patt : 'patt Gram.Entry.t) ((fun () -> (None, @@ -14790,17 +14767,47 @@ Added statements: open Ast - let remove_nothings = + (* Remove NOTHING and expanse __FILE__ and __LOCATION__ *) + let map_expr = function | Ast.ExApp (_, e, (Ast.ExId (_, (Ast.IdUid (_, "NOTHING"))))) | Ast.ExFun (_, (Ast.McArr (_, (Ast.PaId (_, (Ast.IdUid (_, "NOTHING")))), (Ast.ExNil _), e))) -> e + | Ast.ExId (_loc, (Ast.IdLid (_, "__FILE__"))) -> + Ast.ExStr (_loc, + (Ast.safe_string_escaped (Loc.file_name _loc))) + | Ast.ExId (_loc, (Ast.IdLid (_, "__LOCATION__"))) -> + let (a, b, c, d, e, f, g, h) = Loc.to_tuple _loc + in + Ast.ExApp (_loc, + (Ast.ExId (_loc, + (Ast.IdAcc (_loc, (Ast.IdUid (_loc, "Loc")), + (Ast.IdLid (_loc, "of_tuple")))))), + (Ast.ExTup (_loc, + (Ast.ExCom (_loc, + (Ast.ExStr (_loc, (Ast.safe_string_escaped a))), + (Ast.ExCom (_loc, + (Ast.ExCom (_loc, + (Ast.ExCom (_loc, + (Ast.ExCom (_loc, + (Ast.ExCom (_loc, + (Ast.ExCom (_loc, + (Ast.ExInt (_loc, + (string_of_int b))), + (Ast.ExInt (_loc, + (string_of_int c))))), + (Ast.ExInt (_loc, (string_of_int d))))), + (Ast.ExInt (_loc, (string_of_int e))))), + (Ast.ExInt (_loc, (string_of_int f))))), + (Ast.ExInt (_loc, (string_of_int g))))), + (if h + then Ast.ExId (_loc, (Ast.IdUid (_loc, "True"))) + else Ast.ExId (_loc, (Ast.IdUid (_loc, "False"))))))))))) | e -> e - let _ = - register_str_item_filter (Ast.map_expr remove_nothings)#str_item + let _ = register_str_item_filter (Ast.map_expr map_expr)#str_item end diff --git a/camlp4/examples/arith.ml b/camlp4/examples/arith.ml index e60c7fb59a..15953262c5 100644 --- a/camlp4/examples/arith.ml +++ b/camlp4/examples/arith.ml @@ -16,17 +16,17 @@ open Camlp4.PreCast;; module ArithGram = MakeGram(Lexer);; - + type t = Local of string * t * t | Binop of t * (int -> int -> int) * t | Int of int | Var of string;; - + let expression = ArithGram.Entry.mk "expression";; - + EXTEND ArithGram GLOBAL: expression; - + expression: (* A grammar entry for expressions *) [ "top" [ "let"; `LIDENT s; "="; e1 = SELF; "in"; e2 = SELF -> Local(s,e1,e2) ] @@ -41,12 +41,12 @@ | `LIDENT s -> Var(s) | "("; e = expression; ")" -> e ] ]; - + END;; - + let parse_arith s = ArithGram.parse_string expression (Loc.mk "<string>") s;; - + let rec eval env = function | Local(x, e1, e2) -> @@ -56,8 +56,8 @@ op (eval env e1) (eval env e2) | Int(i) -> i | Var(x) -> List.assoc x env;; - + let calc s = Format.printf "%s ==> %d@." s (eval [] (parse_arith s));; - + calc "42 * let x = 21 in x + x";; diff --git a/camlp4/test/fixtures/bug-camlp4o-constr-arity.ml b/camlp4/test/fixtures/bug-camlp4o-constr-arity.ml index 25efe042be..322cc67e1e 100644 --- a/camlp4/test/fixtures/bug-camlp4o-constr-arity.ml +++ b/camlp4/test/fixtures/bug-camlp4o-constr-arity.ml @@ -72,4 +72,3 @@ let rec next line pos0 = () in ();; (* fun Some None None None -> ();; *) (* fun x, y -> ();; |+ syntax error +| *) - diff --git a/camlp4/test/fixtures/macrotest.ml b/camlp4/test/fixtures/macrotest.ml index 023a5b4262..8252970888 100644 --- a/camlp4/test/fixtures/macrotest.ml +++ b/camlp4/test/fixtures/macrotest.ml @@ -36,7 +36,7 @@ ELSIF print_int (A * a_should_be_present + 5); ENDIF; -value e = +value e = IFDEF DNE THEN print_int (c_should_not_be_present + 2) ELSE diff --git a/camlp4/test/fixtures/macrotest3.ml b/camlp4/test/fixtures/macrotest3.ml index ef618d283f..73ca9554cc 100644 --- a/camlp4/test/fixtures/macrotest3.ml +++ b/camlp4/test/fixtures/macrotest3.ml @@ -8,4 +8,3 @@ IFNDEF UNDEFINED_VARIABLE THEN END;; Printf.printf "%d\n" (DOUBLE_SQUARE(42)) ;; - diff --git a/camlp4/test/fixtures/match.ml b/camlp4/test/fixtures/match.ml index 9fb52cb791..3d29ad5d4d 100644 --- a/camlp4/test/fixtures/match.ml +++ b/camlp4/test/fixtures/match.ml @@ -1,6 +1,6 @@ let x = match y with - | A z -> z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z + | A z -> z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z z | B l -> (match l with | [] -> () diff --git a/camlp4/test/fixtures/match_parser.ml b/camlp4/test/fixtures/match_parser.ml index e053ee88fe..0a4fc2fa31 100644 --- a/camlp4/test/fixtures/match_parser.ml +++ b/camlp4/test/fixtures/match_parser.ml @@ -7,4 +7,3 @@ let a = [ <:expr< parser [: `$str:x$ :] -> t >> -> x | _ -> assert False ] in Format.printf "a: %S@." a; - diff --git a/camlp4/test/fixtures/pp_xml.ml b/camlp4/test/fixtures/pp_xml.ml index 986998c419..72d28dd517 100644 --- a/camlp4/test/fixtures/pp_xml.ml +++ b/camlp4/test/fixtures/pp_xml.ml @@ -28,4 +28,3 @@ let tree = ]) let () = Format.printf "%a@." print_elt tree - diff --git a/camlp4/test/fixtures/private_row.ml b/camlp4/test/fixtures/private_row.ml index 53ada775b5..2ea0776d44 100644 --- a/camlp4/test/fixtures/private_row.ml +++ b/camlp4/test/fixtures/private_row.ml @@ -1,4 +1,4 @@ - + module type Ops = sig type expr diff --git a/camlp4/test/fixtures/stream-parser-bug.ml b/camlp4/test/fixtures/stream-parser-bug.ml index 6c17793ce3..468c6671b1 100644 --- a/camlp4/test/fixtures/stream-parser-bug.ml +++ b/camlp4/test/fixtures/stream-parser-bug.ml @@ -3,4 +3,3 @@ let foo = parser let ps = ps + 42 in type_phrases ps | [< >] -> [< >] - diff --git a/camlp4/test/fixtures/try.ml b/camlp4/test/fixtures/try.ml index 90c01a3e08..9eb394e3f3 100644 --- a/camlp4/test/fixtures/try.ml +++ b/camlp4/test/fixtures/try.ml @@ -3,4 +3,3 @@ try in foo bar foo bar foo bar foo bar foo bar foo bar foo bar foo bar foo bar foo bar foo bar foo bar with Not_found -> stderr - diff --git a/camlp4/unmaintained/compile/comp_head.ml b/camlp4/unmaintained/compile/comp_head.ml index cd62343641..c44562146a 100644 --- a/camlp4/unmaintained/compile/comp_head.ml +++ b/camlp4/unmaintained/compile/comp_head.ml @@ -67,4 +67,3 @@ let _ = do { Printf.eprintf "recovered or_zero at loc (%d, %d)\n" loc1 loc2; flu ; (****************************************) - diff --git a/camlp4/unmaintained/etc/.depend b/camlp4/unmaintained/etc/.depend index 863adc1cad..5c310d5b00 100644 --- a/camlp4/unmaintained/etc/.depend +++ b/camlp4/unmaintained/etc/.depend @@ -1,6 +1,6 @@ -parserify.cmo: parserify.cmi -parserify.cmx: parserify.cmi -pr_op_main.cmo: parserify.cmi -pr_op_main.cmx: parserify.cmx -pr_rp_main.cmo: parserify.cmi -pr_rp_main.cmx: parserify.cmx +parserify.cmo: parserify.cmi +parserify.cmx: parserify.cmi +pr_op_main.cmo: parserify.cmi +pr_op_main.cmx: parserify.cmx +pr_rp_main.cmo: parserify.cmi +pr_rp_main.cmx: parserify.cmx diff --git a/camlp4/unmaintained/etc/pa_oop.ml b/camlp4/unmaintained/etc/pa_oop.ml index bb5684ba4e..62302e3960 100644 --- a/camlp4/unmaintained/etc/pa_oop.ml +++ b/camlp4/unmaintained/etc/pa_oop.ml @@ -107,7 +107,7 @@ value rec cstream gloc = <:expr< Stream.lapp $slazy _loc e$ $cstream gloc secl$ >> ] ; -(* Syntax extensions in Ocaml grammar *) +(* Syntax extensions in OCaml grammar *) EXTEND diff --git a/camlp4/unmaintained/format/README b/camlp4/unmaintained/format/README index 830402b651..2b9e63f7a5 100644 --- a/camlp4/unmaintained/format/README +++ b/camlp4/unmaintained/format/README @@ -12,4 +12,3 @@ Library (that is, LGPL with a special exception allowing both static and dynamic link). -- Michel Mauny - diff --git a/camlp4/unmaintained/lefteval/README b/camlp4/unmaintained/lefteval/README index 830402b651..2b9e63f7a5 100644 --- a/camlp4/unmaintained/lefteval/README +++ b/camlp4/unmaintained/lefteval/README @@ -12,4 +12,3 @@ Library (that is, LGPL with a special exception allowing both static and dynamic link). -- Michel Mauny - diff --git a/camlp4/unmaintained/lib/.depend b/camlp4/unmaintained/lib/.depend index a779396987..bf4c0c1afb 100644 --- a/camlp4/unmaintained/lib/.depend +++ b/camlp4/unmaintained/lib/.depend @@ -1,14 +1,14 @@ -debug.cmo: debug.cmi -debug.cmx: debug.cmi -extfun.cmo: extfun.cmi -extfun.cmx: extfun.cmi -fstream.cmo: fstream.cmi -fstream.cmx: fstream.cmi -grammar.cmo: token.cmi plexer.cmi loc.cmi -grammar.cmx: token.cmx plexer.cmi loc.cmx -loc.cmo: loc.cmi -loc.cmx: loc.cmi -token.cmo: loc.cmi token.cmi -token.cmx: loc.cmx token.cmi -plexer.cmi: token.cmi loc.cmi -token.cmi: loc.cmi +debug.cmo: debug.cmi +debug.cmx: debug.cmi +extfun.cmo: extfun.cmi +extfun.cmx: extfun.cmi +fstream.cmo: fstream.cmi +fstream.cmx: fstream.cmi +grammar.cmo: token.cmi plexer.cmi loc.cmi +grammar.cmx: token.cmx plexer.cmi loc.cmx +loc.cmo: loc.cmi +loc.cmx: loc.cmi +token.cmo: loc.cmi token.cmi +token.cmx: loc.cmx token.cmi +plexer.cmi: token.cmi loc.cmi +token.cmi: loc.cmi diff --git a/camlp4/unmaintained/lib/Makefile b/camlp4/unmaintained/lib/Makefile index 3d5be9b45a..76eba3ab0b 100644 --- a/camlp4/unmaintained/lib/Makefile +++ b/camlp4/unmaintained/lib/Makefile @@ -43,7 +43,7 @@ installopt: for f in $(LIBRARIESX) $(LIBRARIESP) *.cmx ; do \ test -f $$f && cp $$f "$(LIBDIR)/camlp4/." || true ; \ done - # Special treatment for this one: some versions of make don't like $(A) in $(TARGET:.cma=.$(A)) + # Special treatment for this one: some versions of make don't like $(A) in $(TARGET:.cma=.$(A)) target="`echo $(LIBRARIES) | sed -e 's/\.cma$$/.$(A)/'`" ; \ if test -f $$target ; then \ cp $$target "$(LIBDIR)/camlp4/." && ( cd "$(LIBDIR)/camlp4/." && $(RANLIB) $$target ) \ diff --git a/camlp4/unmaintained/lib/extfun.ml b/camlp4/unmaintained/lib/extfun.ml index 4f4cbbd93a..721157aa6d 100644 --- a/camlp4/unmaintained/lib/extfun.ml +++ b/camlp4/unmaintained/lib/extfun.ml @@ -92,7 +92,7 @@ value insert_matching matchings (patt, has_when, expr) = if m1.has_when && not m.has_when then [m1 :: gml] else if not m1.has_when && m.has_when then [m :: loop ml] else (* either both or none have a when clause *) - if compare m1.patt m.patt = 0 then + if compare m1.patt m.patt = 0 then if not m1.has_when then [m1 :: ml] else [m1 :: gml] else [m :: loop ml] | [] -> [m1] ] diff --git a/camlp4/unmaintained/ocamllex/README b/camlp4/unmaintained/ocamllex/README index 830402b651..2b9e63f7a5 100644 --- a/camlp4/unmaintained/ocamllex/README +++ b/camlp4/unmaintained/ocamllex/README @@ -12,4 +12,3 @@ Library (that is, LGPL with a special exception allowing both static and dynamic link). -- Michel Mauny - diff --git a/camlp4/unmaintained/ocamllex/pa_ocamllex.ml b/camlp4/unmaintained/ocamllex/pa_ocamllex.ml index e1d4a8ef0d..79c620f7e3 100644 --- a/camlp4/unmaintained/ocamllex/pa_ocamllex.ml +++ b/camlp4/unmaintained/ocamllex/pa_ocamllex.ml @@ -75,7 +75,7 @@ let output_tables tbl = let rec make_alias n = function | [] -> [] - | h::t -> + | h::t -> (h, "__ocaml_lex_arg_" ^ (string_of_int n)) :: (make_alias (succ n) t) let abstraction = @@ -87,13 +87,13 @@ let application = let int i = <:expr< $int:string_of_int i$ >> -let output_memory_actions acts = +let output_memory_actions acts = let aux = function - | Copy (tgt, src) -> - <:expr< lexbuf.Lexing.lex_mem.($int tgt$) := + | Copy (tgt, src) -> + <:expr< lexbuf.Lexing.lex_mem.($int tgt$) := lexbuf.Lexing.lex_mem.($int src$) >> | Set tgt -> - <:expr< lexbuf.Lexing.lex_mem.($int tgt$) := + <:expr< lexbuf.Lexing.lex_mem.($int tgt$) := lexbuf.Lexing.lex_curr_pos >> in <:expr< do { $list:List.map aux acts$ } >> @@ -110,17 +110,17 @@ let output_tag_access = function let rec output_env e = function | [] -> e | (x, Ident_string (o,nstart,nend)) :: rem -> - <:expr< - let $lid:x$ = - Lexing.$lid:if o then "sub_lexeme_opt" else "sub_lexeme"$ - lexbuf $output_tag_access nstart$ $output_tag_access nend$ + <:expr< + let $lid:x$ = + Lexing.$lid:if o then "sub_lexeme_opt" else "sub_lexeme"$ + lexbuf $output_tag_access nstart$ $output_tag_access nend$ in $output_env e rem$ >> | (x, Ident_char (o,nstart)) :: rem -> - <:expr< - let $lid:x$ = - Lexing.$lid: if o then "sub_lexeme_char_opt" else "sub_lexeme_char"$ - lexbuf $output_tag_access nstart$ + <:expr< + let $lid:x$ = + Lexing.$lid: if o then "sub_lexeme_char_opt" else "sub_lexeme_char"$ + lexbuf $output_tag_access nstart$ in $output_env e rem$ >> @@ -129,36 +129,36 @@ let output_entry e = let args = make_alias 0 (e.auto_args @ [ <:patt< lexbuf >> ]) in let f = "__ocaml_lex_rec_" ^ e.auto_name ^ "_rec" in let call_f = application <:expr< $lid:f$ >> args in - let body_wrapper = - <:expr< + let body_wrapper = + <:expr< do { - lexbuf.Lexing.lex_mem := Array.create $int e.auto_mem_size$ (-1) ; - $output_memory_actions init_moves$; + lexbuf.Lexing.lex_mem := Array.create $int e.auto_mem_size$ (-1) ; + $output_memory_actions init_moves$; $call_f$ $int init_num$ } >> in - let cases = + let cases = List.map (fun (num, env, (loc,e)) -> - <:patt< $int:string_of_int num$ >>, - None, - output_env <:expr< $e$ >> env - (* Note: the <:expr<...>> above is there to set the location *) + <:patt< $int:string_of_int num$ >>, + None, + output_env <:expr< $e$ >> env + (* Note: the <:expr<...>> above is there to set the location *) ) e.auto_actions @ [ <:patt< __ocaml_lex_n >>, None, - <:expr< do + <:expr< do { lexbuf.Lexing.refill_buff lexbuf; $call_f$ __ocaml_lex_n }>> ] in - let engine = - if e.auto_mem_size = 0 + let engine = + if e.auto_mem_size = 0 then <:expr< Lexing.engine >> else <:expr< Lexing.new_engine >> in - let body = + let body = <:expr< fun state -> match $engine$ lex_tables state lexbuf with [ $list:cases$ ] >> in [ <:patt< $lid:e.auto_name$ >>, (abstraction args body_wrapper); - <:patt< $lid:f$ >>, (abstraction args body) + <:patt< $lid:f$ >>, (abstraction args body) ] (* Main output function *) @@ -166,7 +166,7 @@ let output_entry e = exception Table_overflow let output_lexdef tables entry_points = - Printf.eprintf + Printf.eprintf "pa_ocamllex: lexer found; %d states, %d transitions, table size %d bytes\n" (Array.length tables.tbl_base) (Array.length tables.tbl_trans) @@ -181,7 +181,7 @@ let output_lexdef tables entry_points = Array.length tables.tbl_check_code) + Array.length tables.tbl_code) in if size_groups > 0 then - Printf.eprintf "pa_ocamllex: %d additional bytes used for bindings\n" + Printf.eprintf "pa_ocamllex: %d additional bytes used for bindings\n" size_groups ; flush stderr; if Array.length tables.tbl_trans > 0x8000 then raise Table_overflow; @@ -237,7 +237,7 @@ EXTEND let_regexp: [ [ x = LIDENT; "="; r = regexp -> if Hashtbl.mem named_regexps x then - Printf.eprintf + Printf.eprintf "pa_ocamllex (warning): multiple definition of named regexp '%s'\n" x; Hashtbl.add named_regexps x r; @@ -250,11 +250,11 @@ EXTEND let (entries, transitions) = make_dfa def in let tables = compact_tables transitions in let output = output_lexdef tables entries in - <:str_item< declare $list: output$ end >> - with - |Table_overflow -> + <:str_item< declare $list: output$ end >> + with + |Table_overflow -> failwith "Transition table overflow in lexer, automaton is too big" - | Lexgen.Memory_overflow -> + | Lexgen.Memory_overflow -> failwith "Position memory overflow in lexer, too many as variables") ] ]; @@ -262,11 +262,11 @@ EXTEND Pcaml.str_item: [ [ "pa_ocamllex"; LIDENT "rule"; d = lexer_def -> d - | "pa_ocamllex"; "let"; let_regexp -> + | "pa_ocamllex"; "let"; let_regexp -> <:str_item< declare $list: []$ end >> ] ]; - + definition: [ [ x=LIDENT; pl = LIST0 Pcaml.patt LEVEL "simple"; "="; short=[ LIDENT "parse" -> false | LIDENT "shortest" -> true ]; @@ -275,7 +275,7 @@ EXTEND ]; action: [ - [ "{"; e = OPT Pcaml.expr; "}" -> + [ "{"; e = OPT Pcaml.expr; "}" -> let e = match e with | Some e -> e | None -> <:expr< () >> @@ -285,7 +285,7 @@ EXTEND ]; header: [ - [ "{"; e = LIST0 [ si = Pcaml.str_item; OPT ";;" -> si ]; "}" -> + [ "{"; e = LIST0 [ si = Pcaml.str_item; OPT ";;" -> si ]; "}" -> [<:str_item< declare $list:e$ end>>, loc] ] | [ -> [] ] ]; @@ -305,7 +305,7 @@ EXTEND | x = LIDENT -> try Hashtbl.find named_regexps x with Not_found -> - failwith + failwith ("pa_ocamllex (error): reference to unbound regexp name `"^x^"'") ] ]; @@ -353,4 +353,3 @@ let standalone = let () = Pcaml.add_option "-ocamllex" (Arg.Unit standalone) "Activate (standalone) ocamllex emulation mode." - diff --git a/camlp4/unmaintained/odyl/.depend b/camlp4/unmaintained/odyl/.depend index a26294403e..fba65acca7 100644 --- a/camlp4/unmaintained/odyl/.depend +++ b/camlp4/unmaintained/odyl/.depend @@ -1,4 +1,4 @@ -odyl.cmo: odyl_main.cmi odyl_config.cmo -odyl.cmx: odyl_main.cmx odyl_config.cmx -odyl_main.cmo: odyl_config.cmo odyl_main.cmi -odyl_main.cmx: odyl_config.cmx odyl_main.cmi +odyl.cmo: odyl_main.cmi odyl_config.cmo +odyl.cmx: odyl_main.cmx odyl_config.cmx +odyl_main.cmo: odyl_config.cmo odyl_main.cmi +odyl_main.cmx: odyl_config.cmx odyl_main.cmi diff --git a/camlp4/unmaintained/olabl/README b/camlp4/unmaintained/olabl/README index 830402b651..2b9e63f7a5 100644 --- a/camlp4/unmaintained/olabl/README +++ b/camlp4/unmaintained/olabl/README @@ -12,4 +12,3 @@ Library (that is, LGPL with a special exception allowing both static and dynamic link). -- Michel Mauny - diff --git a/camlp4/unmaintained/olabl/pa_olabl.ml b/camlp4/unmaintained/olabl/pa_olabl.ml index 285902a144..da70a67563 100644 --- a/camlp4/unmaintained/olabl/pa_olabl.ml +++ b/camlp4/unmaintained/olabl/pa_olabl.ml @@ -1964,7 +1964,7 @@ value rec cstream gloc = else <:expr< Stream.lapp $slazy loc e$ $cstream gloc secl$ >> ] ; -(* Syntax extensions in Ocaml grammar *) +(* Syntax extensions in OCaml grammar *) EXTEND GLOBAL: expr; diff --git a/camlp4/unmaintained/scheme/README b/camlp4/unmaintained/scheme/README index 830402b651..2b9e63f7a5 100644 --- a/camlp4/unmaintained/scheme/README +++ b/camlp4/unmaintained/scheme/README @@ -12,4 +12,3 @@ Library (that is, LGPL with a special exception allowing both static and dynamic link). -- Michel Mauny - diff --git a/camlp4/unmaintained/scheme/pa_scheme.sc b/camlp4/unmaintained/scheme/pa_scheme.sc index cc6de1894b..acc12c9c5e 100644 --- a/camlp4/unmaintained/scheme/pa_scheme.sc +++ b/camlp4/unmaintained/scheme/pa_scheme.sc @@ -1,17 +1,17 @@ ; pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo -; ********************************************************************** -; -; Camlp4 -; -; Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt -; -; Copyright 2002 Institut National de Recherche en Informatique et -; en Automatique. All rights reserved. This file is distributed -; under the terms of the GNU Library General Public License, with -; the special exception on linking described in file -; ../../../LICENSE. -; -; ********************************************************************** +; ********************************************************************** ; +; ; +; Camlp4 ; +; ; +; Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt ; +; ; +; Copyright 2002 Institut National de Recherche en Informatique et ; +; en Automatique. All rights reserved. This file is distributed ; +; under the terms of the GNU Library General Public License, with ; +; the special exception on linking described in file ; +; ../../../LICENSE. ; +; ; +; ********************************************************************** ; (open Pcaml) (open Stdpp) diff --git a/camlp4/unmaintained/scheme/pr_scheme.ml b/camlp4/unmaintained/scheme/pr_scheme.ml index a9cf348eb5..d01c99b85b 100644 --- a/camlp4/unmaintained/scheme/pr_scheme.ml +++ b/camlp4/unmaintained/scheme/pr_scheme.ml @@ -189,7 +189,7 @@ value int_repr s = [ 'b' | 'o' | 'x' | 'B' | 'O' | 'X' -> "#" ^ String.sub s 1 (String.length s - 1) | _ -> s ] - else s + else s ; value assoc_left_parsed_op_list = ["+"; "*"; "land"; "lor"; "lxor"]; diff --git a/camlp4/unmaintained/sml/README b/camlp4/unmaintained/sml/README index 830402b651..2b9e63f7a5 100644 --- a/camlp4/unmaintained/sml/README +++ b/camlp4/unmaintained/sml/README @@ -12,4 +12,3 @@ Library (that is, LGPL with a special exception allowing both static and dynamic link). -- Michel Mauny - diff --git a/camlp4/unmaintained/sml/pa_sml.ml b/camlp4/unmaintained/sml/pa_sml.ml index 1808cdea5e..6caac8cb70 100644 --- a/camlp4/unmaintained/sml/pa_sml.ml +++ b/camlp4/unmaintained/sml/pa_sml.ml @@ -279,7 +279,7 @@ value record_expr loc x1 = <:expr< let module M = struct - class a = object $list:list1 @ list2$ end; + class a = object $list:list1 @ list2$ end; end in new M.a diff --git a/camlp4/unmaintained/sml/smllib.sml b/camlp4/unmaintained/sml/smllib.sml index 5ecd093788..5f2a992812 100644 --- a/camlp4/unmaintained/sml/smllib.sml +++ b/camlp4/unmaintained/sml/smllib.sml @@ -300,7 +300,7 @@ type substring = Substring.substring structure StringCvt = struct datatype radix = BIN | OCT | DEC | HEX - type ('a, 'b) reader = 'b -> ('a * 'b) option + type ('a, 'b) reader = 'b -> ('a * 'b) option end structure ListPair = diff --git a/testsuite/tests/letrec/backreferences.result b/compilerlibs/.gitignore index e69de29bb2..e69de29bb2 100644 --- a/testsuite/tests/letrec/backreferences.result +++ b/compilerlibs/.gitignore diff --git a/config/Makefile.mingw b/config/Makefile.mingw index 0aea48ceb7..aaf17f9293 100644 --- a/config/Makefile.mingw +++ b/config/Makefile.mingw @@ -19,6 +19,9 @@ PREFIX=C:/ocamlmgw +### 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 592aff8874..d2d9562cd5 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 @@ -141,6 +142,13 @@ NATIVECCLINKOPTS= ### Build partially-linked object file PACKLD=link /lib /nologo /out:# there must be no space after this '/out:' +############# Configuration for camlp4 + +# This variable controls whether camlp4 will be built. +# If it is set to camlp4, then it will be built. +# If it is set to the empty string, then it will not be built. +CAMLP4=camlp4 + ############# Configuration for the contributed libraries OTHERLIBRARIES=win32unix systhreads str num win32graph dynlink bigarray labltk diff --git a/config/Makefile.msvc64 b/config/Makefile.msvc64 index 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 new file mode 100644 index 0000000000..acd052df0b --- /dev/null +++ b/config/auto-aux/cfi.S @@ -0,0 +1,6 @@ +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/expm1.c b/config/auto-aux/expm1.c index f115a91110..db4413b92b 100644 --- a/config/auto-aux/expm1.c +++ b/config/auto-aux/expm1.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: longlong.c 4833 2002-05-25 08:33:26Z xleroy $ */ +/* $Id$ */ #include <math.h> diff --git a/config/auto-aux/tryassemble b/config/auto-aux/tryassemble new file mode 100644 index 0000000000..7cd5582c8c --- /dev/null +++ b/config/auto-aux/tryassemble @@ -0,0 +1,17 @@ +#!/bin/sh +if test "$verbose" = yes; then +echo "tryassemble: $aspp -o tst $*" >&2 +$aspp -o tst $* || exit 100 +else +$aspp -o tst $* 2> /dev/null || exit 100 +fi + +# 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 @@ -31,6 +31,7 @@ mathlib='-lm' dllib='' x11_include_dir='' x11_lib_dir='' +graph_wanted=yes tk_wanted=yes pthread_wanted=yes tk_defs='' @@ -43,6 +44,7 @@ debugruntime=noruntimed withsharedlibs=yes gcc_warnings="-Wall" partialld="ld -r" +withcamlp4=camlp4 # Try to turn internationalization off, can cause config.guess to malfunction! unset LANG @@ -82,14 +84,15 @@ while : ; do asppoption="$2"; shift;; -lib*) cclibs="$2 $cclibs"; shift;; - -no-curses) + -no-curses|--no-curses) withcurses=no;; - -no-shared-libs) + -no-shared-libs|--no-shared-libs) withsharedlibs=no;; -x11include*|--x11include*) x11_include_dir=$2; shift;; -x11lib*|--x11lib*) x11_lib_dir=$2; shift;; + -no-graph|--no-graph) graph_wanted=no;; -with-pthread*|--with-pthread*) ;; # Ignored for backward compatibility -no-pthread*|--no-pthread*) @@ -112,6 +115,8 @@ while : ; do verbose=yes;; -with-debug-runtime|--with-debug-runtime) debugruntime=runtimed;; + -no-camlp4|--no-camlp4) + withcamlp4="";; *) echo "Unknown option \"$1\"." 1>&2; exit 2;; esac shift @@ -126,17 +131,23 @@ esac case "$bindir" in /*) ;; "") ;; - *) echo "The -bindir directory must be absolute." 1>&2; exit 2;; + '$(PREFIX)/'*) ;; + *) echo 'The -bindir directory must be absolute or relative to $(PREFIX).'>&2 + exit 2;; esac case "$libdir" in /*) ;; "") ;; - *) echo "The -libdir directory must be absolute." 1>&2; exit 2;; + '$(PREFIX)/'*) ;; + *) echo 'The -libdir directory must be absolute or relative to $(PREFIX).'>&2 + exit 2;; esac case "$mandir" in /*) ;; "") ;; - *) echo "The -mandir directory must be absolute." 1>&2; exit 2;; + '$(PREFIX)/'*) ;; + *) echo 'The -mandir directory must be absolute or relative to $(PREFIX).'>&2 + exit 2;; esac # Generate the files @@ -245,6 +256,7 @@ esac bytecc="$cc" mkexe="\$(BYTECC)" +mkexedebugflag="-g" bytecccompopts="" bytecclinkopts="" dllccompopts="" @@ -262,7 +274,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) @@ -309,7 +321,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" @@ -317,6 +329,7 @@ case "$bytecc,$host" in else iflexdir="-I\"$flexdir\"" mkexe="$flexlink -exe" + mkexedebugflag="-link -g" fi fi exe=".exe" @@ -616,14 +629,16 @@ 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*) if test $arch64 == true; then natdynlink=true fi;; - powerpc64-*-linux*) natdynlink=true;; - sparc-*-linux*) natdynlink=true;; + x86_64-*-darwin*) 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;; @@ -633,6 +648,7 @@ if test $withsharedlibs = "yes"; then i[345]86-*-netbsd*) natdynlink=true;; x86_64-*-netbsd*) natdynlink=true;; i386-*-gnu0.3) natdynlink=true;; + arm*-*-linux*) natdynlink=true;; esac fi @@ -650,7 +666,6 @@ model=default system=unknown case "$host" in - sparc*-*-sunos4.*) arch=sparc; system=sunos;; sparc*-*-solaris2.*) arch=sparc; system=solaris;; sparc*-*-*bsd*) arch=sparc; system=bsd;; sparc*-*-linux*) arch=sparc; system=linux;; @@ -676,14 +691,19 @@ case "$host" in powerpc-*-rhapsody*) arch=power; model=ppc; system=rhapsody;; powerpc-*-darwin*) arch=power; system=rhapsody if $arch64; then model=ppc64; else model=ppc; fi;; - arm*-*-linux*) arch=arm; system=linux;; - arm*-*-gnu*) arch=arm; system=gnu;; + arm*-*-linux-gnueabihf) arch=arm; system=linux_eabihf;; + armv7*-*-linux-gnueabi) arch=arm; model=armv7; system=linux_eabi;; + armv6t2*-*-linux-gnueabi) arch=arm; model=armv6t2; system=linux_eabi;; + armv6*-*-linux-gnueabi) arch=arm; model=armv6; system=linux_eabi;; + armv5te*-*-linux-gnueabi) arch=arm; model=armv5te; system=linux_eabi;; + armv5*-*-linux-gnueabi) arch=arm; model=armv5; system=linux_eabi;; + arm*-*-linux-gnueabi) arch=arm; system=linux_eabi;; x86_64-*-linux*) arch=amd64; system=linux;; x86_64-*-gnu*) arch=amd64; system=gnu;; x86_64-*-freebsd*) arch=amd64; system=freebsd;; x86_64-*-netbsd*) arch=amd64; system=netbsd;; x86_64-*-openbsd*) arch=amd64; system=openbsd;; - x86_64-*-darwin9.5) arch=amd64; system=macosx;; + x86_64-*-darwin*) arch=amd64; system=macosx;; esac # Some platforms exist both in 32-bit and 64-bit variants, not distinguished @@ -765,6 +785,7 @@ case "$arch,$model,$system" in case "$nativecc" in gcc*) ;; *) cc_profile='-xpg';; esac;; amd64,*,linux) profiling='prof';; amd64,*,gnu) profiling='prof';; + arm,*,linux*) profiling='prof';; *) profiling='noprof';; esac @@ -1098,6 +1119,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 @@ -1130,7 +1156,7 @@ fi # Determine if system stack overflows can be detected case "$arch,$system" in - i386,linux_elf|amd64,linux|power,rhapsody|amd64,macosx|i386,macosx|amd64,macosx) + i386,linux_elf|amd64,linux|power,rhapsody|amd64,macosx|i386,macosx) echo "System stack overflow can be detected." echo "#define HAS_STACK_OVERFLOW_DETECTION" >> s.h;; *) @@ -1211,10 +1237,22 @@ fi # Determine the location of X include files and libraries +# If the user specified -x11include and/or -x11lib, these settings +# are used. Otherwise, we check whether there is pkg-config, and take +# the flags from there. Otherwise, we search the location. + x11_include="not found" x11_link="not found" -for dir in \ +if test -z "$x11_include_dir" -a -z "$x11_lib_dir"; then + if pkg-config --exists x11 2>/dev/null; then + x11_include=`pkg-config --cflags x11` + x11_link=`pkg-config --libs x11` + fi +fi + +if test "$x11_include" = "not found"; then + for dir in \ $x11_include_dir \ \ /usr/X11R7/include \ @@ -1260,20 +1298,21 @@ for dir in \ /usr/openwin/include \ /usr/openwin/share/include \ ; \ -do - if test -f $dir/X11/X.h; then - x11_include=$dir - break - fi -done + do + if test -f $dir/X11/X.h; then + x11_include_dir=$dir + x11_include="-I$dir" + break + fi + done -if test "$x11_include" = "not found"; then - x11_try_lib_dir='' -else - x11_try_lib_dir=`echo $x11_include | sed -e 's|include|lib|'` -fi + if test "$x11_include" = "not found"; then + x11_try_lib_dir='' + else + x11_try_lib_dir=`echo $x11_include_dir | sed -e 's|include|lib|'` + fi -for dir in \ + for dir in \ $x11_lib_dir \ $x11_try_lib_dir \ \ @@ -1320,39 +1359,52 @@ for dir in \ /usr/lib/i386-linux-gnu \ /usr/lib/x86_64-linux-gnu \ ; \ -do - if test -f $dir/libX11.a || \ - test -f $dir/libX11.so || \ - test -f $dir/libX11.dll.a || \ - test -f $dir/libX11.dylib || \ - test -f $dir/libX11.sa; then - if test $dir = /usr/lib; then - x11_link="-lX11" - else - x11_libs="-L$dir" - case "$host" in - *-kfreebsd*-gnu) x11_link="-L$dir -lX11";; - *-*-*bsd*) x11_link="-R$dir -L$dir -lX11";; - *) x11_link="-L$dir -lX11";; - esac + do + if test -f $dir/libX11.a || \ + test -f $dir/libX11.so || \ + test -f $dir/libX11.dll.a || \ + test -f $dir/libX11.dylib || \ + test -f $dir/libX11.sa; then + if test $dir = /usr/lib; then + x11_link="-lX11" + else + x11_libs="-L$dir" + case "$host" in + *-kfreebsd*-gnu) x11_link="-L$dir -lX11";; + *-*-*bsd*) x11_link="-R$dir -L$dir -lX11";; + *) x11_link="-L$dir -lX11";; + esac + fi + break fi - break - fi -done + done +fi +if test "x11_include" != "not found"; then + if test "$x11_include" = "-I/usr/include"; then + x11_include="" + fi + if ./hasgot $x11_include $x11_link -i X11/Xlib.h XrmInitialize; then + echo "X11 works" + else + echo "Cannot compile X11 program" + x11_include="not found" + fi +fi +has_graph=false if test "$x11_include" = "not found" || test "$x11_link" = "not found" then echo "X11 not found, the \"graph\" library will not be supported." - x11_include="" + x11_include="not found" + x11_link="not found" else - echo "Location of X11 include files: $x11_include/X11" + echo "Options for compiling for X11: $x11_include" echo "Options for linking with X11: $x11_link" - otherlibraries="$otherlibraries graph" - if test "$x11_include" = "/usr/include"; then - x11_include="" - else - x11_include="-I$x11_include" + if test "$graph_wanted" = yes + then + has_graph=true + otherlibraries="$otherlibraries graph" fi fi echo "X11_INCLUDES=$x11_include" >> Makefile @@ -1367,11 +1419,11 @@ if test $tk_wanted = no; then elif test $tk_x11 = no; then has_tk=true elif test "$x11_include" = "not found" || test "$x11_link" = "not found"; then - echo "X11 not found." + echo "X11 not found or disabled." has_tk=false else tk_x11_include="$x11_include" - tk_x11_libs="$x11_libs -lX11" + tk_x11_libs="$x11_link" has_tk=true fi @@ -1501,6 +1553,20 @@ else echo "LIBBFD_LINK=" >> Makefile fi +# Check whether assembler supports CFI directives + +asm_cfi_supported=false + +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 nativeccprofopts="$nativecccompopts" @@ -1568,9 +1634,12 @@ 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 +echo "CAMLP4=${withcamlp4}" >>Makefile +echo "ASM_CFI_SUPPORTED=$asm_cfi_supported" >> Makefile rm -f tst hasgot.c rm -f ../m.h ../s.h ../Makefile @@ -1615,6 +1684,11 @@ else echo " options for linking....... $nativecclinkopts $cclibs" echo " assembler ................ $as" echo " preprocessed assembler ... $aspp" + if test "$asm_cfi_supported" = "true"; then + echo " assembler supports CFI ... yes" + else + echo " assembler supports CFI ... no" + fi echo " native dynlink ........... $natdynlink" if test "$profiling" = "prof"; then echo " profiling with gprof ..... supported" @@ -1639,17 +1713,19 @@ echo " $otherlibraries" echo "Configuration for the \"num\" library:" echo " target architecture ...... $bng_arch (asm level $bng_asm_level)" -if test "$x11_include" != "not found" && test "$x11_lib" != "not found"; then +if $has_graph; then echo "Configuration for the \"graph\" library:" echo " options for compiling .... $x11_include" echo " options for linking ...... $x11_link" +else +echo "The \"graph\" library: not supported" fi if test $has_tk = true; then echo "Configuration for the \"labltk\" library:" echo " use tcl/tk version ....... $tcl_version" -echo " options for compiling .... $tk_defs" -echo " options for linking ...... $tk_libs" +echo " options for compiling .... $tk_defs $tk_x11_include" +echo " options for linking ...... $tk_libs $tk_x11_libs" else echo "The \"labltk\" library: not supported" fi @@ -1657,3 +1733,8 @@ fi echo echo "** OCaml configuration completed successfully **" echo + +if test ! -z "$MACOSX_DEPLOYMENT_TARGET"; then + echo "WARNING: the environment variable MACOSX_DEPLOYMENT_TARGET is set." + echo "This will probably prevent compiling the OCaml system." +fi diff --git a/debugger/.depend b/debugger/.depend index 1a04b1eaaa..ec87403c86 100644 --- a/debugger/.depend +++ b/debugger/.depend @@ -1,46 +1,49 @@ -breakpoints.cmi: primitives.cmi ../bytecomp/instruct.cmi -checkpoints.cmi: primitives.cmi debugcom.cmi -command_line.cmi: -debugcom.cmi: primitives.cmi -debugger_config.cmi: -dynlink.cmi: -envaux.cmi: ../typing/path.cmi ../bytecomp/instruct.cmi ../typing/env.cmi -eval.cmi: ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \ +breakpoints.cmi : primitives.cmi ../bytecomp/instruct.cmi +checkpoints.cmi : primitives.cmi debugcom.cmi +command_line.cmi : +debugcom.cmi : primitives.cmi +debugger_config.cmi : +dynlink.cmi : +envaux.cmi : ../typing/subst.cmi ../typing/path.cmi ../bytecomp/instruct.cmi \ + ../typing/env.cmi +eval.cmi : ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \ ../parsing/longident.cmi ../bytecomp/instruct.cmi ../typing/ident.cmi \ ../typing/env.cmi debugcom.cmi -events.cmi: ../bytecomp/instruct.cmi -exec.cmi: -frames.cmi: primitives.cmi ../bytecomp/instruct.cmi -history.cmi: -input_handling.cmi: primitives.cmi -int64ops.cmi: -lexer.cmi: parser.cmi -loadprinter.cmi: ../parsing/longident.cmi dynlink.cmi -parameters.cmi: -parser.cmi: parser_aux.cmi ../parsing/longident.cmi -parser_aux.cmi: primitives.cmi ../parsing/longident.cmi -pattern_matching.cmi: ../typing/typedtree.cmi parser_aux.cmi debugcom.cmi -pos.cmi: ../bytecomp/instruct.cmi -primitives.cmi: $(UNIXDIR)/unix.cmi -printval.cmi: ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \ +events.cmi : ../bytecomp/instruct.cmi +exec.cmi : +frames.cmi : primitives.cmi ../bytecomp/instruct.cmi +history.cmi : +input_handling.cmi : primitives.cmi +int64ops.cmi : +lexer.cmi : parser.cmi +loadprinter.cmi : ../parsing/longident.cmi dynlink.cmi +parameters.cmi : +parser.cmi : parser_aux.cmi ../parsing/longident.cmi +parser_aux.cmi : primitives.cmi ../parsing/longident.cmi +pattern_matching.cmi : ../typing/typedtree.cmi parser_aux.cmi debugcom.cmi +pos.cmi : ../bytecomp/instruct.cmi +primitives.cmi : $(UNIXDIR)/unix.cmi +printval.cmi : ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \ ../typing/env.cmi debugcom.cmi -program_loading.cmi: primitives.cmi -program_management.cmi: -question.cmi: -show_information.cmi: ../bytecomp/instruct.cmi -show_source.cmi: ../bytecomp/instruct.cmi -source.cmi: -symbols.cmi: ../bytecomp/instruct.cmi -time_travel.cmi: primitives.cmi -trap_barrier.cmi: -unix_tools.cmi: $(UNIXDIR)/unix.cmi -breakpoints.cmo: symbols.cmi primitives.cmi pos.cmi ../bytecomp/instruct.cmi \ - exec.cmi debugcom.cmi checkpoints.cmi breakpoints.cmi -breakpoints.cmx: symbols.cmx primitives.cmx pos.cmx ../bytecomp/instruct.cmx \ - exec.cmx debugcom.cmx checkpoints.cmx breakpoints.cmi -checkpoints.cmo: primitives.cmi int64ops.cmi debugcom.cmi checkpoints.cmi -checkpoints.cmx: primitives.cmx int64ops.cmx debugcom.cmx checkpoints.cmi -command_line.cmo: unix_tools.cmi $(UNIXDIR)/unix.cmi \ +program_loading.cmi : primitives.cmi +program_management.cmi : +question.cmi : +show_information.cmi : ../bytecomp/instruct.cmi +show_source.cmi : ../bytecomp/instruct.cmi +source.cmi : +symbols.cmi : ../bytecomp/instruct.cmi +time_travel.cmi : primitives.cmi +trap_barrier.cmi : +unix_tools.cmi : $(UNIXDIR)/unix.cmi +breakpoints.cmo : symbols.cmi primitives.cmi pos.cmi \ + ../bytecomp/instruct.cmi exec.cmi debugcom.cmi checkpoints.cmi \ + breakpoints.cmi +breakpoints.cmx : symbols.cmx primitives.cmx pos.cmx \ + ../bytecomp/instruct.cmx exec.cmx debugcom.cmx checkpoints.cmx \ + breakpoints.cmi +checkpoints.cmo : primitives.cmi int64ops.cmi debugcom.cmi checkpoints.cmi +checkpoints.cmx : primitives.cmx int64ops.cmx debugcom.cmx checkpoints.cmi +command_line.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi \ ../typing/types.cmi time_travel.cmi symbols.cmi source.cmi \ show_source.cmi show_information.cmi question.cmi program_management.cmi \ program_loading.cmi printval.cmi primitives.cmi pos.cmi parser_aux.cmi \ @@ -50,7 +53,7 @@ command_line.cmo: unix_tools.cmi $(UNIXDIR)/unix.cmi \ events.cmi eval.cmi envaux.cmi debugger_config.cmi debugcom.cmi \ ../typing/ctype.cmi ../utils/config.cmi checkpoints.cmi breakpoints.cmi \ command_line.cmi -command_line.cmx: unix_tools.cmx $(UNIXDIR)/unix.cmx \ +command_line.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx \ ../typing/types.cmx time_travel.cmx symbols.cmx source.cmx \ show_source.cmx show_information.cmx question.cmx program_management.cmx \ program_loading.cmx printval.cmx primitives.cmx pos.cmx parser_aux.cmi \ @@ -60,153 +63,157 @@ command_line.cmx: unix_tools.cmx $(UNIXDIR)/unix.cmx \ events.cmx eval.cmx envaux.cmx debugger_config.cmx debugcom.cmx \ ../typing/ctype.cmx ../utils/config.cmx checkpoints.cmx breakpoints.cmx \ command_line.cmi -debugcom.cmo: primitives.cmi ../utils/misc.cmi int64ops.cmi \ +debugcom.cmo : primitives.cmi ../utils/misc.cmi int64ops.cmi \ input_handling.cmi debugcom.cmi -debugcom.cmx: primitives.cmx ../utils/misc.cmx int64ops.cmx \ +debugcom.cmx : primitives.cmx ../utils/misc.cmx int64ops.cmx \ input_handling.cmx debugcom.cmi -debugger_config.cmo: int64ops.cmi debugger_config.cmi -debugger_config.cmx: int64ops.cmx debugger_config.cmi -dynlink.cmo: ../bytecomp/symtable.cmi ../bytecomp/opcodes.cmo \ +debugger_config.cmo : int64ops.cmi debugger_config.cmi +debugger_config.cmx : int64ops.cmx debugger_config.cmi +dynlink.cmo : ../bytecomp/symtable.cmi ../bytecomp/opcodes.cmo \ ../utils/misc.cmi ../bytecomp/meta.cmi ../bytecomp/dll.cmi \ ../utils/consistbl.cmi ../utils/config.cmi ../bytecomp/cmo_format.cmi \ - dynlink.cmi -dynlink.cmx: ../bytecomp/symtable.cmx ../bytecomp/opcodes.cmx \ + ../typing/cmi_format.cmi dynlink.cmi +dynlink.cmx : ../bytecomp/symtable.cmx ../bytecomp/opcodes.cmx \ ../utils/misc.cmx ../bytecomp/meta.cmx ../bytecomp/dll.cmx \ ../utils/consistbl.cmx ../utils/config.cmx ../bytecomp/cmo_format.cmi \ - dynlink.cmi -envaux.cmo: ../typing/types.cmi ../typing/subst.cmi ../typing/printtyp.cmi \ + ../typing/cmi_format.cmx dynlink.cmi +envaux.cmo : ../typing/types.cmi ../typing/subst.cmi ../typing/printtyp.cmi \ ../typing/path.cmi ../typing/mtype.cmi ../utils/misc.cmi \ ../bytecomp/instruct.cmi ../typing/env.cmi envaux.cmi -envaux.cmx: ../typing/types.cmx ../typing/subst.cmx ../typing/printtyp.cmx \ +envaux.cmx : ../typing/types.cmx ../typing/subst.cmx ../typing/printtyp.cmx \ ../typing/path.cmx ../typing/mtype.cmx ../utils/misc.cmx \ ../bytecomp/instruct.cmx ../typing/env.cmx envaux.cmi -eval.cmo: ../typing/types.cmi ../bytecomp/symtable.cmi ../typing/subst.cmi \ +eval.cmo : ../typing/types.cmi ../bytecomp/symtable.cmi ../typing/subst.cmi \ printval.cmi ../typing/printtyp.cmi ../typing/predef.cmi \ ../typing/path.cmi parser_aux.cmi ../utils/misc.cmi \ ../parsing/longident.cmi ../bytecomp/instruct.cmi ../typing/ident.cmi \ frames.cmi ../typing/env.cmi debugcom.cmi ../typing/ctype.cmi \ ../typing/btype.cmi eval.cmi -eval.cmx: ../typing/types.cmx ../bytecomp/symtable.cmx ../typing/subst.cmx \ +eval.cmx : ../typing/types.cmx ../bytecomp/symtable.cmx ../typing/subst.cmx \ printval.cmx ../typing/printtyp.cmx ../typing/predef.cmx \ ../typing/path.cmx parser_aux.cmi ../utils/misc.cmx \ ../parsing/longident.cmx ../bytecomp/instruct.cmx ../typing/ident.cmx \ frames.cmx ../typing/env.cmx debugcom.cmx ../typing/ctype.cmx \ ../typing/btype.cmx eval.cmi -events.cmo: ../parsing/location.cmi ../bytecomp/instruct.cmi events.cmi -events.cmx: ../parsing/location.cmx ../bytecomp/instruct.cmx events.cmi -exec.cmo: exec.cmi -exec.cmx: exec.cmi -frames.cmo: symbols.cmi ../utils/misc.cmi ../bytecomp/instruct.cmi events.cmi \ - debugcom.cmi frames.cmi -frames.cmx: symbols.cmx ../utils/misc.cmx ../bytecomp/instruct.cmx events.cmx \ - debugcom.cmx frames.cmi -history.cmo: primitives.cmi int64ops.cmi debugger_config.cmi checkpoints.cmi \ - history.cmi -history.cmx: primitives.cmx int64ops.cmx debugger_config.cmx checkpoints.cmx \ - history.cmi -input_handling.cmo: $(UNIXDIR)/unix.cmi primitives.cmi \ +events.cmo : ../parsing/location.cmi ../bytecomp/instruct.cmi events.cmi +events.cmx : ../parsing/location.cmx ../bytecomp/instruct.cmx events.cmi +exec.cmo : exec.cmi +exec.cmx : exec.cmi +frames.cmo : symbols.cmi ../utils/misc.cmi ../bytecomp/instruct.cmi \ + events.cmi debugcom.cmi frames.cmi +frames.cmx : symbols.cmx ../utils/misc.cmx ../bytecomp/instruct.cmx \ + events.cmx debugcom.cmx frames.cmi +history.cmo : primitives.cmi int64ops.cmi debugger_config.cmi \ + checkpoints.cmi history.cmi +history.cmx : primitives.cmx int64ops.cmx debugger_config.cmx \ + checkpoints.cmx history.cmi +input_handling.cmo : $(UNIXDIR)/unix.cmi primitives.cmi \ input_handling.cmi -input_handling.cmx: $(UNIXDIR)/unix.cmx primitives.cmx \ +input_handling.cmx : $(UNIXDIR)/unix.cmx primitives.cmx \ input_handling.cmi -int64ops.cmo: int64ops.cmi -int64ops.cmx: int64ops.cmi -lexer.cmo: parser.cmi lexer.cmi -lexer.cmx: parser.cmx lexer.cmi -loadprinter.cmo: ../typing/types.cmi ../bytecomp/symtable.cmi printval.cmi \ +int64ops.cmo : int64ops.cmi +int64ops.cmx : int64ops.cmi +lexer.cmo : parser.cmi lexer.cmi +lexer.cmx : parser.cmx lexer.cmi +loadprinter.cmo : ../typing/types.cmi ../bytecomp/symtable.cmi printval.cmi \ ../typing/printtyp.cmi ../typing/path.cmi ../utils/misc.cmi \ ../parsing/longident.cmi ../typing/ident.cmi ../typing/env.cmi \ dynlink.cmi ../typing/ctype.cmi ../utils/config.cmi loadprinter.cmi -loadprinter.cmx: ../typing/types.cmx ../bytecomp/symtable.cmx printval.cmx \ +loadprinter.cmx : ../typing/types.cmx ../bytecomp/symtable.cmx printval.cmx \ ../typing/printtyp.cmx ../typing/path.cmx ../utils/misc.cmx \ ../parsing/longident.cmx ../typing/ident.cmx ../typing/env.cmx \ dynlink.cmx ../typing/ctype.cmx ../utils/config.cmx loadprinter.cmi -main.cmo: unix_tools.cmi $(UNIXDIR)/unix.cmi time_travel.cmi \ +main.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi time_travel.cmi \ show_information.cmi question.cmi program_management.cmi primitives.cmi \ parameters.cmi ../utils/misc.cmi input_handling.cmi frames.cmi exec.cmi \ ../typing/env.cmi debugger_config.cmi ../utils/config.cmi \ - command_line.cmi ../utils/clflags.cmi checkpoints.cmi -main.cmx: unix_tools.cmx $(UNIXDIR)/unix.cmx time_travel.cmx \ + command_line.cmi ../typing/cmi_format.cmi ../utils/clflags.cmi \ + checkpoints.cmi +main.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx time_travel.cmx \ show_information.cmx question.cmx program_management.cmx primitives.cmx \ parameters.cmx ../utils/misc.cmx input_handling.cmx frames.cmx exec.cmx \ ../typing/env.cmx debugger_config.cmx ../utils/config.cmx \ - command_line.cmx ../utils/clflags.cmx checkpoints.cmx -parameters.cmo: primitives.cmi envaux.cmi debugger_config.cmi \ + command_line.cmx ../typing/cmi_format.cmx ../utils/clflags.cmx \ + checkpoints.cmx +parameters.cmo : primitives.cmi envaux.cmi debugger_config.cmi \ ../utils/config.cmi parameters.cmi -parameters.cmx: primitives.cmx envaux.cmx debugger_config.cmx \ +parameters.cmx : primitives.cmx envaux.cmx debugger_config.cmx \ ../utils/config.cmx parameters.cmi -parser.cmo: parser_aux.cmi ../parsing/longident.cmi int64ops.cmi \ +parser.cmo : parser_aux.cmi ../parsing/longident.cmi int64ops.cmi \ input_handling.cmi parser.cmi -parser.cmx: parser_aux.cmi ../parsing/longident.cmx int64ops.cmx \ +parser.cmx : parser_aux.cmi ../parsing/longident.cmx int64ops.cmx \ input_handling.cmx parser.cmi -pattern_matching.cmo: ../typing/typedtree.cmi parser_aux.cmi \ +pattern_matching.cmo : ../typing/typedtree.cmi parser_aux.cmi \ ../utils/misc.cmi debugger_config.cmi debugcom.cmi ../typing/ctype.cmi \ pattern_matching.cmi -pattern_matching.cmx: ../typing/typedtree.cmx parser_aux.cmi \ +pattern_matching.cmx : ../typing/typedtree.cmx parser_aux.cmi \ ../utils/misc.cmx debugger_config.cmx debugcom.cmx ../typing/ctype.cmx \ pattern_matching.cmi -pos.cmo: source.cmi primitives.cmi ../parsing/location.cmi \ +pos.cmo : source.cmi primitives.cmi ../parsing/location.cmi \ ../bytecomp/instruct.cmi pos.cmi -pos.cmx: source.cmx primitives.cmx ../parsing/location.cmx \ +pos.cmx : source.cmx primitives.cmx ../parsing/location.cmx \ ../bytecomp/instruct.cmx pos.cmi -primitives.cmo: $(UNIXDIR)/unix.cmi primitives.cmi -primitives.cmx: $(UNIXDIR)/unix.cmx primitives.cmi -printval.cmo: ../typing/types.cmi ../bytecomp/symtable.cmi \ +primitives.cmo : $(UNIXDIR)/unix.cmi primitives.cmi +primitives.cmx : $(UNIXDIR)/unix.cmx primitives.cmi +printval.cmo : ../typing/types.cmi ../bytecomp/symtable.cmi \ ../typing/printtyp.cmi ../typing/path.cmi parser_aux.cmi \ ../typing/outcometree.cmi ../typing/oprint.cmi \ ../toplevel/genprintval.cmi debugcom.cmi printval.cmi -printval.cmx: ../typing/types.cmx ../bytecomp/symtable.cmx \ +printval.cmx : ../typing/types.cmx ../bytecomp/symtable.cmx \ ../typing/printtyp.cmx ../typing/path.cmx parser_aux.cmi \ ../typing/outcometree.cmi ../typing/oprint.cmx \ ../toplevel/genprintval.cmx debugcom.cmx printval.cmi -program_loading.cmo: unix_tools.cmi $(UNIXDIR)/unix.cmi primitives.cmi \ - parameters.cmi input_handling.cmi debugger_config.cmi program_loading.cmi -program_loading.cmx: unix_tools.cmx $(UNIXDIR)/unix.cmx primitives.cmx \ - parameters.cmx input_handling.cmx debugger_config.cmx program_loading.cmi -program_management.cmo: unix_tools.cmi $(UNIXDIR)/unix.cmi \ +program_loading.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi \ + primitives.cmi parameters.cmi input_handling.cmi debugger_config.cmi \ + program_loading.cmi +program_loading.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx \ + primitives.cmx parameters.cmx input_handling.cmx debugger_config.cmx \ + program_loading.cmi +program_management.cmo : unix_tools.cmi $(UNIXDIR)/unix.cmi \ time_travel.cmi symbols.cmi question.cmi program_loading.cmi \ primitives.cmi parameters.cmi int64ops.cmi input_handling.cmi history.cmi \ debugger_config.cmi breakpoints.cmi program_management.cmi -program_management.cmx: unix_tools.cmx $(UNIXDIR)/unix.cmx \ +program_management.cmx : unix_tools.cmx $(UNIXDIR)/unix.cmx \ time_travel.cmx symbols.cmx question.cmx program_loading.cmx \ primitives.cmx parameters.cmx int64ops.cmx input_handling.cmx history.cmx \ debugger_config.cmx breakpoints.cmx program_management.cmi -question.cmo: primitives.cmi lexer.cmi input_handling.cmi question.cmi -question.cmx: primitives.cmx lexer.cmx input_handling.cmx question.cmi -show_information.cmo: symbols.cmi source.cmi show_source.cmi printval.cmi \ +question.cmo : primitives.cmi lexer.cmi input_handling.cmi question.cmi +question.cmx : primitives.cmx lexer.cmx input_handling.cmx question.cmi +show_information.cmo : symbols.cmi source.cmi show_source.cmi printval.cmi \ ../utils/misc.cmi ../bytecomp/instruct.cmi frames.cmi events.cmi \ debugcom.cmi checkpoints.cmi breakpoints.cmi show_information.cmi -show_information.cmx: symbols.cmx source.cmx show_source.cmx printval.cmx \ +show_information.cmx : symbols.cmx source.cmx show_source.cmx printval.cmx \ ../utils/misc.cmx ../bytecomp/instruct.cmx frames.cmx events.cmx \ debugcom.cmx checkpoints.cmx breakpoints.cmx show_information.cmi -show_source.cmo: source.cmi primitives.cmi parameters.cmi \ +show_source.cmo : source.cmi primitives.cmi parameters.cmi \ ../parsing/location.cmi ../bytecomp/instruct.cmi events.cmi \ debugger_config.cmi show_source.cmi -show_source.cmx: source.cmx primitives.cmx parameters.cmx \ +show_source.cmx : source.cmx primitives.cmx parameters.cmx \ ../parsing/location.cmx ../bytecomp/instruct.cmx events.cmx \ debugger_config.cmx show_source.cmi -source.cmo: primitives.cmi ../utils/misc.cmi debugger_config.cmi \ +source.cmo : primitives.cmi ../utils/misc.cmi debugger_config.cmi \ ../utils/config.cmi source.cmi -source.cmx: primitives.cmx ../utils/misc.cmx debugger_config.cmx \ +source.cmx : primitives.cmx ../utils/misc.cmx debugger_config.cmx \ ../utils/config.cmx source.cmi -symbols.cmo: ../bytecomp/symtable.cmi program_loading.cmi \ +symbols.cmo : ../bytecomp/symtable.cmi program_loading.cmi \ ../bytecomp/instruct.cmi events.cmi debugger_config.cmi debugcom.cmi \ checkpoints.cmi ../bytecomp/bytesections.cmi symbols.cmi -symbols.cmx: ../bytecomp/symtable.cmx program_loading.cmx \ +symbols.cmx : ../bytecomp/symtable.cmx program_loading.cmx \ ../bytecomp/instruct.cmx events.cmx debugger_config.cmx debugcom.cmx \ checkpoints.cmx ../bytecomp/bytesections.cmx symbols.cmi -time_travel.cmo: trap_barrier.cmi symbols.cmi question.cmi \ +time_travel.cmo : trap_barrier.cmi symbols.cmi question.cmi \ program_loading.cmi primitives.cmi ../utils/misc.cmi int64ops.cmi \ ../bytecomp/instruct.cmi input_handling.cmi exec.cmi events.cmi \ debugger_config.cmi debugcom.cmi checkpoints.cmi breakpoints.cmi \ time_travel.cmi -time_travel.cmx: trap_barrier.cmx symbols.cmx question.cmx \ +time_travel.cmx : trap_barrier.cmx symbols.cmx question.cmx \ program_loading.cmx primitives.cmx ../utils/misc.cmx int64ops.cmx \ ../bytecomp/instruct.cmx input_handling.cmx exec.cmx events.cmx \ debugger_config.cmx debugcom.cmx checkpoints.cmx breakpoints.cmx \ time_travel.cmi -trap_barrier.cmo: exec.cmi debugcom.cmi checkpoints.cmi trap_barrier.cmi -trap_barrier.cmx: exec.cmx debugcom.cmx checkpoints.cmx trap_barrier.cmi -unix_tools.cmo: $(UNIXDIR)/unix.cmi primitives.cmi ../utils/misc.cmi \ +trap_barrier.cmo : exec.cmi debugcom.cmi checkpoints.cmi trap_barrier.cmi +trap_barrier.cmx : exec.cmx debugcom.cmx checkpoints.cmx trap_barrier.cmi +unix_tools.cmo : $(UNIXDIR)/unix.cmi primitives.cmi ../utils/misc.cmi \ unix_tools.cmi -unix_tools.cmx: $(UNIXDIR)/unix.cmx primitives.cmx ../utils/misc.cmx \ +unix_tools.cmx : $(UNIXDIR)/unix.cmx primitives.cmx ../utils/misc.cmx \ unix_tools.cmi diff --git a/debugger/.ignore b/debugger/.ignore index 45440f86d7..45eec7cceb 100644 --- a/debugger/.ignore +++ b/debugger/.ignore @@ -2,5 +2,6 @@ lexer.ml parser.ml parser.mli ocamldebug +ocamldebug.exe dynlink.ml dynlink.mli diff --git a/debugger/Makefile.shared b/debugger/Makefile.shared index 820af9af9e..d2142c2061 100644 --- a/debugger/Makefile.shared +++ b/debugger/Makefile.shared @@ -35,7 +35,7 @@ OTHEROBJS=\ ../typing/ident.cmo ../typing/path.cmo ../typing/types.cmo \ ../typing/btype.cmo ../typing/primitive.cmo ../typing/typedtree.cmo \ ../typing/subst.cmo ../typing/predef.cmo \ - ../typing/datarepr.cmo ../typing/env.cmo ../typing/oprint.cmo \ + ../typing/datarepr.cmo ../typing/cmi_format.cmo ../typing/env.cmo ../typing/oprint.cmo \ ../typing/ctype.cmo ../typing/printtyp.cmo ../typing/mtype.cmo \ ../bytecomp/runtimedef.cmo ../bytecomp/bytesections.cmo \ ../bytecomp/dll.cmo ../bytecomp/meta.cmo ../bytecomp/symtable.cmo \ diff --git a/debugger/command_line.ml b/debugger/command_line.ml index 3f84ea7b2c..ab955dc7ce 100644 --- a/debugger/command_line.ml +++ b/debugger/command_line.ml @@ -209,8 +209,8 @@ let line_loop ppf line_buffer = with | Exit -> stop_user_input () - | Sys_error s -> - error ("System error : " ^ s) +(* | Sys_error s -> + error ("System error : " ^ s) *) (** Instructions. **) let instr_cd ppf lexbuf = @@ -230,6 +230,22 @@ let instr_shell ppf lexbuf = if (err != 0) then eprintf "Shell command %S failed with exit code %d\n%!" cmd err +let instr_env ppf lexbuf = + let cmdarg = argument_list_eol argument lexbuf in + let cmdarg = string_trim (String.concat " " cmdarg) in + if cmdarg <> "" then + try + if (String.index cmdarg '=') > 0 then + Debugger_config.environment := cmdarg :: !Debugger_config.environment + else + eprintf "Environment variables should not have an empty name\n%!" + with Not_found -> + eprintf "Environment variables should have the \"name=value\" format\n%!" + else + List.iter + (printf "%s\n%!") + (List.rev !Debugger_config.environment) + let instr_pwd ppf lexbuf = eol lexbuf; fprintf ppf "%s@." (Sys.getcwd ()) @@ -454,7 +470,7 @@ let instr_help ppf lexbuf = fprintf ppf "Ambiguous command \"%s\" : %a@." x pr_instrs l end | None -> - fprintf ppf "List of commands :%a@." pr_instrs !instruction_list + fprintf ppf "List of commands : %a@." pr_instrs !instruction_list (* Printing values *) @@ -962,6 +978,9 @@ With no argument, reset the search path." }; { instr_name = "shell"; instr_prio = false; instr_action = instr_shell; instr_repeat = true; instr_help = "Execute a given COMMAND thru the system shell." }; + { instr_name = "environment"; instr_prio = false; + instr_action = instr_env; instr_repeat = false; instr_help = +"environment variable to give to program being debugged when it is started." }; (* Displacements *) { instr_name = "run"; instr_prio = true; instr_action = instr_run; instr_repeat = true; instr_help = diff --git a/debugger/debugcom.ml b/debugger/debugcom.ml index 8839476e33..1da00cbab8 100644 --- a/debugger/debugcom.ml +++ b/debugger/debugcom.ml @@ -189,8 +189,7 @@ let set_trap_barrier pos = let value_size = if 1 lsl 31 = 0 then 4 else 8 let input_remote_value ic = - let v = String.create value_size in - really_input ic v 0 value_size; v + Misc.input_bytes ic value_size let output_remote_value ic v = output ic v 0 value_size @@ -247,8 +246,7 @@ module Remote_value = if input_byte !conn.io_in = 0 then Remote(input_remote_value !conn.io_in) else begin - let buf = String.create 8 in - really_input !conn.io_in buf 0 8; + let buf = Misc.input_bytes !conn.io_in 8 in let floatbuf = float n (* force allocation of a new float *) in String.unsafe_blit buf 0 (Obj.magic floatbuf) 0 8; Local(Obj.repr floatbuf) diff --git a/debugger/debugger_config.ml b/debugger/debugger_config.ml index 007a3e973b..2928759365 100644 --- a/debugger/debugger_config.ml +++ b/debugger/debugger_config.ml @@ -80,3 +80,7 @@ let make_checkpoints = ref (match Sys.os_type with "Win32" -> false | _ -> true) + +(*** Environment variables for debugee. ***) + +let environment = ref [] diff --git a/debugger/debugger_config.mli b/debugger/debugger_config.mli index 64411f96a5..d3f1a2a7d9 100644 --- a/debugger/debugger_config.mli +++ b/debugger/debugger_config.mli @@ -33,3 +33,7 @@ val checkpoint_big_step : int64 ref val checkpoint_small_step : int64 ref val checkpoint_max_count : int ref val make_checkpoints : bool ref + +(*** Environment variables for debugee. ***) + +val environment : string list ref diff --git a/debugger/envaux.ml b/debugger/envaux.ml index 56786929eb..d146cd0fd8 100644 --- a/debugger/envaux.ml +++ b/debugger/envaux.ml @@ -31,7 +31,7 @@ let reset_cache () = let extract_sig env mty = match Mtype.scrape env mty with - Tmty_signature sg -> sg + Mty_signature sg -> sg | _ -> fatal_error "Envaux.extract_sig" let rec env_from_summary sum subst = diff --git a/debugger/envaux.mli b/debugger/envaux.mli index b78173c4a7..6ecc524b3c 100644 --- a/debugger/envaux.mli +++ b/debugger/envaux.mli @@ -17,6 +17,7 @@ open Format (* Convert environment summaries to environments *) +val env_from_summary : Env.summary -> Subst.t -> Env.t val env_of_event: Instruct.debug_event option -> Env.t (* Empty the environment caches. To be called when load_path changes. *) diff --git a/debugger/eval.ml b/debugger/eval.ml index 0f8c8a0566..1e84d92081 100644 --- a/debugger/eval.ml +++ b/debugger/eval.ml @@ -149,7 +149,7 @@ and find_label lbl env ty path tydesc pos = function [] -> raise(Error(Wrong_label(ty, lbl))) | (name, mut, ty_arg) :: rem -> - if name = lbl then begin + if Ident.name name = lbl then begin let ty_res = Btype.newgenty(Tconstr(path, tydesc.type_params, ref Mnil)) in diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml index 0395cfb307..1c0427a9c5 100644 --- a/debugger/loadprinter.ml +++ b/debugger/loadprinter.ml @@ -95,6 +95,15 @@ let rec eval_path = function (* Install, remove a printer (as in toplevel/topdirs) *) +(* since 4.00, "topdirs.cmi" is not in the same directory as the standard + libray, so we load it beforehand as it cannot be found in the search path. *) +let () = + let compiler_libs = + Filename.concat Config.standard_library "compiler-libs" in + let topdirs = + Filename.concat compiler_libs "topdirs.cmi" in + ignore (Env.read_signature "Topdirs" topdirs) + let match_printer_type desc typename = let (printer_type, _) = try diff --git a/debugger/main.ml b/debugger/main.ml index 5e80081f0c..1dcd5cf40a 100644 --- a/debugger/main.ml +++ b/debugger/main.ml @@ -183,7 +183,11 @@ let speclist = [ " Print version number and exit"; ] +let function_placeholder () = + raise Not_found + let main () = + Callback.register "Debugger.function_placeholder" function_placeholder; try socket_name := (match Sys.os_type with @@ -220,6 +224,11 @@ let main () = Env.report_error err_formatter e; eprintf "@]@."; exit 2 + | Cmi_format.Error e -> + eprintf "Debugger [version %s] environment error:@ @[@;" Config.version; + Cmi_format.report_error err_formatter e; + eprintf "@]@."; + exit 2 let _ = Printexc.catch (Unix.handle_unix_error main) () diff --git a/debugger/parser.mly b/debugger/parser.mly index ae1b0d153d..5bba611b9d 100644 --- a/debugger/parser.mly +++ b/debugger/parser.mly @@ -170,6 +170,8 @@ longident : LIDENT { Lident $1 } | module_path DOT LIDENT { Ldot($1, $3) } | OPERATOR { Lident $1 } + | module_path DOT OPERATOR { Ldot($1, $3) } + | module_path DOT LPAREN OPERATOR RPAREN { Ldot($1, $4) } ; module_path : diff --git a/debugger/printval.ml b/debugger/printval.ml index 84a0f06e41..6b3e9c79d8 100644 --- a/debugger/printval.ml +++ b/debugger/printval.ml @@ -47,7 +47,7 @@ let check_depth ppf depth obj ty = module EvalPath = struct - type value = Debugcom.Remote_value.t + type valu = Debugcom.Remote_value.t exception Error let rec eval_path = function Pident id -> diff --git a/debugger/program_loading.ml b/debugger/program_loading.ml index 3f32cb245f..bef9f80d17 100644 --- a/debugger/program_loading.ml +++ b/debugger/program_loading.ml @@ -35,6 +35,39 @@ let load_program () = (*** Launching functions. ***) +(* Returns the environment to be passed to debugee *) +let get_environment () = + let env = Unix.environment () in + let have_same_name x y = + let split = Primitives.split_string '=' in + match split x, split y with + (hd1 :: _), (hd2 :: _) -> hd1 = hd2 + | _ -> false in + let have_name_in_config_env x = + List.exists + (have_same_name x) + !Debugger_config.environment in + let env = + Array.fold_right + (fun elem acc -> + if have_name_in_config_env elem then + acc + else + elem :: acc) + env + [] in + Array.of_list (env @ !Debugger_config.environment) + +(* Returns the environment to be passed to debugee *) +let get_win32_environment () = + let res = Buffer.create 256 in + let env = get_environment () in + let len = Array.length env in + for i = 0 to pred len do + Buffer.add_string res (Printf.sprintf "set %s && " env.(i)) + done; + Buffer.contents res + (* A generic function for launching the program *) let generic_exec_unix cmdline = function () -> if !debug_loading then @@ -52,7 +85,7 @@ let generic_exec_unix cmdline = function () -> 0 -> (* Try to detach the process from the controlling terminal, so that it does not receive SIGINT on ctrl-C. *) begin try ignore(setsid()) with Invalid_argument _ -> () end; - execv shell [| shell; "-c"; cmdline() |] + execve shell [| shell; "-c"; cmdline() |] (get_environment ()) | _ -> exit 0 with x -> Unix_tools.report_error x; @@ -76,7 +109,7 @@ let generic_exec = "Win32" -> generic_exec_win | _ -> generic_exec_unix -(* Execute the program by calling the runtime explicitely *) +(* Execute the program by calling the runtime explicitly *) let exec_with_runtime = generic_exec (function () -> @@ -86,7 +119,8 @@ let exec_with_runtime = but quoting is even worse because Unix.create_process thinks each command line parameter is a file. So no good solution so far *) - Printf.sprintf "set CAML_DEBUG_SOCKET=%s && %s %s %s" + Printf.sprintf "%sset CAML_DEBUG_SOCKET=%s && %s %s %s" + (get_win32_environment ()) !socket_name runtime_program !program_name @@ -105,7 +139,8 @@ let exec_direct = match Sys.os_type with "Win32" -> (* See the comment above *) - Printf.sprintf "set CAML_DEBUG_SOCKET=%s && %s %s" + Printf.sprintf "%sset CAML_DEBUG_SOCKET=%s && %s %s" + (get_win32_environment ()) !socket_name !program_name !arguments diff --git a/debugger/program_management.ml b/debugger/program_management.ml index 3e6ffa81d1..27f1d9cc58 100644 --- a/debugger/program_management.ml +++ b/debugger/program_management.ml @@ -116,8 +116,10 @@ let ask_kill_program () = (*** Program loading and initializations. ***) let initialize_loading () = - if !debug_loading then + if !debug_loading then begin prerr_endline "Loading debugging information..."; + Printf.fprintf Pervasives.stderr "\tProgram: [%s]\n%!" !program_name; + end; begin try access !program_name [F_OK] with Unix_error _ -> prerr_endline "Program not found."; diff --git a/debugger/source.ml b/debugger/source.ml index 372b8be37a..65634cbe5f 100644 --- a/debugger/source.ml +++ b/debugger/source.ml @@ -28,7 +28,7 @@ let source_of_module pos mdle = try (String.sub m 0 len') = m' && (String.get m len') = '.' with - Invalid_argument _ -> false in + Invalid_argument _ -> false in let path = Hashtbl.fold (fun mdl dirs acc -> @@ -39,7 +39,20 @@ let source_of_module pos mdle = Debugger_config.load_path_for !Config.load_path in let fname = pos.Lexing.pos_fname in - if Filename.is_implicit fname then + if fname = "" then + let innermost_module = + try + let dot_index = String.rindex mdle '.' in + String.sub mdle (succ dot_index) (pred ((String.length mdle) - dot_index)) + with Not_found -> mdle in + let rec loop = + function + | [] -> raise Not_found + | ext :: exts -> + try find_in_path_uncap path (innermost_module ^ ext) + with Not_found -> loop exts + in loop source_extensions + else if Filename.is_implicit fname then find_in_path path fname else fname @@ -63,13 +76,11 @@ let get_buffer pos mdle = try List.assoc mdle !buffer_list with Not_found -> let inchan = open_in_bin (source_of_module pos mdle) in - let (content, _) as buffer = - (String.create (in_channel_length inchan), ref []) - in - unsafe_really_input inchan content 0 (in_channel_length inchan); - buffer_list := - (list_truncate !buffer_max_count ((mdle, buffer)::!buffer_list)); - buffer + let content = Misc.input_bytes inchan (in_channel_length inchan) in + let buffer = (content, ref []) in + buffer_list := + (list_truncate !buffer_max_count ((mdle, buffer)::!buffer_list)); + buffer let buffer_content = (fst : buffer -> string) diff --git a/debugger/unix_tools.ml b/debugger/unix_tools.ml index dea47f99f8..2897420bc8 100644 --- a/debugger/unix_tools.ml +++ b/debugger/unix_tools.ml @@ -58,6 +58,7 @@ let report_error = function (* Return the full path if found. *) (* Raise `Not_found' otherwise. *) let search_in_path name = + Printf.fprintf Pervasives.stderr "search_in_path [%s]\n%!" name; let check name = try access name [X_OK]; name with Unix_error _ -> raise Not_found in diff --git a/driver/compile.ml b/driver/compile.ml index 85531f040e..fdee2eea85 100644 --- a/driver/compile.ml +++ b/driver/compile.ml @@ -79,19 +79,23 @@ 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 env = initial_env () in - let sg = Typemod.transl_signature env ast in + let tsg = Typemod.transl_signature initial_env ast in if !Clflags.print_types then - Printtyp.wrap_printing_env env (fun () -> + Printtyp.wrap_printing_env initial_env (fun () -> fprintf std_formatter "%a@." - Printtyp.signature (Typemod.simplify_signature sg)); + Printtyp.signature (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; @@ -118,9 +122,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 @@ -139,12 +147,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 bcbd7f23c4..dc493411a3 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 81ffe28d7c..068cfa9fe7 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -93,6 +93,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 @@ -174,14 +175,15 @@ let main () = Compile.init_path(); Bytelibrarian.create_archive ppf (List.rev !objfiles) - (extract_output !output_name) + (extract_output !output_name); + Warnings.check_fatal (); end else if !make_package then begin Compile.init_path(); - let exctracted_output = extract_output !output_name in + let extracted_output = extract_output !output_name in let revd = List.rev !objfiles in - Bytepackager.package_files ppf (revd) - (exctracted_output) + Bytepackager.package_files ppf revd (extracted_output); + Warnings.check_fatal (); end else if not !compile_only && !objfiles <> [] then begin let target = @@ -201,7 +203,8 @@ let main () = default_output !output_name in Compile.init_path(); - Bytelink.link ppf (List.rev !objfiles) target + Bytelink.link ppf (List.rev !objfiles) target; + Warnings.check_fatal (); end; exit 0 with x -> diff --git a/driver/main_args.ml b/driver/main_args.ml index 51af61163d..5759b8a6fd 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)" ;; @@ -169,6 +173,11 @@ let mk_noprompt f = "-noprompt", Arg.Unit f, " Suppress all prompts" ;; +let mk_nopromptcont f = + "-nopromptcont", Arg.Unit f, + " Suppress prompts for continuation lines of multi-line inputs" +;; + let mk_nostdlib f = "-nostdlib", Arg.Unit f, " Do not add default directory to the list of include directories" @@ -327,6 +336,10 @@ let mk_dlambda f = "-dlambda", Arg.Unit f, " (undocumented)" ;; +let mk_dclambda f = + "-dclambda", Arg.Unit f, " (undocumented)" +;; + let mk_dinstr f = "-dinstr", Arg.Unit f, " (undocumented)" ;; @@ -392,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 @@ -455,6 +469,7 @@ module type Bytetop_options = sig val _noassert : unit -> unit val _nolabels : unit -> unit val _noprompt : unit -> unit + val _nopromptcont : unit -> unit val _nostdlib : unit -> unit val _principal : unit -> unit val _real_paths : unit -> unit @@ -480,6 +495,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 @@ -529,6 +545,7 @@ module type Optcomp_options = sig val _dparsetree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit + val _dclambda : unit -> unit val _dcmm : unit -> unit val _dsel : unit -> unit val _dcombine : unit -> unit @@ -557,6 +574,7 @@ module type Opttop_options = sig val _noassert : unit -> unit val _nolabels : unit -> unit val _noprompt : unit -> unit + val _nopromptcont : unit -> unit val _nostdlib : unit -> unit val _principal : unit -> unit val _real_paths : unit -> unit @@ -574,6 +592,7 @@ module type Opttop_options = sig val _dparsetree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit + val _dclambda : unit -> unit val _dcmm : unit -> unit val _dsel : unit -> unit val _dcombine : unit -> unit @@ -601,6 +620,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; @@ -673,6 +693,7 @@ struct mk_noassert F._noassert; mk_nolabels F._nolabels; mk_noprompt F._noprompt; + mk_nopromptcont F._nopromptcont; mk_nostdlib F._nostdlib; mk_principal F._principal; mk_real_paths F._real_paths; @@ -701,6 +722,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; @@ -751,11 +773,13 @@ struct mk_dparsetree F._dparsetree; mk_drawlambda F._drawlambda; mk_dlambda F._dlambda; + mk_dclambda F._dclambda; mk_dcmm F._dcmm; mk_dsel F._dsel; mk_dcombine F._dcombine; mk_dlive F._dlive; mk_dspill F._dspill; + mk_dsplit F._dsplit; mk_dinterf F._dinterf; mk_dprefer F._dprefer; mk_dalloc F._dalloc; @@ -780,6 +804,7 @@ module Make_opttop_options (F : Opttop_options) = struct mk_noassert F._noassert; mk_nolabels F._nolabels; mk_noprompt F._noprompt; + mk_nopromptcont F._nopromptcont; mk_nostdlib F._nostdlib; mk_principal F._principal; mk_real_paths F._real_paths; @@ -796,11 +821,13 @@ module Make_opttop_options (F : Opttop_options) = struct mk_dparsetree F._dparsetree; mk_drawlambda F._drawlambda; + mk_dclambda F._dclambda; mk_dcmm F._dcmm; mk_dsel F._dsel; mk_dcombine F._dcombine; mk_dlive F._dlive; mk_dspill F._dspill; + mk_dsplit F._dsplit; mk_dinterf F._dinterf; mk_dprefer F._dprefer; mk_dalloc F._dalloc; diff --git a/driver/main_args.mli b/driver/main_args.mli index 5962cf5ee7..251ec9186d 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 @@ -81,6 +82,7 @@ module type Bytetop_options = sig val _noassert : unit -> unit val _nolabels : unit -> unit val _noprompt : unit -> unit + val _nopromptcont : unit -> unit val _nostdlib : unit -> unit val _principal : unit -> unit val _real_paths : unit -> unit @@ -106,6 +108,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 @@ -155,6 +158,7 @@ module type Optcomp_options = sig val _dparsetree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit + val _dclambda : unit -> unit val _dcmm : unit -> unit val _dsel : unit -> unit val _dcombine : unit -> unit @@ -183,6 +187,7 @@ module type Opttop_options = sig val _noassert : unit -> unit val _nolabels : unit -> unit val _noprompt : unit -> unit + val _nopromptcont : unit -> unit val _nostdlib : unit -> unit val _principal : unit -> unit val _real_paths : unit -> unit @@ -200,6 +205,7 @@ module type Opttop_options = sig val _dparsetree : unit -> unit val _drawlambda : unit -> unit val _dlambda : unit -> unit + val _dclambda : unit -> unit val _dcmm : unit -> unit val _dsel : unit -> unit val _dcombine : unit -> unit diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 1e6ab0ce3f..3154ad1481 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -76,22 +76,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 *) @@ -133,12 +136,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..4078bbb2fd 100644 --- a/driver/opterrors.ml +++ b/driver/opterrors.ml @@ -33,24 +33,27 @@ 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 "In this program,@ variant constructors@ `%s and `%s@ \ have the same hash value.@ Change one of them." l l' - | Typecore.Error(loc, err) -> - Location.print_error ppf loc; Typecore.report_error ppf err + | Typecore.Error(loc, env, err) -> + Location.print_error ppf loc; Typecore.report_error env ppf err | Typetexp.Error(loc, err) -> Location.print_error ppf loc; Typetexp.report_error ppf err | Typedecl.Error(loc, err) -> Location.print_error ppf loc; Typedecl.report_error ppf err - | Typeclass.Error(loc, err) -> - Location.print_error ppf loc; Typeclass.report_error ppf err + | Typeclass.Error(loc, env, err) -> + Location.print_error ppf loc; Typeclass.report_error env ppf err | Includemod.Error err -> Location.print_error_cur_file ppf; Includemod.report_error ppf err - | Typemod.Error(loc, err) -> - Location.print_error ppf loc; Typemod.report_error ppf err + | Typemod.Error(loc, env, err) -> + Location.print_error ppf loc; Typemod.report_error env ppf err | Translcore.Error(loc, err) -> Location.print_error ppf loc; Translcore.report_error ppf err | Translclass.Error(loc, err) -> diff --git a/driver/optmain.ml b/driver/optmain.ml index cb18447bad..4025b5c596 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -30,6 +30,8 @@ let process_implementation_file ppf name = Optcompile.implementation ppf name opref; objfiles := (opref ^ ".cmx") :: !objfiles +let cmxa_present = ref false;; + let process_file ppf name = if Filename.check_suffix name ".ml" || Filename.check_suffix name ".mlt" then @@ -39,10 +41,12 @@ let process_file ppf name = Optcompile.interface ppf name opref; if !make_package then objfiles := (opref ^ ".cmi") :: !objfiles end - else if Filename.check_suffix name ".cmx" - || Filename.check_suffix name ".cmxa" then + else if Filename.check_suffix name ".cmx" then + objfiles := name :: !objfiles + else if Filename.check_suffix name ".cmxa" then begin + cmxa_present := true; objfiles := name :: !objfiles - else if Filename.check_suffix name ".cmi" && !make_package then + end else if Filename.check_suffix name ".cmi" && !make_package then objfiles := name :: !objfiles else if Filename.check_suffix name ext_obj || Filename.check_suffix name ext_lib then @@ -100,6 +104,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 @@ -149,6 +154,7 @@ module Options = Main_args.Make_optcomp_options (struct let _dparsetree = set dump_parsetree let _drawlambda = set dump_rawlambda let _dlambda = set dump_lambda + let _dclambda = set dump_clambda let _dcmm = set dump_cmm let _dsel = set dump_selection let _dcombine = set dump_combine @@ -178,19 +184,24 @@ let main () = then fatal "Please specify at most one of -pack, -a, -shared, -c, -output-obj"; if !make_archive then begin + if !cmxa_present then + fatal "Option -a cannot be used with .cmxa input files."; Optcompile.init_path(); let target = extract_output !output_name in Asmlibrarian.create_archive (List.rev !objfiles) target; + Warnings.check_fatal (); end else if !make_package then begin Optcompile.init_path(); let target = extract_output !output_name in Asmpackager.package_files ppf (List.rev !objfiles) target; + Warnings.check_fatal (); end else if !shared then begin Optcompile.init_path(); let target = extract_output !output_name in Asmlink.link_shared ppf (List.rev !objfiles) target; + Warnings.check_fatal (); end else if not !compile_only && !objfiles <> [] then begin let target = @@ -209,7 +220,8 @@ let main () = default_output !output_name in Optcompile.init_path(); - Asmlink.link ppf (List.rev !objfiles) target + Asmlink.link ppf (List.rev !objfiles) target; + Warnings.check_fatal (); end; exit 0 with x -> diff --git a/driver/pparse.ml b/driver/pparse.ml index 5d27beeb42..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 @@ -51,15 +51,14 @@ let file ppf inputfile parse_fun ast_magic = let ic = open_in_bin inputfile in let is_ast_file = try - let buffer = String.create (String.length ast_magic) in - really_input ic buffer 0 (String.length ast_magic); + let buffer = Misc.input_bytes ic (String.length ast_magic) in if buffer = ast_magic then true else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then raise Outdated_version else false with Outdated_version -> - Misc.fatal_error "Ocaml and preprocessor have incompatible versions" + Misc.fatal_error "OCaml and preprocessor have incompatible versions" | _ -> false in let ast = diff --git a/emacs/Makefile b/emacs/Makefile index 77aa0c6295..6475be9070 100644 --- a/emacs/Makefile +++ b/emacs/Makefile @@ -41,6 +41,7 @@ COMPILECMD=(progn \ install: @if test "$(EMACSDIR)" = ""; then \ + $(EMACS) --batch --eval 't; see PR#5403'; \ set xxx `($(EMACS) --batch --eval "(mapcar 'print load-path)") \ 2>/dev/null | \ sed -n -e 's/^"\(.*\/site-lisp\).*/\1/gp' | \ diff --git a/emacs/README b/emacs/README index ea82a9fd47..9c30c8892d 100644 --- a/emacs/README +++ b/emacs/README @@ -123,7 +123,7 @@ Version 1.07: Version 1.06: ------------ -* new keywords in O'Caml 1.06 +* new keywords in Objective Caml 1.06 * compatibility with GNU Emacs 20 @@ -153,7 +153,7 @@ Version 1.03b: (setq caml-quote-char "`") (setq inferior-caml-program "camllight") Literals will be correctly understood and highlighted. However, - indentation rules are still Objective Caml's: this just happens to + indentation rules are still OCaml's: this just happens to work well in most cases, but is only intended for occasional use. * as many people asked for it, application is now indented. This seems @@ -167,10 +167,10 @@ Version 1.03b: Version 1.03: ------------ -* support of Objective Caml and Objective Label. +* support of OCaml and Objective Label. * an indentation very close to mine, which happens to be the same as - Xavier's, since the sources of the Objective Caml compiler do not + Xavier's, since the sources of the OCaml compiler do not change if you indent them in this mode. * highlighting. @@ -178,7 +178,7 @@ Version 1.03: Some remarks about the style supported: -------------------------------------- -Since Objective Caml's syntax is very liberal (more than 100 +Since OCaml's syntax is very liberal (more than 100 shift-reduce conflicts with yacc), automatic indentation is far from easy. Moreover, you expect the indentation to be not purely syntactic, but also semantic: reflecting the meaning of your program. diff --git a/emacs/README.itz b/emacs/README.itz index 8e1366f478..7bcc7aa05d 100644 --- a/emacs/README.itz +++ b/emacs/README.itz @@ -1,7 +1,7 @@ DESCRIPTION: -This directory contains files to help editing Caml code, running a -Caml toplevel, and running the Caml debugger under the Gnu Emacs editor. +This directory contains files to help editing OCaml code, running a +OCaml toplevel, and running the OCaml debugger under the Gnu Emacs editor. AUTHORS: @@ -13,10 +13,10 @@ camldebug.el is derived from FSF code. CONTENTS: - caml.el A major mode for editing Caml code in Gnu Emacs - inf-caml.el To run a Caml toplevel under Emacs, with input and + caml.el A major mode for editing OCaml code in Gnu Emacs + inf-caml.el To run a OCaml toplevel under Emacs, with input and output in an Emacs buffer. - camldebug.el To run the Caml debugger under Emacs. + camldebug.el To run the OCaml debugger under Emacs. NOTE FOR EMACS 18 USERS: @@ -29,13 +29,13 @@ USAGE: Add the following lines to your .emacs file: (setq auto-mode-alist (cons '("\\.ml[iylp]?" . caml-mode) auto-mode-alist)) -(autoload 'caml-mode "caml" "Major mode for editing Caml code." t) -(autoload 'run-caml "inf-caml" "Run an inferior Caml process." t) -(autoload 'camldebug "camldebug" "Run the Caml debugger." t) +(autoload 'caml-mode "caml" "Major mode for editing OCaml code." t) +(autoload 'run-caml "inf-caml" "Run an inferior OCaml process." t) +(autoload 'camldebug "camldebug" "Run the OCaml debugger." t) The Caml major mode is triggered by visiting a file with extension .ml, .mli, .mly. .mll or .mlp, or manually by M-x caml-mode. It gives you the -correct syntax table for the Caml language. For a brief description of +correct syntax table for the OCaml language. For a brief description of the indentation capabilities, see below under NEWS. The Caml mode also allows you to run batch Caml compilations from @@ -44,16 +44,16 @@ sets the point at the beginning of the erroneous program fragment, and the mark at the end. Under Emacs 19, the program fragment is temporarily highlighted. -M-x run-caml starts a Caml toplevel with input and output in an Emacs +M-x run-caml starts an OCaml toplevel with input and output in an Emacs buffer named *inferior-caml*. This gives you the full power of Emacs -to edit the input to the Caml toplevel. This mode is based on comint +to edit the input to the OCaml toplevel. This mode is based on comint so you get all the usual comint features, including command history. After M-x run-caml, typing C-c C-e or M-C-x in a buffer in Caml mode -sends the current phrase (containing the point) to the Caml toplevel, +sends the current phrase (containing the point) to the OCaml toplevel, and evaluates it. -M-x camldebug FILE starts the Caml debugger camldebug on the executable +M-x camldebug FILE starts the OCaml debugger camldebug on the executable FILE, with input and output in an Emacs buffer named *camldebug-FILE*. For a brief description of the commands available in this buffer, see NEWS below. diff --git a/emacs/caml-hilit.el b/emacs/caml-hilit.el index 0d437c5096..25376eb2a4 100644 --- a/emacs/caml-hilit.el +++ b/emacs/caml-hilit.el @@ -53,7 +53,7 @@ "\\|\|\\|->\\|&\\|#") nil 'keyword) '(";" nil struct)) - "Hilit19 patterns used for Caml mode") + "Hilit19 patterns used for OCaml mode") (hilit-set-mode-patterns 'caml-mode caml-mode-patterns) (hilit-set-mode-patterns diff --git a/emacs/caml-types.el b/emacs/caml-types.el index 70d38bccea..ac3fb1bf80 100644 --- a/emacs/caml-types.el +++ b/emacs/caml-types.el @@ -38,7 +38,7 @@ Their format is: <SP> is a space character (ASCII 0x20) <LF> is a line-feed character (ASCII 0x0A) num is a sequence of decimal digits - filename is a string with the lexical conventions of O'Caml + filename is a string with the lexical conventions of OCaml open-paren is an open parenthesis (ASCII 0x28) close-paren is a closed parenthesis (ASCII 0x29) data is any sequence of characters where <LF> is always followed by @@ -411,8 +411,7 @@ See `caml-types-location-re' for annotation file format. (unless (caml-types-not-in-file l-file r-file target-file) (setq annotation ()) (while (next-annotation) - (cond ((looking-at - "^\\([a-z]+\\)(\n \\(\\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)") + (cond ((looking-at "^\\([a-z]+\\)(\n \\(\\(.*\n \\)*.*\\)\n)") (let ((kind (caml-types-hcons (match-string 1) table)) (info (caml-types-hcons (match-string 2) table))) (setq annotation (cons (cons kind info) annotation)))))) @@ -595,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))) @@ -687,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/emacs/caml.el b/emacs/caml.el index 342305de97..d1127f789c 100644 --- a/emacs/caml.el +++ b/emacs/caml.el @@ -12,7 +12,7 @@ ;(* $Id$ *) -;;; caml.el --- O'Caml code editing commands for Emacs +;;; caml.el --- OCaml code editing commands for Emacs ;; Xavier Leroy, july 1993. @@ -484,7 +484,7 @@ have caml-electric-indent on, which see.") "Hook for caml-mode") (defun caml-mode () - "Major mode for editing Caml code. + "Major mode for editing OCaml code. \\{caml-mode-map}" @@ -588,7 +588,7 @@ have caml-electric-indent on, which see.") ;;; subshell support (defun caml-eval-region (start end) - "Send the current region to the inferior Caml process." + "Send the current region to the inferior OCaml process." (interactive"r") (require 'inf-caml) (inferior-caml-eval-region start end)) @@ -596,7 +596,7 @@ have caml-electric-indent on, which see.") ;; old version ---to be deleted later ; ; (defun caml-eval-phrase () -; "Send the current Caml phrase to the inferior Caml process." +; "Send the current OCaml phrase to the inferior Caml process." ; (interactive) ; (save-excursion ; (let ((bounds (caml-mark-phrase))) @@ -825,7 +825,7 @@ from an error message produced by camlc.") ;that way we get our effect even when we do \C-x` in compilation buffer (defadvice next-error (after caml-next-error activate) - "Reads the extra positional information provided by the Caml compiler. + "Reads the extra positional information provided by the OCaml compiler. Puts the point and the mark exactly around the erroneous program fragment. The erroneous fragment is also temporarily highlighted if @@ -903,7 +903,7 @@ whole string." ;; itz Thu Sep 24 19:02:42 PDT 1998 this is to have some level of ;; comfort when sending phrases to the toplevel and getting errors. (defun caml-goto-phrase-error () - "Find the error location in current Caml phrase." + "Find the error location in current OCaml phrase." (interactive) (require 'inf-caml) (let ((bounds (save-excursion (caml-mark-phrase)))) @@ -984,7 +984,7 @@ to the end. beg)) (defun caml-mark-phrase (&optional min-pos max-pos) - "Put mark at end of this Caml phrase, point at beginning. + "Put mark at end of this OCaml phrase, point at beginning. " (interactive) (let* ((beg (caml-find-phrase min-pos max-pos)) (end (point))) @@ -1756,7 +1756,7 @@ by |, insert one." (goto-char (match-end 0)))) ;; to mark phrases, so that repeated calls will take several of them -;; knows little about Ocaml appart literals and comments, so it should work +;; knows little about OCaml except literals and comments, so it should work ;; with other dialects as long as ;; marks the end of phrase. (defun caml-indent-phrase (arg) @@ -1912,7 +1912,7 @@ with prefix arg, indent that many phrases starting with the current phrase." (beginning-of-line 1) (backward-char 4))) -(autoload 'run-caml "inf-caml" "Run an inferior Caml process." t) +(autoload 'run-caml "inf-caml" "Run an inferior OCaml process." t) (autoload 'caml-types-show-type "caml-types" "Show the type of expression or pattern at point." t) diff --git a/emacs/camldebug.el b/emacs/camldebug.el index 199a6cc1ad..790eb6eb43 100644 --- a/emacs/camldebug.el +++ b/emacs/camldebug.el @@ -89,7 +89,7 @@ (define-derived-mode camldebug-mode comint-mode "Inferior CDB" - "Major mode for interacting with an inferior Camldebug process. + "Major mode for interacting with an inferior ocamldebug process. The following commands are available: @@ -575,7 +575,7 @@ the camldebug commands `cd DIR' and `directory'." (let ((process-window)) ;; it does not seem necessary to save excursion here, ;; since set-buffer as a temporary effect. - ;; comint-output-filter explicitly avoids it. + ;; comint-output-filter explicitly avoids it. ;; in version 23, it prevents the marker to stay at end of buffer ;; (save-excursion (set-buffer (process-buffer proc)) @@ -595,8 +595,8 @@ the camldebug commands `cd DIR' and `directory'." (get-buffer-window (current-buffer)))) ;; Insert the text, moving the process-marker. (comint-output-filter proc output) - ;; ) - ;; this was the end of save-excursion. + ;; ) + ;; this was the end of save-excursion. ;; if save-excursion is used (comint-next-prompt 1) would be needed ;; to move the mark past then next prompt, but this is not as good ;; as solution. diff --git a/emacs/inf-caml.el b/emacs/inf-caml.el index 4b9cd6bb8d..5b864efcb0 100644 --- a/emacs/inf-caml.el +++ b/emacs/inf-caml.el @@ -12,7 +12,7 @@ ;(* $Id$ *) -;;; inf-caml.el --- run the Caml toplevel in an Emacs buffer +;;; inf-caml.el --- run the OCaml toplevel in an Emacs buffer ;; Xavier Leroy, july 1993. @@ -37,14 +37,14 @@ (setq inferior-caml-mode-map (copy-keymap comint-mode-map))) -;; Augment Caml mode, so you can process Caml code in the source files. +;; Augment Caml mode, so you can process OCaml code in the source files. (defvar inferior-caml-program "ocaml" - "*Program name for invoking an inferior Caml from Emacs.") + "*Program name for invoking an inferior OCaml from Emacs.") (defun inferior-caml-mode () - "Major mode for interacting with an inferior Caml process. -Runs a Caml toplevel as a subprocess of Emacs, with I/O through an + "Major mode for interacting with an inferior OCaml process. +Runs an OCaml toplevel as a subprocess of Emacs, with I/O through an Emacs buffer. A history of input phrases is maintained. Phrases can be sent from another buffer in Caml mode. @@ -95,7 +95,7 @@ be sent from another buffer in Caml mode. (defun inferior-caml-mode-output-hook () (set-variable 'comint-output-filter-functions - (list (function inferior-caml-signal-output)) + (list (function inferior-caml-signal-output)) t)) (add-hook 'inferior-caml-mode-hooks 'inferior-caml-mode-output-hook) @@ -106,7 +106,7 @@ be sent from another buffer in Caml mode. (if (not cmd) (if (comint-check-proc inferior-caml-buffer-name) (setq cmd inferior-caml-program) - (setq cmd (read-from-minibuffer "Caml toplevel to run: " + (setq cmd (read-from-minibuffer "OCaml toplevel to run: " inferior-caml-program)))) (setq inferior-caml-program cmd) (let ((cmdlist (inferior-caml-args-to-list cmd)) @@ -124,11 +124,11 @@ be sent from another buffer in Caml mode. ;; caml-run-process-when-needed (defun run-caml (&optional cmd) - "Run an inferior Caml process. + "Run an inferior OCaml process. Input and output via buffer `*inferior-caml*'." (interactive (list (if (not (comint-check-proc inferior-caml-buffer-name)) - (read-from-minibuffer "Caml toplevel to run: " + (read-from-minibuffer "OCaml toplevel to run: " inferior-caml-program)))) (caml-run-process-if-needed cmd) (switch-to-buffer-other-window inferior-caml-buffer-name)) @@ -174,7 +174,7 @@ Input and output via buffer `*inferior-caml*'." ;; patched by Didier to move cursor after evaluation (defun inferior-caml-eval-region (start end) - "Send the current region to the inferior Caml process." + "Send the current region to the inferior OCaml process." (interactive "r") (save-excursion (caml-run-process-if-needed)) (save-excursion diff --git a/experimental/doligez/checkheaders b/experimental/doligez/checkheaders index 044080f2e8..779c8c8862 100755 --- a/experimental/doligez/checkheaders +++ b/experimental/doligez/checkheaders @@ -18,7 +18,7 @@ case $# in *) echo $1;; esac ) | \ -while read f; do +while read f; do awk -f - "$f" <<\EOF function checkline (x) { diff --git a/experimental/garrigue/.cvsignore b/experimental/garrigue/.cvsignore index 4c57147b38..4539eb6d09 100644 --- a/experimental/garrigue/.cvsignore +++ b/experimental/garrigue/.cvsignore @@ -1 +1,2 @@ -*.out *.out2
\ No newline at end of file +*.out +*.out2 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/experimental/garrigue/dirs_multimatch b/experimental/garrigue/dirs_multimatch index b449514644..3e44400046 100644 --- a/experimental/garrigue/dirs_multimatch +++ b/experimental/garrigue/dirs_multimatch @@ -1 +1 @@ -parsing typing bytecomp driver toplevel
\ No newline at end of file +parsing typing bytecomp driver toplevel diff --git a/experimental/garrigue/fixedtypes.ml b/experimental/garrigue/fixedtypes.ml index a7d7ca4ae3..aa6e530e78 100644 --- a/experimental/garrigue/fixedtypes.ml +++ b/experimental/garrigue/fixedtypes.ml @@ -59,7 +59,7 @@ module M6 : sig val x : int method x : int method move : int -> unit - end + end type c = private #ci val create : int -> c end = struct diff --git a/experimental/garrigue/varunion.ml b/experimental/garrigue/varunion.ml index 30a410f22a..41dca65f2f 100644 --- a/experimental/garrigue/varunion.ml +++ b/experimental/garrigue/varunion.ml @@ -67,7 +67,7 @@ module M = Mix(I)(M1)(M2) ;; let c = (`C 'c' : M.t) ;; -module M(X : sig type t = private [> `A] end) = +module M(X : sig type t = private [> `A] end) = struct let f (#X.t as x) = x end;; (* code generation *) @@ -128,7 +128,7 @@ module F(X: sig end) : sig type v = private [< X.t | X.u | `D] end = struct open X let f = function #u -> 1 | #t -> 2 | `D -> 3 - let g = function #u|#t|`D -> 2 + let g = function #u|#t|`D -> 2 type v = [t|u|`D] end @@ -201,7 +201,7 @@ module Add(X : Exp with type t = private [> num | 'a add] as 'a) = struct `Num n1, `Num n2 -> `Num (n1+n2) | `Num 0, e | e, `Num 0 -> e | e12 -> `Add e12 -end +end type 'a mul = [`Mul of 'a * 'a] @@ -376,7 +376,7 @@ module Add(X : Exp with type t = private [> num | 'a add] as 'a) = struct `Num n1, `Num n2 -> `Num (n1+n2) | `Num 0, e | e, `Num 0 -> e | _ -> e -end +end module Mul(X : Exp with type t = private [> num | 'a mul] as 'a) = struct type t = X.t mul diff --git a/lex/.depend b/lex/.depend index b51dbd3bdf..b0df0b874f 100644 --- a/lex/.depend +++ b/lex/.depend @@ -1,34 +1,34 @@ -common.cmi: syntax.cmi lexgen.cmi -compact.cmi: lexgen.cmi -cset.cmi: -lexer.cmi: parser.cmi -lexgen.cmi: syntax.cmi -output.cmi: syntax.cmi lexgen.cmi compact.cmi common.cmi -outputbis.cmi: syntax.cmi lexgen.cmi common.cmi -parser.cmi: syntax.cmi -syntax.cmi: cset.cmi -table.cmi: -common.cmo: syntax.cmi lexgen.cmi common.cmi -common.cmx: syntax.cmx lexgen.cmx common.cmi -compact.cmo: table.cmi lexgen.cmi compact.cmi -compact.cmx: table.cmx lexgen.cmx compact.cmi -cset.cmo: cset.cmi -cset.cmx: cset.cmi -lexer.cmo: syntax.cmi parser.cmi lexer.cmi -lexer.cmx: syntax.cmx parser.cmx lexer.cmi -lexgen.cmo: table.cmi syntax.cmi cset.cmi lexgen.cmi -lexgen.cmx: table.cmx syntax.cmx cset.cmx lexgen.cmi -main.cmo: syntax.cmi parser.cmi outputbis.cmi output.cmi lexgen.cmi lexer.cmi \ - cset.cmi compact.cmi common.cmi -main.cmx: syntax.cmx parser.cmx outputbis.cmx output.cmx lexgen.cmx lexer.cmx \ - cset.cmx compact.cmx common.cmx -output.cmo: syntax.cmi lexgen.cmi compact.cmi common.cmi output.cmi -output.cmx: syntax.cmx lexgen.cmx compact.cmx common.cmx output.cmi -outputbis.cmo: syntax.cmi lexgen.cmi common.cmi outputbis.cmi -outputbis.cmx: syntax.cmx lexgen.cmx common.cmx outputbis.cmi -parser.cmo: syntax.cmi cset.cmi parser.cmi -parser.cmx: syntax.cmx cset.cmx parser.cmi -syntax.cmo: cset.cmi syntax.cmi -syntax.cmx: cset.cmx syntax.cmi -table.cmo: table.cmi -table.cmx: table.cmi +common.cmi : syntax.cmi lexgen.cmi +compact.cmi : lexgen.cmi +cset.cmi : +lexer.cmi : parser.cmi +lexgen.cmi : syntax.cmi +output.cmi : syntax.cmi lexgen.cmi compact.cmi common.cmi +outputbis.cmi : syntax.cmi lexgen.cmi common.cmi +parser.cmi : syntax.cmi +syntax.cmi : cset.cmi +table.cmi : +common.cmo : syntax.cmi lexgen.cmi common.cmi +common.cmx : syntax.cmx lexgen.cmx common.cmi +compact.cmo : table.cmi lexgen.cmi compact.cmi +compact.cmx : table.cmx lexgen.cmx compact.cmi +cset.cmo : cset.cmi +cset.cmx : cset.cmi +lexer.cmo : syntax.cmi parser.cmi lexer.cmi +lexer.cmx : syntax.cmx parser.cmx lexer.cmi +lexgen.cmo : table.cmi syntax.cmi cset.cmi lexgen.cmi +lexgen.cmx : table.cmx syntax.cmx cset.cmx lexgen.cmi +main.cmo : syntax.cmi parser.cmi outputbis.cmi output.cmi lexgen.cmi \ + lexer.cmi cset.cmi compact.cmi common.cmi +main.cmx : syntax.cmx parser.cmx outputbis.cmx output.cmx lexgen.cmx \ + lexer.cmx cset.cmx compact.cmx common.cmx +output.cmo : syntax.cmi lexgen.cmi compact.cmi common.cmi output.cmi +output.cmx : syntax.cmx lexgen.cmx compact.cmx common.cmx output.cmi +outputbis.cmo : syntax.cmi lexgen.cmi common.cmi outputbis.cmi +outputbis.cmx : syntax.cmx lexgen.cmx common.cmx outputbis.cmi +parser.cmo : syntax.cmi cset.cmi parser.cmi +parser.cmx : syntax.cmx cset.cmx parser.cmi +syntax.cmo : cset.cmi syntax.cmi +syntax.cmx : cset.cmx syntax.cmi +table.cmo : table.cmi +table.cmx : table.cmi diff --git a/lex/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 e6c1e193bc..4c0cb81914 100644 --- a/man/Makefile +++ b/man/Makefile @@ -20,3 +20,4 @@ install: for i in *.m; do cp $$i $(DIR)/`basename $$i .m`.$(MANEXT); done echo '.so man$(MANEXT)/ocamlc.$(MANEXT)' > $(DIR)/ocamlc.opt.$(MANEXT) echo '.so man$(MANEXT)/ocamlopt.$(MANEXT)' > $(DIR)/ocamlopt.opt.$(MANEXT) + echo '.so man$(MANEXT)/ocamlcp.$(MANEXT)' > $(DIR)/ocamloptp.$(MANEXT) diff --git a/man/ocaml.m b/man/ocaml.m index d7679af3a7..c230038c20 100644 --- a/man/ocaml.m +++ b/man/ocaml.m @@ -114,6 +114,14 @@ applications, and parameter order becomes strict. .B \-noprompt Do not display any prompt when waiting for input. .TP +.B \-nopromptcont +Do not display the secondary prompt when waiting for continuation lines in +multi-line inputs. This should be used e.g. when running +.BR ocaml (1) +in an +.BR emacs (1) +window. +.TP .B \-nostdlib Do not include the standard library directory in the list of directories searched for source and compiled files. diff --git a/man/ocamlc.m b/man/ocamlc.m index 1ca02be08d..6e3ee3d8fb 100644 --- a/man/ocamlc.m +++ b/man/ocamlc.m @@ -208,6 +208,11 @@ file can be used with the emacs commands given in .B emacs/caml\-types.el to display types and other annotations interactively. .TP +.B \-dtypes +Has been deprecated. Please use +.B \-annot +instead. +.TP .B \-c Compile only. Suppress the linking phase of the compilation. Source code files are turned into compiled files, but no @@ -402,9 +407,8 @@ specify the name of the output file produced. .B \-output\-obj Cause the linker to produce a C object file instead of a bytecode executable file. This is useful to wrap OCaml code as a C library, -callable from any C program. The name of the output object file is -.B camlprog.o -by default; it can be set with the +callable from any C program. The name of the output object file +must be set with the .B \-o option. This option can also be used to produce a C source file (.c extension) or @@ -501,7 +505,7 @@ invocations of the C compiler and linker in .B \-custom mode. Useful to debug C library problems. .TP -.BR \-vnum\ or \-version +.BR \-vnum \ or\ \-version Print the version number of the compiler in short form (e.g. "3.11.0"), then exit. .TP @@ -543,6 +547,27 @@ between them. A warning specifier is one of the following: \ \ Enable and mark warning number .IR num . +.BI + num1 .. num2 +\ \ Enable all warnings between +.I num1 +and +.I num2 +(inclusive). + +.BI \- num1 .. num2 +\ \ Disable all warnings between +.I num1 +and +.I num2 +(inclusive). + +.BI @ num1 .. num2 +\ \ Enable and mark all warnings between +.I num1 +and +.I num2 +(inclusive). + .BI + letter \ \ Enable the set of warnings corresponding to .IR letter . @@ -590,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. @@ -722,7 +747,7 @@ mentioned here corresponds to the empty set. .IP The default setting is -.BR \-w\ +a\-4\-6\-9\-27\-29\-32\-33\-34\-35\-36\-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. @@ -744,14 +769,14 @@ sign (or a lowercase letter) turns them back into warnings, and a .B @ sign both enables and marks the corresponding warnings. -Note: it is not recommended to use warning sets (i.e. letters) as -arguments to +Note: it is not recommended to use the .B \-warn\-error -in production code, because this can break your build when future versions -of OCaml add some new warnings. +option in production code, because it will almost certainly prevent +compiling your program with later versions of OCaml when they add new +warnings. The default setting is -.B \-warn\-error\ +a +.B \-warn\-error\ -a (none of the warnings is treated as an error). .TP .B \-where 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/ocamldoc.m b/man/ocamldoc.m index 32d6aae1c1..064cc82d5b 100644 --- a/man/ocamldoc.m +++ b/man/ocamldoc.m @@ -253,7 +253,7 @@ as the title for the generated documentation. .BI \-intro \ file Use content of .I file -as +as .B ocamldoc text to use as introduction (HTML, LaTeX and TeXinfo only). For HTML, the file is used to create the whole "index.html" file. diff --git a/man/ocamlopt.m b/man/ocamlopt.m index a366d5a848..e6f6ae9b44 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 @@ -170,6 +170,11 @@ file can be used with the emacs commands given in .B emacs/caml\-types.el to display types and other annotations interactively. .TP +.B \-dtypes +Has been deprecated. Please use +.BI \-annot +instead. +.TP .B \-c Compile only. Suppress the linking phase of the compilation. Source code files are turned into compiled files, but no @@ -331,8 +336,8 @@ option is given, specify the name of plugin file produced. .B \-output\-obj Cause the linker to produce a C object file instead of an executable file. This is useful to wrap OCaml code as a C library, -callable from any C program. The name of the output object file is -camlprog.o by default; it can be set with the +callable from any C program. The name of the output object file +must be set with the .B \-o option. This option can also be used to produce a compiled shared/dynamic @@ -511,14 +516,14 @@ sign (or a lowercase letter) turns them back into warnings, and a .B @ sign both enables and marks the corresponding warnings. -Note: it is not recommended to use warning sets (i.e. letters) as -arguments to +Note: it is not recommended to use the .B \-warn\-error -in production code, because this can break your build when future versions -of OCaml add some new warnings. +option in production code, because it will almost certainly prevent +compiling your program with later versions of OCaml when they add new +warnings. The default setting is -.B \-warn\-error\ +a +.B \-warn\-error\ -a (none of the warnings is treated as an error). .TP .B \-where diff --git a/myocamlbuild_config.mli b/myocamlbuild_config.mli index 5eec980326..340ce687f7 100644 --- a/myocamlbuild_config.mli +++ b/myocamlbuild_config.mli @@ -69,3 +69,4 @@ val toolchain : string val ccomptype : string val extralibs : string val tk_defs : string +val asm_cfi_supported : bool diff --git a/ocamlbuild/ChangeLog b/ocamlbuild/ChangeLog index a844e38b85..183be58210 100644 --- a/ocamlbuild/ChangeLog +++ b/ocamlbuild/ChangeLog @@ -2302,7 +2302,7 @@ 2006-12-08 Nicolas Pouillard <nicolas.pouillard@gmail.com> - Ocaml distrib stuffs. + OCaml distrib stuffs. * command.ml, * command.mli: Add a normalization callback. @@ -3619,4 +3619,3 @@ * ocamlbuild.ml: Add some flags -lflag, -ppflag, -cflag, --. Also add a detection mechanism for dependencies. * discard_printf.ml, Makefile: Update. - diff --git a/ocamlbuild/command.ml b/ocamlbuild/command.ml index 131cd8586c..1ce80c9743 100644 --- a/ocamlbuild/command.ml +++ b/ocamlbuild/command.ml @@ -91,9 +91,15 @@ let atomize_paths l = S(List.map (fun x -> P x) l) let env_path = lazy begin let path_var = Sys.getenv "PATH" in + let parse_path = + if Sys.os_type = "Win32" then + Lexers.parse_environment_path_w + else + Lexers.parse_environment_path + in let paths = try - Lexers.parse_environment_path (Lexing.from_string path_var) + parse_path (Lexing.from_string path_var) with Lexers.Error msg -> raise (Lexers.Error ("$PATH: " ^ msg)) in let norm_current_dir_name path = @@ -119,21 +125,33 @@ let virtual_solver virtual_command = failwith (Printf.sprintf "the solver for the virtual command %S \ has failed finding a valid command" virtual_command) +(* On Windows, we need to also check for the ".exe" version of the file. *) +let file_or_exe_exists file = + sys_file_exists file || Sys.os_type = "Win32" && sys_file_exists (file ^ ".exe") -(* FIXME windows *) let search_in_path cmd = + (* Try to find [cmd] in path [path]. *) + let try_path path = + (* Don't know why we're trying to be subtle here... *) + if path = Filename.current_dir_name then file_or_exe_exists cmd + else file_or_exe_exists (filename_concat path cmd) + in if Filename.is_implicit cmd then - let path = List.find begin fun path -> - if path = Filename.current_dir_name then sys_file_exists cmd - else sys_file_exists (filename_concat path cmd) - end !*env_path in + let path = List.find try_path !*env_path in + (* We're not trying to append ".exe" here because all windows shells are + * capable of understanding the command without the ".exe" suffix. *) filename_concat path cmd - else cmd + else + cmd (*** string_of_command_spec{,_with_calls *) let rec string_of_command_spec_with_calls call_with_tags call_with_target resolve_virtuals spec = let self = string_of_command_spec_with_calls call_with_tags call_with_target resolve_virtuals in let b = Buffer.create 256 in + (* The best way to prevent bash from switching to its windows-style + * quote-handling is to prepend an empty string before the command name. *) + if Sys.os_type = "Win32" then + Buffer.add_string b "''"; let first = ref true in let put_space () = if !first then diff --git a/ocamlbuild/command.mli b/ocamlbuild/command.mli index 0cdc602c8a..f54b8e8ac1 100644 --- a/ocamlbuild/command.mli +++ b/ocamlbuild/command.mli @@ -44,3 +44,5 @@ val deps_of_tags : Tags.t -> pathname list val dep : Tags.elt list -> pathname list -> unit val pdep : Tags.elt list -> Tags.elt -> (string -> pathname list) -> unit + +val file_or_exe_exists: string -> bool diff --git a/ocamlbuild/digest_cache.ml b/ocamlbuild/digest_cache.ml index 95ddfed1c8..5f624afcc4 100644 --- a/ocamlbuild/digest_cache.ml +++ b/ocamlbuild/digest_cache.ml @@ -20,7 +20,7 @@ let get = Hashtbl.find digests let put = Hashtbl.replace digests -let _digests = lazy (Pathname.pwd / !Options.build_dir / (Pathname.mk "_digests")) +let _digests = lazy (!Options.build_dir / (Pathname.mk "_digests")) let finalize () = with_output_file !*_digests begin fun oc -> diff --git a/ocamlbuild/display.ml b/ocamlbuild/display.ml index f8aab13740..11586662f9 100644 --- a/ocamlbuild/display.ml +++ b/ocamlbuild/display.ml @@ -120,7 +120,7 @@ let create match log_file with | None -> None | Some fn -> - let oc = open_out_gen [Open_text; Open_wronly; Open_creat; Open_trunc] 0o644 fn in + let oc = open_out_gen [Open_text; Open_wronly; Open_creat; Open_trunc] 0o666 fn in let f = Format.formatter_of_out_channel oc in Format.fprintf f "### Starting build.\n"; Some (f, oc) diff --git a/ocamlbuild/fda.ml b/ocamlbuild/fda.ml index 4d4bbac027..d359f78194 100644 --- a/ocamlbuild/fda.ml +++ b/ocamlbuild/fda.ml @@ -22,10 +22,10 @@ exception Exit_hygiene_failed let laws = [ - { law_name = "Leftover Ocaml compilation files"; + { law_name = "Leftover OCaml compilation files"; law_rules = [Not ".cmo"; Not ".cmi"; Not ".cmx"; Not ".cma"; Not ".cmxa"]; law_penalty = Fail }; - { law_name = "Leftover Ocaml type annotation files"; + { law_name = "Leftover OCaml type annotation files"; law_rules = [Not ".annot"]; law_penalty = Warn }; { law_name = "Leftover object files"; diff --git a/ocamlbuild/findlib.ml b/ocamlbuild/findlib.ml index 873adbabf8..b5ef878108 100644 --- a/ocamlbuild/findlib.ml +++ b/ocamlbuild/findlib.ml @@ -112,8 +112,24 @@ let rec query name = | Lexers.Error s -> error (Cannot_parse_query (name, s)) +let split_nl s = + let x = ref [] in + let rec go s = + let pos = String.index s '\n' in + x := (String.before s pos)::!x; + go (String.after s (pos + 1)) + in + try + go s + with Not_found -> !x + +let before_space s = + try + String.before s (String.index s ' ') + with Not_found -> s + let list () = - run_and_parse Lexers.blank_sep_strings "%s list | cut -d' ' -f1" ocamlfind + List.map before_space (split_nl & run_and_read "%s list" ocamlfind) (* The closure algorithm is easy because the dependencies are already closed and sorted for each package. We only have to make the union. We could also diff --git a/ocamlbuild/hygiene.ml b/ocamlbuild/hygiene.ml index 97a9ea9275..33c01ed13c 100644 --- a/ocamlbuild/hygiene.ml +++ b/ocamlbuild/hygiene.ml @@ -72,7 +72,8 @@ let check ?sanitize laws entry = list_collect begin function | File(path, name, _, true) -> - if Filename.check_suffix name suffix then + if Filename.check_suffix name suffix + && not ( Pathname.link_to_dir (filename_concat path name) !Options.build_dir ) then begin remove path name; Some(sf "File %s in %s has suffix %s" name path suffix) @@ -150,7 +151,7 @@ let check ?sanitize laws entry = @ or@ use@ other@ options@ (such@ as@ defining@ hygiene@ exceptions\ @ or@ using@ the@ -no-hygiene@ option).@]" m (if m = 1 then "" else "s") fn; - let oc = open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o755 fn in + let oc = open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o777 fn in (* See PR #5338: under mingw, one produces a shell script, which must follow Unix eol convention; hence Open_binary. *) let fp = Printf.fprintf in diff --git a/ocamlbuild/lexers.mli b/ocamlbuild/lexers.mli index 2f37edca64..bc5de4cfb1 100644 --- a/ocamlbuild/lexers.mli +++ b/ocamlbuild/lexers.mli @@ -32,6 +32,8 @@ val trim_blanks : Lexing.lexbuf -> string Example: ":aaa:bbb:::ccc:" -> [""; "aaa"; "bbb"; ""; ""; "ccc"; ""] *) val parse_environment_path : Lexing.lexbuf -> string list +(* Same one, for Windows (PATH is ;-separated) *) +val parse_environment_path_w : Lexing.lexbuf -> string list val conf_lines : string option -> int -> string -> Lexing.lexbuf -> conf val path_scheme : bool -> Lexing.lexbuf -> diff --git a/ocamlbuild/lexers.mll b/ocamlbuild/lexers.mll index 7b191b0d97..2206f862c0 100644 --- a/ocamlbuild/lexers.mll +++ b/ocamlbuild/lexers.mll @@ -81,6 +81,15 @@ and comma_or_blank_sep_strings_aux = parse | space* eof { [] } | _ { raise (Error "Expecting (comma|blank)-separated strings (2)") } +and parse_environment_path_w = parse + | ([^ ';']* as word) { word :: parse_environment_path_aux_w lexbuf } + | ';' ([^ ';']* as word) { "" :: word :: parse_environment_path_aux_w lexbuf } + | eof { [] } +and parse_environment_path_aux_w = parse + | ';' ([^ ';']* as word) { word :: parse_environment_path_aux_w lexbuf } + | eof { [] } + | _ { raise (Error "Impossible: expecting colon-separated strings") } + and parse_environment_path = parse | ([^ ':']* as word) { word :: parse_environment_path_aux lexbuf } | ':' ([^ ':']* as word) { "" :: word :: parse_environment_path_aux lexbuf } diff --git a/ocamlbuild/main.ml b/ocamlbuild/main.ml index 28b7c5c462..3b9bd8927b 100644 --- a/ocamlbuild/main.ml +++ b/ocamlbuild/main.ml @@ -37,6 +37,10 @@ let clean () = ;; let show_tags () = + if List.length !Options.show_tags > 0 then + Log.eprintf "Warning: the following tags do not include \ + dynamically-generated tags, such as link, compile, pack, byte, native, c, \ + pdf... (this list is by no means exhaustive).\n"; List.iter begin fun path -> Log.eprintf "@[<2>Tags for %S:@ {. %a .}@]" path Tags.print (tags_of_pathname path) end !Options.show_tags diff --git a/ocamlbuild/man/ocamlbuild.1 b/ocamlbuild/man/ocamlbuild.1 index dab9e941d9..918c598102 100644 --- a/ocamlbuild/man/ocamlbuild.1 +++ b/ocamlbuild/man/ocamlbuild.1 @@ -68,7 +68,7 @@ produce. Target names are of the form .BR base.extension where .BR base -is usually the name of the underlying Ocaml module and +is usually the name of the underlying OCaml module and .BR extension denotes the kind of object to produce from that file -- a byte code executable, a native executable, documentation... diff --git a/ocamlbuild/manual/manual.tex b/ocamlbuild/manual/manual.tex index 01d671eb74..bccdd9a6fe 100644 --- a/ocamlbuild/manual/manual.tex +++ b/ocamlbuild/manual/manual.tex @@ -620,7 +620,7 @@ library. Just write a file with the \texttt{mltop} extension (like \subsection{Preprocessor options and tags} You can specify preprocessor options with \texttt{-pp} followed by the preprocessor string, for instance \texttt{ocamlbuild -pp "camlp4o.opt -unsafe"} -would run your sources thru CamlP4 with the \texttt{-unsafe} option. +would run your sources through CamlP4 with the \texttt{-unsafe} option. Another way is to use the tags file. \begin{center} \begin{tabular}{|l|l|l|} diff --git a/ocamlbuild/my_std.ml b/ocamlbuild/my_std.ml index 78286b53c8..a7839d059d 100644 --- a/ocamlbuild/my_std.ml +++ b/ocamlbuild/my_std.ml @@ -249,18 +249,17 @@ let sys_command = | "Win32" -> fun cmd -> if cmd = "" then 0 else let cmd = "bash -c "^Filename.quote cmd in - (* FIXME fix Filename.quote for windows *) - let cmd = String.subst "\"&\"\"&\"" "&&" cmd in Sys.command cmd | _ -> fun cmd -> if cmd = "" then 0 else Sys.command cmd (* FIXME warning fix and use Filename.concat *) let filename_concat x y = if x = Filename.current_dir_name || x = "" then y else - if x.[String.length x - 1] = '/' then + if Sys.os_type = "Win32" && (x.[String.length x - 1] = '\\') || x.[String.length x - 1] = '/' then if y = "" then x else x ^ y - else x ^ "/" ^ y + else + x ^ "/" ^ y (* let reslash = match Sys.os_type with @@ -333,7 +332,7 @@ module Digest = struct (* USEFUL FOR DIGEST DEBUGING let digest_log_hash = Hashtbl.create 103;; let digest_log = "digest.log";; - let digest_log_oc = open_out_gen [Open_append;Open_wronly;Open_text;Open_creat] 0o644 digest_log;; + let digest_log_oc = open_out_gen [Open_append;Open_wronly;Open_text;Open_creat] 0o666 digest_log;; let my_to_hex x = to_hex x ^ ";";; if sys_file_exists digest_log then with_input_file digest_log begin fun ic -> diff --git a/ocamlbuild/ocaml_dependencies.mli b/ocamlbuild/ocaml_dependencies.mli index 68bc427cc2..5c1ebfe66c 100644 --- a/ocamlbuild/ocaml_dependencies.mli +++ b/ocamlbuild/ocaml_dependencies.mli @@ -11,7 +11,7 @@ (* Original author: Nicolas Pouillard *) -(** Ocaml dependencies *) +(** OCaml dependencies *) exception Circular_dependencies of string list * string diff --git a/ocamlbuild/ocaml_specific.ml b/ocamlbuild/ocaml_specific.ml index 454daaed4f..05343de13e 100644 --- a/ocamlbuild/ocaml_specific.ml +++ b/ocamlbuild/ocaml_specific.ml @@ -382,12 +382,21 @@ flag ["ocaml"; "compile"] begin atomize !Options.ocaml_cflags end;; +flag ["c"; "compile"] begin + atomize !Options.ocaml_cflags +end;; + flag ["ocaml"; "link"] begin atomize !Options.ocaml_lflags end;; +flag ["c"; "link"] begin + atomize !Options.ocaml_lflags +end;; + flag ["ocaml"; "ocamlyacc"] (atomize !Options.ocaml_yaccflags);; flag ["ocaml"; "menhir"] (atomize !Options.ocaml_yaccflags);; +flag ["ocaml"; "doc"] (atomize !Options.ocaml_docflags);; (* Tell menhir to explain conflicts *) flag [ "ocaml" ; "menhir" ; "explain" ] (S[A "--explain"]);; @@ -434,7 +443,7 @@ let () = (* tags package(X), predicate(X) and syntax(X) *) List.iter begin fun tags -> pflag tags "package" (fun pkg -> S [A "-package"; A pkg]); - pflag tags "predicate" (fun pkg -> S [A "-predicate"; A pkg]); + pflag tags "predicate" (fun pkg -> S [A "-predicates"; A pkg]); pflag tags "syntax" (fun pkg -> S [A "-syntax"; A pkg]) end all_tags end else begin @@ -453,6 +462,8 @@ let () = let () = pflag ["ocaml"; "native"; "compile"] "for-pack" (fun param -> S [A "-for-pack"; A param]); + pflag ["ocaml"; "native"; "pack"] "for-pack" + (fun param -> S [A "-for-pack"; A param]); pflag ["ocaml"; "native"; "compile"] "inline" (fun param -> S [A "-inline"; A param]); pflag ["ocaml"; "compile"] "pp" @@ -462,7 +473,9 @@ let () = pflag ["ocaml"; "doc"] "pp" (fun param -> S [A "-pp"; A param]); pflag ["ocaml"; "infer_interface"] "pp" - (fun param -> S [A "-pp"; A param]) + (fun param -> S [A "-pp"; A param]); + pflag ["ocaml";"compile";] "warn" + (fun param -> S [A "-w"; A param]) let camlp4_flags camlp4s = List.iter begin fun camlp4 -> diff --git a/ocamlbuild/ocaml_utils.ml b/ocamlbuild/ocaml_utils.ml index 3dafe25a41..7726825c19 100644 --- a/ocamlbuild/ocaml_utils.ml +++ b/ocamlbuild/ocaml_utils.ml @@ -29,8 +29,7 @@ let flag_and_dep tags cmd_spec = dep tags ps let stdlib_dir = lazy begin - (* FIXME *) - let ocamlc_where = sprintf "%s/ocamlc.where" (Pathname.pwd / !Options.build_dir) in + let ocamlc_where = !Options.build_dir / (Pathname.mk "ocamlc.where") in let () = Command.execute ~quiet:true (Cmd(S[!Options.ocamlc; A"-where"; Sh">"; P ocamlc_where])) in String.chomp (read_file ocamlc_where) end diff --git a/ocamlbuild/ocamlbuild-presentation.rslide b/ocamlbuild/ocamlbuild-presentation.rslide deleted file mode 100644 index 8f17da0bc7..0000000000 --- a/ocamlbuild/ocamlbuild-presentation.rslide +++ /dev/null @@ -1,362 +0,0 @@ -######################################################################### -# # -# OCaml # -# # -# Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt # -# # -# Copyright 2007 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -# Works with rslide revision 8 -# http://gallium.inria.fr/~pouillar/rslide/rslide -documentclass :beamer, :t, :compress, :red -usepackage :inputenc, :utf8 - -words "**OCaml**", "**ocamlbuild**", "_Makefile_" - -title "ocamlbuild" -subtitle "a compilation manager for OCaml projects" -authors "Berke Durak", "Nicolas Pouillard" -institute do - > @@Berke.Durak@inria.fr@@ - hfill - > @@Nicolas.Pouillard@inria.fr@@ -end - -usetheme :JuanLesPins -usefonttheme :serif -beamer_header '\setbeamercolor*{titlelike}{parent=structure}' -at_begin_section do - slide "Outline" do - tableofcontents 'sectionstyle=show/shaded', - 'subsectionstyle=show/shaded/hide' - end -end -beamer_footline 50, 0 - -extend do - def code_caml *a, &b - latex_only.small.code_inline(*a, &b) - html_only.code(*a, &b) - end - def code_tags *a, &b - latex_only.small.code_inline(*a, &b) - html_only.code(*a, &b) - end -end - -html_only do - paragraph.huge1 "Warning: this presentation has a degraded style compared to the Beamer/PDF version" -end - -short_version = true - -maketitle - -h1 "Introduction" - -slide "Why such a tool?", '<+->' do - * To make our OCaml life easier - * To stop writing poor MakefileS - * To have a tool that Just worksâ„¢ -end - -slide "What does ocamlbuild handle?", '<+->' do - - box "Regular OCaml projects of arbitrary size" do - > Trivially handled using the command line options. - end - - box "Mostly regular OCaml projects with common exceptions" do - > Requires writing one tag file (__tags_) that declares those exceptions. - end - - box "Almost any project" do - > Accomplished by writing an ocamlbuild plugin. - end - -end - -slide "What does ocamlbuild provide?" do - list do - overlay 1,2 do - * Automated whole-project compilation - * Minimal recompilation - * Lots of useful targets (doc, debugging, profiling...) - * Supports multiple build directories - * Automatic and safe cleaning - * A source directory uncluttered by object files - * A portable tool shipped with OCaml - end - overlay 2 do - * Saves time and money! - end - end -end - -h1 "Regular OCaml projects" - -slide "What's a regular OCaml project?" do - box "It's a project that needs no exceptions from the standard rules:" do - * Has compilation units (_ml_ and _mli_ files) - * May have parsers and lexers (_mly_ and _mll_ files) - * May use packages, libraries and toplevels (_ml{pack,lib,top}_) - * May link with external libraries - * Has one main OCaml unit from which these units are reachable - end -end - -slide "How difficult is it to build regular projects by hand?" do - box "OCaml has subtle compilation rules" do - * Interfaces (_.mli_) can be absent, yet buildable (_.mly_) - * Native and bytecode suffixes and settings differ - * Native packages are difficult to do (_-for-pack_) - * Linkage order must be correctly computed - * Include directories must be ordered - * _ocamldep_ gives partial information (too conservative) - end -end - -slide "How does ocamlbuild manage all that?" do - > It has a lot of hand-crafted Ocaml-specific compilation logic! - box "A dynamic exploration approach", '<2>' do - * Start from the given targets - * Attempt to discover dependencies using _ocamldep_ - * _ocamldep_ cannot always be trusted: backtrack if necessary - * Launch compilations and discover more dependencies - end -end - -unless short_version -slide "Demo..." do - box "Many projects can be compiled with a single command:" do - * Menhir: _ocamlbuild -lib unix back.native_ - * Hevea: _ocamlbuild latexmain.native_ - * Ergo: _ocamlbuild main.native_ - * Ocamlgraph: _ocamlbuild -cflags -for-pack,Ocamlgraph demo.native_ - * ... - end - box "To be fair..." do - > Some of these projects require that a _version.ml_ - or _stdlib.ml_ file be generated beforehand. - end -end -end - -h1 "Dealing with exceptions to standard rules" - -slide "What's an exception?" do - box "Files that need specific flags" do - * Warnings to be enabled or disabled - * Debugging (_-g_), profiling (_-p_), type annotation, - recursive types, _-linkall_, _-thread_, _-custom_... - end - list do - * Units that need external C libraries - * Binaries that need external OCaml libraries - * Directories that must be included or excluded - * Dependencies that cannot be discovered - end -end - -slide "_Make_ and exceptions" do - * The _make_ tool can't handle exceptions very well - * Needs exceptions to be encoded as specific rules - * This generally makes rules and exceptions tightly bound by variables - * This creates non-modular makefiles that don't *scale* -end - -slide "The tags, our way to specify exceptions", 'fragile=singleslide' do - list do - * Tagging is made in _tags files - * Each line is made of a pattern and a list of signed tags - * A line adds or removes tags from matching files - * Patterns are boolean combinations of shell-like globbing expressions - end - code_tags do - : "funny.ml": rectypes - ~<**/*.ml*>~: warn_A, warn_error_A, debug, annot - "foo.ml" or "bar.ml": warn_v, warn_error_v - "vendor.ml": -warn_A, -warn_error_A - <main.{byte,native}>: use_unix - "main.byte": use_dynlink, linkall - "test": not_hygienic - <satsolver.cm[io]>: precious - end -end - -slide "How tags and rules give commands", 'fragile=singleslide' do - box "Files are tagged using tagging rules" do - code_tags do - : "foo/bar.ml": rectypes - end - end - box "Rules then produce commands with *tagged holes*" do - code_caml do - : let tagged_hole = - tags_for(ml)++"ocaml"++"compile"++"byte" in - Cmd(S[A"ocamlc";A"-c";T tagged_hole;P ml;A"-o";P cmo]) - end - end - box "These holes are filled by command fragments (such as flags)" do - code_caml do - : flag ["ocaml"; "compile"; "byte"; "rectypes"] - (A"-rectypes") - end - end -end - -slide "Tags and dependencies", 'fragile=singleslide' do - box "One can define dependencies triggered by combinations of tags" do - code_caml do - : dep ["ocaml"; "link"; "byte"; "program"; "plugin:foo"] - ["plugin/pluginlib.cma"; "plugin/plugin_foo.cmo"] - end - end - box "By tagging files we make things happen" do - code_tags do - : "test.byte": plugin:foo - end - end -end - -h1 "Writing an ocamlbuild plugin" - -slide "Not a specific language, but plain OCaml code" do - list do - * Plugins are compiled on the fly - * Dynamic configuration is feasible - end - box "With a plugin one can:" do - * Extend rules (add new ones, override old ones) - * Add flags and dependencies based on tags - * Tag files - * Change options - * Define the directory structure precisely - * Help _ocamldep_ - * Specify external libraries - end -end - -unless short_version -slide "A plugin example" do - > Let's read it in live... -end -end - -# slide "ocamlbuild scales" do -# > Indeed ocamlbuild is used as an experimental replacement in OCaml itself. -# end - -h1 "General features" - -slide "Parallel execution where applicable" do - * You select the maximum number of jobs (_-j N_) - * Rules know how to ask for parallel targets - * The system keeps things scheduled correctly - * Example: Separate compilation of byte code - * (Optimal scheduling would require a static graph) -end - -unless short_version -slide "A status bar for your visual comfort" do - list do - * Compilation tools echo commands and their output - * This creates a long and boring output that scrolls too fast - * Here you can keep an eye on what is going on! - * It succinctly displays time, number of targets, and tags - * Command outputs are correctly multiplexed - * A trace of the commands executed is kept in a log file - * This log file can be used as the basis of a shell script - end - latex_only.example do - invisible_join do - count = 0 - mod = 1 - File.read("manual/trace.out").each do |line| - count += 1 - next if count % mod != 0 - line.gsub!("\\", "|") - line.latex_encode! - line.gsub!(/( +)/) { "\\hspace{#{0.49 * $1.size}em}" } - line.chomp! - s = "\\only<#{count / mod}>{\\tt #{line}}%\n" - verbatim_text s - end - end - end -end - -slide "Hygiene and sterilization" do - > ocamlbuild has a Hygiene Squad (HS) that checks your source tree for cleanliness - box "It has preconceived but useful cleanliness notions", '<1->' do - * Files dirty by default: _.cmi_, _.cmo_, _.cma_, _.cmx_... - * _ocamllex_/_ocamlyacc_ files: _.ml_ *if* _.mll_, _.ml_&_.mli_ *if* _.mly_... - end - box "If unsatisfied, the HS produces a sterilization script", '<2->' do - * Read it carefully (or work with versioning) - * Run at your own risks - end - box "HS can be told of exceptions", '<3->' do - > Files or directories tagged as __not_hygienic__ or _precious_. - end -end -end - -slide "Some supported tools" do - box "_Menhir_ as an _ocamlyacc_ replacement", '<1->' do - * Enabled with the __use_menhir__ global tag or the __-use-menhir__ option - * Handles implicit dependencies using _--infer_ - end - box "_Ocamldoc_ to build your doc", '<2->' do - * Separated construction using (_-dump_/_-load_) - * Handles ??HTML??, ??LaTeX??, ??Man??, ??Dot??, ??TeXi?? - end - # box "_ocamlmklib_, _ocamlmktop_" do - # > Basic support using _.mllib_ and _.mltop_ files - # end - box "_Camlp4_ aware", '<3->' do - * Tags allow to setup any installed _Camlp4_ preprocessor - * Fine grained dependencies help a lot... - end -end - -h1 "Conclusion" - -slide "Resume" do - box "ocamlbuild can be used in three ways:", '<1->' do - * With only command-line options for fully regular projects - * With the __tags_ file for intermediate projects - * With a plugin for the most complex projects - end - box "ocamlbuild saves your time by:", '<2->' do - * Building your project gently - * Compiling only as necessary - * Running commands in parallel - * Keeping your house clean - * Letting you concentrate on your code! - end -end - -unless short_version -slide "Acknowledgments" do - box "For enlightening discussions about OCaml internals:", '<1->' do - * Xavier Leroy - * Damien Doligez - end - box "For his insights about OCaml dependencies:", '<2->' do - * Alain Frisch - end - box "For letting this happen:", '<3->' do - * Michel Mauny - end -end - -slide "Conclusion", '<+->' do - * ocamlbuild is not perfect but already damn useful - * Try it now! It's in OCaml 3.10! -end -end diff --git a/ocamlbuild/ocamlbuild.odocl b/ocamlbuild/ocamlbuild.odocl index 9b56f12d5d..c3b04f06e4 100644 --- a/ocamlbuild/ocamlbuild.odocl +++ b/ocamlbuild/ocamlbuild.odocl @@ -39,4 +39,4 @@ Ocaml_dependencies Exit_codes Digest_cache Ocamlbuild_plugin -Findlib
\ No newline at end of file +Findlib diff --git a/ocamlbuild/ocamlbuild_pack.mlpack b/ocamlbuild/ocamlbuild_pack.mlpack index 9653afbcc6..09dc4e0262 100644 --- a/ocamlbuild/ocamlbuild_pack.mlpack +++ b/ocamlbuild/ocamlbuild_pack.mlpack @@ -38,4 +38,4 @@ Ocaml_dependencies Exit_codes Digest_cache Findlib -Param_tags
\ No newline at end of file +Param_tags diff --git a/ocamlbuild/options.ml b/ocamlbuild/options.ml index e547d44e3e..1be4b6360f 100644 --- a/ocamlbuild/options.ml +++ b/ocamlbuild/options.ml @@ -22,7 +22,7 @@ open Format open Command let entry = ref None -let build_dir = ref "_build" +let build_dir = ref (Filename.concat (Sys.getcwd ()) "_build") let include_dirs = ref [] let exclude_dirs = ref [] let nothing_should_be_rebuilt = ref false @@ -50,8 +50,8 @@ let mk_virtual_solvers = if sys_file_exists !dir then let long = filename_concat !dir cmd in let long_opt = long ^ ".opt" in - if sys_file_exists long_opt then A long_opt - else if sys_file_exists long then A long + if file_or_exe_exists long_opt then A long_opt + else if file_or_exe_exists long then A long else try let _ = search_in_path opt in a_opt with Not_found -> a_cmd else @@ -89,6 +89,7 @@ let ocaml_mods_internal = ref [] let ocaml_pkgs_internal = ref [] let ocaml_lflags_internal = ref [] let ocaml_cflags_internal = ref [] +let ocaml_docflags_internal = ref [] let ocaml_ppflags_internal = ref [] let ocaml_yaccflags_internal = ref [] let ocaml_lexflags_internal = ref [] @@ -126,7 +127,12 @@ let add_to' rxs x = else () let set_cmd rcmd = String (fun s -> rcmd := Sh s) -let set_build_dir s = make_links := false; build_dir := s +let set_build_dir s = + make_links := false; + if Filename.is_relative s then + build_dir := Filename.concat (Sys.getcwd ()) s + else + build_dir := s let spec = ref ( Arg.align [ @@ -157,6 +163,8 @@ let spec = ref ( "-lflags", String (add_to ocaml_lflags_internal), "<flag,...> (idem)"; "-cflag", String (add_to' ocaml_cflags_internal), "<flag> Add to ocamlc compile flags"; "-cflags", String (add_to ocaml_cflags_internal), "<flag,...> (idem)"; + "-docflag", String (add_to' ocaml_docflags_internal), "<flag> Add to ocamldoc flags"; + "-docflags", String (add_to ocaml_docflags_internal), "<flag,...> (idem)"; "-yaccflag", String (add_to' ocaml_yaccflags_internal), "<flag> Add to ocamlyacc flags"; "-yaccflags", String (add_to ocaml_yaccflags_internal), "<flag,...> (idem)"; "-lexflag", String (add_to' ocaml_lexflags_internal), "<flag> Add to ocamllex flags"; @@ -219,6 +227,7 @@ let ocaml_pkgs = ref [] let ocaml_lflags = ref [] let ocaml_cflags = ref [] let ocaml_ppflags = ref [] +let ocaml_docflags = ref [] let ocaml_yaccflags = ref [] let ocaml_lexflags = ref [] let program_args = ref [] @@ -267,6 +276,7 @@ let init () = reorder ocaml_cflags ocaml_cflags_internal; reorder ocaml_lflags ocaml_lflags_internal; reorder ocaml_ppflags ocaml_ppflags_internal; + reorder ocaml_docflags ocaml_docflags_internal; reorder ocaml_yaccflags ocaml_yaccflags_internal; reorder ocaml_lexflags ocaml_lexflags_internal; reorder program_args program_args_internal; diff --git a/ocamlbuild/shell.ml b/ocamlbuild/shell.ml index c76d154583..3fbeb81aa7 100644 --- a/ocamlbuild/shell.ml +++ b/ocamlbuild/shell.ml @@ -23,7 +23,12 @@ let is_simple_filename s = | _ -> false in loop 0 let quote_filename_if_needed s = - if is_simple_filename s then s else Filename.quote s + if is_simple_filename s then s + (* We should probably be using [Filename.unix_quote] except that function + * isn't exported. Users on Windows will have to live with not being able to + * install OCaml into c:\o'caml. Too bad. *) + else if Sys.os_type = "Win32" then Printf.sprintf "'%s'" s + else Filename.quote s let chdir dir = reset_filesys_cache (); Sys.chdir dir diff --git a/ocamlbuild/shell.mli b/ocamlbuild/shell.mli index d393c7b3e7..2d867b032d 100644 --- a/ocamlbuild/shell.mli +++ b/ocamlbuild/shell.mli @@ -9,10 +9,14 @@ (* *) (***********************************************************************) - (* Original author: Nicolas Pouillard *) + val is_simple_filename : string -> bool + val quote_filename_if_needed : string -> string +(** This will quote using Unix conventions, even on Windows, because commands are + * always run through bash -c on Windows. *) + val chdir : string -> unit val rm : string -> unit val rm_f : string -> unit diff --git a/ocamlbuild/signatures.mli b/ocamlbuild/signatures.mli index 91dc6c62f1..3b6c44eca9 100644 --- a/ocamlbuild/signatures.mli +++ b/ocamlbuild/signatures.mli @@ -389,6 +389,7 @@ module type OPTIONS = sig val ocaml_cflags : string list ref val ocaml_lflags : string list ref val ocaml_ppflags : string list ref + val ocaml_docflags : string list ref val ocaml_yaccflags : string list ref val ocaml_lexflags : string list ref val program_args : string list ref diff --git a/ocamlbuild/test/test10/dbdi b/ocamlbuild/test/test10/dbdi index 7f548108bb..88f9fa049f 100644 --- a/ocamlbuild/test/test10/dbdi +++ b/ocamlbuild/test/test10/dbdi @@ -6,7 +6,7 @@ #load "bool.cmo";; #load "glob_ast.cmo";; #load "glob_lexer.cmo";; -#load "glob.cmo";; +#load "glob.cmo";; #load "lexers.cmo";; #load "my_std.cmo";; #load "tags.cmo";; diff --git a/ocamlbuild/test/test5/test.sh b/ocamlbuild/test/test5/test.sh index 9d78f1991c..740012c0c8 100755 --- a/ocamlbuild/test/test5/test.sh +++ b/ocamlbuild/test/test5/test.sh @@ -1,5 +1,5 @@ #!/bin/sh -cd `dirname $0` +cd `dirname $0` set -e set -x CMDOPTS="" # -- command args diff --git a/ocamlbuild/test/test6/test.sh b/ocamlbuild/test/test6/test.sh index fedbc9c9b3..6650e02398 100755 --- a/ocamlbuild/test/test6/test.sh +++ b/ocamlbuild/test/test6/test.sh @@ -23,4 +23,3 @@ if $BUILD1; then else echo FAIL fi - diff --git a/ocamldoc/.depend b/ocamldoc/.depend index 6467d445b3..f8e0d35704 100644 --- a/ocamldoc/.depend +++ b/ocamldoc/.depend @@ -1,12 +1,12 @@ -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 -odoc_analyse.cmo: ../utils/warnings.cmi ../typing/typetexp.cmi \ +odoc_analyse.cmo : ../utils/warnings.cmi ../typing/typetexp.cmi \ ../typing/types.cmi ../typing/typemod.cmi ../typing/typedtree.cmi \ ../typing/typedecl.cmi ../typing/typecore.cmi ../typing/typeclass.cmi \ ../bytecomp/translcore.cmi ../bytecomp/translclass.cmi \ @@ -16,9 +16,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 \ @@ -28,226 +28,229 @@ 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 \ odoc_global.cmi odoc_exception.cmo odoc_env.cmi odoc_class.cmo \ ../utils/misc.cmi ../parsing/location.cmi ../typing/ident.cmi \ ../parsing/asttypes.cmi odoc_ast.cmi -odoc_ast.cmx: ../typing/types.cmx ../typing/typedtree.cmx \ +odoc_ast.cmx : ../typing/types.cmx ../typing/typedtree.cmx \ ../typing/predef.cmx ../typing/path.cmx ../parsing/parsetree.cmi \ odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_sig.cmx \ odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_messages.cmx \ odoc_global.cmx odoc_exception.cmx odoc_env.cmx odoc_class.cmx \ ../utils/misc.cmx ../parsing/location.cmx ../typing/ident.cmx \ ../parsing/asttypes.cmi odoc_ast.cmi -odoc_class.cmo: ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ +odoc_class.cmo : ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ odoc_parameter.cmo odoc_name.cmi -odoc_class.cmx: ../typing/types.cmx odoc_value.cmx odoc_types.cmx \ +odoc_class.cmx : ../typing/types.cmx odoc_value.cmx odoc_types.cmx \ odoc_parameter.cmx odoc_name.cmx -odoc_comments.cmo: odoc_types.cmi odoc_text.cmi odoc_see_lexer.cmo \ +odoc_comments.cmo : odoc_types.cmi odoc_text.cmi odoc_see_lexer.cmo \ odoc_parser.cmi odoc_misc.cmi odoc_messages.cmo odoc_merge.cmi \ odoc_lexer.cmo odoc_global.cmi odoc_cross.cmi odoc_comments_global.cmi \ odoc_comments.cmi -odoc_comments.cmx: odoc_types.cmx odoc_text.cmx odoc_see_lexer.cmx \ +odoc_comments.cmx : odoc_types.cmx odoc_text.cmx odoc_see_lexer.cmx \ odoc_parser.cmx odoc_misc.cmx odoc_messages.cmx odoc_merge.cmx \ odoc_lexer.cmx odoc_global.cmx odoc_cross.cmx odoc_comments_global.cmx \ odoc_comments.cmi -odoc_comments_global.cmo: odoc_comments_global.cmi -odoc_comments_global.cmx: odoc_comments_global.cmi -odoc_config.cmo: ../utils/config.cmi odoc_config.cmi -odoc_config.cmx: ../utils/config.cmx odoc_config.cmi -odoc_control.cmo: -odoc_control.cmx: -odoc_cross.cmo: odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_search.cmi \ +odoc_comments_global.cmo : odoc_comments_global.cmi +odoc_comments_global.cmx : odoc_comments_global.cmi +odoc_config.cmo : ../utils/config.cmi odoc_config.cmi +odoc_config.cmx : ../utils/config.cmx odoc_config.cmi +odoc_control.cmo : +odoc_control.cmx : +odoc_cross.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_search.cmi \ odoc_scan.cmo odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \ odoc_misc.cmi odoc_messages.cmo odoc_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 -odoc_html.cmx: odoc_text.cmx odoc_ocamlhtml.cmx odoc_messages.cmx \ +odoc_html.cmx : odoc_text.cmx odoc_ocamlhtml.cmx odoc_messages.cmx \ odoc_info.cmx odoc_global.cmx odoc_dag2html.cmx ../parsing/asttypes.cmi -odoc_info.cmo: ../typing/printtyp.cmi odoc_value.cmo odoc_types.cmi \ +odoc_info.cmo : ../typing/printtyp.cmi odoc_value.cmo odoc_types.cmi \ odoc_type.cmo odoc_text.cmi odoc_str.cmi odoc_search.cmi odoc_scan.cmo \ odoc_print.cmi odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \ odoc_misc.cmi odoc_global.cmi odoc_exception.cmo odoc_dep.cmo \ odoc_config.cmi odoc_comments.cmi odoc_class.cmo odoc_analyse.cmi \ - odoc_info.cmi -odoc_info.cmx: ../typing/printtyp.cmx odoc_value.cmx odoc_types.cmx \ + ../parsing/location.cmi odoc_info.cmi +odoc_info.cmx : ../typing/printtyp.cmx odoc_value.cmx odoc_types.cmx \ odoc_type.cmx odoc_text.cmx odoc_str.cmx odoc_search.cmx odoc_scan.cmx \ odoc_print.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \ odoc_misc.cmx odoc_global.cmx odoc_exception.cmx odoc_dep.cmx \ odoc_config.cmx odoc_comments.cmx odoc_class.cmx odoc_analyse.cmx \ - odoc_info.cmi -odoc_inherit.cmo: -odoc_inherit.cmx: -odoc_latex.cmo: odoc_to_text.cmo odoc_messages.cmo odoc_latex_style.cmo \ + ../parsing/location.cmx odoc_info.cmi +odoc_inherit.cmo : +odoc_inherit.cmx : +odoc_latex.cmo : odoc_to_text.cmo odoc_messages.cmo odoc_latex_style.cmo \ odoc_info.cmi ../parsing/asttypes.cmi -odoc_latex.cmx: odoc_to_text.cmx odoc_messages.cmx odoc_latex_style.cmx \ +odoc_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 -odoc_messages.cmx: ../utils/config.cmx -odoc_misc.cmo: ../typing/types.cmi ../typing/predef.cmi ../typing/path.cmi \ +odoc_messages.cmo : ../utils/config.cmi +odoc_messages.cmx : ../utils/config.cmx +odoc_misc.cmo : ../typing/types.cmi ../typing/predef.cmi ../typing/path.cmi \ odoc_types.cmi odoc_messages.cmo ../parsing/longident.cmi \ ../typing/ctype.cmi ../typing/btype.cmi odoc_misc.cmi -odoc_misc.cmx: ../typing/types.cmx ../typing/predef.cmx ../typing/path.cmx \ +odoc_misc.cmx : ../typing/types.cmx ../typing/predef.cmx ../typing/path.cmx \ odoc_types.cmx odoc_messages.cmx ../parsing/longident.cmx \ ../typing/ctype.cmx ../typing/btype.cmx odoc_misc.cmi -odoc_module.cmo: ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ +odoc_module.cmo : ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ odoc_type.cmo odoc_name.cmi odoc_exception.cmo odoc_class.cmo -odoc_module.cmx: ../typing/types.cmx odoc_value.cmx odoc_types.cmx \ +odoc_module.cmx : ../typing/types.cmx odoc_value.cmx odoc_types.cmx \ odoc_type.cmx odoc_name.cmx odoc_exception.cmx odoc_class.cmx -odoc_name.cmo: ../typing/path.cmi odoc_misc.cmi ../typing/ident.cmi \ +odoc_name.cmo : ../typing/path.cmi odoc_misc.cmi ../typing/ident.cmi \ odoc_name.cmi -odoc_name.cmx: ../typing/path.cmx odoc_misc.cmx ../typing/ident.cmx \ +odoc_name.cmx : ../typing/path.cmx odoc_misc.cmx ../typing/ident.cmx \ odoc_name.cmi -odoc_ocamlhtml.cmo: -odoc_ocamlhtml.cmx: -odoc_parameter.cmo: ../typing/types.cmi odoc_types.cmi -odoc_parameter.cmx: ../typing/types.cmx odoc_types.cmx -odoc_parser.cmo: odoc_types.cmi odoc_comments_global.cmi odoc_parser.cmi -odoc_parser.cmx: odoc_types.cmx odoc_comments_global.cmx odoc_parser.cmi -odoc_print.cmo: ../typing/types.cmi ../typing/printtyp.cmi odoc_print.cmi -odoc_print.cmx: ../typing/types.cmx ../typing/printtyp.cmx odoc_print.cmi -odoc_scan.cmo: odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_module.cmo \ +odoc_ocamlhtml.cmo : +odoc_ocamlhtml.cmx : +odoc_parameter.cmo : ../typing/types.cmi odoc_types.cmi +odoc_parameter.cmx : ../typing/types.cmx odoc_types.cmx +odoc_parser.cmo : odoc_types.cmi odoc_comments_global.cmi odoc_parser.cmi +odoc_parser.cmx : odoc_types.cmx odoc_comments_global.cmx odoc_parser.cmi +odoc_print.cmo : ../typing/types.cmi ../typing/printtyp.cmi odoc_print.cmi +odoc_print.cmx : ../typing/types.cmx ../typing/printtyp.cmx odoc_print.cmi +odoc_scan.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_module.cmo \ odoc_exception.cmo odoc_class.cmo -odoc_scan.cmx: odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_module.cmx \ +odoc_scan.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_module.cmx \ odoc_exception.cmx odoc_class.cmx -odoc_search.cmo: odoc_value.cmo odoc_types.cmi odoc_type.cmo \ +odoc_search.cmo : odoc_value.cmo odoc_types.cmi odoc_type.cmo \ odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_exception.cmo \ odoc_class.cmo odoc_search.cmi -odoc_search.cmx: odoc_value.cmx odoc_types.cmx odoc_type.cmx \ +odoc_search.cmx : odoc_value.cmx odoc_types.cmx odoc_type.cmx \ odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_exception.cmx \ odoc_class.cmx odoc_search.cmi -odoc_see_lexer.cmo: odoc_parser.cmi -odoc_see_lexer.cmx: odoc_parser.cmx -odoc_sig.cmo: ../typing/types.cmi ../typing/typedtree.cmi ../typing/path.cmi \ - ../parsing/parsetree.cmi odoc_value.cmo odoc_types.cmi odoc_type.cmo \ - odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_misc.cmi \ - odoc_messages.cmo odoc_merge.cmi odoc_global.cmi odoc_exception.cmo \ - odoc_env.cmi odoc_class.cmo ../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 -odoc_test.cmo: odoc_info.cmi odoc_gen.cmi odoc_args.cmi -odoc_test.cmx: odoc_info.cmx odoc_gen.cmx odoc_args.cmx -odoc_texi.cmo: odoc_to_text.cmo odoc_messages.cmo odoc_info.cmi \ - ../parsing/asttypes.cmi -odoc_texi.cmx: odoc_to_text.cmx odoc_messages.cmx odoc_info.cmx \ - ../parsing/asttypes.cmi -odoc_text.cmo: odoc_types.cmi odoc_text_parser.cmi odoc_text_lexer.cmo \ +odoc_test.cmo : odoc_info.cmi odoc_gen.cmi odoc_args.cmi +odoc_test.cmx : odoc_info.cmx odoc_gen.cmx odoc_args.cmx +odoc_texi.cmo : ../typing/types.cmi odoc_to_text.cmo odoc_messages.cmo \ + odoc_info.cmi ../parsing/asttypes.cmi +odoc_texi.cmx : ../typing/types.cmx odoc_to_text.cmx odoc_messages.cmx \ + odoc_info.cmx ../parsing/asttypes.cmi +odoc_text.cmo : odoc_types.cmi odoc_text_parser.cmi odoc_text_lexer.cmo \ odoc_text.cmi -odoc_text.cmx: odoc_types.cmx odoc_text_parser.cmx odoc_text_lexer.cmx \ +odoc_text.cmx : odoc_types.cmx odoc_text_parser.cmx odoc_text_lexer.cmx \ odoc_text.cmi -odoc_text_lexer.cmo: odoc_text_parser.cmi odoc_misc.cmi -odoc_text_lexer.cmx: odoc_text_parser.cmx odoc_misc.cmx -odoc_text_parser.cmo: odoc_types.cmi odoc_misc.cmi odoc_text_parser.cmi -odoc_text_parser.cmx: odoc_types.cmx odoc_misc.cmx odoc_text_parser.cmi -odoc_to_text.cmo: odoc_module.cmo odoc_messages.cmo odoc_info.cmi -odoc_to_text.cmx: odoc_module.cmx odoc_messages.cmx odoc_info.cmx -odoc_type.cmo: ../typing/types.cmi odoc_types.cmi odoc_name.cmi \ +odoc_text_lexer.cmo : odoc_text_parser.cmi odoc_misc.cmi +odoc_text_lexer.cmx : odoc_text_parser.cmx odoc_misc.cmx +odoc_text_parser.cmo : odoc_types.cmi odoc_misc.cmi odoc_text_parser.cmi +odoc_text_parser.cmx : odoc_types.cmx odoc_misc.cmx odoc_text_parser.cmi +odoc_to_text.cmo : odoc_module.cmo odoc_messages.cmo odoc_info.cmi +odoc_to_text.cmx : odoc_module.cmx odoc_messages.cmx odoc_info.cmx +odoc_type.cmo : ../typing/types.cmi odoc_types.cmi odoc_name.cmi \ ../parsing/asttypes.cmi -odoc_type.cmx: ../typing/types.cmx odoc_types.cmx odoc_name.cmx \ +odoc_type.cmx : ../typing/types.cmx odoc_types.cmx odoc_name.cmx \ ../parsing/asttypes.cmi -odoc_types.cmo: odoc_messages.cmo odoc_types.cmi -odoc_types.cmx: odoc_messages.cmx odoc_types.cmi -odoc_value.cmo: ../typing/types.cmi ../typing/printtyp.cmi odoc_types.cmi \ +odoc_types.cmo : odoc_messages.cmo ../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 -t.cmo: -t.cmx: -odoc_analyse.cmi: odoc_module.cmo odoc_global.cmi -odoc_args.cmi: odoc_gen.cmi -odoc_ast.cmi: ../typing/types.cmi ../typing/typedtree.cmi ../typing/path.cmi \ - ../parsing/parsetree.cmi odoc_sig.cmi odoc_name.cmi odoc_module.cmo -odoc_comments.cmi: odoc_types.cmi odoc_module.cmo -odoc_comments_global.cmi: -odoc_config.cmi: -odoc_cross.cmi: odoc_types.cmi odoc_module.cmo -odoc_dag2html.cmi: odoc_info.cmi -odoc_env.cmi: ../typing/types.cmi odoc_name.cmi -odoc_gen.cmi: odoc_texi.cmo odoc_module.cmo odoc_man.cmo odoc_latex.cmo \ +odoc_analyse.cmi : odoc_module.cmo odoc_global.cmi +odoc_args.cmi : odoc_gen.cmi +odoc_ast.cmi : ../typing/types.cmi ../typing/typedtree.cmi \ + ../typing/path.cmi ../parsing/parsetree.cmi odoc_sig.cmi odoc_name.cmi \ + odoc_module.cmo +odoc_comments.cmi : odoc_types.cmi odoc_module.cmo +odoc_comments_global.cmi : +odoc_config.cmi : +odoc_cross.cmi : odoc_types.cmi odoc_module.cmo +odoc_dag2html.cmi : odoc_info.cmi +odoc_env.cmi : ../typing/types.cmi odoc_name.cmi +odoc_gen.cmi : odoc_texi.cmo odoc_module.cmo odoc_man.cmo odoc_latex.cmo \ odoc_html.cmo odoc_dot.cmo -odoc_global.cmi: odoc_types.cmi -odoc_info.cmi: ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ +odoc_global.cmi : odoc_types.cmi +odoc_info.cmi : ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ odoc_type.cmo odoc_search.cmi odoc_parameter.cmo odoc_module.cmo \ - odoc_global.cmi odoc_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/Changes.txt b/ocamldoc/Changes.txt index 3707d265bd..49ed84d24d 100644 --- a/ocamldoc/Changes.txt +++ b/ocamldoc/Changes.txt @@ -6,8 +6,8 @@ TODO: module type M = sig type u end module N : sig include M val f: u -> unit end Here, in html for example, f in displayed being of type Foo.u instead of Foo.M.u - - latex: types variant polymorphes dépassent de la page quand ils sont trop longs - - utilisation nouvelles infos de Xavier: "début de rec", etc. + - latex: types variant polymorphes depassent de la page quand ils sont trop longs + - utilisation nouvelles infos de Xavier: "debut de rec", etc. - xml generator ===== @@ -61,12 +61,12 @@ Release 3.08.1: Release 3.08.0: - fix: method parameters names in signature are now retrieved correctly (fix of Odoc_value.parameter_list_from_arrows to handle Tpoly for methods) - - ajout à la doc de Module_list et Index_list (utilisé dans le html seulement) - - ajout à la doc: fichier de l'option -intro utilisé pour l'index en html + - ajout a la doc de Module_list et Index_list (utilise dans le html seulement) + - ajout a la doc: fichier de l'option -intro utilise pour l'index en html - fix: create a Module_with instead of a Module_alias when we encounter module A : Foo in a signature - latex: style latex pour indenter dans les module kind et les class kind - - latex: il manque la génération des paramètres de classe + - latex: il manque la generation des parametres de classe - parse des {!modules: } et {!indexlist} - gestion des Module_list et Index_list - no need to Dynlink.add_available_units any more diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index d04809aa31..573d9af8f6 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 \ @@ -168,6 +171,7 @@ OCAMLCMOFILES=$(OCAMLSRCDIR)/parsing/printast.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 \ @@ -205,17 +209,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 @@ -305,6 +309,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 a65b59738c..07a7571b07 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/generators/odoc_literate.ml b/ocamldoc/generators/odoc_literate.ml index e79b4f1a21..6a1e0783e8 100644 --- a/ocamldoc/generators/odoc_literate.ml +++ b/ocamldoc/generators/odoc_literate.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_literate.ml,v 1.1 2008/02/28 11:09:33 guesdon Exp $ *) +(* $Id$ *) open Odoc_info module Naming = Odoc_html.Naming diff --git a/ocamldoc/generators/odoc_todo.ml b/ocamldoc/generators/odoc_todo.ml index 23e6c8892d..626236cf1a 100644 --- a/ocamldoc/generators/odoc_todo.ml +++ b/ocamldoc/generators/odoc_todo.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_todo.ml 411 2004-08-03 13:08:20Z guesdon $ *) +(* $Id$ *) (** An OCamldoc generator to retrieve information in "todo" tags and generate an html page with all todo items. *) @@ -48,7 +48,7 @@ struct method private gen_if_tag name target info_opt = match info_opt with None -> () - | Some i -> + | Some i -> let l = List.fold_left (fun acc (t, text) -> @@ -69,7 +69,7 @@ struct | _ -> (None, text) :: acc end - | _ -> acc + | _ -> acc ) [] i.i_custom diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index 2091dd3967..a2a7dc6a4c 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -46,7 +46,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; @@ -73,15 +73,14 @@ let parse_file inputfile parse_fun ast_magic = let ic = open_in_bin inputfile in let is_ast_file = try - let buffer = String.create (String.length ast_magic) in - really_input ic buffer 0 (String.length ast_magic); + let buffer = Misc.input_bytes ic (String.length ast_magic) in if buffer = ast_magic then true else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then raise Outdated_version else false with Outdated_version -> - fatal_error "Ocaml and preprocessor have incompatible versions" + fatal_error "OCaml and preprocessor have incompatible versions" | _ -> false in let ast = @@ -114,7 +113,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 -> @@ -165,13 +167,16 @@ 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 "In this program,@ variant constructors@ `%s and `%s@ \ have the same hash value." l l' - | Typecore.Error(loc, err) -> - Location.print_error ppf loc; Typecore.report_error ppf err + | Typecore.Error(loc, env, err) -> + Location.print_error ppf loc; Typecore.report_error env ppf err | Typetexp.Error(loc, err) -> Location.print_error ppf loc; Typetexp.report_error ppf err | Typedecl.Error(loc, err) -> @@ -179,15 +184,15 @@ let process_error exn = | Includemod.Error err -> Location.print_error_cur_file ppf; Includemod.report_error ppf err - | Typemod.Error(loc, err) -> - Location.print_error ppf loc; Typemod.report_error ppf err + | Typemod.Error(loc, env, err) -> + Location.print_error ppf loc; Typemod.report_error env ppf err | Translcore.Error(loc, err) -> Location.print_error ppf loc; Translcore.report_error ppf err | Sys_error msg -> Location.print_error_cur_file ppf; fprintf ppf "I/O error: %s" msg - | Typeclass.Error(loc, err) -> - Location.print_error ppf loc; Typeclass.report_error ppf err + | Typeclass.Error(loc, env, err) -> + Location.print_error ppf loc; Typeclass.report_error env ppf err | Translclass.Error(loc, err) -> Location.print_error ppf loc; Translclass.report_error ppf err | Warnings.Errors (n) -> @@ -252,7 +257,7 @@ 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 + !Location.input_name ast signat.sig_type in file_module.Odoc_module.m_top_deps <- Odoc_dep.intf_dependencies ast ; @@ -279,7 +284,11 @@ let process_file ppf sourcefile = Location.input_name := file; try let mod_name = - String.capitalize (Filename.basename (Filename.chop_extension file)) + let s = + try Filename.chop_extension file + with _ -> file + in + String.capitalize (Filename.basename s) in let txt = try Odoc_text.Texter.text_of_string (Odoc_misc.input_file_as_string file) @@ -289,7 +298,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 ; @@ -297,7 +306,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 2979dea051..bee38930ad 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. *) @@ -225,7 +315,7 @@ let help_action () = let msg = Arg.usage_string (!options @ !help_options) - (M.usage ^ M.options_are) in + (M.usage ^ M.options_are) in print_string msg let () = help_options := [ diff --git a/ocamldoc/odoc_args.mli b/ocamldoc/odoc_args.mli index 2f190ef756..1d55de7477 100644 --- a/ocamldoc/odoc_args.mli +++ b/ocamldoc/odoc_args.mli @@ -19,6 +19,30 @@ val current_generator : Odoc_gen.generator option 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 f436e646cf..eb7f736ece 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) -> + (fun (ident,ident_loc, _, mod_expr) -> Hashtbl.add table (M (Name.from_ident ident)) - (Typedtree.Tstr_module (ident,mod_expr)) + (Typedtree.Tstr_module (ident,ident_loc, mod_expr)) ) mods - | Typedtree.Tstr_modtype (ident, _) -> + | 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 _ -> () @@ -116,41 +116,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, []) @@ -159,50 +160,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, Some 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 @@ -210,12 +211,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 = @@ -253,14 +254,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 -> @@ -268,7 +269,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, _, _) -> @@ -322,7 +323,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 ; @@ -341,7 +342,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 *) @@ -352,11 +353,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 ; @@ -364,25 +372,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 ] @@ -411,9 +426,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 @@ -427,7 +442,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 [] -> @@ -437,7 +452,7 @@ module Analyser = | l -> match l with [] -> - (* cas impossible, on l'a filtré avant *) + (* cas impossible, on l'a filtre avant *) assert false | (pattern_param, exp) :: second_ele :: q -> (* implicit pattern matching -> anonymous parameter *) @@ -467,7 +482,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 ; @@ -513,8 +528,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 @@ -541,113 +558,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 = @@ -655,17 +694,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 :-( meme 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 parametres 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 | _ -> @@ -679,11 +718,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 @@ -700,16 +739,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 ; @@ -739,23 +778,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 :-( meme 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]) @@ -778,14 +817,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 @@ -810,8 +849,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 @@ -833,7 +873,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 @@ -842,8 +882,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 _ @@ -853,7 +893,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 ? *) @@ -865,7 +905,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. *) @@ -888,7 +928,7 @@ module Analyser = 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.Tmty_signature lsig -> + 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; | _ -> () @@ -898,7 +938,7 @@ module Analyser = 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.Tmty_signature lsig -> + 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; | _ -> () @@ -908,7 +948,7 @@ module Analyser = let f = match ele with Element_module m -> (function - Types.Tsig_module (ident,t,_) -> + Types.Sig_module (ident,t,_) -> let n1 = Name.simple m.m_name and n2 = Ident.name ident in ( @@ -919,7 +959,7 @@ module Analyser = | _ -> false) | Element_module_type mt -> (function - Types.Tsig_modtype (ident,Types.Tmodtype_manifest t) -> + Types.Sig_modtype (ident,Types.Modtype_manifest t) -> let n1 = Name.simple mt.mt_name and n2 = Ident.name ident in ( @@ -930,36 +970,36 @@ module Analyser = | _ -> false) | Element_value v -> (function - Types.Tsig_value (ident,_) -> + 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.Tsig_type (ident,_,_) -> - (* A VOIR: il est possible que le détail du type soit caché *) + Types.Sig_type (ident,_,_) -> + (* A VOIR: il est possible que le detail du type soit cache *) let n1 = Name.simple t.ty_name and n2 = Ident.name ident in n1 = n2 | _ -> false) | Element_exception e -> (function - Types.Tsig_exception (ident,_) -> + 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.Tsig_class (ident,_,_) -> + 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.Tsig_cltype (ident,_,_) -> + Types.Sig_class_type (ident,_,_) -> let n1 = Name.simple ct.clt_name and n2 = Ident.name ident in n1 = n2 @@ -974,7 +1014,7 @@ module Analyser = (** 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 @@ -1047,7 +1087,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 @@ -1085,116 +1125,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 = + in + let new_end = loc_end + maybe_more in + let t = + { + ty_name = complete_name ; + ty_info = com_opt ; + ty_parameters = List.map2 - (fun p (co,cn,_) -> - (Odoc_env.subst_type new_env p, - co, cn) - ) + (fun p (co,cn,_) -> + (Odoc_env.subst_type new_env p, + co, cn) + ) tt_type_decl.Types.type_params tt_type_decl.Types.type_variance ; - ty_kind = kind ; - ty_private = tt_type_decl.Types.type_private; - ty_manifest = - (match tt_type_decl.Types.type_manifest with - None -> None - | Some t -> Some (Odoc_env.subst_type new_env t)); - ty_loc = { loc_impl = Some (!file_name, loc_start) ; loc_inter = None } ; - ty_code = + ty_kind = kind ; + ty_private = tt_type_decl.Types.type_private; + ty_manifest = + (match tt_type_decl.Types.type_manifest with + None -> None + | Some t -> Some (Odoc_env.subst_type new_env t)); + ty_loc = { loc_impl = Some 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 @@ -1205,9 +1254,11 @@ module Analyser = { ex_name = complete_name ; ex_info = comment_opt ; - ex_args = List.map (Odoc_env.subst_type new_env) tt_excep_decl ; + ex_args = List.map (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 @@ -1219,12 +1270,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 @@ -1236,7 +1287,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 @@ -1246,11 +1297,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 @@ -1270,8 +1321,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 etre 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 | _ -> @@ -1280,7 +1331,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)) ) @@ -1290,22 +1341,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 | _ -> @@ -1318,11 +1369,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 *) @@ -1334,7 +1385,7 @@ module Analyser = let new_module = analyse_module new_env current_module_name - name + name.txt com_opt mod_exp tt_mod_exp @@ -1346,31 +1397,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 etre 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 @@ -1393,7 +1444,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 @@ -1405,9 +1456,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) = @@ -1435,7 +1486,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 @@ -1447,13 +1498,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 @@ -1478,7 +1530,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 @@ -1497,13 +1549,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 : etendre l'environnement ? avec quoi ? *) (** Analysis of a [Parsetree.module_expr] and a name to return a [t_module].*) and analyse_module env current_module_name module_name comment_opt p_module_expr tt_module_expr = 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 @@ -1525,7 +1578,7 @@ 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 ; @@ -1533,7 +1586,7 @@ module Analyser = } in match (p_module_expr.Parsetree.pmod_desc, tt_module_expr.Typedtree.mod_desc) with - (Parsetree.Pmod_ident longident, Typedtree.Tmod_ident path) -> + (Parsetree.Pmod_ident longident, Typedtree.Tmod_ident (path, _)) -> 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 ; } } @@ -1546,19 +1599,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 + 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 ; } @@ -1581,7 +1634,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 @@ -1603,7 +1656,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); let m_base2 = analyse_module env @@ -1629,7 +1682,7 @@ module Analyser = | (Parsetree.Pmod_structure p_structure, Typedtree.Tmod_constraint ({ Typedtree.mod_desc = Typedtree.Tmod_structure tt_structure}, - tt_modtype, _) + tt_modtype, _, _) ) -> (* needed for recursive modules *) @@ -1643,7 +1696,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 = @@ -1657,7 +1710,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 @@ -1720,12 +1773,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..5d696819fb 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 analyse, 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 ea5427e077..af524eefaf 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 39965f83b2..cd79790d24 100644 --- a/ocamldoc/odoc_cross.ml +++ b/ocamldoc/odoc_cross.ml @@ -58,7 +58,9 @@ module P_alias = let p_class c _ = (false, false) let p_class_type ct _ = (false, false) let p_value v _ = false - let p_type t _ = false + let p_recfield _ _ _ = false + let p_const _ _ _ = false + let p_type t _ = (false, false) let p_exception e _ = e.ex_alias <> None let p_attribute a _ = false let p_method m _ = false @@ -178,7 +180,7 @@ let kind_name_exists kind = match kind with RK_module -> (fun e -> match e with Odoc_search.Res_module _ -> true | _ -> false) | RK_module_type -> (fun e -> match e with Odoc_search.Res_module_type _ -> true | _ -> false) - | RK_class -> (fun e -> match e with Odoc_search.Res_class_type _ -> true | _ -> false) + | RK_class -> (fun e -> match e with Odoc_search.Res_class _ -> true | _ -> false) | RK_class_type -> (fun e -> match e with Odoc_search.Res_class_type _ -> true | _ -> false) | RK_value -> (fun e -> match e with Odoc_search.Res_value _ -> true | _ -> false) | RK_type -> (fun e -> match e with Odoc_search.Res_type _ -> true | _ -> false) @@ -186,6 +188,8 @@ let kind_name_exists kind = | RK_attribute -> (fun e -> match e with Odoc_search.Res_attribute _ -> true | _ -> false) | RK_method -> (fun e -> match e with Odoc_search.Res_method _ -> true | _ -> false) | RK_section _ -> assert false + | RK_recfield -> (fun e -> match e with Odoc_search.Res_recfield _ -> true | _ -> false) + | RK_const -> (fun e -> match e with Odoc_search.Res_const _ -> true | _ -> false) in fun name -> try List.exists pred (get_known_elements name) @@ -200,6 +204,8 @@ let type_exists = kind_name_exists RK_type let exception_exists = kind_name_exists RK_exception let attribute_exists = kind_name_exists RK_attribute let method_exists = kind_name_exists RK_method +let recfield_exists = kind_name_exists RK_recfield +let const_exists = kind_name_exists RK_const let lookup_module name = match List.find @@ -246,8 +252,17 @@ class scan = inherit Odoc_scan.scanner method! scan_value v = add_known_element v.val_name (Odoc_search.Res_value v) - method! scan_type t = - add_known_element t.ty_name (Odoc_search.Res_type t) + method! scan_type_recfield t f = + add_known_element + (Printf.sprintf "%s.%s" t.ty_name f.rf_name) + (Odoc_search.Res_recfield (t, f)) + method! scan_type_const t f = + add_known_element + (Printf.sprintf "%s.%s" t.ty_name f.vc_name) + (Odoc_search.Res_const (t, f)) + method! scan_type_pre t = + add_known_element t.ty_name (Odoc_search.Res_type t); + true method! scan_exception e = add_known_element e.ex_name (Odoc_search.Res_exception e) method! scan_attribute a = @@ -620,6 +635,8 @@ let not_found_of_kind kind name = | RK_attribute -> Odoc_messages.cross_attribute_not_found | RK_method -> Odoc_messages.cross_method_not_found | RK_section _ -> Odoc_messages.cross_section_not_found + | RK_recfield -> Odoc_messages.cross_recfield_not_found + | RK_const -> Odoc_messages.cross_const_not_found ) name let rec assoc_comments_text_elements parent_name module_list t_ele = @@ -675,6 +692,10 @@ let rec assoc_comments_text_elements parent_name module_list t_ele = | Odoc_search.Res_attribute a -> (a.att_value.val_name, RK_attribute) | Odoc_search.Res_method m -> (m.met_value.val_name, RK_method) | Odoc_search.Res_section (_ ,t)-> assert false + | Odoc_search.Res_recfield (t, f) -> + (Printf.sprintf "%s.%s" t.ty_name f.rf_name, RK_recfield) + | Odoc_search.Res_const (t, f) -> + (Printf.sprintf "%s.%s" t.ty_name f.vc_name, RK_const) in add_verified (name, Some kind) ; (name, Some kind) @@ -731,6 +752,8 @@ let rec assoc_comments_text_elements parent_name module_list t_ele = | RK_attribute -> attribute_exists | RK_method -> method_exists | RK_section _ -> assert false + | RK_recfield -> recfield_exists + | RK_const -> const_exists in if f name then ( diff --git a/ocamldoc/odoc_dot.ml b/ocamldoc/odoc_dot.ml index a0d5ee2224..bf35e86218 100644 --- a/ocamldoc/odoc_dot.ml +++ b/ocamldoc/odoc_dot.ml @@ -143,4 +143,3 @@ class dot = end module type Dot_generator = module type of Generator - diff --git a/ocamldoc/odoc_env.ml b/ocamldoc/odoc_env.ml index a108cf416a..3621a3ca78 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 ou 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 ou 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_global.ml b/ocamldoc/odoc_global.ml index b2d7bf872f..11273a84b9 100644 --- a/ocamldoc/odoc_global.ml +++ b/ocamldoc/odoc_global.ml @@ -84,6 +84,3 @@ let with_trailer = ref true let with_toc = ref true let with_index = ref true - - - diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml index 369114d74c..85b052e305 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) @@ -316,14 +335,10 @@ 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 "<pre class=\"codepre\"><code class=\""; bs b Odoc_ocamlhtml.code_class; bs b "\">" ; bs b (self#escape (remove_useless_newlines s)); @@ -331,7 +346,7 @@ class virtual text = ) method html_of_Verbatim b s = - bs b "<pre>"; + bs b "<pre class=\"verbatim\">"; bs b (self#escape s); bs b "</pre>" @@ -440,6 +455,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 @@ -466,7 +483,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 = @@ -490,8 +507,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; @@ -500,7 +518,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 @@ -690,7 +709,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 -> () @@ -701,7 +720,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 @@ -748,11 +767,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 }" ; @@ -761,9 +776,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; "^ @@ -788,7 +812,7 @@ class html = "h6 { font-size : 20pt ; border: 1px solid #000000; "^ "margin-top: 5px; margin-bottom: 2px;"^ - "text-align: center; background-color: #C0FFFF ; "^ + "text-align: center; background-color: #90BDFF ; "^ "padding: 2px; }" ; "div.h7 { font-size : 20pt ; border: 1px solid #000000; "^ @@ -806,17 +830,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 { }"; - "div.sig_block {margin-left: 2em}" ; + ".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}" ; + + ".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. *) @@ -1052,21 +1081,24 @@ class html = match pre with None -> () | Some name -> - bp b "<a href=\"%s\">%s</a>\n" + 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" + 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" @@ -1244,7 +1276,7 @@ class html = self#html_of_module_kind b father k2; self#html_of_text b [Code ")"] | Module_with (k, s) -> - (* TODO: à modifier quand Module_with sera plus détaillé *) + (* TODO: 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); @@ -1427,7 +1459,7 @@ class html = (match t.ty_manifest, t.ty_kind with None, Type_abstract -> "<pre>" | None, Type_variant _ - | None, Type_record _ -> "<br><code>" + | None, Type_record _ -> "<pre><code>" | Some _, Type_abstract -> "<pre>" | Some _, Type_variant _ | Some _, Type_record _ -> "<pre>" @@ -1456,7 +1488,7 @@ class html = bs b ( match t.ty_manifest with - None -> "</code>" + None -> "</code></pre>" | Some _ -> "</pre>" ); bs b "<table class=\"typetable\">\n"; @@ -1466,7 +1498,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 -> () @@ -1479,8 +1513,8 @@ class html = | l,Some r -> bs b (" " ^ (self#keyword ":") ^ " "); self#html_of_type_expr_list ~par: false b father " * " l; - bs b (" " ^ (self#keyword "->") ^ " "); - self#html_of_type_expr b father r; + bs b (" " ^ (self#keyword "->") ^ " "); + self#html_of_type_expr b father r; ); bs b "</code></td>\n"; ( @@ -1511,7 +1545,7 @@ class html = bs b ( match t.ty_manifest with - None -> "</code>" + None -> "</code></pre>" | Some _ -> "</pre>" ); bs b "<table class=\"typetable\">\n" ; @@ -1521,7 +1555,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"; ( @@ -1834,7 +1870,7 @@ class html = self#html_of_text b [Code "end"] | Class_apply capp -> - (* TODO: afficher le type final à partir du typedtree *) + (* TODO: display final type from typedtree *) self#html_of_text b [Raw "class application not handled yet"] | Class_constr cco -> @@ -2085,9 +2121,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 "<body>\n"; + self#print_navbar b None None ""; + bs b "<h1>"; bs b title; - bs b "</h1></center>\n" ; + bs b "</h1>\n" ; let sorted_elements = List.sort (fun e1 e2 -> compare (Name.simple (name e1)) (Name.simple (name e2))) @@ -2120,7 +2158,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 @@ -2159,11 +2197,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 @@ -2207,11 +2245,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 *) @@ -2252,14 +2290,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 *) @@ -2320,7 +2358,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>"; if modu.m_text_only then bs b modu.m_name else @@ -2339,7 +2377,7 @@ class html = | Some _ -> bp b " (<a href=\"%s\">.ml</a>)" code_file ) ); - bs b "</h1></center>\n<br>\n"; + bs b "</h1>\n"; if not modu.m_text_only then self#html_of_module b ~with_link: false modu; @@ -2397,9 +2435,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 047fa2b5bb..769aade9ca 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 @@ -81,8 +83,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 } @@ -293,6 +295,8 @@ module Search = | Res_attribute of Value.t_attribute | Res_method of Value.t_method | Res_section of string * text + | Res_recfield of Type.t_type * Type.record_field + | Res_const of Type.t_type * Type.variant_constructor type search_result = result_element list diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli index 0ab1fa815a..15332fd539 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. *) @@ -98,8 +100,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. *) @@ -201,7 +203,7 @@ module Type : { vc_name : string ; (** Name of the constructor. *) vc_args : Types.type_expr list ; (** Arguments of the constructor. *) - vc_ret : Types.type_expr option ; + vc_ret : Types.type_expr option ; mutable vc_text : text option ; (** Optional description in the associated comment. *) } @@ -792,6 +794,8 @@ module Search : | Res_attribute of Value.t_attribute | Res_method of Value.t_method | Res_section of string * text + | Res_recfield of Type.t_type * Type.record_field + | Res_const of Type.t_type * Type.variant_constructor (** The type representing a research result.*) type search_result = result_element list @@ -836,6 +840,10 @@ module Scan : (** Scan of 'leaf elements'. *) method scan_value : Value.t_value -> unit + + method scan_type_pre : Type.t_type -> bool + method scan_type_const : Type.t_type -> Type.variant_constructor -> unit + method scan_type_recfield : Type.t_type -> Type.record_field -> unit method scan_type : Type.t_type -> unit method scan_exception : Exception.t_exception -> unit method scan_attribute : Value.t_attribute -> unit diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml index 6d29acedff..901be36c17 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 @@ -86,77 +87,87 @@ class text = "\\"^sec^"{"^s^"}\n" with Not_found -> s - (** Associations of strings to subsitute in latex code. *) - val mutable subst_strings = [ - ("MAXENCE"^"ZZZ", "\\$"); - ("MAXENCE"^"YYY", "\\&"); - ("MAXENCE"^"XXX", "{\\textbackslash}") ; - ("à", "\\`a") ; - ("â", "\\^a") ; - ("é", "\\'e") ; - ("è", "\\`e") ; - ("ê", "\\^e") ; - ("ë", "\\\"e") ; - ("ç", "\\c{c}") ; - ("ô", "\\^o") ; - ("ö", "\\\"o") ; - ("î", "\\^i") ; - ("ï", "\\\"i") ; - ("ù", "\\`u") ; - ("û", "\\^u") ; - ("%", "\\%") ; - ("_", "\\_"); - ("\\.\\.\\.", "$\\ldots$"); - ("~", "\\~{}"); - ("#", "\\verb`#`"); - ("}", "\\}"); - ("{", "\\{"); - ("&", "\\&"); - (">", "$>$"); - ("<", "$<$"); - ("=", "$=$"); - (">=", "$\\geq$"); - ("<=", "$\\leq$"); - ("->", "$\\rightarrow$") ; - ("<-", "$\\leftarrow$"); - ("|", "\\textbar "); - ("\\^", "\\textasciicircum ") ; - ("\\.\\.\\.", "$\\ldots$"); - ("\\\\", "MAXENCE"^"XXX") ; - ("&", "MAXENCE"^"YYY") ; - ("\\$", "MAXENCE"^"ZZZ"); - ] - - val mutable subst_strings_simple = + (** Associations of strings to substitute in latex code. *) + val subst_strings = List.map (fun (x, y) -> (Str.regexp x, y)) [ - ("MAXENCE"^"XXX", "{\\textbackslash}") ; - "}", "\\}" ; - "{", "\\{" ; - ("\\\\", "MAXENCE"^"XXX") ; + "\001", "\001\002"; + "\\\\", "\001b"; + + "{", "\\\\{"; + "}", "\\\\}"; + "\\$", "\\\\$"; + "\\^", "{\\\\textasciicircum}"; + "\xE0", "\\\\`a"; + "\xE2", "\\\\^a"; + "\xE9", "\\\\'e"; + "\xE8", "\\\\`e"; + "\xEA", "\\\\^e"; + "\xEB", "\\\\\"e"; + "\xE7", "\\\\c{c}"; + "\xF4", "\\\\^o"; + "\xF6", "\\\\\"o"; + "\xEE", "\\\\^i"; + "\xEF", "\\\\\"i"; + "\xF9", "\\\\`u"; + "\xFB", "\\\\^u"; + "%", "\\\\%"; + "_", "\\\\_"; + "~", "\\\\~{}"; + "#", "{\\char35}"; + "->", "$\\\\rightarrow$"; + "<-", "$\\\\leftarrow$"; + ">=", "$\\\\geq$"; + "<=", "$\\\\leq$"; + ">", "$>$"; + "<", "$<$"; + "=", "$=$"; + "|", "{\\\\textbar}"; + "\\.\\.\\.", "$\\\\ldots$"; + "&", "\\\\&"; + + "\001b", "{\\\\char92}"; + "\001\002", "\001"; ] - val mutable subst_strings_code = [ - ("MAXENCE"^"ZZZ", "\\$"); - ("MAXENCE"^"YYY", "\\&"); - ("MAXENCE"^"XXX", "{\\textbackslash}") ; - ("%", "\\%") ; - ("_", "\\_"); - ("~", "\\~{}"); - ("#", "\\verb`#`"); - ("}", "\\}"); - ("{", "\\{"); - ("&", "\\&"); - ("\\^", "\\textasciicircum ") ; - ("&", "MAXENCE"^"YYY") ; - ("\\$", "MAXENCE"^"ZZZ") ; - ("\\\\", "MAXENCE"^"XXX") ; - ] + val subst_strings_simple = List.map (fun (x, y) -> (Str.regexp x, y)) + [ + "\001", "\001\002"; + "\\\\", "\001b"; + "{", "\001l"; + + "}", "{\\\\char125}"; + "'", "{\\\\textquotesingle}"; + "`", "{\\\\textasciigrave}"; + + "\001b", "{\\\\char92}"; + "\001l", "{\\\\char123}"; + "\001\002", "\001"; + ] + + val subst_strings_code = List.map (fun (x, y) -> (Str.regexp x, y)) + [ + "\001", "\001\002"; + "\\\\", "\001b"; + "{", "\001l"; + + "}", "{\\\\char125}"; + "'", "{\\\\textquotesingle}"; + "`", "{\\\\textasciigrave}"; + "%", "\\\\%"; + "_", "\\\\_"; + "~", "{\\\\char126}"; + "#", "{\\\\char35}"; + "&", "\\\\&"; + "\\$", "\\\\$"; + "\\^", "{\\\\char94}"; + + "\001b", "{\\\\char92}"; + "\001l", "{\\\\char123}"; + "\001\002", "\001"; + ] method subst l s = - List.fold_right - (fun (s, s2) -> fun acc -> Str.global_replace (Str.regexp s) s2 acc) - l - s + List.fold_left (fun acc (re, st) -> Str.global_replace re st acc) s l (** Escape the strings which would clash with LaTeX syntax. *) method escape s = self#subst subst_strings s @@ -230,6 +241,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^"}" @@ -291,9 +308,9 @@ class text = ps fmt "\n\\end{ocamldoccode}\n" method latex_of_Verbatim fmt s = - ps fmt "\\begin{verbatim}"; + ps fmt "\n\\begin{verbatim}\n"; ps fmt s; - ps fmt "\\end{verbatim}" + ps fmt "\n\\end{verbatim}\n" method latex_of_Bold fmt t = ps fmt "{\\bf "; @@ -399,6 +416,8 @@ class text = | Odoc_info.RK_attribute -> self#attribute_label | Odoc_info.RK_method -> self#method_label | Odoc_info.RK_section _ -> assert false + | Odoc_info.RK_recfield -> self#recfield_label + | Odoc_info.RK_const -> self#const_label in let text = match text_opt with @@ -555,8 +574,8 @@ class latex = p fmt2 " %s@ %s@ %s@ %s" ":" (self#normal_type_list ~par: false mod_name " * " l) - "->" - (self#normal_type mod_name r) + "->" + (self#normal_type mod_name r) ); flush2 () in @@ -684,7 +703,7 @@ class latex = self#latex_of_module_kind fmt father k2; self#latex_of_text fmt [Code ")"] | Module_with (k, s) -> - (* TODO: à modifier quand Module_with sera plus détaillé *) + (* TODO: a modifier quand Module_with sera plus detaille *) self#latex_of_module_type_kind fmt father k; self#latex_of_text fmt [ Code " "; @@ -713,7 +732,7 @@ class latex = self#latex_of_text fmt [Latex "\\end{ocamldocobjectend}\n"] | Class_apply capp -> - (* TODO: afficher le type final à partir du typedtree *) + (* TODO: afficher le type final a partir du typedtree *) self#latex_of_text fmt [Raw "class application not handled yet"] | Class_constr cco -> @@ -1112,6 +1131,7 @@ class latex = ps fmt "\\documentclass[11pt]{article} \n"; ps fmt "\\usepackage[latin1]{inputenc} \n"; ps fmt "\\usepackage[T1]{fontenc} \n"; + ps fmt "\\usepackage{textcomp}\n"; ps fmt "\\usepackage{fullpage} \n"; ps fmt "\\usepackage{url} \n"; ps fmt "\\usepackage{ocamldoc}\n"; diff --git a/ocamldoc/odoc_lexer.mll b/ocamldoc/odoc_lexer.mll index 318a839fff..4a534e1c3d 100644 --- a/ocamldoc/odoc_lexer.mll +++ b/ocamldoc/odoc_lexer.mll @@ -22,10 +22,10 @@ let line_number = ref 0 let string_buffer = Buffer.create 32 -(** Fonction de remise à zéro de la chaine de caractères tampon *) +(** Fonction de remise a zero de la chaine de caracteres 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 caractere dans la chaine de caracteres tampon *) let ajout_char_string = Buffer.add_char string_buffer (** Add a string to the buffer. *) diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml index 037dee02da..e6a3ed3d10 100644 --- a/ocamldoc/odoc_man.ml +++ b/ocamldoc/odoc_man.ml @@ -478,10 +478,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; @@ -492,13 +492,13 @@ class man = | l, None, Some r -> bs b "\n.B : "; self#man_of_type_expr_list ~par: false b father " * " l; - bs b ".B -> "; + bs b ".B -> "; self#man_of_type_expr b father r; bs b " " | l, (Some t), Some r -> bs b "\n.B of "; self#man_of_type_expr_list ~par: false b father " * " l; - bs b ".B -> "; + bs b ".B -> "; self#man_of_type_expr b father r; bs b ".I \" \"\n"; bs b "(* "; @@ -999,6 +999,8 @@ class man = | Res_attribute a -> Name.simple a.att_value.val_name | Res_method m -> Name.simple m.met_value.val_name | Res_section _ -> assert false + | Res_recfield (_,f) -> f.rf_name + | Res_const (_,f) -> f.vc_name in let all_items_pre = Odoc_info.Search.search_by_name module_list (Str.regexp ".*") in let all_items = List.filter @@ -1040,6 +1042,8 @@ class man = | Res_attribute a -> a.att_value.val_name | Res_method m -> m.met_value.val_name | Res_section (s,_) -> s + | Res_recfield (_,f) -> f.rf_name + | Res_const (_,f) -> f.vc_name ) in let date = Unix.time () in diff --git a/ocamldoc/odoc_merge.mli b/ocamldoc/odoc_merge.mli index 4f580ee899..748a8b2fe1 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 1f27d5763f..7dfdff4907 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 = "Value "^n^" not found" let cross_type_not_found n = "Type "^n^" not found" +let cross_recfield_not_found n = Printf.sprintf "Record field %s not found" n +let cross_const_not_found n = Printf.sprintf "Constructor %s not found" n let object_end = "object ... end" let struct_end = "struct ... end" let sig_end = "sig ... end" +let current_generator_is_not kind = + Printf.sprintf "Current generator is not a %s generator" kind +;; + (** Messages for verbose mode. *) let analysing f = "Analysing file "^f^"..." diff --git a/ocamldoc/odoc_misc.ml b/ocamldoc/odoc_misc.ml index c48c1f6a56..f3de94858b 100644 --- a/ocamldoc/odoc_misc.ml +++ b/ocamldoc/odoc_misc.ml @@ -334,7 +334,7 @@ let rec get_before_dot s = let len = String.length s in let n = String.index s '.' in if n + 1 >= len then - (* le point est le dernier caractère *) + (* le point est le dernier caractere *) (true, s, "") else match s.[n+1] with diff --git a/ocamldoc/odoc_module.ml b/ocamldoc/odoc_module.ml index cc1fe02ca8..0cbc2cc6ac 100644 --- a/ocamldoc/odoc_module.ml +++ b/ocamldoc/odoc_module.ml @@ -238,7 +238,7 @@ let rec module_elements ?(trans=true) m = module_elements ~trans: trans { m_name = "" ; m_info = None ; - m_type = Types.Tmty_signature [] ; + 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 b82cf87458..9a934d7522 100644 --- a/ocamldoc/odoc_name.ml +++ b/ocamldoc/odoc_name.ml @@ -52,11 +52,11 @@ let strip_string s = else match s.[n] with ' ' | '\t' | '\n' | '\r' -> iter_last (n-1) - | _ -> Some n + | _ -> Some n in match iter_last (len-1) with None -> String.sub s first 1 - | Some last -> String.sub s first ((last-first)+1) + | Some last -> String.sub s first ((last-first)+1) let parens_if_infix name = match strip_string name with @@ -215,3 +215,9 @@ let to_path n = | Some p -> p 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..f8c0e09fe9 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 imprimees 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..b5e0371d94 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 heritees.*) 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 heritees.*) method scan_class_type_elements ct = List.iter (fun ele -> diff --git a/ocamldoc/odoc_search.ml b/ocamldoc/odoc_search.ml index 65d602d3b9..91b1d13c89 100644 --- a/ocamldoc/odoc_search.ml +++ b/ocamldoc/odoc_search.ml @@ -32,6 +32,8 @@ type result_element = | Res_attribute of t_attribute | Res_method of t_method | Res_section of string * Odoc_types.text + | Res_recfield of t_type * record_field + | Res_const of t_type * variant_constructor type result = result_element list @@ -43,7 +45,9 @@ module type Predicates = val p_class : t_class -> t -> bool * bool val p_class_type : t_class_type -> t -> bool * bool val p_value : t_value -> t -> bool - val p_type : t_type -> t -> bool + val p_recfield : t_type -> record_field -> t -> bool + val p_const : t_type -> variant_constructor -> t -> bool + val p_type : t_type -> t -> (bool * bool) val p_exception : t_exception -> t -> bool val p_attribute : t_attribute -> t -> bool val p_method : t_method -> t -> bool @@ -92,7 +96,26 @@ module Search = let search_value va v = if P.p_value va v then [Res_value va] else [] - let search_type t v = if P.p_type t v then [Res_type t] else [] + let search_recfield t f v = + if P.p_recfield t f v then [Res_recfield (t,f)] else [] + + let search_const t f v = + if P.p_const t f v then [Res_const (t,f)] else [] + + let search_type t v = + let (go_deeper, ok) = P.p_type t v in + let l = + match go_deeper with + false -> [] + | true -> + match t.ty_kind with + Type_abstract -> [] + | Type_record l -> + List.flatten (List.map (fun rf -> search_recfield t rf v) l) + | Type_variant l -> + List.flatten (List.map (fun rf -> search_const t rf v) l) + in + if ok then (Res_type t) :: l else l let search_exception e v = if P.p_exception e v then [Res_exception e] else [] @@ -305,7 +328,13 @@ module P_name = let p_class c r = (true, c.cl_name =~ r) let p_class_type ct r = (true, ct.clt_name =~ r) let p_value v r = v.val_name =~ r - let p_type t r = t.ty_name =~ r + let p_recfield t f r = + let name = Printf.sprintf "%s.%s" t.ty_name f.rf_name in + name =~ r + let p_const t f r = + let name = Printf.sprintf "%s.%s" t.ty_name f.vc_name in + name =~ r + let p_type t r = (true, t.ty_name =~ r) let p_exception e r = e.ex_name =~ r let p_attribute a r = a.att_value.val_name =~ r let p_method m r = m.met_value.val_name =~ r @@ -322,7 +351,9 @@ module P_values = let p_class _ _ = (false, false) let p_class_type _ _ = (false, false) let p_value _ _ = true - let p_type _ _ = false + let p_recfield _ _ _ = false + let p_const _ _ _ = false + let p_type _ _ = (false, false) let p_exception _ _ = false let p_attribute _ _ = false let p_method _ _ = false @@ -347,7 +378,9 @@ module P_exceptions = let p_class _ _ = (false, false) let p_class_type _ _ = (false, false) let p_value _ _ = false - let p_type _ _ = false + let p_recfield _ _ _ = false + let p_const _ _ _ = false + let p_type _ _ = (false, false) let p_exception _ _ = true let p_attribute _ _ = false let p_method _ _ = false @@ -372,7 +405,9 @@ module P_types = let p_class _ _ = (false, false) let p_class_type _ _ = (false, false) let p_value _ _ = false - let p_type _ _ = true + let p_recfield _ _ _ = false + let p_const _ _ _ = false + let p_type _ _ = (false, true) let p_exception _ _ = false let p_attribute _ _ = false let p_method _ _ = false @@ -397,7 +432,9 @@ module P_attributes = let p_class _ _ = (true, false) let p_class_type _ _ = (true, false) let p_value _ _ = false - let p_type _ _ = false + let p_recfield _ _ _ = false + let p_const _ _ _ = false + let p_type _ _ = (false, false) let p_exception _ _ = false let p_attribute _ _ = true let p_method _ _ = false @@ -422,7 +459,9 @@ module P_methods = let p_class _ _ = (true, false) let p_class_type _ _ = (true, false) let p_value _ _ = false - let p_type _ _ = false + let p_recfield _ _ _ = false + let p_const _ _ _ = false + let p_type _ _ = (false, false) let p_exception _ _ = false let p_attribute _ _ = false let p_method _ _ = true @@ -447,7 +486,9 @@ module P_classes = let p_class _ _ = (false, true) let p_class_type _ _ = (false, false) let p_value _ _ = false - let p_type _ _ = false + let p_recfield _ _ _ = false + let p_const _ _ _ = false + let p_type _ _ = (false, false) let p_exception _ _ = false let p_attribute _ _ = false let p_method _ _ = false @@ -472,7 +513,9 @@ module P_class_types = let p_class _ _ = (false, false) let p_class_type _ _ = (false, true) let p_value _ _ = false - let p_type _ _ = false + let p_recfield _ _ _ = false + let p_const _ _ _ = false + let p_type _ _ = (false, false) let p_exception _ _ = false let p_attribute _ _ = false let p_method _ _ = false @@ -497,7 +540,9 @@ module P_modules = let p_class _ _ = (false, false) let p_class_type _ _ = (false, false) let p_value _ _ = false - let p_type _ _ = false + let p_recfield _ _ _ = false + let p_const _ _ _ = false + let p_type _ _ = (false, false) let p_exception _ _ = false let p_attribute _ _ = false let p_method _ _ = false @@ -522,7 +567,9 @@ module P_module_types = let p_class _ _ = (false, false) let p_class_type _ _ = (false, false) let p_value _ _ = false - let p_type _ _ = false + let p_recfield _ _ _ = false + let p_const _ _ _ = false + let p_type _ _ = (false, false) let p_exception _ _ = false let p_attribute _ _ = false let p_method _ _ = false diff --git a/ocamldoc/odoc_search.mli b/ocamldoc/odoc_search.mli index 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 44fce22e52..2d69f76df8 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]) + 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 @@ -231,7 +232,7 @@ module Analyser = { vc_name = constructor_name ; vc_args = List.map (Odoc_env.subst_type env) type_expr_list ; - vc_ret = may_map (Odoc_env.subst_type env) ret_type; + vc_ret = may_map (Odoc_env.subst_type env) ret_type; vc_text = comment_opt } in @@ -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 ; + 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 ; @@ -691,8 +728,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 etre 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 ]) @@ -701,7 +738,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 *) @@ -711,8 +748,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 etre 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"; @@ -726,9 +763,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, []) @@ -740,19 +778,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) @@ -767,7 +804,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 ; @@ -792,11 +829,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 @@ -815,7 +852,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) = @@ -826,8 +863,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 etre 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 ]) @@ -835,7 +872,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 _ -> @@ -844,7 +881,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 let name = f module_type.Parsetree.pmty_desc in @@ -856,14 +893,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 @@ -889,11 +926,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) = @@ -913,7 +950,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) = @@ -939,7 +976,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 @@ -965,11 +1002,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 @@ -987,7 +1024,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) = @@ -1008,13 +1045,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 ; @@ -1022,25 +1060,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 @@ -1052,7 +1091,7 @@ module Analyser = mp_kind = mp_kind ; } in - let k = analyse_module_type_kind env + let k = analyse_module_type_kind ~erased env current_module_name module_type2 body_module_type @@ -1061,16 +1100,18 @@ 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_type_with (k, s) ) @@ -1081,7 +1122,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 @@ -1089,8 +1131,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 @@ -1102,12 +1145,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 @@ -1123,7 +1166,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 @@ -1132,15 +1175,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 -> @@ -1154,8 +1198,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 = @@ -1168,7 +1212,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 @@ -1178,8 +1222,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 parametres a l'interieur des tuples *) (* si label = "", pas de label. ici on a l'information pour savoir si on a un label explicite. *) if parse_label = label then ( @@ -1195,7 +1239,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") ) | _ -> @@ -1205,8 +1249,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 { @@ -1217,7 +1261,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 @@ -1227,11 +1273,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 @@ -1290,12 +1336,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 65ee128fc5..766994d717 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. @@ -156,7 +156,7 @@ module Analyser : (** 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 -> + ?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 d420c05971..0360e3f0e6 100644 --- a/ocamldoc/odoc_str.ml +++ b/ocamldoc/odoc_str.ml @@ -126,7 +126,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 -> " ( @@ -144,8 +144,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_texi.ml b/ocamldoc/odoc_texi.ml index 5c75b4fdfa..eeb4d9e239 100644 --- a/ocamldoc/odoc_texi.ml +++ b/ocamldoc/odoc_texi.ml @@ -149,23 +149,23 @@ struct ] @ (if !esc_8bits then [ - (Str.regexp "à", "@`a") ; - (Str.regexp "â", "@^a") ; - (Str.regexp "é", "@'e") ; - (Str.regexp "è", "@`e") ; - (Str.regexp "ê", "@^e") ; - (Str.regexp "ë", "@\"e") ; - (Str.regexp "ç", "@,{c}") ; - (Str.regexp "ô", "@^o") ; - (Str.regexp "ö", "@\"o") ; - (Str.regexp "î", "@^i") ; - (Str.regexp "ï", "@\"i") ; - (Str.regexp "ù", "@`u") ; - (Str.regexp "û", "@^u") ; - (Str.regexp "æ", "@ae{}" ) ; - (Str.regexp "Æ", "@AE{}" ) ; - (Str.regexp "ß", "@ss{}" ) ; - (Str.regexp "©", "@copyright{}" ) ; + (Str.regexp "\xE0", "@`a") ; + (Str.regexp "\xE2", "@^a") ; + (Str.regexp "\xE9", "@'e") ; + (Str.regexp "\xE8", "@`e") ; + (Str.regexp "\xEA", "@^e") ; + (Str.regexp "\xEB", "@\"e") ; + (Str.regexp "\xF7", "@,{c}") ; + (Str.regexp "\xF4", "@^o") ; + (Str.regexp "\xF6", "@\"o") ; + (Str.regexp "\xEE", "@^i") ; + (Str.regexp "\xEF", "@\"i") ; + (Str.regexp "\xF9", "@`u") ; + (Str.regexp "\xFB", "@^u") ; + (Str.regexp "\xE6", "@ae{}" ) ; + (Str.regexp "\xC6", "@AE{}" ) ; + (Str.regexp "\xDF", "@ss{}" ) ; + (Str.regexp "\xA9", "@copyright{}" ) ; ] else []) @@ -640,13 +640,13 @@ class texi = Printf.sprintf "(%s) " (String.concat ", " (List.map f l)) - method string_of_type_args (args:Types.type_expr list) (ret:Types.type_expr option) = + method string_of_type_args (args:Types.type_expr list) (ret:Types.type_expr option) = match args, ret with | [], None -> "" | args, None -> " of " ^ (Odoc_info.string_of_type_list " * " args) | [], Some r -> " : " ^ (Odoc_info.string_of_type_expr r) - | args, Some r -> " : " ^ (Odoc_info.string_of_type_list " * " args) ^ - " -> " ^ (Odoc_info.string_of_type_expr r) + | args, Some r -> " : " ^ (Odoc_info.string_of_type_list " * " args) ^ + " -> " ^ (Odoc_info.string_of_type_expr r) (** Return Texinfo code for a type. *) method texi_of_type ty = diff --git a/ocamldoc/odoc_text.ml b/ocamldoc/odoc_text.ml index b50a2dbd17..e80b680ed4 100644 --- a/ocamldoc/odoc_text.ml +++ b/ocamldoc/odoc_text.ml @@ -133,6 +133,8 @@ module Texter = | RK_attribute -> "attribute" | RK_method -> "method" | RK_section _ -> "section" + | RK_recfield -> "recfield" + | RK_const -> "const" in s^":" ) diff --git a/ocamldoc/odoc_text_lexer.mll b/ocamldoc/odoc_text_lexer.mll index f229f08a66..4c92834f41 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 a zero de la chaine de caracteres 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 caractere dans la chaine de caracteres tampon *) let ajout_char_string = Buffer.add_char string_buffer (** Add a string to the buffer. *) @@ -161,6 +161,8 @@ let begin_clt_ref = "{!classtype:"blank_nl | "{!classtype:" let begin_att_ref = "{!attribute:"blank_nl | "{!attribute:" let begin_met_ref = "{!method:"blank_nl | "{!method:" let begin_sec_ref = "{!section:"blank_nl | "{!section:" +let begin_recf_ref = "{!recfield:"blank_nl | "{!recfield:" +let begin_const_ref = "{!const:"blank_nl | "{!const:" let begin_mod_list_ref = "{!modules:"blank_nl | "{!modules:" let index_list = "{!indexlist}" let begin_custom = "{"['a'-'z''A'-'Z']['a'-'z''A'-'Z''0'-'9']* @@ -664,7 +666,38 @@ rule main = parse Char (Lexing.lexeme lexbuf) ) } - +| begin_recf_ref + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then + Char (Lexing.lexeme lexbuf) + else + if not !ele_ref_mode then + ( + ele_ref_mode := true; + RECF_REF + ) + else + ( + Char (Lexing.lexeme lexbuf) + ) + } +| begin_const_ref + { + incr_cpts lexbuf ; + if !verb_mode or !target_mode or !code_pre_mode or !open_brackets >= 1 then + Char (Lexing.lexeme lexbuf) + else + if not !ele_ref_mode then + ( + ele_ref_mode := true; + CONST_REF + ) + else + ( + Char (Lexing.lexeme lexbuf) + ) + } | begin_mod_list_ref { incr_cpts lexbuf ; @@ -720,7 +753,10 @@ rule main = parse | shortcut_list_item { incr_cpts lexbuf ; - if !shortcut_list_mode then + if !target_mode || (!open_brackets >= 1) || !code_pre_mode + || !ele_ref_mode || !verb_mode then + Char (Lexing.lexeme lexbuf) + else if !shortcut_list_mode then ( SHORTCUT_LIST_ITEM ) @@ -734,7 +770,10 @@ rule main = parse | shortcut_enum_item { incr_cpts lexbuf ; - if !shortcut_list_mode then + if !target_mode || (!open_brackets >= 1) || !code_pre_mode + || !ele_ref_mode || !verb_mode then + Char (Lexing.lexeme lexbuf) + else if !shortcut_list_mode then SHORTCUT_ENUM_ITEM else ( diff --git a/ocamldoc/odoc_text_parser.mly b/ocamldoc/odoc_text_parser.mly index 478cfa074e..6efc32f54d 100644 --- a/ocamldoc/odoc_text_parser.mly +++ b/ocamldoc/odoc_text_parser.mly @@ -62,6 +62,8 @@ let print_DEBUG s = print_string s; print_newline () %token ATT_REF %token MET_REF %token SEC_REF +%token RECF_REF +%token CONST_REF %token MOD_LIST_REF %token INDEX_LIST @@ -80,8 +82,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: @@ -98,6 +101,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 } @@ -110,6 +123,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 53a1ca5f9c..d1ae70ef2d 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 @@ -91,8 +93,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 d4affb5039..f6eca5d96c 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. *) @@ -94,8 +96,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/.depend b/otherlibs/bigarray/.depend index c70f81a520..889328a333 100644 --- a/otherlibs/bigarray/.depend +++ b/otherlibs/bigarray/.depend @@ -3,7 +3,7 @@ bigarray_stubs.o: bigarray_stubs.c ../../byterun/alloc.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h bigarray.h \ ../../byterun/config.h ../../byterun/mlvalues.h ../../byterun/custom.h \ ../../byterun/fail.h ../../byterun/intext.h ../../byterun/io.h \ - ../../byterun/fix_code.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/hash.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h mmap_unix.o: mmap_unix.c bigarray.h ../../byterun/config.h \ @@ -16,6 +16,6 @@ mmap_win32.o: mmap_win32.c bigarray.h ../../byterun/config.h \ ../../byterun/mlvalues.h ../../byterun/config.h ../../byterun/misc.h \ ../../byterun/alloc.h ../../byterun/mlvalues.h ../../byterun/custom.h \ ../../byterun/fail.h ../../byterun/sys.h ../unix/unixsupport.h -bigarray.cmi: -bigarray.cmo: bigarray.cmi -bigarray.cmx: bigarray.cmi +bigarray.cmi : +bigarray.cmo : bigarray.cmi +bigarray.cmx : bigarray.cmi diff --git a/otherlibs/bigarray/bigarray.h b/otherlibs/bigarray/bigarray.h index 6953065446..f6552107a6 100644 --- a/otherlibs/bigarray/bigarray.h +++ b/otherlibs/bigarray/bigarray.h @@ -42,7 +42,7 @@ enum caml_ba_kind { CAML_BA_UINT16, /* Unsigned 16-bit integers */ CAML_BA_INT32, /* Signed 32-bit integers */ CAML_BA_INT64, /* Signed 64-bit integers */ - CAML_BA_CAML_INT, /* Caml-style integers (signed 31 or 63 bits) */ + CAML_BA_CAML_INT, /* OCaml-style integers (signed 31 or 63 bits) */ CAML_BA_NATIVE_INT, /* Platform-native long integers (32 or 64 bits) */ CAML_BA_COMPLEX32, /* Single-precision complex */ CAML_BA_COMPLEX64, /* Double-precision complex */ @@ -56,8 +56,8 @@ enum caml_ba_layout { }; enum caml_ba_managed { - CAML_BA_EXTERNAL = 0, /* Data is not allocated by Caml */ - CAML_BA_MANAGED = 0x200, /* Data is allocated by Caml */ + CAML_BA_EXTERNAL = 0, /* Data is not allocated by OCaml */ + CAML_BA_MANAGED = 0x200, /* Data is allocated by OCaml */ CAML_BA_MAPPED_FILE = 0x400, /* Data is a memory mapped file */ CAML_BA_MANAGED_MASK = 0x600 /* Mask for "managed" bits in flags field */ }; @@ -73,7 +73,12 @@ struct caml_ba_array { intnat num_dims; /* Number of dimensions */ intnat flags; /* Kind of element array + memory layout + allocation status */ struct caml_ba_proxy * proxy; /* The proxy for sub-arrays, or NULL */ + /* PR#5516: use C99's flexible array types if possible */ +#if (__STDC_VERSION__ >= 199901L) + intnat dim[] /*[num_dims]*/; /* Size in each dimension */ +#else intnat dim[1] /*[num_dims]*/; /* Size in each dimension */ +#endif }; #define Caml_ba_array_val(v) ((struct caml_ba_array *) Data_custom_val(v)) diff --git a/otherlibs/bigarray/bigarray.mli b/otherlibs/bigarray/bigarray.mli index ed60976f70..fb252cb421 100644 --- a/otherlibs/bigarray/bigarray.mli +++ b/otherlibs/bigarray/bigarray.mli @@ -18,18 +18,18 @@ This module implements multi-dimensional arrays of integers and floating-point numbers, thereafter referred to as ``big arrays''. The implementation allows efficient sharing of large numerical - arrays between Caml code and C or Fortran numerical libraries. + arrays between OCaml code and C or Fortran numerical libraries. Concerning the naming conventions, users of this module are encouraged to do [open Bigarray] in their source, then refer to array types and operations via short dot notation, e.g. [Array1.t] or [Array2.sub]. - Big arrays support all the Caml ad-hoc polymorphic operations: + Big arrays support all the OCaml ad-hoc polymorphic operations: - comparisons ([=], [<>], [<=], etc, as well as {!Pervasives.compare}); - hashing (module [Hash]); - - and structured input-output ({!Pervasives.output_value} - 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} *) @@ -47,7 +47,7 @@ ({!Bigarray.int8_signed_elt} or {!Bigarray.int8_unsigned_elt}), - 16-bit integers (signed or unsigned) ({!Bigarray.int16_signed_elt} or {!Bigarray.int16_unsigned_elt}), -- Caml integers (signed, 31 bits on 32-bit architectures, +- OCaml integers (signed, 31 bits on 32-bit architectures, 63 bits on 64-bit architectures) ({!Bigarray.int_elt}), - 32-bit signed integer ({!Bigarray.int32_elt}), - 64-bit signed integers ({!Bigarray.int64_elt}), @@ -72,20 +72,20 @@ type int64_elt type nativeint_elt type ('a, 'b) kind -(** To each element kind is associated a Caml type, which is - the type of Caml values that can be stored in the big array +(** To each element kind is associated an OCaml type, which is + the type of OCaml values that can be stored in the big array or read back from it. This type is not necessarily the same as the type of the array elements proper: for instance, a big array whose elements are of kind [float32_elt] contains 32-bit single precision floats, but reading or writing one of - its elements from Caml uses the Caml type [float], which is + its elements from OCaml uses the OCaml type [float], which is 64-bit double precision floats. The abstract type [('a, 'b) kind] captures this association - of a Caml type ['a] for values read or written in the big array, + of an OCaml type ['a] for values read or written in the big array, and of an element kind ['b] which represents the actual contents of the big array. The following predefined values of type - [kind] list all possible associations of Caml types with + [kind] list all possible associations of OCaml types with element kinds: *) val float32 : (float, float32_elt) kind @@ -127,12 +127,12 @@ val nativeint : (nativeint, nativeint_elt) kind val char : (char, int8_unsigned_elt) kind (** As shown by the types of the values above, big arrays of kind [float32_elt] and [float64_elt] are - accessed using the Caml type [float]. Big arrays of complex kinds - [complex32_elt], [complex64_elt] are accessed with the Caml type + accessed using the OCaml type [float]. Big arrays of complex kinds + [complex32_elt], [complex64_elt] are accessed with the OCaml type {!Complex.t}. Big arrays of - integer kinds are accessed using the smallest Caml integer + integer kinds are accessed using the smallest OCaml integer type large enough to represent the array elements: - [int] for 8- and 16-bit integer bigarrays, as well as Caml-integer + [int] for 8- and 16-bit integer bigarrays, as well as OCaml-integer bigarrays; [int32] for 32-bit integer bigarrays; [int64] for 64-bit integer bigarrays; and [nativeint] for platform-native integer bigarrays. Finally, big arrays of @@ -195,7 +195,7 @@ module Genarray : The three type parameters to [Genarray.t] identify the array element kind and layout, as follows: - - the first parameter, ['a], is the Caml type for accessing array + - the first parameter, ['a], is the OCaml type for accessing array elements ([float], [int], [int32], [int64], [nativeint]); - the second parameter, ['b], is the actual kind of array elements ([float32_elt], [float64_elt], [int8_signed_elt], [int8_unsigned_elt], @@ -206,7 +206,7 @@ module Genarray : For instance, [(float, float32_elt, fortran_layout) Genarray.t] is the type of generic big arrays containing 32-bit floats in Fortran layout; reads and writes in this array use the - Caml type [float]. *) + OCaml type [float]. *) external create: ('a, 'b) kind -> 'c layout -> int array -> ('a, 'b, 'c) t = "caml_ba_create" @@ -440,7 +440,7 @@ module Genarray : module Array1 : sig type ('a, 'b, 'c) t (** The type of one-dimensional big arrays whose elements have - Caml type ['a], representation kind ['b], and memory layout ['c]. *) + OCaml type ['a], representation kind ['b], and memory layout ['c]. *) val create: ('a, 'b) kind -> 'c layout -> int -> ('a, 'b, 'c) t (** [Array1.create kind layout dim] returns a new bigarray of @@ -519,7 +519,7 @@ module Array2 : sig type ('a, 'b, 'c) t (** The type of two-dimensional big arrays whose elements have - Caml type ['a], representation kind ['b], and memory layout ['c]. *) + OCaml type ['a], representation kind ['b], and memory layout ['c]. *) val create: ('a, 'b) kind -> 'c layout -> int -> int -> ('a, 'b, 'c) t (** [Array2.create kind layout dim1 dim2] returns a new bigarray of @@ -622,7 +622,7 @@ module Array3 : sig type ('a, 'b, 'c) t (** The type of three-dimensional big arrays whose elements have - Caml type ['a], representation kind ['b], and memory layout ['c]. *) + OCaml type ['a], representation kind ['b], and memory layout ['c]. *) val create: ('a, 'b) kind -> 'c layout -> int -> int -> int -> ('a, 'b, 'c) t (** [Array3.create kind layout dim1 dim2 dim3] returns a new bigarray of diff --git a/otherlibs/bigarray/bigarray_stubs.c b/otherlibs/bigarray/bigarray_stubs.c index 7c751b7cf9..c66ccbcc3b 100644 --- a/otherlibs/bigarray/bigarray_stubs.c +++ b/otherlibs/bigarray/bigarray_stubs.c @@ -123,20 +123,20 @@ caml_ba_multov(uintnat a, uintnat b, int * overflow) /* Allocation of a big array */ -#define CAML_BA_MAX_MEMORY 256*1024*1024 -/* 256 Mb -- after allocating that much, it's probably worth speeding +#define CAML_BA_MAX_MEMORY 1024*1024*1024 +/* 1 Gb -- after allocating that much, it's probably worth speeding up the major GC */ /* [caml_ba_alloc] will allocate a new bigarray object in the heap. If [data] is NULL, the memory for the contents is also allocated (with [malloc]) by [caml_ba_alloc]. - [data] cannot point into the Caml heap. - [dim] may point into an object in the Caml heap. + [data] cannot point into the OCaml heap. + [dim] may point into an object in the OCaml heap. */ CAMLexport value caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim) { - uintnat num_elts, size; + uintnat num_elts, asize, size; int overflow, i; value res; struct caml_ba_array * b; @@ -160,10 +160,13 @@ caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim) if (data == NULL && size != 0) caml_raise_out_of_memory(); flags |= CAML_BA_MANAGED; } - res = caml_alloc_custom(&caml_ba_ops, - sizeof(struct caml_ba_array) - + (num_dims - 1) * sizeof(intnat), - size, CAML_BA_MAX_MEMORY); + /* PR#5516: use C99's flexible array types if possible */ +#if (__STDC_VERSION__ >= 199901L) + asize = sizeof(struct caml_ba_array) + num_dims * sizeof(intnat); +#else + asize = sizeof(struct caml_ba_array) + (num_dims - 1) * sizeof(intnat); +#endif + res = caml_alloc_custom(&caml_ba_ops, asize, size, CAML_BA_MAX_MEMORY); b = Caml_ba_array_val(res); b->data = data; b->num_dims = num_dims; @@ -183,6 +186,7 @@ CAMLexport value caml_ba_alloc_dims(int flags, int num_dims, void * data, ...) int i; value res; + Assert(num_dims <= CAML_BA_MAX_NUM_DIMS); va_start(ap, data); for (i = 0; i < num_dims; i++) dim[i] = va_arg(ap, intnat); va_end(ap); @@ -190,7 +194,7 @@ CAMLexport value caml_ba_alloc_dims(int flags, int num_dims, void * data, ...) return res; } -/* Allocate a bigarray from Caml */ +/* Allocate a bigarray from OCaml */ CAMLprim value caml_ba_create(value vkind, value vlayout, value vdim) { @@ -773,7 +777,7 @@ static void caml_ba_serialize(value v, caml_ba_serialize_longarray(b->data, num_elts, -0x80000000, 0x7FFFFFFF); break; } - /* Compute required size in Caml heap. Assumes struct caml_ba_array + /* Compute required size in OCaml heap. Assumes struct caml_ba_array is exactly 4 + num_dims words */ Assert(sizeof(struct caml_ba_array) == 5 * sizeof(value)); *wsize_32 = (4 + b->num_dims) * 4; @@ -794,7 +798,7 @@ static void caml_ba_deserialize_longarray(void * dest, intnat num_elts) #else if (sixty) caml_deserialize_error("input_value: cannot read bigarray " - "with 64-bit Caml ints"); + "with 64-bit OCaml ints"); caml_deserialize_block_4(dest, num_elts); #endif } @@ -905,7 +909,7 @@ CAMLprim value caml_ba_slice(value vb, value vind) sub_data = (char *) b->data + offset * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK]; - /* Allocate a Caml bigarray to hold the result */ + /* Allocate an OCaml bigarray to hold the result */ res = caml_ba_alloc(b->flags, b->num_dims - num_inds, sub_data, sub_dims); /* Create or update proxy in case of managed bigarray */ caml_ba_update_proxy(b, Caml_ba_array_val(res)); @@ -946,7 +950,7 @@ CAMLprim value caml_ba_sub(value vb, value vofs, value vlen) sub_data = (char *) b->data + ofs * mul * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK]; - /* Allocate a Caml bigarray to hold the result */ + /* Allocate an OCaml bigarray to hold the result */ res = caml_ba_alloc(b->flags, b->num_dims, sub_data, b->dim); /* Doctor the changed dimension */ Caml_ba_array_val(res)->dim[changed_dim] = len; @@ -1080,7 +1084,7 @@ CAMLprim value caml_ba_reshape(value vb, value vdim) num_elts = 1; for (i = 0; i < num_dims; i++) { dim[i] = Long_val(Field(vdim, i)); - if (dim[i] < 0 || dim[i] > 0x7FFFFFFFL) + if (dim[i] < 0) caml_invalid_argument("Bigarray.reshape: negative dimension"); num_elts *= dim[i]; } diff --git a/otherlibs/bigarray/mmap_unix.c b/otherlibs/bigarray/mmap_unix.c index 4d77c2e541..2e7d98d2da 100644 --- a/otherlibs/bigarray/mmap_unix.c +++ b/otherlibs/bigarray/mmap_unix.c @@ -13,6 +13,10 @@ /* $Id$ */ +/* Needed (under Linux at least) to get pwrite's prototype in unistd.h. + Must be defined before the first system .h is included. */ +#define _XOPEN_SOURCE 500 + #include <stddef.h> #include <string.h> #include "bigarray.h" @@ -25,12 +29,14 @@ extern int caml_ba_element_size[]; /* from bigarray_stubs.c */ +#include <errno.h> #ifdef HAS_UNISTD #include <unistd.h> #endif #ifdef HAS_MMAP #include <sys/types.h> #include <sys/mman.h> +#include <sys/stat.h> #endif #if defined(HAS_MMAP) @@ -39,15 +45,61 @@ extern int caml_ba_element_size[]; /* from bigarray_stubs.c */ #define MAP_FAILED ((void *) -1) #endif +/* [caml_grow_file] function contributed by Gerd Stolpmann (PR#5543). */ + +static int caml_grow_file(int fd, file_offset size) +{ + char c; + int p; + + /* First use pwrite for growing - it is a conservative method, as it + can never happen that we shrink by accident + */ +#ifdef HAS_PWRITE + c = 0; + p = pwrite(fd, &c, 1, size - 1); +#else + + /* Emulate pwrite with lseek. This should only be necessary on ancient + systems nowadays + */ + file_offset currpos; + currpos = lseek(fd, 0, SEEK_CUR); + if (currpos != -1) { + p = lseek(fd, size - 1, SEEK_SET); + if (p != -1) { + c = 0; + p = write(fd, &c, 1); + if (p != -1) + p = lseek(fd, currpos, SEEK_SET); + } + } + else p=-1; +#endif +#ifdef HAS_TRUNCATE + if (p == -1 && errno == ESPIPE) { + /* Plan B. Check if at least ftruncate is possible. There are + some non-seekable descriptor types that do not support pwrite + but ftruncate, like shared memory. We never get into this case + for real files, so there is no danger of truncating persistent + data by accident + */ + p = ftruncate(fd, size); + } +#endif + return p; +} + + CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, value vshared, value vdim, value vstart) { int fd, flags, major_dim, shared; intnat num_dims, i; intnat dim[CAML_BA_MAX_NUM_DIMS]; - file_offset currpos, startpos, file_size, data_size; + file_offset startpos, file_size, data_size; + struct stat st; uintnat array_size, page, delta; - char c; void * addr; fd = Int_val(vfd); @@ -55,7 +107,7 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, startpos = File_offset_val(vstart); num_dims = Wosize_val(vdim); major_dim = flags & CAML_BA_FORTRAN_LAYOUT ? num_dims - 1 : 0; - /* Extract dimensions from Caml array */ + /* Extract dimensions from OCaml array */ num_dims = Wosize_val(vdim); if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS) caml_invalid_argument("Bigarray.mmap: bad number of dimensions"); @@ -65,18 +117,15 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, if (dim[i] < 0) caml_invalid_argument("Bigarray.create: negative dimension"); } - /* Determine file size */ + /* Determine file size. We avoid lseek here because it is fragile, + and because some mappable file types do not support it + */ caml_enter_blocking_section(); - currpos = lseek(fd, 0, SEEK_CUR); - if (currpos == -1) { - caml_leave_blocking_section(); - caml_sys_error(NO_ARG); - } - file_size = lseek(fd, 0, SEEK_END); - if (file_size == -1) { + if (fstat(fd, &st) == -1) { caml_leave_blocking_section(); caml_sys_error(NO_ARG); } + file_size = st.st_size; /* Determine array size in bytes (or size of array without the major dimension if that dimension wasn't specified) */ array_size = caml_ba_element_size[flags & CAML_BA_KIND_MASK]; @@ -99,37 +148,33 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, } else { /* Check that file is large enough, and grow it otherwise */ if (file_size < startpos + array_size) { - if (lseek(fd, startpos + array_size - 1, SEEK_SET) == -1) { - caml_leave_blocking_section(); - caml_sys_error(NO_ARG); - } - c = 0; - if (write(fd, &c, 1) != 1) { + if (caml_grow_file(fd, startpos + array_size) == -1) { /* PR#5543 */ caml_leave_blocking_section(); caml_sys_error(NO_ARG); } } } - /* Restore original file position */ - lseek(fd, currpos, SEEK_SET); /* Determine offset so that the mapping starts at the given file pos */ page = getpagesize(); - delta = (uintnat) (startpos % page); + delta = (uintnat) startpos % page; /* Do the mmap */ shared = Bool_val(vshared) ? MAP_SHARED : MAP_PRIVATE; - addr = mmap(NULL, array_size + delta, PROT_READ | PROT_WRITE, - shared, fd, startpos - delta); + if (array_size > 0) + addr = mmap(NULL, array_size + delta, PROT_READ | PROT_WRITE, + shared, fd, startpos - delta); + else + addr = NULL; /* PR#5463 - mmap fails on empty region */ caml_leave_blocking_section(); if (addr == (void *) MAP_FAILED) caml_sys_error(NO_ARG); addr = (void *) ((uintnat) addr + delta); - /* Build and return the Caml bigarray */ + /* Build and return the OCaml bigarray */ return caml_ba_alloc(flags | CAML_BA_MAPPED_FILE, num_dims, addr, dim); } #else -value caml_ba_map_file(value vfd, value vkind, value vlayout, - value vshared, value vdim, value vpos) +CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, + value vshared, value vdim, value vpos) { caml_invalid_argument("Bigarray.map_file: not supported"); return Val_unit; @@ -148,6 +193,12 @@ void caml_ba_unmap_file(void * addr, uintnat len) #if defined(HAS_MMAP) uintnat page = getpagesize(); uintnat delta = (uintnat) addr % page; - munmap((void *)((uintnat)addr - delta), len + delta); + if (len == 0) return; /* PR#5463 */ + addr = (void *)((uintnat)addr - delta); + len = len + delta; +#if defined(_POSIX_SYNCHRONIZED_IO) + msync(addr, len, MS_ASYNC); /* PR#3571 */ +#endif + munmap(addr, len); #endif } diff --git a/otherlibs/bigarray/mmap_win32.c b/otherlibs/bigarray/mmap_win32.c index 067e3284af..ded2270ee6 100644 --- a/otherlibs/bigarray/mmap_win32.c +++ b/otherlibs/bigarray/mmap_win32.c @@ -62,7 +62,7 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, startpos = Int64_val(vstart); num_dims = Wosize_val(vdim); major_dim = flags & CAML_BA_FORTRAN_LAYOUT ? num_dims - 1 : 0; - /* Extract dimensions from Caml array */ + /* Extract dimensions from OCaml array */ num_dims = Wosize_val(vdim); if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS) caml_invalid_argument("Bigarray.mmap: bad number of dimensions"); @@ -117,7 +117,7 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, addr = (void *) ((uintnat) addr + delta); /* Close the file mapping */ CloseHandle(fmap); - /* Build and return the Caml bigarray */ + /* Build and return the OCaml bigarray */ return caml_ba_alloc(flags | CAML_BA_MAPPED_FILE, num_dims, addr, dim); } diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile index e6a632956b..8c13c70581 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 603535d65a..ee136fe2c7 100644 --- a/otherlibs/dynlink/dynlink.ml +++ b/otherlibs/dynlink/dynlink.ml @@ -121,19 +121,18 @@ let digest_interface unit loadpath = raise (Error(File_not_found shortname)) in let ic = open_in_bin filename in try - let buffer = String.create (String.length Config.cmi_magic_number) in - really_input ic buffer 0 (String.length Config.cmi_magic_number); + let buffer = Misc.input_bytes ic (String.length Config.cmi_magic_number) in if buffer <> Config.cmi_magic_number then begin close_in ic; raise(Error(Corrupted_interface filename)) 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; @@ -159,7 +158,10 @@ let check_unsafe_module cu = (* Load in-core and execute a bytecode object file *) -let load_compunit ic file_name compunit = +external register_code_fragment: string -> int -> string -> unit + = "caml_register_code_fragment" + +let load_compunit ic file_name file_digest compunit = check_consistency file_name compunit; check_unsafe_module compunit; seek_in ic compunit.cu_pos; @@ -188,6 +190,11 @@ let load_compunit ic file_name compunit = | _ -> assert false in raise(Error(Linking_error (file_name, new_error))) end; + (* PR#5215: identify this code fragment by + digest of file contents + unit name. + Unit name is needed for .cma files, which produce several code fragments.*) + let digest = Digest.string (file_digest ^ compunit.cu_name) in + register_code_fragment code code_size digest; begin try ignore((Meta.reify_bytecode code code_size) ()) with exn -> @@ -199,16 +206,18 @@ let loadfile file_name = init(); if not (Sys.file_exists file_name) then raise(Error (File_not_found file_name)); let ic = open_in_bin file_name in + let file_digest = Digest.channel ic (-1) in + seek_in ic 0; try - let buffer = String.create (String.length Config.cmo_magic_number) in - begin - try really_input ic buffer 0 (String.length Config.cmo_magic_number) - with End_of_file -> raise(Error(Not_a_bytecode_file file_name)) - end; + let buffer = + try Misc.input_bytes ic (String.length Config.cmo_magic_number) + with End_of_file -> raise (Error (Not_a_bytecode_file file_name)) + in if buffer = Config.cmo_magic_number then begin let compunit_pos = input_binary_int ic in (* Go to descriptor *) seek_in ic compunit_pos; - load_compunit ic file_name (input_value ic : compilation_unit) + let cu = (input_value ic : compilation_unit) in + load_compunit ic file_name file_digest cu end else if buffer = Config.cma_magic_number then begin let toc_pos = input_binary_int ic in (* Go to table of contents *) @@ -220,7 +229,7 @@ let loadfile file_name = with Failure reason -> raise(Error(Cannot_open_dll reason)) end; - List.iter (load_compunit ic file_name) lib.lib_units + List.iter (load_compunit ic file_name file_digest) lib.lib_units end else raise(Error(Not_a_bytecode_file file_name)); close_in ic diff --git a/otherlibs/dynlink/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/graph/.depend b/otherlibs/graph/.depend index 54df0691ff..84c8960d89 100644 --- a/otherlibs/graph/.depend +++ b/otherlibs/graph/.depend @@ -5,7 +5,7 @@ color.o: color.c libgraph.h \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h \ - + draw.o: draw.c libgraph.h \ \ \ @@ -98,9 +98,9 @@ text.o: text.c libgraph.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ ../../byterun/mlvalues.h -graphics.cmi: -graphicsX11.cmi: -graphics.cmo: graphics.cmi -graphics.cmx: graphics.cmi -graphicsX11.cmo: graphics.cmi graphicsX11.cmi -graphicsX11.cmx: graphics.cmx graphicsX11.cmi +graphics.cmi : +graphicsX11.cmi : +graphics.cmo : graphics.cmi +graphics.cmx : graphics.cmi +graphicsX11.cmo : graphics.cmi graphicsX11.cmi +graphicsX11.cmx : graphics.cmx graphicsX11.cmi diff --git a/otherlibs/graph/graphicsX11.mli b/otherlibs/graph/graphicsX11.mli index f35f5a6647..0210d9676d 100644 --- a/otherlibs/graph/graphicsX11.mli +++ b/otherlibs/graph/graphicsX11.mli @@ -18,12 +18,12 @@ type window_id = string val window_id : unit -> window_id -(** Return the unique identifier of the Caml graphics window. +(** Return the unique identifier of the OCaml graphics window. The returned string is an unsigned 32 bits integer in decimal form. *) val open_subwindow : x:int -> y:int -> width:int -> height:int -> window_id -(** Create a sub-window of the current Caml graphics window +(** Create a sub-window of the current OCaml graphics window and return its identifier. *) val close_subwindow : window_id -> unit diff --git a/otherlibs/graph/libgraph.h b/otherlibs/graph/libgraph.h index db3fd71d82..c8192e05b0 100644 --- a/otherlibs/graph/libgraph.h +++ b/otherlibs/graph/libgraph.h @@ -55,7 +55,7 @@ extern int caml_gr_bits_per_pixel; #define DEFAULT_SCREEN_WIDTH 600 #define DEFAULT_SCREEN_HEIGHT 450 #define BORDER_WIDTH 2 -#define DEFAULT_WINDOW_NAME "Caml graphics" +#define DEFAULT_WINDOW_NAME "OCaml graphics" #define DEFAULT_SELECTED_EVENTS \ (ExposureMask | KeyPressMask | StructureNotifyMask) #define DEFAULT_FONT "fixed" diff --git a/otherlibs/labltk/README b/otherlibs/labltk/README index 5d3e9d314d..6815b6669d 100644 --- a/otherlibs/labltk/README +++ b/otherlibs/labltk/README @@ -13,11 +13,11 @@ In addition to the basic interface with Tcl/Tk, this package contains mlTk = CamlTk + LablTk ====================== -There existed two parallel Tcl/Tk interfaces for O'Caml, CamlTk and LablTk. +There existed two parallel Tcl/Tk interfaces for OCaml, CamlTk and LablTk. CamlTk uses classical features only, therefore it is easy to understand for -the beginners of ML. It makes many conservative O'Caml gurus also happy. -LablTk, on the other hand, uses rather newer features of O'Caml, the labeled +the beginners of ML. It makes many conservative OCaml gurus also happy. +LablTk, on the other hand, uses rather newer features of OCaml, the labeled optional arguments and polymorphic variants. Its syntax has much more Tcl/Tk script flavor, but provides more powerful typing than CamlTk at the same time (i.e. less run time type checking of widgets). @@ -44,9 +44,9 @@ OSF/1 V4.0 (alpha), DGUX SVR4 (m88k) and Windows (VC++ and Cygwin). INSTALLATION ============ -0. Check-out the O'Caml CVS source code tree. +0. Check-out the OCaml CVS source code tree. -1. Compile O'Caml (= make world). If you want, also make opt. +1. Compile OCaml (= make world). If you want, also make opt. 2. Untar this mlTk distribution in the otherlibs directory, just like the labltk source tree. @@ -55,9 +55,9 @@ INSTALLATION 4. To install the library, make install (and make installopt) -To compile mlTk, you need the O'Caml source tree, since mltk/camlbrowser -requires some modules of O'Caml. If you are not interested in camlbrowser, -you can compile mlTk without the O'Caml source tree, but you have to modify +To compile mlTk, you need the OCaml source tree, since mltk/camlbrowser +requires some modules of OCaml. If you are not interested in camlbrowser, +you can compile mlTk without the OCaml source tree, but you have to modify support/Makefile.common. diff --git a/otherlibs/labltk/browser/.depend b/otherlibs/labltk/browser/.depend index 5e3e2a2b80..9903879dbf 100644 --- a/otherlibs/labltk/browser/.depend +++ b/otherlibs/labltk/browser/.depend @@ -1,97 +1,265 @@ -editor.cmo: viewer.cmi typecheck.cmi shell.cmi setpath.cmi searchpos.cmi \ - searchid.cmi mytypes.cmi lexical.cmi jg_toplevel.cmo jg_tk.cmo \ - jg_text.cmi jg_message.cmi jg_menu.cmo jg_button.cmo jg_bind.cmi \ - fileselect.cmi editor.cmi -editor.cmx: viewer.cmx typecheck.cmx shell.cmx setpath.cmx searchpos.cmx \ - searchid.cmx mytypes.cmi lexical.cmx jg_toplevel.cmx jg_tk.cmx \ - jg_text.cmx jg_message.cmx jg_menu.cmx jg_button.cmx jg_bind.cmx \ - fileselect.cmx editor.cmi -fileselect.cmo: useunix.cmi setpath.cmi list2.cmo jg_toplevel.cmo jg_memo.cmi \ - jg_entry.cmo jg_box.cmo fileselect.cmi -fileselect.cmx: useunix.cmx setpath.cmx list2.cmx jg_toplevel.cmx jg_memo.cmx \ - jg_entry.cmx jg_box.cmx fileselect.cmi -help.cmo: -help.cmx: -jg_bind.cmo: jg_bind.cmi -jg_bind.cmx: jg_bind.cmi -jg_box.cmo: jg_completion.cmi jg_bind.cmi -jg_box.cmx: jg_completion.cmx jg_bind.cmx -jg_button.cmo: -jg_button.cmx: -jg_completion.cmo: jg_completion.cmi -jg_completion.cmx: jg_completion.cmi -jg_config.cmo: jg_tk.cmo jg_config.cmi -jg_config.cmx: jg_tk.cmx jg_config.cmi -jg_entry.cmo: jg_bind.cmi -jg_entry.cmx: jg_bind.cmx -jg_memo.cmo: jg_memo.cmi -jg_memo.cmx: jg_memo.cmi -jg_menu.cmo: -jg_menu.cmx: -jg_message.cmo: jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_bind.cmi \ - jg_message.cmi -jg_message.cmx: jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_bind.cmx \ - jg_message.cmi -jg_multibox.cmo: jg_completion.cmi jg_bind.cmi jg_multibox.cmi -jg_multibox.cmx: jg_completion.cmx jg_bind.cmx jg_multibox.cmi -jg_text.cmo: jg_toplevel.cmo jg_tk.cmo jg_button.cmo jg_bind.cmi jg_text.cmi -jg_text.cmx: jg_toplevel.cmx jg_tk.cmx jg_button.cmx jg_bind.cmx jg_text.cmi -jg_tk.cmo: -jg_tk.cmx: -jg_toplevel.cmo: -jg_toplevel.cmx: -lexical.cmo: jg_tk.cmo lexical.cmi -lexical.cmx: jg_tk.cmx lexical.cmi -list2.cmo: -list2.cmx: -main.cmo: viewer.cmi shell.cmi searchpos.cmi searchid.cmi jg_config.cmi \ +editor.cmo : ../labltk/wm.cmi ../labltk/winfo.cmi ../support/widget.cmi \ + viewer.cmi ../../../typing/types.cmi typecheck.cmi ../labltk/toplevel.cmi \ + ../labltk/tk.cmo ../support/timer.cmi ../support/textvariable.cmi \ + ../labltk/text.cmi shell.cmi setpath.cmi ../labltk/selection.cmi \ + searchpos.cmi searchid.cmi ../support/protocol.cmi \ + ../../../parsing/parsetree.cmi ../../../parsing/parser.cmi \ + ../labltk/pack.cmi mytypes.cmi ../labltk/menu.cmi \ + ../../../parsing/longident.cmi ../../../parsing/location.cmi \ + ../labltk/listbox.cmi lexical.cmi ../../../parsing/lexer.cmi \ + ../labltk/label.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_message.cmi \ + jg_menu.cmo jg_button.cmo jg_bind.cmi ../../../typing/ident.cmi \ + ../labltk/frame.cmi ../labltk/focus.cmi fileselect.cmi \ + ../../../typing/env.cmi ../labltk/entry.cmi ../labltk/clipboard.cmi \ + ../../../utils/clflags.cmi ../labltk/checkbutton.cmi ../labltk/button.cmi \ editor.cmi -main.cmx: viewer.cmx shell.cmx searchpos.cmx searchid.cmx jg_config.cmx \ - editor.cmx -searchid.cmo: list2.cmo searchid.cmi -searchid.cmx: list2.cmx searchid.cmi -searchpos.cmo: searchid.cmi lexical.cmi jg_tk.cmo jg_text.cmi jg_message.cmi \ - jg_memo.cmi jg_bind.cmi searchpos.cmi -searchpos.cmx: searchid.cmx lexical.cmx jg_tk.cmx jg_text.cmx jg_message.cmx \ - jg_memo.cmx jg_bind.cmx searchpos.cmi -setpath.cmo: useunix.cmi list2.cmo jg_toplevel.cmo jg_button.cmo jg_box.cmo \ - jg_bind.cmi setpath.cmi -setpath.cmx: useunix.cmx list2.cmx jg_toplevel.cmx jg_button.cmx jg_box.cmx \ - jg_bind.cmx setpath.cmi -shell.cmo: list2.cmo lexical.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi \ - jg_message.cmi jg_menu.cmo jg_memo.cmi fileselect.cmi dummy.cmi shell.cmi -shell.cmx: list2.cmx lexical.cmx jg_toplevel.cmx jg_tk.cmx jg_text.cmx \ - jg_message.cmx jg_menu.cmx jg_memo.cmx fileselect.cmx dummy.cmi shell.cmi -typecheck.cmo: mytypes.cmi jg_tk.cmo jg_text.cmi jg_message.cmi typecheck.cmi -typecheck.cmx: mytypes.cmi jg_tk.cmx jg_text.cmx jg_message.cmx typecheck.cmi -useunix.cmo: useunix.cmi -useunix.cmx: useunix.cmi -viewer.cmo: useunix.cmi shell.cmi setpath.cmi searchpos.cmi searchid.cmi \ - mytypes.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_multibox.cmi \ - jg_message.cmi jg_menu.cmo jg_entry.cmo jg_completion.cmi jg_button.cmo \ - jg_box.cmo jg_bind.cmi help.cmo viewer.cmi -viewer.cmx: useunix.cmx shell.cmx setpath.cmx searchpos.cmx searchid.cmx \ - mytypes.cmi jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_multibox.cmx \ - jg_message.cmx jg_menu.cmx jg_entry.cmx jg_completion.cmx jg_button.cmx \ - jg_box.cmx jg_bind.cmx help.cmx viewer.cmi -dummy.cmi: -dummyUnix.cmi: -dummyWin.cmi: -editor.cmi: -fileselect.cmi: -jg_bind.cmi: -jg_completion.cmi: -jg_config.cmi: -jg_memo.cmi: -jg_message.cmi: -jg_multibox.cmi: -jg_text.cmi: -lexical.cmi: -mytypes.cmi: shell.cmi -searchid.cmi: -searchpos.cmi: -setpath.cmi: -shell.cmi: -typecheck.cmi: mytypes.cmi -useunix.cmi: -viewer.cmi: +editor.cmx : ../labltk/wm.cmx ../labltk/winfo.cmx ../support/widget.cmx \ + viewer.cmx ../../../typing/types.cmx typecheck.cmx ../labltk/toplevel.cmx \ + ../labltk/tk.cmx ../support/timer.cmx ../support/textvariable.cmx \ + ../labltk/text.cmx shell.cmx setpath.cmx ../labltk/selection.cmx \ + searchpos.cmx searchid.cmx ../support/protocol.cmx \ + ../../../parsing/parsetree.cmi ../../../parsing/parser.cmx \ + ../labltk/pack.cmx mytypes.cmi ../labltk/menu.cmx \ + ../../../parsing/longident.cmx ../../../parsing/location.cmx \ + ../labltk/listbox.cmx lexical.cmx ../../../parsing/lexer.cmx \ + ../labltk/label.cmx jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_message.cmx \ + jg_menu.cmx jg_button.cmx jg_bind.cmx ../../../typing/ident.cmx \ + ../labltk/frame.cmx ../labltk/focus.cmx fileselect.cmx \ + ../../../typing/env.cmx ../labltk/entry.cmx ../labltk/clipboard.cmx \ + ../../../utils/clflags.cmx ../labltk/checkbutton.cmx ../labltk/button.cmx \ + editor.cmi +fileselect.cmo : useunix.cmi ../labltk/tkwait.cmi ../labltk/tk.cmo \ + ../support/textvariable.cmi setpath.cmi ../labltk/pack.cmi \ + ../../../utils/misc.cmi ../labltk/listbox.cmi list2.cmo \ + ../labltk/label.cmi jg_toplevel.cmo jg_memo.cmi jg_entry.cmo jg_box.cmo \ + ../labltk/grab.cmi ../labltk/frame.cmi ../labltk/focus.cmi \ + ../../../utils/config.cmi ../labltk/checkbutton.cmi ../labltk/button.cmi \ + fileselect.cmi +fileselect.cmx : useunix.cmx ../labltk/tkwait.cmx ../labltk/tk.cmx \ + ../support/textvariable.cmx setpath.cmx ../labltk/pack.cmx \ + ../../../utils/misc.cmx ../labltk/listbox.cmx list2.cmx \ + ../labltk/label.cmx jg_toplevel.cmx jg_memo.cmx jg_entry.cmx jg_box.cmx \ + ../labltk/grab.cmx ../labltk/frame.cmx ../labltk/focus.cmx \ + ../../../utils/config.cmx ../labltk/checkbutton.cmx ../labltk/button.cmx \ + fileselect.cmi +help.cmo : +help.cmx : +jg_bind.cmo : ../labltk/tk.cmo ../labltk/focus.cmi ../labltk/button.cmi \ + jg_bind.cmi +jg_bind.cmx : ../labltk/tk.cmx ../labltk/focus.cmx ../labltk/button.cmx \ + jg_bind.cmi +jg_box.cmo : ../labltk/winfo.cmi ../labltk/tk.cmo ../labltk/scrollbar.cmi \ + ../labltk/listbox.cmi jg_completion.cmi jg_bind.cmi ../labltk/frame.cmi +jg_box.cmx : ../labltk/winfo.cmx ../labltk/tk.cmx ../labltk/scrollbar.cmx \ + ../labltk/listbox.cmx jg_completion.cmx jg_bind.cmx ../labltk/frame.cmx +jg_button.cmo : ../labltk/tk.cmo ../labltk/button.cmi +jg_button.cmx : ../labltk/tk.cmx ../labltk/button.cmx +jg_completion.cmo : ../support/timer.cmi jg_completion.cmi +jg_completion.cmx : ../support/timer.cmx jg_completion.cmi +jg_config.cmo : ../support/widget.cmi ../labltk/option.cmi jg_tk.cmo \ + jg_config.cmi +jg_config.cmx : ../support/widget.cmx ../labltk/option.cmx jg_tk.cmx \ + jg_config.cmi +jg_entry.cmo : ../labltk/tk.cmo jg_bind.cmi ../labltk/entry.cmi +jg_entry.cmx : ../labltk/tk.cmx jg_bind.cmx ../labltk/entry.cmx +jg_memo.cmo : jg_memo.cmi +jg_memo.cmx : jg_memo.cmi +jg_menu.cmo : ../labltk/toplevel.cmi ../labltk/tk.cmo ../labltk/menu.cmi +jg_menu.cmx : ../labltk/toplevel.cmx ../labltk/tk.cmx ../labltk/menu.cmx +jg_message.cmo : ../labltk/wm.cmi ../labltk/tkwait.cmi ../labltk/tk.cmo \ + ../support/textvariable.cmi ../labltk/text.cmi ../labltk/message.cmi \ + jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_bind.cmi ../labltk/grab.cmi \ + ../labltk/frame.cmi ../labltk/button.cmi jg_message.cmi +jg_message.cmx : ../labltk/wm.cmx ../labltk/tkwait.cmx ../labltk/tk.cmx \ + ../support/textvariable.cmx ../labltk/text.cmx ../labltk/message.cmx \ + jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_bind.cmx ../labltk/grab.cmx \ + ../labltk/frame.cmx ../labltk/button.cmx jg_message.cmi +jg_multibox.cmo : ../labltk/tk.cmo ../labltk/scrollbar.cmi \ + ../labltk/listbox.cmi jg_completion.cmi jg_bind.cmi ../labltk/focus.cmi \ + jg_multibox.cmi +jg_multibox.cmx : ../labltk/tk.cmx ../labltk/scrollbar.cmx \ + ../labltk/listbox.cmx jg_completion.cmx jg_bind.cmx ../labltk/focus.cmx \ + jg_multibox.cmi +jg_text.cmo : ../labltk/wm.cmi ../labltk/winfo.cmi ../labltk/tk.cmo \ + ../support/textvariable.cmi ../labltk/text.cmi ../labltk/scrollbar.cmi \ + ../labltk/radiobutton.cmi ../support/protocol.cmi ../labltk/label.cmi \ + jg_toplevel.cmo jg_tk.cmo jg_button.cmo jg_bind.cmi ../labltk/frame.cmi \ + ../labltk/focus.cmi ../labltk/entry.cmi ../labltk/button.cmi jg_text.cmi +jg_text.cmx : ../labltk/wm.cmx ../labltk/winfo.cmx ../labltk/tk.cmx \ + ../support/textvariable.cmx ../labltk/text.cmx ../labltk/scrollbar.cmx \ + ../labltk/radiobutton.cmx ../support/protocol.cmx ../labltk/label.cmx \ + jg_toplevel.cmx jg_tk.cmx jg_button.cmx jg_bind.cmx ../labltk/frame.cmx \ + ../labltk/focus.cmx ../labltk/entry.cmx ../labltk/button.cmx jg_text.cmi +jg_tk.cmo : ../labltk/tk.cmo +jg_tk.cmx : ../labltk/tk.cmx +jg_toplevel.cmo : ../labltk/wm.cmi ../support/widget.cmi \ + ../labltk/toplevel.cmi ../labltk/tk.cmo +jg_toplevel.cmx : ../labltk/wm.cmx ../support/widget.cmx \ + ../labltk/toplevel.cmx ../labltk/tk.cmx +lexical.cmo : ../labltk/tk.cmo ../labltk/text.cmi \ + ../../../parsing/parser.cmi ../../../parsing/location.cmi \ + ../../../parsing/lexer.cmi jg_tk.cmo lexical.cmi +lexical.cmx : ../labltk/tk.cmx ../labltk/text.cmx \ + ../../../parsing/parser.cmx ../../../parsing/location.cmx \ + ../../../parsing/lexer.cmx jg_tk.cmx lexical.cmi +list2.cmo : +list2.cmx : +main.cmo : ../../../utils/warnings.cmi viewer.cmi ../labltk/tk.cmo shell.cmi \ + searchpos.cmi searchid.cmi ../support/protocol.cmi \ + ../../../utils/misc.cmi ../labltk/message.cmi jg_config.cmi \ + ../../../typing/env.cmi editor.cmi ../../../utils/config.cmi \ + ../../../utils/clflags.cmi ../labltk/button.cmi +main.cmx : ../../../utils/warnings.cmx viewer.cmx ../labltk/tk.cmx shell.cmx \ + searchpos.cmx searchid.cmx ../support/protocol.cmx \ + ../../../utils/misc.cmx ../labltk/message.cmx jg_config.cmx \ + ../../../typing/env.cmx editor.cmx ../../../utils/config.cmx \ + ../../../utils/clflags.cmx ../labltk/button.cmx +searchid.cmo : ../../../typing/typetexp.cmi ../../../typing/types.cmi \ + ../../../typing/typemod.cmi ../../../typing/typedtree.cmi \ + ../../../parsing/syntaxerr.cmi ../../../typing/path.cmi \ + ../../../parsing/parsetree.cmi ../../../parsing/parse.cmi \ + ../../../parsing/longident.cmi ../../../parsing/location.cmi list2.cmo \ + ../../../parsing/lexer.cmi ../../../typing/ident.cmi \ + ../../../typing/env.cmi ../../../typing/ctype.cmi \ + ../../../typing/btype.cmi ../../../parsing/asttypes.cmi searchid.cmi +searchid.cmx : ../../../typing/typetexp.cmx ../../../typing/types.cmx \ + ../../../typing/typemod.cmx ../../../typing/typedtree.cmx \ + ../../../parsing/syntaxerr.cmx ../../../typing/path.cmx \ + ../../../parsing/parsetree.cmi ../../../parsing/parse.cmx \ + ../../../parsing/longident.cmx ../../../parsing/location.cmx list2.cmx \ + ../../../parsing/lexer.cmx ../../../typing/ident.cmx \ + ../../../typing/env.cmx ../../../typing/ctype.cmx \ + ../../../typing/btype.cmx ../../../parsing/asttypes.cmi searchid.cmi +searchpos.cmo : ../labltk/wm.cmi ../labltk/winfo.cmi ../support/widget.cmi \ + ../../../typing/typetexp.cmi ../../../typing/types.cmi \ + ../../../typing/typemod.cmi ../../../typing/typedtree.cmi \ + ../../../typing/typedecl.cmi ../../../typing/typeclass.cmi \ + ../labltk/tk.cmo ../labltk/text.cmi ../../../parsing/syntaxerr.cmi \ + ../support/support.cmi ../../../typing/stypes.cmi searchid.cmi \ + ../../../typing/printtyp.cmi ../../../typing/path.cmi \ + ../../../parsing/parsetree.cmi ../../../parsing/parse.cmi \ + ../labltk/pack.cmi ../labltk/option.cmi ../../../utils/misc.cmi \ + ../labltk/menu.cmi ../../../parsing/longident.cmi \ + ../../../parsing/location.cmi lexical.cmi ../../../parsing/lexer.cmi \ + ../labltk/label.cmi jg_tk.cmo jg_text.cmi jg_message.cmi jg_memo.cmi \ + jg_bind.cmi ../../../typing/ident.cmi ../../../typing/env.cmi \ + ../../../typing/ctype.cmi ../../../utils/config.cmi ../labltk/button.cmi \ + ../../../parsing/asttypes.cmi searchpos.cmi +searchpos.cmx : ../labltk/wm.cmx ../labltk/winfo.cmx ../support/widget.cmx \ + ../../../typing/typetexp.cmx ../../../typing/types.cmx \ + ../../../typing/typemod.cmx ../../../typing/typedtree.cmx \ + ../../../typing/typedecl.cmx ../../../typing/typeclass.cmx \ + ../labltk/tk.cmx ../labltk/text.cmx ../../../parsing/syntaxerr.cmx \ + ../support/support.cmx ../../../typing/stypes.cmx searchid.cmx \ + ../../../typing/printtyp.cmx ../../../typing/path.cmx \ + ../../../parsing/parsetree.cmi ../../../parsing/parse.cmx \ + ../labltk/pack.cmx ../labltk/option.cmx ../../../utils/misc.cmx \ + ../labltk/menu.cmx ../../../parsing/longident.cmx \ + ../../../parsing/location.cmx lexical.cmx ../../../parsing/lexer.cmx \ + ../labltk/label.cmx jg_tk.cmx jg_text.cmx jg_message.cmx jg_memo.cmx \ + jg_bind.cmx ../../../typing/ident.cmx ../../../typing/env.cmx \ + ../../../typing/ctype.cmx ../../../utils/config.cmx ../labltk/button.cmx \ + ../../../parsing/asttypes.cmi searchpos.cmi +setpath.cmo : useunix.cmi ../labltk/tk.cmo ../support/textvariable.cmi \ + ../support/protocol.cmi ../labltk/listbox.cmi list2.cmo \ + ../labltk/label.cmi jg_toplevel.cmo jg_button.cmo jg_box.cmo jg_bind.cmi \ + ../labltk/frame.cmi ../labltk/entry.cmi ../../../utils/config.cmi \ + ../labltk/button.cmi setpath.cmi +setpath.cmx : useunix.cmx ../labltk/tk.cmx ../support/textvariable.cmx \ + ../support/protocol.cmx ../labltk/listbox.cmx list2.cmx \ + ../labltk/label.cmx jg_toplevel.cmx jg_button.cmx jg_box.cmx jg_bind.cmx \ + ../labltk/frame.cmx ../labltk/entry.cmx ../../../utils/config.cmx \ + ../labltk/button.cmx setpath.cmi +shell.cmo : ../labltk/winfo.cmi ../../../utils/warnings.cmi \ + ../labltk/toplevel.cmi ../labltk/tk.cmo ../support/timer.cmi \ + ../labltk/text.cmi ../labltk/menu.cmi list2.cmo lexical.cmi \ + jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_message.cmi jg_menu.cmo \ + jg_memo.cmi fileselect.cmi ../support/fileevent.cmi dummy.cmi \ + ../../../utils/config.cmi ../../../utils/clflags.cmi shell.cmi +shell.cmx : ../labltk/winfo.cmx ../../../utils/warnings.cmx \ + ../labltk/toplevel.cmx ../labltk/tk.cmx ../support/timer.cmx \ + ../labltk/text.cmx ../labltk/menu.cmx list2.cmx lexical.cmx \ + jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_message.cmx jg_menu.cmx \ + jg_memo.cmx fileselect.cmx ../support/fileevent.cmx dummy.cmi \ + ../../../utils/config.cmx ../../../utils/clflags.cmx shell.cmi +typecheck.cmo : ../../../typing/typetexp.cmi ../../../typing/typemod.cmi \ + ../../../typing/typedtree.cmi ../../../typing/typedecl.cmi \ + ../../../typing/typecore.cmi ../../../typing/typeclass.cmi \ + ../labltk/tk.cmo ../labltk/text.cmi ../../../parsing/syntaxerr.cmi \ + ../../../typing/stypes.cmi ../../../parsing/parsetree.cmi \ + ../../../parsing/parse.cmi mytypes.cmi ../../../utils/misc.cmi \ + ../../../parsing/location.cmi ../../../parsing/lexer.cmi jg_tk.cmo \ + jg_text.cmi jg_message.cmi ../../../typing/includemod.cmi \ + ../../../typing/env.cmi ../../../typing/ctype.cmi \ + ../../../utils/config.cmi ../../../typing/cmi_format.cmi \ + ../../../utils/clflags.cmi ../../../utils/ccomp.cmi typecheck.cmi +typecheck.cmx : ../../../typing/typetexp.cmx ../../../typing/typemod.cmx \ + ../../../typing/typedtree.cmx ../../../typing/typedecl.cmx \ + ../../../typing/typecore.cmx ../../../typing/typeclass.cmx \ + ../labltk/tk.cmx ../labltk/text.cmx ../../../parsing/syntaxerr.cmx \ + ../../../typing/stypes.cmx ../../../parsing/parsetree.cmi \ + ../../../parsing/parse.cmx mytypes.cmi ../../../utils/misc.cmx \ + ../../../parsing/location.cmx ../../../parsing/lexer.cmx jg_tk.cmx \ + jg_text.cmx jg_message.cmx ../../../typing/includemod.cmx \ + ../../../typing/env.cmx ../../../typing/ctype.cmx \ + ../../../utils/config.cmx ../../../typing/cmi_format.cmx \ + ../../../utils/clflags.cmx ../../../utils/ccomp.cmx typecheck.cmi +useunix.cmo : useunix.cmi +useunix.cmx : useunix.cmi +viewer.cmo : ../labltk/wm.cmi useunix.cmi ../../../typing/types.cmi \ + ../../../typing/typedtree.cmi ../labltk/toplevel.cmi ../labltk/tk.cmo \ + ../support/textvariable.cmi ../labltk/text.cmi shell.cmi setpath.cmi \ + searchpos.cmi searchid.cmi ../labltk/radiobutton.cmi \ + ../support/protocol.cmi ../../../typing/predef.cmi \ + ../../../typing/path.cmi ../labltk/pack.cmi mytypes.cmi \ + ../labltk/menu.cmi ../../../parsing/longident.cmi \ + ../../../parsing/location.cmi ../labltk/listbox.cmi ../labltk/label.cmi \ + jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_multibox.cmi jg_message.cmi \ + jg_menu.cmo jg_entry.cmo jg_completion.cmi jg_button.cmo jg_box.cmo \ + jg_bind.cmi ../../../typing/ident.cmi help.cmo ../labltk/frame.cmi \ + ../labltk/focus.cmi ../../../typing/env.cmi ../labltk/entry.cmi \ + ../../../utils/config.cmi ../../../typing/cmi_format.cmi \ + ../labltk/button.cmi viewer.cmi +viewer.cmx : ../labltk/wm.cmx useunix.cmx ../../../typing/types.cmx \ + ../../../typing/typedtree.cmx ../labltk/toplevel.cmx ../labltk/tk.cmx \ + ../support/textvariable.cmx ../labltk/text.cmx shell.cmx setpath.cmx \ + searchpos.cmx searchid.cmx ../labltk/radiobutton.cmx \ + ../support/protocol.cmx ../../../typing/predef.cmx \ + ../../../typing/path.cmx ../labltk/pack.cmx mytypes.cmi \ + ../labltk/menu.cmx ../../../parsing/longident.cmx \ + ../../../parsing/location.cmx ../labltk/listbox.cmx ../labltk/label.cmx \ + jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_multibox.cmx jg_message.cmx \ + jg_menu.cmx jg_entry.cmx jg_completion.cmx jg_button.cmx jg_box.cmx \ + jg_bind.cmx ../../../typing/ident.cmx help.cmx ../labltk/frame.cmx \ + ../labltk/focus.cmx ../../../typing/env.cmx ../labltk/entry.cmx \ + ../../../utils/config.cmx ../../../typing/cmi_format.cmx \ + ../labltk/button.cmx viewer.cmi +dummy.cmi : +dummyUnix.cmi : +dummyWin.cmi : +editor.cmi : ../support/widget.cmi +fileselect.cmi : +jg_bind.cmi : ../support/widget.cmi +jg_completion.cmi : +jg_config.cmi : +jg_memo.cmi : +jg_message.cmi : ../support/widget.cmi +jg_multibox.cmi : ../support/widget.cmi ../labltk/tk.cmo +jg_text.cmi : ../support/widget.cmi ../labltk/tk.cmo +lexical.cmi : ../support/widget.cmi ../labltk/tk.cmo +mytypes.cmi : ../support/widget.cmi ../../../typing/types.cmi \ + ../../../typing/typedtree.cmi ../support/textvariable.cmi \ + ../../../typing/stypes.cmi shell.cmi ../../../parsing/parsetree.cmi +searchid.cmi : ../../../typing/path.cmi ../../../parsing/parsetree.cmi \ + ../../../parsing/longident.cmi ../../../typing/env.cmi +searchpos.cmi : ../support/widget.cmi ../../../typing/types.cmi \ + ../../../typing/typedtree.cmi ../../../typing/stypes.cmi \ + ../../../typing/path.cmi ../../../parsing/parsetree.cmi \ + ../../../parsing/longident.cmi ../../../parsing/location.cmi \ + ../../../typing/env.cmi +setpath.cmi : ../support/widget.cmi +shell.cmi : ../support/widget.cmi +typecheck.cmi : ../support/widget.cmi mytypes.cmi +useunix.cmi : +viewer.cmi : ../support/widget.cmi ../../../parsing/longident.cmi \ + ../../../typing/env.cmi diff --git a/otherlibs/labltk/browser/Makefile.shared b/otherlibs/labltk/browser/Makefile.shared index 35b8edf7f1..53a4f0bb06 100644 --- a/otherlibs/labltk/browser/Makefile.shared +++ b/otherlibs/labltk/browser/Makefile.shared @@ -43,10 +43,10 @@ JG = jg_tk.cmo jg_config.cmo jg_bind.cmo jg_completion.cmo \ all: ocamlbrowser$(EXE) -ocamlbrowser$(EXE): $(TOPDIR)/toplevel/toplevellib.cma jglib.cma $(OBJ) \ +ocamlbrowser$(EXE): $(TOPDIR)/compilerlibs/ocamlcommon.cma jglib.cma $(OBJ) \ ../support/lib$(LIBNAME).$(A) $(XTRAOBJ) $(CAMLC) -o ocamlbrowser$(EXE) $(INCLUDES) \ - $(TOPDIR)/toplevel/toplevellib.cma \ + $(TOPDIR)/compilerlibs/ocamlcommon.cma \ unix.cma str.cma $(XTRALIBS) $(LIBNAME).cma jglib.cma \ $(OBJ) $(XTRAOBJ) @@ -69,10 +69,10 @@ clean: rm -f *.cm? ocamlbrowser$(EXE) dummy.mli *~ *.orig *.$(O) help.ml depend: help.ml - $(CAMLDEP) *.ml *.mli > .depend + $(CAMLDEP) $(LABLTKLIB) $(OCAMLTOPLIB) *.ml *.mli > .depend shell.cmo: dummy.cmi -setpath.cmo fileselect.cmo lexical.cmi searchid.cmi typecheck.cmi: $(TOPDIR)/toplevel/toplevellib.cma +setpath.cmo fileselect.cmo lexical.cmi searchid.cmi typecheck.cmi: $(TOPDIR)/compilerlibs/ocamlcommon.cma mytypes.cmi searchpos.cmi searchpos.cmo typecheck.cmo: $(TOPDIR)/typing/stypes.cmi include .depend diff --git a/otherlibs/labltk/browser/editor.ml b/otherlibs/labltk/browser/editor.ml index a9f7e6eace..90241c6b14 100644 --- a/otherlibs/labltk/browser/editor.ml +++ b/otherlibs/labltk/browser/editor.ml @@ -618,7 +618,7 @@ class editor ~top ~menus = object (self) (try Filename.chop_extension basename with _ -> basename) in let env = Env.add_module (Ident.create modname) - (Types.Tmty_signature txt.signature) + (Types.Mty_signature txt.signature) Env.initial in Viewer.view_defined (Longident.Lident modname) ~env ~show_all:true end; diff --git a/otherlibs/labltk/browser/mytypes.mli b/otherlibs/labltk/browser/mytypes.mli index b4deead236..217fc111cd 100644 --- a/otherlibs/labltk/browser/mytypes.mli +++ b/otherlibs/labltk/browser/mytypes.mli @@ -22,7 +22,7 @@ type edit_window = frame: frame widget; modified: Textvariable.textVariable; mutable shell: (string * Shell.shell) option; - mutable structure: Typedtree.structure; + mutable structure: Typedtree.structure_item list; mutable type_info: Stypes.annotation list; mutable signature: Types.signature; mutable psignature: Parsetree.signature; diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml index c8618e1c46..b714fe7cc7 100644 --- a/otherlibs/labltk/browser/searchid.ml +++ b/otherlibs/labltk/browser/searchid.ml @@ -14,6 +14,7 @@ (* $Id$ *) +open Asttypes open StdLabels open Location open Longident @@ -218,9 +219,9 @@ let rec search_type_in_signature t ~sign ~prefix ~mode = and lid_of_id id = mklid (prefix @ [Ident.name id]) in List2.flat_map sign ~f: begin fun item -> match item with - Tsig_value (id, vd) -> + Sig_value (id, vd) -> if matches vd.val_type then [lid_of_id id, Pvalue] else [] - | Tsig_type (id, td, _) -> + | Sig_type (id, td, _) -> if matches (newconstr (Pident id) td.type_params) || begin match td.type_manifest with @@ -239,23 +240,23 @@ let rec search_type_in_signature t ~sign ~prefix ~mode = List.exists l ~f:(fun (_, _, t) -> matches t) end then [lid_of_id id, Ptype] else [] - | Tsig_exception (id, l) -> - if List.exists l ~f:matches + | Sig_exception (id, l) -> + if List.exists l.exn_args ~f:matches then [lid_of_id id, Pconstructor] else [] - | Tsig_module (id, Tmty_signature sign, _) -> + | Sig_module (id, Mty_signature sign, _) -> search_type_in_signature t ~sign ~mode ~prefix:(prefix @ [Ident.name id]) - | Tsig_module _ -> [] - | Tsig_modtype _ -> [] - | Tsig_class (id, cl, _) -> + | Sig_module _ -> [] + | Sig_modtype _ -> [] + | Sig_class (id, cl, _) -> let self = self_type cl.cty_type in if matches self || (match cl.cty_new with None -> false | Some ty -> matches ty) (* || List.exists (get_fields ~prefix ~sign self) ~f:(fun (_,_,ty_field) -> matches ty_field) *) then [lid_of_id id, Pclass] else [] - | Tsig_cltype (id, cl, _) -> + | Sig_class_type (id, cl, _) -> let self = self_type cl.clty_type in if matches self (* || List.exists (get_fields ~prefix ~sign self) @@ -273,7 +274,7 @@ let search_all_types t ~mode = begin fun modname -> let mlid = Lident modname in try match lookup_module mlid initial with - _, Tmty_signature sign -> + _, Mty_signature sign -> List2.flat_map tl ~f:(search_type_in_signature ~sign ~prefix:[modname] ~mode) | _ -> [] @@ -286,12 +287,12 @@ let search_string_type text ~mode = try let sexp = Parse.interface (Lexing.from_string ("val z : " ^ text)) in let sign = - try Typemod.transl_signature !start_env sexp with _ -> + try (Typemod.transl_signature !start_env sexp).sig_type with _ -> let env = List.fold_left !module_list ~init:initial ~f: begin fun acc m -> try open_pers_signature m acc with Env.Error _ -> acc end in - try Typemod.transl_signature env sexp + try (Typemod.transl_signature env sexp).sig_type with Env.Error err -> [] | Typemod.Error (l,_,_) -> let start_c = l.loc_start.Lexing.pos_cnum in @@ -302,7 +303,7 @@ let search_string_type text ~mode = let end_c = l.loc_end.Lexing.pos_cnum in raise (Error (start_c - 8, end_c - 8)) in match sign with - [Tsig_value (_, vd)] -> + [ Sig_value (_, vd) ] -> search_all_types vd.val_type ~mode | _ -> [] with @@ -355,20 +356,20 @@ let search_pattern_symbol text = let l = List.map !module_list ~f: begin fun modname -> Lident modname, try match lookup_module (Lident modname) initial with - _, Tmty_signature sign -> + _, Mty_signature sign -> List2.flat_map sign ~f: begin function - Tsig_value (i, _) when check i -> [i, Pvalue] - | Tsig_type (i, _, _) when check i -> [i, Ptype] - | Tsig_exception (i, _) when check i -> [i, Pconstructor] - | Tsig_module (i, _, _) when check i -> [i, Pmodule] - | Tsig_modtype (i, _) when check i -> [i, Pmodtype] - | Tsig_class (i, cl, _) when check i + Sig_value (i, _) when check i -> [i, Pvalue] + | Sig_type (i, _, _) when check i -> [i, Ptype] + | Sig_exception (i, _) when check i -> [i, Pconstructor] + | Sig_module (i, _, _) when check i -> [i, Pmodule] + | Sig_modtype (i, _) when check i -> [i, Pmodtype] + | Sig_class (i, cl, _) when check i || List.exists (get_fields ~prefix:[modname] ~sign (self_type cl.cty_type)) ~f:(fun (name,_,_) -> check_match ~pattern (explode name)) -> [i, Pclass] - | Tsig_cltype (i, cl, _) when check i + | Sig_class_type (i, cl, _) when check i || List.exists (get_fields ~prefix:[modname] ~sign (self_type cl.clty_type)) ~f:(fun (name,_,_) -> check_match ~pattern (explode name)) @@ -412,8 +413,8 @@ open Parsetree let rec bound_variables pat = match pat.ppat_desc with Ppat_any | Ppat_constant _ | Ppat_type _ | Ppat_unpack _ -> [] - | Ppat_var s -> [s] - | Ppat_alias (pat,s) -> s :: bound_variables pat + | Ppat_var s -> [s.txt] + | Ppat_alias (pat,s) -> s.txt :: bound_variables pat | Ppat_tuple l -> List2.flat_map l ~f:bound_variables | Ppat_construct (_,None,_) -> [] | Ppat_construct (_,Some pat,_) -> bound_variables pat @@ -437,7 +438,7 @@ let search_structure str ~name ~kind ~prefix = List.fold_left ~init:[] str ~f: begin fun acc item -> match item.pstr_desc with - Pstr_module (s, mexp) when s = modu -> + Pstr_module (s, mexp) when s.txt = modu -> loc := mexp.pmod_loc.loc_start.Lexing.pos_cnum; begin match mexp.pmod_desc with Pmod_structure str -> str @@ -457,27 +458,27 @@ let search_structure str ~name ~kind ~prefix = then loc := pat.ppat_loc.loc_start.Lexing.pos_cnum end; false - | Pstr_primitive (s, _) when kind = Pvalue -> name = s + | Pstr_primitive (s, _) when kind = Pvalue -> name = s.txt | Pstr_type l when kind = Ptype -> List.iter l ~f: begin fun (s, td) -> - if s = name then loc := td.ptype_loc.loc_start.Lexing.pos_cnum + if s.txt = name then loc := td.ptype_loc.loc_start.Lexing.pos_cnum end; false - | Pstr_exception (s, _) when kind = Pconstructor -> name = s - | Pstr_module (s, _) when kind = Pmodule -> name = s - | Pstr_modtype (s, _) when kind = Pmodtype -> name = s + | Pstr_exception (s, _) when kind = Pconstructor -> name = s.txt + | Pstr_module (s, _) when kind = Pmodule -> name = s.txt + | Pstr_modtype (s, _) when kind = Pmodtype -> name = s.txt | Pstr_class l when kind = Pclass || kind = Ptype || kind = Pcltype -> List.iter l ~f: begin fun c -> - if c.pci_name = name + if c.pci_name.txt = name then loc := c.pci_loc.loc_start.Lexing.pos_cnum end; false | Pstr_class_type l when kind = Pcltype || kind = Ptype -> List.iter l ~f: begin fun c -> - if c.pci_name = name + if c.pci_name.txt = name then loc := c.pci_loc.loc_start.Lexing.pos_cnum end; false @@ -487,6 +488,8 @@ let search_structure str ~name ~kind ~prefix = !loc let search_signature sign ~name ~kind ~prefix = + ignore (name = ""); + ignore (prefix = [""]); let loc = ref 0 in let rec search_module_type sign ~prefix = match prefix with [] -> sign @@ -495,7 +498,7 @@ let search_signature sign ~name ~kind ~prefix = List.fold_left ~init:[] sign ~f: begin fun acc item -> match item.psig_desc with - Psig_module (s, mtyp) when s = modu -> + Psig_module (s, mtyp) when s.txt = modu -> loc := mtyp.pmty_loc.loc_start.Lexing.pos_cnum; begin match mtyp.pmty_desc with Pmty_signature sign -> sign @@ -508,27 +511,27 @@ let search_signature sign ~name ~kind ~prefix = List.iter (search_module_type sign ~prefix) ~f: begin fun item -> if match item.psig_desc with - Psig_value (s, _) when kind = Pvalue -> name = s + Psig_value (s, _) when kind = Pvalue -> name = s.txt | Psig_type l when kind = Ptype -> List.iter l ~f: begin fun (s, td) -> - if s = name then loc := td.ptype_loc.loc_start.Lexing.pos_cnum + if s.txt = name then loc := td.ptype_loc.loc_start.Lexing.pos_cnum end; false - | Psig_exception (s, _) when kind = Pconstructor -> name = s - | Psig_module (s, _) when kind = Pmodule -> name = s - | Psig_modtype (s, _) when kind = Pmodtype -> name = s + | Psig_exception (s, _) when kind = Pconstructor -> name = s.txt + | Psig_module (s, _) when kind = Pmodule -> name = s.txt + | Psig_modtype (s, _) when kind = Pmodtype -> name = s.txt | Psig_class l when kind = Pclass || kind = Ptype || kind = Pcltype -> List.iter l ~f: begin fun c -> - if c.pci_name = name + if c.pci_name.txt = name then loc := c.pci_loc.loc_start.Lexing.pos_cnum end; false | Psig_class_type l when kind = Ptype || kind = Pcltype -> List.iter l ~f: begin fun c -> - if c.pci_name = name + if c.pci_name.txt = name then loc := c.pci_loc.loc_start.Lexing.pos_cnum end; false diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml index d2d2b34edd..1383307036 100644 --- a/otherlibs/labltk/browser/searchpos.ml +++ b/otherlibs/labltk/browser/searchpos.ml @@ -14,6 +14,7 @@ (* $Id$ *) +open Asttypes open StdLabels open Support open Tk @@ -118,7 +119,7 @@ let rec search_pos_type t ~pos ~env = List.iter tl ~f:(search_pos_type ~pos ~env) | Ptyp_constr (lid, tl) -> List.iter tl ~f:(search_pos_type ~pos ~env); - add_found_sig (`Type, lid) ~env ~loc:t.ptyp_loc + add_found_sig (`Type, lid.txt) ~env ~loc:t.ptyp_loc | Ptyp_object fl -> List.iter fl ~f: begin function @@ -127,7 +128,7 @@ let rec search_pos_type t ~pos ~env = end | Ptyp_class (lid, tl, _) -> List.iter tl ~f:(search_pos_type ~pos ~env); - add_found_sig (`Type, lid) ~env ~loc:t.ptyp_loc + add_found_sig (`Type, lid.txt) ~env ~loc:t.ptyp_loc | Ptyp_alias (t, _) | Ptyp_poly (_, t) -> search_pos_type ~pos ~env t | Ptyp_package (_, stl) -> @@ -138,23 +139,23 @@ let rec search_pos_class_type cl ~pos ~env = if in_loc cl.pcty_loc ~pos then begin match cl.pcty_desc with Pcty_constr (lid, _) -> - add_found_sig (`Class, lid) ~env ~loc:cl.pcty_loc - | Pcty_signature (_, cfl) -> - List.iter cfl ~f: - begin function + add_found_sig (`Class, lid.txt) ~env ~loc:cl.pcty_loc + | Pcty_signature cl -> + List.iter cl.pcsig_fields ~f: (fun fl -> + begin match fl.pctf_desc with Pctf_inher cty -> search_pos_class_type cty ~pos ~env - | Pctf_val (_, _, _, ty, loc) -> - if in_loc loc ~pos then search_pos_type ty ~pos ~env - | Pctf_virt (_, _, ty, loc) -> - if in_loc loc ~pos then search_pos_type ty ~pos ~env - | Pctf_meth (_, _, ty, loc) -> - if in_loc loc ~pos then search_pos_type ty ~pos ~env - | Pctf_cstr (ty1, ty2, loc) -> - if in_loc loc ~pos then begin + | Pctf_val (_, _, _, ty) -> + if in_loc fl.pctf_loc ~pos then search_pos_type ty ~pos ~env + | Pctf_virt (_, _, ty) -> + if in_loc fl.pctf_loc ~pos then search_pos_type ty ~pos ~env + | Pctf_meth (_, _, ty) -> + if in_loc fl.pctf_loc ~pos then search_pos_type ty ~pos ~env + | Pctf_cstr (ty1, ty2) -> + if in_loc fl.pctf_loc ~pos then begin search_pos_type ty1 ~pos ~env; search_pos_type ty2 ~pos ~env end - end + end) | Pcty_fun (_, ty, cty) -> search_pos_type ty ~pos ~env; search_pos_class_type cty ~pos ~env @@ -187,13 +188,13 @@ let rec search_pos_signature l ~pos ~env = begin fun env pt -> let env = match pt.psig_desc with Psig_open id -> - let path, mt = lookup_module id env in + let path, mt = lookup_module id.txt env in begin match mt with - Tmty_signature sign -> open_signature path sign env + Mty_signature sign -> open_signature path sign env | _ -> env end | sign_item -> - try add_signature (Typemod.transl_signature env [pt]) env + try add_signature (Typemod.transl_signature env [pt]).sig_type env with Typemod.Error _ | Typeclass.Error _ | Typetexp.Error _ | Typedecl.Error _ -> env in @@ -219,7 +220,7 @@ let rec search_pos_signature l ~pos ~env = List.iter l ~f:(fun ci -> search_pos_class_type ci.pci_expr ~pos ~env) (* The last cases should not happen in generated interfaces *) - | Psig_open lid -> add_found_sig (`Module, lid) ~env ~loc:pt.psig_loc + | Psig_open lid -> add_found_sig (`Module, lid.txt) ~env ~loc:pt.psig_loc | Psig_include t -> search_pos_module t ~pos ~env end; env @@ -228,7 +229,7 @@ let rec search_pos_signature l ~pos ~env = and search_pos_module m ~pos ~env = if in_loc m.pmty_loc ~pos then begin begin match m.pmty_desc with - Pmty_ident lid -> add_found_sig (`Modtype, lid) ~env ~loc:m.pmty_loc + Pmty_ident lid -> add_found_sig (`Modtype, lid.txt) ~env ~loc:m.pmty_loc | Pmty_signature sg -> search_pos_signature sg ~pos ~env | Pmty_functor (_ , m1, m2) -> search_pos_module m1 ~pos ~env; @@ -240,7 +241,7 @@ and search_pos_module m ~pos ~env = _, Pwith_type t -> search_pos_type_decl t ~pos ~env | _ -> () end - | Pmty_typeof md -> + | Pmty_typeof md -> () (* TODO? *) end end @@ -292,13 +293,13 @@ let edit_source ~file ~path ~sign = [item] -> let id, kind = match item with - Tsig_value (id, _) -> id, Pvalue - | Tsig_type (id, _, _) -> id, Ptype - | Tsig_exception (id, _) -> id, Pconstructor - | Tsig_module (id, _, _) -> id, Pmodule - | Tsig_modtype (id, _) -> id, Pmodtype - | Tsig_class (id, _, _) -> id, Pclass - | Tsig_cltype (id, _, _) -> id, Pcltype + Sig_value (id, _) -> id, Pvalue + | Sig_type (id, _, _) -> id, Ptype + | Sig_exception (id, _) -> id, Pconstructor + | Sig_module (id, _, _) -> id, Pmodule + | Sig_modtype (id, _) -> id, Pmodtype + | Sig_class (id, _, _) -> id, Pclass + | Sig_class_type (id, _, _) -> id, Pcltype in let prefix = List.tl (list_of_path path) and name = Ident.name id in let pos = @@ -319,7 +320,7 @@ let edit_source ~file ~path ~sign = (* List of windows to destroy by Close All *) let top_widgets = ref [] -let dummy_item = Tsig_modtype (Ident.create "dummy", Tmodtype_abstract) +let dummy_item = Sig_modtype (Ident.create "dummy", Modtype_abstract) let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign = let env = @@ -398,6 +399,7 @@ let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign = match e with Syntaxerr.Unclosed(l,_,_,_) -> l | Syntaxerr.Applicative_path l -> l + | Syntaxerr.Variable_in_scope(l,_) -> l | Syntaxerr.Other l -> l in Jg_text.tag_and_see tw ~start:(tpos l.loc_start.Lexing.pos_cnum) @@ -441,11 +443,11 @@ and view_signature_item sign ~path ~env = and view_module path ~env = match find_module path env with - Tmty_signature sign -> + Mty_signature sign -> !view_defined_ref (Searchid.longident_of_path path) ~env | modtype -> let id = ident_of_path path ~default:"M" in - view_signature_item [Tsig_module (id, modtype, Trec_not)] ~path ~env + view_signature_item [Sig_module (id, modtype, Trec_not)] ~path ~env and view_module_id id ~env = let path, _ = lookup_module id env in @@ -458,12 +460,12 @@ and view_type_decl path ~env = {desc = Tobject _} -> let clt = find_cltype path env in view_signature_item ~path ~env - [Tsig_cltype(ident_of_path path ~default:"ct", clt, Trec_first); + [Sig_class_type(ident_of_path path ~default:"ct", clt, Trec_first); dummy_item; dummy_item] | _ -> raise Not_found with Not_found -> view_signature_item ~path ~env - [Tsig_type(ident_of_path path ~default:"t", td, Trec_first)] + [Sig_type(ident_of_path path ~default:"t", td, Trec_first)] and view_type_id li ~env = let path, decl = lookup_type li env in @@ -472,19 +474,19 @@ and view_type_id li ~env = and view_class_id li ~env = let path, cl = lookup_class li env in view_signature_item ~path ~env - [Tsig_class(ident_of_path path ~default:"c", cl, Trec_first); + [Sig_class(ident_of_path path ~default:"c", cl, Trec_first); dummy_item; dummy_item; dummy_item] and view_cltype_id li ~env = let path, clt = lookup_cltype li env in view_signature_item ~path ~env - [Tsig_cltype(ident_of_path path ~default:"ct", clt, Trec_first); + [Sig_class_type(ident_of_path path ~default:"ct", clt, Trec_first); dummy_item; dummy_item] and view_modtype_id li ~env = let path, td = lookup_modtype li env in view_signature_item ~path ~env - [Tsig_modtype(ident_of_path path ~default:"S", td)] + [Sig_modtype(ident_of_path path ~default:"S", td)] and view_expr_type ?title ?path ?env ?(name="noname") t = let title = @@ -496,8 +498,8 @@ and view_expr_type ?title ?path ?env ?(name="noname") t = | Some path -> parent_path path, ident_of_path path ~default:name in view_signature ~title ?path ?env - [Tsig_value (id, {val_type = t; val_kind = Val_reg; - val_loc = Location.none})] + [Sig_value (id, {val_type = t; val_kind = Val_reg; + Types.val_loc = Location.none})] and view_decl lid ~kind ~env = match kind with @@ -579,7 +581,7 @@ let view_type kind ~env = begin try let vd = find_value path env in view_signature_item ~path ~env - [Tsig_value(ident_of_path path ~default:"v", vd)] + [Sig_value(ident_of_path path ~default:"v", vd)] with Not_found -> view_expr_type ty ~path ~env end @@ -589,19 +591,19 @@ let view_type kind ~env = | `New path -> let cl = find_class path env in view_signature_item ~path ~env - [Tsig_class(ident_of_path path ~default:"c", cl, Trec_first)] + [Sig_class(ident_of_path path ~default:"c", cl, Trec_first)] end | `Class (path, cty) -> let cld = { cty_params = []; cty_variance = []; cty_type = cty; cty_path = path; cty_new = None } in view_signature_item ~path ~env - [Tsig_class(ident_of_path path ~default:"c", cld, Trec_first)] + [Sig_class(ident_of_path path ~default:"c", cld, Trec_first)] | `Module (path, mty) -> match mty with - Tmty_signature sign -> view_signature sign ~path ~env + Mty_signature sign -> view_signature sign ~path ~env | modtype -> view_signature_item ~path ~env - [Tsig_module(ident_of_path path ~default:"M", mty, Trec_not)] + [Sig_module(ident_of_path path ~default:"M", mty, Trec_not)] let view_type_menu kind ~env ~parent = let title = @@ -664,7 +666,7 @@ let add_found_str = add_found ~found:found_str let rec search_pos_structure ~pos str = List.iter str ~f: - begin function + begin function str -> match str.str_desc with Tstr_eval exp -> search_pos_expr exp ~pos | Tstr_value (rec_flag, l) -> List.iter l ~f: @@ -674,56 +676,59 @@ let rec search_pos_structure ~pos str = search_pos_pat pat ~pos ~env; search_pos_expr exp ~pos end - | Tstr_primitive (_, vd) ->() + | Tstr_primitive (_, _, vd) ->() | Tstr_type _ -> () | Tstr_exception _ -> () - | Tstr_exn_rebind(_, _) -> () - | Tstr_module (_, m) -> search_pos_module_expr m ~pos + | Tstr_exn_rebind(_, _, _, _) -> () + | Tstr_module (_, _, m) -> search_pos_module_expr m ~pos | Tstr_recmodule bindings -> - List.iter bindings ~f:(fun (_, m) -> search_pos_module_expr m ~pos) + List.iter bindings ~f:(fun (_, _, _, m) -> search_pos_module_expr m ~pos) | Tstr_modtype _ -> () | Tstr_open _ -> () | Tstr_class l -> - List.iter l ~f:(fun (id, _, _, cl, _) -> search_pos_class_expr cl ~pos) - | Tstr_cltype _ -> () + List.iter l ~f:(fun (cl, _, _) -> search_pos_class_expr cl.ci_expr ~pos) + | Tstr_class_type _ -> () | Tstr_include (m, _) -> search_pos_module_expr m ~pos end and search_pos_class_structure ~pos cls = - List.iter cls.cl_field ~f: - begin function - Cf_inher (cl, _, _) -> + List.iter cls.cstr_fields ~f: + begin function cf -> match cf.cf_desc with + Tcf_inher (_, cl, _, _, _) -> search_pos_class_expr cl ~pos - | Cf_val (_, _, Some exp, _) -> search_pos_expr exp ~pos - | Cf_val _ -> () - | Cf_meth (_, exp) -> search_pos_expr exp ~pos - | Cf_init exp -> search_pos_expr exp ~pos + | Tcf_val (_, _, _, _, Tcfk_concrete exp, _) -> search_pos_expr exp ~pos + | Tcf_val _ -> () + | Tcf_meth (_, _, _, Tcfk_concrete exp, _) -> search_pos_expr exp ~pos + | Tcf_init exp -> search_pos_expr exp ~pos + | Tcf_constr _ + | Tcf_meth _ + -> assert false (* TODO !!!!!!!!!!!!!!!!! *) end and search_pos_class_expr ~pos cl = if in_loc cl.cl_loc ~pos then begin begin match cl.cl_desc with - Tclass_ident path -> + Tcl_ident (path, _, _) -> add_found_str (`Class (path, cl.cl_type)) ~env:!start_env ~loc:cl.cl_loc - | Tclass_structure cls -> + | Tcl_structure cls -> search_pos_class_structure ~pos cls - | Tclass_fun (pat, iel, cl, _) -> + | Tcl_fun (_, pat, iel, cl, _) -> search_pos_pat pat ~pos ~env:pat.pat_env; - List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos); + List.iter iel ~f:(fun (_,_, exp) -> search_pos_expr exp ~pos); search_pos_class_expr cl ~pos - | Tclass_apply (cl, el) -> + | Tcl_apply (cl, el) -> search_pos_class_expr cl ~pos; - List.iter el ~f:(fun (x,_) -> Misc.may (search_pos_expr ~pos) x) - | Tclass_let (_, pel, iel, cl) -> + List.iter el ~f:(fun (_, x,_) -> Misc.may (search_pos_expr ~pos) x) + | Tcl_let (_, pel, iel, cl) -> List.iter pel ~f: begin fun (pat, exp) -> search_pos_pat pat ~pos ~env:exp.exp_env; search_pos_expr exp ~pos end; - List.iter iel ~f:(fun (_,exp) -> search_pos_expr exp ~pos); + List.iter iel ~f:(fun (_,_, exp) -> search_pos_expr exp ~pos); search_pos_class_expr cl ~pos - | Tclass_constraint (cl, _, _, _) -> + | Tcl_constraint (cl, _, _, _, _) -> search_pos_class_expr cl ~pos end; add_found_str (`Class (Pident (Ident.create "c"), cl.cl_type)) @@ -733,7 +738,7 @@ and search_pos_class_expr ~pos cl = and search_pos_expr ~pos exp = if in_loc exp.exp_loc ~pos then begin begin match exp.exp_desc with - Texp_ident (path, _) -> + Texp_ident (path, _, _) -> add_found_str (`Exp(`Val path, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc | Texp_constant v -> @@ -746,14 +751,14 @@ and search_pos_expr ~pos exp = search_pos_expr exp' ~pos end; search_pos_expr exp ~pos - | Texp_function (l, _) -> + | Texp_function (_, l, _) -> List.iter l ~f: begin fun (pat, exp) -> search_pos_pat pat ~pos ~env:exp.exp_env; search_pos_expr exp ~pos end | Texp_apply (exp, l) -> - List.iter l ~f:(fun (x,_) -> Misc.may (search_pos_expr ~pos) x); + List.iter l ~f:(fun (_, x,_) -> Misc.may (search_pos_expr ~pos) x); search_pos_expr exp ~pos | Texp_match (exp, l, _) -> search_pos_expr exp ~pos; @@ -770,14 +775,14 @@ and search_pos_expr ~pos exp = search_pos_expr exp ~pos end | Texp_tuple l -> List.iter l ~f:(search_pos_expr ~pos) - | Texp_construct (_, l) -> List.iter l ~f:(search_pos_expr ~pos) + | Texp_construct (_, _, _, l,_) -> List.iter l ~f:(search_pos_expr ~pos) | Texp_variant (_, None) -> () | Texp_variant (_, Some exp) -> search_pos_expr exp ~pos | Texp_record (l, opt) -> - List.iter l ~f:(fun (_, exp) -> search_pos_expr exp ~pos); + List.iter l ~f:(fun (_, _, _, exp) -> search_pos_expr exp ~pos); (match opt with None -> () | Some exp -> search_pos_expr exp ~pos) - | Texp_field (exp, _) -> search_pos_expr exp ~pos - | Texp_setfield (a, _, b) -> + | Texp_field (exp, _, _, _) -> search_pos_expr exp ~pos + | Texp_setfield (a, _, _, _, b) -> search_pos_expr a ~pos; search_pos_expr b ~pos | Texp_array l -> List.iter l ~f:(search_pos_expr ~pos) | Texp_ifthenelse (a, b, c) -> @@ -789,24 +794,24 @@ and search_pos_expr ~pos exp = search_pos_expr a ~pos; search_pos_expr b ~pos | Texp_while (a,b) -> search_pos_expr a ~pos; search_pos_expr b ~pos - | Texp_for (_, a, b, _, c) -> + | Texp_for (_, _, a, b, _, c) -> List.iter [a;b;c] ~f:(search_pos_expr ~pos) | Texp_when (a, b) -> search_pos_expr a ~pos; search_pos_expr b ~pos - | Texp_send (exp, _) -> search_pos_expr exp ~pos - | Texp_new (path, _) -> + | Texp_send (exp, _, _) -> search_pos_expr exp ~pos + | Texp_new (path, _, _) -> add_found_str (`Exp(`New path, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc - | Texp_instvar (_,path) -> + | Texp_instvar (_, path, _) -> add_found_str (`Exp(`Var path, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc - | Texp_setinstvar (_, path, exp) -> + | Texp_setinstvar (_, path, _, exp) -> search_pos_expr exp ~pos; add_found_str (`Exp(`Var path, exp.exp_type)) ~env:exp.exp_env ~loc:exp.exp_loc | Texp_override (_, l) -> - List.iter l ~f:(fun (_, exp) -> search_pos_expr exp ~pos) - | Texp_letmodule (id, modexp, exp) -> + List.iter l ~f:(fun (_, _, exp) -> search_pos_expr exp ~pos) + | Texp_letmodule (id, _, modexp, exp) -> search_pos_module_expr modexp ~pos; search_pos_expr exp ~pos | Texp_assertfalse -> () @@ -814,7 +819,7 @@ and search_pos_expr ~pos exp = search_pos_expr exp ~pos | Texp_lazy exp -> search_pos_expr exp ~pos - | Texp_object (cls, _, _) -> + | Texp_object (cls, _) -> search_pos_class_structure ~pos cls | Texp_pack modexp -> search_pos_module_expr modexp ~pos @@ -826,21 +831,21 @@ and search_pos_pat ~pos ~env pat = if in_loc pat.pat_loc ~pos then begin begin match pat.pat_desc with Tpat_any -> () - | Tpat_var id -> + | Tpat_var (id, _) -> add_found_str (`Exp(`Val (Pident id), pat.pat_type)) ~env ~loc:pat.pat_loc - | Tpat_alias (pat, _) -> search_pos_pat pat ~pos ~env + | Tpat_alias (pat, _, _) -> search_pos_pat pat ~pos ~env | Tpat_lazy pat -> search_pos_pat pat ~pos ~env | Tpat_constant _ -> add_found_str (`Exp(`Const, pat.pat_type)) ~env ~loc:pat.pat_loc | Tpat_tuple l -> List.iter l ~f:(search_pos_pat ~pos ~env) - | Tpat_construct (_, l) -> + | Tpat_construct (_, _, _, l, _) -> List.iter l ~f:(search_pos_pat ~pos ~env) | Tpat_variant (_, None, _) -> () | Tpat_variant (_, Some pat, _) -> search_pos_pat pat ~pos ~env - | Tpat_record l -> - List.iter l ~f:(fun (_, pat) -> search_pos_pat pat ~pos ~env) + | Tpat_record (l, _) -> + List.iter l ~f:(fun (_, _, _, pat) -> search_pos_pat pat ~pos ~env) | Tpat_array l -> List.iter l ~f:(search_pos_pat ~pos ~env) | Tpat_or (a, b, None) -> @@ -851,17 +856,17 @@ and search_pos_pat ~pos ~env pat = add_found_str (`Exp(`Pat, pat.pat_type)) ~env ~loc:pat.pat_loc end -and search_pos_module_expr ~pos m = +and search_pos_module_expr ~pos (m :module_expr) = if in_loc m.mod_loc ~pos then begin begin match m.mod_desc with - Tmod_ident path -> + Tmod_ident (path, _) -> add_found_str (`Module (path, m.mod_type)) ~env:m.mod_env ~loc:m.mod_loc - | Tmod_structure str -> search_pos_structure str ~pos - | Tmod_functor (_, _, m) -> search_pos_module_expr m ~pos + | Tmod_structure str -> search_pos_structure str.str_items ~pos + | Tmod_functor (_, _, _, m) -> search_pos_module_expr m ~pos | Tmod_apply (a, b, _) -> search_pos_module_expr a ~pos; search_pos_module_expr b ~pos - | Tmod_constraint (m, _, _) -> search_pos_module_expr m ~pos + | Tmod_constraint (m, _, _, _) -> search_pos_module_expr m ~pos | Tmod_unpack (e, _) -> search_pos_expr e ~pos end; add_found_str (`Module (Pident (Ident.create "M"), m.mod_type)) diff --git a/otherlibs/labltk/browser/typecheck.ml b/otherlibs/labltk/browser/typecheck.ml index fb2e559602..0faa282c81 100644 --- a/otherlibs/labltk/browser/typecheck.ml +++ b/otherlibs/labltk/browser/typecheck.ml @@ -17,6 +17,7 @@ open StdLabels open Tk open Parsetree +open Typedtree open Location open Jg_tk open Mytypes @@ -60,8 +61,7 @@ let parse_pp ~parse ~wrap ~ext text = let ic = open_in_bin tmpfile in let ast = try - let buffer = String.create (String.length ast_magic) in - really_input ic buffer 0 (String.length ast_magic); + let buffer = Misc.input_bytes ic (String.length ast_magic) in if buffer = ast_magic then begin ignore (input_value ic); wrap (input_value ic) @@ -73,7 +73,7 @@ let parse_pp ~parse ~wrap ~ext text = Outdated_version -> close_in ic; Sys.remove tmpfile; - failwith "Ocaml and preprocessor have incompatible versions" + failwith "OCaml and preprocessor have incompatible versions" | _ -> seek_in ic 0; let buffer = Lexing.from_channel ic in @@ -106,7 +106,7 @@ let f txt = let psign = parse_pp text ~ext:".mli" ~parse:Parse.interface ~wrap:(fun x -> x) in txt.psignature <- psign; - txt.signature <- Typemod.transl_signature !env psign + txt.signature <- (Typemod.transl_signature !env psign).sig_type; else (* others are interpreted as .ml *) @@ -116,7 +116,7 @@ let f txt = begin function Ptop_def pstr -> let str, sign, env' = Typemod.type_structure !env pstr Location.none in - txt.structure <- txt.structure @ str; + txt.structure <- txt.structure @ str.str_items; txt.signature <- txt.signature @ sign; env := env' | Ptop_dir _ -> () @@ -140,6 +140,7 @@ let f txt = begin match err with Syntaxerr.Unclosed(l,_,_,_) -> l | Syntaxerr.Applicative_path l -> l + | Syntaxerr.Variable_in_scope(l,_) -> l | Syntaxerr.Other l -> l end | Typecore.Error (l, env, err) -> @@ -156,6 +157,8 @@ let f txt = Includemod.report_error Format.std_formatter errl; Location.none | Env.Error err -> Env.report_error Format.std_formatter err; Location.none + | Cmi_format.Error err -> + Cmi_format.report_error Format.std_formatter err; Location.none | Ctype.Tags(l, l') -> Format.printf "In this program,@ variant constructors@ `%s and `%s@ have same hash value.@." l l'; Location.none diff --git a/otherlibs/labltk/browser/viewer.ml b/otherlibs/labltk/browser/viewer.ml index 6c0c9351f5..34ccfd7a25 100644 --- a/otherlibs/labltk/browser/viewer.ml +++ b/otherlibs/labltk/browser/viewer.ml @@ -61,20 +61,20 @@ let view_symbol ~kind ~env ?path id = match kind with Pvalue -> let path, vd = lookup_value id env in - view_signature_item ~path ~env [Tsig_value (Ident.create name, vd)] + view_signature_item ~path ~env [Sig_value (Ident.create name, vd)] | Ptype -> view_type_id id ~env - | Plabel -> let ld = lookup_label id env in + | Plabel -> let _,ld = lookup_label id env in begin match ld.lbl_res.desc with Tconstr (path, _, _) -> view_type_decl path ~env | _ -> () end | Pconstructor -> - let cd = lookup_constructor id env in + let _,cd = lookup_constructor id env in begin match cd.cstr_res.desc with Tconstr (cpath, _, _) -> if Path.same cpath Predef.path_exn then view_signature ~title:(string_of_longident id) ~env ?path - [Tsig_exception (Ident.create name, cd.cstr_args)] + [Sig_exception (Ident.create name, {Types.exn_loc = Location.none; exn_args = cd.cstr_args})] else view_type_decl cpath ~env | _ -> () @@ -217,23 +217,23 @@ let search_symbol () = (* Display the contents of a module *) let ident_of_decl ~modlid = function - Tsig_value (id, _) -> Lident (Ident.name id), Pvalue - | Tsig_type (id, _, _) -> Lident (Ident.name id), Ptype - | Tsig_exception (id, _) -> Ldot (modlid, Ident.name id), Pconstructor - | Tsig_module (id, _, _) -> Lident (Ident.name id), Pmodule - | Tsig_modtype (id, _) -> Lident (Ident.name id), Pmodtype - | Tsig_class (id, _, _) -> Lident (Ident.name id), Pclass - | Tsig_cltype (id, _, _) -> Lident (Ident.name id), Pcltype + Sig_value (id, _) -> Lident (Ident.name id), Pvalue + | Sig_type (id, _, _) -> Lident (Ident.name id), Ptype + | Sig_exception (id, _) -> Ldot (modlid, Ident.name id), Pconstructor + | Sig_module (id, _, _) -> Lident (Ident.name id), Pmodule + | Sig_modtype (id, _) -> Lident (Ident.name id), Pmodtype + | Sig_class (id, _, _) -> Lident (Ident.name id), Pclass + | Sig_class_type (id, _, _) -> Lident (Ident.name id), Pcltype let view_defined ~env ?(show_all=false) modlid = - try match lookup_module modlid env with path, Tmty_signature sign -> + try match lookup_module modlid env with path, Mty_signature sign -> let rec iter_sign sign idents = match sign with [] -> List.rev idents | decl :: rem -> let rem = match decl, rem with - Tsig_class _, cty :: ty1 :: ty2 :: rem -> rem - | Tsig_cltype _, ty1 :: ty2 :: rem -> rem + Sig_class _, cty :: ty1 :: ty2 :: rem -> rem + | Sig_class_type _, ty1 :: ty2 :: rem -> rem | _, rem -> rem in iter_sign rem (ident_of_decl ~modlid decl :: idents) in @@ -248,6 +248,10 @@ let view_defined ~env ?(show_all=false) modlid = let tl, tw, finish = Jg_message.formatted ~title:"Error!" () in Env.report_error Format.std_formatter err; finish () + | Cmi_format.Error err -> + let tl, tw, finish = Jg_message.formatted ~title:"Error!" () in + Cmi_format.report_error Format.std_formatter err; + finish () (* Manage toplevel windows *) diff --git a/otherlibs/labltk/compiler/compile.ml b/otherlibs/labltk/compiler/compile.ml index 2735deb87f..029cce70fb 100644 --- a/otherlibs/labltk/compiler/compile.ml +++ b/otherlibs/labltk/compiler/compile.ml @@ -548,7 +548,7 @@ let write_TKtoCAML ~w name ~def:typdef = (* Converters *) (******************************) -(* Produce an in-lined converter Caml -> Tk for simple types *) +(* Produce an in-lined converter OCaml -> Tk for simple types *) (* the converter is a function of type: <type> -> string *) let rec converterCAMLtoTK ~context_widget argname ty = match ty with diff --git a/otherlibs/labltk/examples_camltk/eyes.ml b/otherlibs/labltk/examples_camltk/eyes.ml index ba88af3436..b7636de42d 100644 --- a/otherlibs/labltk/examples_camltk/eyes.ml +++ b/otherlibs/labltk/examples_camltk/eyes.ml @@ -14,7 +14,7 @@ (* *) (***********************************************************************) -(* The eyes of Caml (CamlTk) *) +(* The eyes of OCaml (CamlTk) *) open Camltk;; diff --git a/otherlibs/labltk/frx/README b/otherlibs/labltk/frx/README index b86f8dcd85..65e5dc4c2d 100644 --- a/otherlibs/labltk/frx/README +++ b/otherlibs/labltk/frx/README @@ -1,2 +1,2 @@ This is Francois Rouaix's widget set library, Frx. -It uses CamlTk API.
\ No newline at end of file +It uses CamlTk API. diff --git a/otherlibs/labltk/frx/frx_mem.mli b/otherlibs/labltk/frx/frx_mem.mli index 4f17fa79de..190297b5e8 100644 --- a/otherlibs/labltk/frx/frx_mem.mli +++ b/otherlibs/labltk/frx/frx_mem.mli @@ -13,7 +13,7 @@ (* described in file LICENSE found in the OCaml source tree. *) (* *) (***********************************************************************) -(* A Garbage Collector Gauge for Caml *) +(* A Garbage Collector Gauge for OCaml *) val init : unit -> unit (* [init ()] creates the gauge and its updater, but keeps it iconified *) diff --git a/otherlibs/labltk/lib/Makefile b/otherlibs/labltk/lib/Makefile index 35ba8ff680..ac128baaa1 100644 --- a/otherlibs/labltk/lib/Makefile +++ b/otherlibs/labltk/lib/Makefile @@ -42,7 +42,13 @@ SUPPORT=../support/support.cmo ../support/rawwidget.cmo \ TKOBJS=$(SUPPORT) $(LABLTKOBJS) $(CAMLTKOBJS) -TOPDEPS = $(TOPDIR)/toplevel/toplevellib.cma $(TOPDIR)/toplevel/topmain.cmo +TOPLEVELLIBS=$(TOPDIR)/compilerlibs/ocamlcommon.cma \ + $(TOPDIR)/compilerlibs/ocamlbytecomp.cma \ + $(TOPDIR)/compilerlibs/ocamltoplevel.cma + +TOPLEVELSTART=$(TOPDIR)/toplevel/topstart.cmo + +TOPDEPS = $(TOPLEVELLIBS) $(TOPLEVELSTART) $(LIBNAME).cma: $(SUPPORT) ../Widgets.src $(MAKE) superclean @@ -50,7 +56,7 @@ $(LIBNAME).cma: $(SUPPORT) ../Widgets.src cd ../camltk; $(MAKE) $(MKLIB) -ocamlc '$(CAMLCB)' -o $(LIBNAME) \ -I ../labltk -I ../camltk $(TKOBJS) \ - -ccopt "\"$(TK_LINK)\"" + $(TK_LINK) $(LIBNAME).cmxa: $(SUPPORT:.cmo=.cmx) ../Widgets.src $(MAKE) superclean @@ -58,15 +64,15 @@ $(LIBNAME).cmxa: $(SUPPORT:.cmo=.cmx) ../Widgets.src cd ../camltk; $(MAKE) opt $(MKLIB) -ocamlopt '$(CAMLOPTB)' -o $(LIBNAME) -oc $(LIBNAME) \ -I ../labltk -I ../camltk $(TKOBJS:.cmo=.cmx) \ - -ccopt "\"$(TK_LINK)\"" + $(TK_LINK) $(LIBNAME)top$(EXE) : $(TOPDEPS) $(LIBNAME).cma ../support/lib$(LIBNAME).$(A) $(CAMLC) -verbose -linkall -o $(LIBNAME)top$(EXE) -I ../support \ - -I $(TOPDIR)/toplevel toplevellib.cma \ + $(TOPLEVELLIBS) \ -I $(OTHERS)/unix -I $(OTHERS)/win32unix unix.cma \ -I ../labltk -I ../camltk $(LIBNAME).cma \ -I $(OTHERS)/str str.cma \ - topstart.cmo + $(TOPLEVELSTART) $(LIBNAME): Makefile $(TOPDIR)/config/Makefile @echo Generate $@ diff --git a/otherlibs/labltk/lib/Makefile.nt b/otherlibs/labltk/lib/Makefile.nt index 67bf904edf..2b0b5ab535 100644 --- a/otherlibs/labltk/lib/Makefile.nt +++ b/otherlibs/labltk/lib/Makefile.nt @@ -1 +1 @@ -include Makefile
\ No newline at end of file +include Makefile diff --git a/otherlibs/labltk/lib/labltk.bat b/otherlibs/labltk/lib/labltk.bat index f760e80006..8020fafdde 100755 --- a/otherlibs/labltk/lib/labltk.bat +++ b/otherlibs/labltk/lib/labltk.bat @@ -1 +1 @@ -@ocaml -I +labltk labltk.cma %1 %2 %3 %4 %5 %6 %7 %8 %9
\ No newline at end of file +@ocaml -I +labltk labltk.cma %1 %2 %3 %4 %5 %6 %7 %8 %9 diff --git a/otherlibs/labltk/support/camltk.h b/otherlibs/labltk/support/camltk.h index 54671a075d..29452aacce 100644 --- a/otherlibs/labltk/support/camltk.h +++ b/otherlibs/labltk/support/camltk.h @@ -33,7 +33,7 @@ #endif /* cltkMisc.c */ -/* copy a Caml string to the C heap. Must be deallocated with stat_free */ +/* copy an OCaml string to the C heap. Must be deallocated with stat_free */ extern char *string_to_c(value s); /* cltkUtf.c */ @@ -45,7 +45,7 @@ CAMLTKextern Tcl_Interp *cltclinterp; /* The Tcl interpretor */ extern value copy_string_list(int argc, char **argv); /* cltkCaml.c */ -/* pointers to Caml values */ +/* pointers to OCaml values */ extern value *tkerror_exn; extern value *handler_code; extern int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp, diff --git a/otherlibs/labltk/support/cltkCaml.c b/otherlibs/labltk/support/cltkCaml.c index f0372f14b7..9a3d38a550 100644 --- a/otherlibs/labltk/support/cltkCaml.c +++ b/otherlibs/labltk/support/cltkCaml.c @@ -27,7 +27,7 @@ value * tkerror_exn = NULL; value * handler_code = NULL; -/* The Tcl command for evaluating callback in Caml */ +/* The Tcl command for evaluating callback in OCaml */ int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp, int argc, CONST84 char **argv) { @@ -41,7 +41,7 @@ int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp, return TCL_ERROR; callback2(*handler_code,Val_int(id), copy_string_list(argc - 2,(char **)&argv[2])); - /* Never fails (Caml would have raised an exception) */ + /* Never fails (OCaml would have raised an exception) */ /* but result may have been set by callback */ return TCL_OK; } @@ -69,14 +69,14 @@ CAMLprim void tk_error(char *errmsg) } -/* The initialisation of the C global variables pointing to Caml values - must be made accessible from Caml, so that we are sure that it *always* +/* The initialisation of the C global variables pointing to OCaml values + must be made accessible from OCaml, so that we are sure that it *always* takes place during loading of the protocol module */ CAMLprim value camltk_init(value v) { - /* Initialize the Caml pointers */ + /* Initialize the OCaml pointers */ if (tkerror_exn == NULL) tkerror_exn = caml_named_value("tkerror"); if (handler_code == NULL) diff --git a/otherlibs/labltk/support/cltkDMain.c b/otherlibs/labltk/support/cltkDMain.c index 7edb92a98d..04af209de3 100644 --- a/otherlibs/labltk/support/cltkDMain.c +++ b/otherlibs/labltk/support/cltkDMain.c @@ -35,7 +35,7 @@ /* - * Dealing with signals: when a signal handler is defined in Caml, + * Dealing with signals: when a signal handler is defined in OCaml, * the actual execution of the signal handler upon reception of the * signal is delayed until we are sure we are out of the GC. * If a signal occurs during the MainLoop, we would have to wait diff --git a/otherlibs/labltk/support/cltkEval.c b/otherlibs/labltk/support/cltkEval.c index 282d2f44c8..69ba6d8a17 100644 --- a/otherlibs/labltk/support/cltkEval.c +++ b/otherlibs/labltk/support/cltkEval.c @@ -32,7 +32,7 @@ /* The Tcl interpretor */ Tcl_Interp *cltclinterp = NULL; -/* Copy a list of strings from the C heap to Caml */ +/* Copy a list of strings from the C heap to OCaml */ value copy_string_list(int argc, char **argv) { CAMLparam0(); @@ -53,7 +53,7 @@ value copy_string_list(int argc, char **argv) } /* - * Calling Tcl from Caml + * Calling Tcl from OCaml * this version works on an arbitrary Tcl command, * and does parsing and substitution */ @@ -65,7 +65,7 @@ CAMLprim value camltk_tcl_eval(value str) CheckInit(); /* Tcl_Eval may write to its argument, so we take a copy - * If the evaluation raises a Caml exception, we have a space + * If the evaluation raises an OCaml exception, we have a space * leak */ Tcl_ResetResult(cltclinterp); @@ -84,7 +84,7 @@ CAMLprim value camltk_tcl_eval(value str) } /* - * Calling Tcl from Caml + * Calling Tcl from OCaml * direct call, argument is TkArgs vect type TkArgs = TkToken of string @@ -142,7 +142,7 @@ int fill_args (char **argv, int where, value v) tmpargv = (char **)stat_alloc((size + 1) * sizeof(char *)); fill_args(tmpargv,0,Field(v,0)); tmpargv[size] = NULL; - merged = Tcl_Merge(size,tmpargv); + merged = Tcl_Merge(size,(const char *const*)tmpargv); for(i = 0; i<size; i++){ stat_free(tmpargv[i]); } stat_free((char *)tmpargv); /* must be freed by stat_free */ @@ -207,17 +207,17 @@ CAMLprim value camltk_tcl_direct_eval(value v) result = Tcl_Eval(cltclinterp, Tcl_DStringValue(&buf)); Tcl_DStringFree(&buf); } else { - result = (*info.proc)(info.clientData,cltclinterp,size,argv); + result = (*info.proc)(info.clientData,cltclinterp,size,(const char**)argv); } #else - result = (*info.proc)(info.clientData,cltclinterp,size,argv); + result = (*info.proc)(info.clientData,cltclinterp,size,(const char**)argv); #endif } else { /* implement the autoload stuff */ if (Tcl_GetCommandInfo(cltclinterp,"unknown",&info)) { /* unknown found */ for (i = size; i >= 0; i--) argv[i+1] = argv[i]; argv[0] = "unknown"; - result = (*info.proc)(info.clientData,cltclinterp,size+1,argv); + result = (*info.proc)(info.clientData,cltclinterp,size+1,(const char**)argv); } else { /* ah, it isn't there at all */ result = TCL_ERROR; Tcl_AppendResult(cltclinterp, "Unknown command \"", diff --git a/otherlibs/labltk/support/cltkFile.c b/otherlibs/labltk/support/cltkFile.c index b4ebca6144..c01f39545f 100644 --- a/otherlibs/labltk/support/cltkFile.c +++ b/otherlibs/labltk/support/cltkFile.c @@ -16,10 +16,6 @@ /* $Id$ */ -#ifdef __CYGWIN__ -#define _WIN32 -#endif - #ifdef _WIN32 #include <wtypes.h> #include <winbase.h> diff --git a/otherlibs/labltk/support/cltkImg.c b/otherlibs/labltk/support/cltkImg.c index 7f47760dff..0a0fa17c5c 100644 --- a/otherlibs/labltk/support/cltkImg.c +++ b/otherlibs/labltk/support/cltkImg.c @@ -90,7 +90,7 @@ camltk_setimgdata_native (value imgname, value pixmap, value x, value y, tk_error("no such image"); #endif - pib.pixelPtr = String_val(pixmap); + pib.pixelPtr = (unsigned char *)String_val(pixmap); pib.width = Int_val(w); pib.height = Int_val(h); pib.pitch = pib.width * 3; diff --git a/otherlibs/labltk/support/cltkMain.c b/otherlibs/labltk/support/cltkMain.c index 5886e2cc33..8751334c51 100644 --- a/otherlibs/labltk/support/cltkMain.c +++ b/otherlibs/labltk/support/cltkMain.c @@ -35,7 +35,7 @@ #endif /* - * Dealing with signals: when a signal handler is defined in Caml, + * Dealing with signals: when a signal handler is defined in OCaml, * the actual execution of the signal handler upon reception of the * signal is delayed until we are sure we are out of the GC. * If a signal occurs during the MainLoop, we would have to wait @@ -125,7 +125,7 @@ CAMLprim value camltk_opentk(value argv) sprintf( argcstr, "%d", argc ); Tcl_SetVar(cltclinterp, "argc", argcstr, TCL_GLOBAL_ONLY); - args = Tcl_Merge(argc, tkargv); /* args must be freed by Tcl_Free */ + args = Tcl_Merge(argc, (const char *const*)tkargv); /* args must be freed by Tcl_Free */ Tcl_SetVar(cltclinterp, "argv", args, TCL_GLOBAL_ONLY); Tcl_Free(args); stat_free( tkargv ); diff --git a/otherlibs/labltk/support/cltkMisc.c b/otherlibs/labltk/support/cltkMisc.c index e5360aa209..a89ea341f1 100644 --- a/otherlibs/labltk/support/cltkMisc.c +++ b/otherlibs/labltk/support/cltkMisc.c @@ -35,7 +35,7 @@ CAMLprim value camltk_splitlist (value v) utf = caml_string_to_tcl(v); /* argv is allocated by Tcl, to be freed by us */ - result = Tcl_SplitList(cltclinterp,utf,&argc,&argv); + result = Tcl_SplitList(cltclinterp,utf,&argc,(const char ***)&argv); switch(result) { case TCL_OK: { value res = copy_string_list(argc,argv); @@ -51,7 +51,7 @@ CAMLprim value camltk_splitlist (value v) } } -/* Copy a Caml string to the C heap. Should deallocate with stat_free */ +/* Copy an OCaml string to the C heap. Should deallocate with stat_free */ char *string_to_c(value s) { int l = string_length(s); diff --git a/otherlibs/labltk/support/cltkTimer.c b/otherlibs/labltk/support/cltkTimer.c index 380dde3ed5..afebef8e1d 100644 --- a/otherlibs/labltk/support/cltkTimer.c +++ b/otherlibs/labltk/support/cltkTimer.c @@ -34,11 +34,11 @@ CAMLprim value camltk_add_timer(value milli, value cbid) CheckInit(); /* look at tkEvent.c , Tk_Token is an int */ return (Val_int(Tcl_CreateTimerHandler(Int_val(milli), TimerProc, - (ClientData) (Int_val(cbid))))); + (ClientData) (Long_val(cbid))))); } CAMLprim value camltk_rem_timer(value token) { - Tcl_DeleteTimerHandler((Tcl_TimerToken) Int_val(token)); + Tcl_DeleteTimerHandler((Tcl_TimerToken) Long_val(token)); return Val_unit; } diff --git a/otherlibs/labltk/support/cltkVar.c b/otherlibs/labltk/support/cltkVar.c index 96af9d21d1..e647d9d672 100644 --- a/otherlibs/labltk/support/cltkVar.c +++ b/otherlibs/labltk/support/cltkVar.c @@ -33,13 +33,13 @@ CAMLprim value camltk_getvar(value var) CheckInit(); stable_var = string_to_c(var); - s = Tcl_GetVar(cltclinterp,stable_var, - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); + s = (char *)Tcl_GetVar(cltclinterp,stable_var, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); stat_free(stable_var); if (s == NULL) tk_error(Tcl_GetStringResult(cltclinterp)); - else + else return(tcl_string_to_caml(s)); } @@ -51,12 +51,12 @@ CAMLprim value camltk_setvar(value var, value contents) CheckInit(); /* SetVar makes a copy of the contents. */ - /* In case we have write traces in Caml, it's better to make sure that + /* In case we have write traces in OCaml, it's better to make sure that var doesn't move... */ stable_var = string_to_c(var); utf_contents = caml_string_to_tcl(contents); - s = Tcl_SetVar(cltclinterp,stable_var, utf_contents, - TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); + s = (char *)Tcl_SetVar(cltclinterp,stable_var, utf_contents, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG); stat_free(stable_var); if( s == utf_contents ){ tk_error("camltk_setvar: Tcl_SetVar returned strange result. Call the author of mlTk!"); @@ -65,7 +65,7 @@ CAMLprim value camltk_setvar(value var, value contents) if (s == NULL) tk_error(Tcl_GetStringResult(cltclinterp)); - else + else return(Val_unit); } diff --git a/otherlibs/num/.depend b/otherlibs/num/.depend index 1e783ec0f9..2013ac35b8 100644 --- a/otherlibs/num/.depend +++ b/otherlibs/num/.depend @@ -1,11 +1,9 @@ bng.o: bng.c bng.h ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/compatibility.h bng_amd64.c \ bng_digit.c -bng_alpha.o: bng_alpha.c bng_amd64.o: bng_amd64.c bng_digit.o: bng_digit.c bng_ia32.o: bng_ia32.c -bng_mips.o: bng_mips.c bng_ppc.o: bng_ppc.c bng_sparc.o: bng_sparc.c nat_stubs.o: nat_stubs.c ../../byterun/alloc.h \ @@ -13,28 +11,28 @@ nat_stubs.o: nat_stubs.c ../../byterun/alloc.h \ ../../byterun/config.h ../../byterun/../config/m.h \ ../../byterun/../config/s.h ../../byterun/mlvalues.h \ ../../byterun/config.h ../../byterun/custom.h ../../byterun/intext.h \ - ../../byterun/io.h ../../byterun/fix_code.h ../../byterun/fail.h \ + ../../byterun/io.h ../../byterun/fail.h ../../byterun/hash.h \ ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h \ ../../byterun/mlvalues.h bng.h nat.h -arith_flags.cmi: -arith_status.cmi: -big_int.cmi: nat.cmi -int_misc.cmi: -nat.cmi: -num.cmi: ratio.cmi nat.cmi big_int.cmi -ratio.cmi: nat.cmi big_int.cmi -arith_flags.cmo: arith_flags.cmi -arith_flags.cmx: arith_flags.cmi -arith_status.cmo: arith_flags.cmi arith_status.cmi -arith_status.cmx: arith_flags.cmx arith_status.cmi -big_int.cmo: nat.cmi int_misc.cmi big_int.cmi -big_int.cmx: nat.cmx int_misc.cmx big_int.cmi -int_misc.cmo: int_misc.cmi -int_misc.cmx: int_misc.cmi -nat.cmo: int_misc.cmi nat.cmi -nat.cmx: int_misc.cmx nat.cmi -num.cmo: ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi -num.cmx: ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi -ratio.cmo: nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi -ratio.cmx: nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi +arith_flags.cmi : +arith_status.cmi : +big_int.cmi : nat.cmi +int_misc.cmi : +nat.cmi : +num.cmi : ratio.cmi nat.cmi big_int.cmi +ratio.cmi : nat.cmi big_int.cmi +arith_flags.cmo : arith_flags.cmi +arith_flags.cmx : arith_flags.cmi +arith_status.cmo : arith_flags.cmi arith_status.cmi +arith_status.cmx : arith_flags.cmx arith_status.cmi +big_int.cmo : nat.cmi int_misc.cmi big_int.cmi +big_int.cmx : nat.cmx int_misc.cmx big_int.cmi +int_misc.cmo : int_misc.cmi +int_misc.cmx : int_misc.cmi +nat.cmo : int_misc.cmi nat.cmi +nat.cmx : int_misc.cmx nat.cmi +num.cmo : ratio.cmi nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi num.cmi +num.cmx : ratio.cmx nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx num.cmi +ratio.cmo : nat.cmi int_misc.cmi big_int.cmi arith_flags.cmi ratio.cmi +ratio.cmx : nat.cmx int_misc.cmx big_int.cmx arith_flags.cmx ratio.cmi diff --git a/otherlibs/num/nat_stubs.c b/otherlibs/num/nat_stubs.c index 5215851659..9a62759fac 100644 --- a/otherlibs/num/nat_stubs.c +++ b/otherlibs/num/nat_stubs.c @@ -416,4 +416,3 @@ static intnat hash_nat(value v) } return h; } - 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/str/.depend b/otherlibs/str/.depend index df6eb9af08..5be8377c2d 100644 --- a/otherlibs/str/.depend +++ b/otherlibs/str/.depend @@ -4,6 +4,6 @@ strstubs.o: strstubs.c ../../byterun/mlvalues.h \ ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/mlvalues.h \ ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h -str.cmi: -str.cmo: str.cmi -str.cmx: str.cmi +str.cmi : +str.cmo : str.cmi +str.cmx : str.cmi diff --git a/otherlibs/systhreads/.depend b/otherlibs/systhreads/.depend index 9c6889b708..85add2e592 100644 --- a/otherlibs/systhreads/.depend +++ b/otherlibs/systhreads/.depend @@ -9,18 +9,18 @@ st_stubs.o: st_stubs.c ../../byterun/alloc.h \ ../../byterun/mlvalues.h ../../byterun/printexc.h ../../byterun/roots.h \ ../../byterun/memory.h ../../byterun/signals.h ../../byterun/stacks.h \ ../../byterun/sys.h threads.h st_posix.h -condition.cmi: mutex.cmi -event.cmi: -mutex.cmi: -thread.cmi: -threadUnix.cmi: -condition.cmo: mutex.cmi condition.cmi -condition.cmx: mutex.cmx condition.cmi -event.cmo: mutex.cmi condition.cmi event.cmi -event.cmx: mutex.cmx condition.cmx event.cmi -mutex.cmo: mutex.cmi -mutex.cmx: mutex.cmi -thread.cmo: thread.cmi -thread.cmx: thread.cmi -threadUnix.cmo: thread.cmi threadUnix.cmi -threadUnix.cmx: thread.cmx threadUnix.cmi +condition.cmi : mutex.cmi +event.cmi : +mutex.cmi : +thread.cmi : +threadUnix.cmi : +condition.cmo : mutex.cmi condition.cmi +condition.cmx : mutex.cmx condition.cmi +event.cmo : mutex.cmi condition.cmi event.cmi +event.cmx : mutex.cmx condition.cmx event.cmi +mutex.cmo : mutex.cmi +mutex.cmx : mutex.cmi +thread.cmo : thread.cmi +thread.cmx : thread.cmi +threadUnix.cmo : thread.cmi threadUnix.cmi +threadUnix.cmx : thread.cmx threadUnix.cmi diff --git a/otherlibs/systhreads/Makefile b/otherlibs/systhreads/Makefile index fbdd899466..9037b68e0d 100644 --- a/otherlibs/systhreads/Makefile +++ b/otherlibs/systhreads/Makefile @@ -30,7 +30,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_posix.h b/otherlibs/systhreads/st_posix.h index 68ac00ddfe..44b475110e 100644 --- a/otherlibs/systhreads/st_posix.h +++ b/otherlibs/systhreads/st_posix.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: posix.c 9270 2009-05-20 11:52:42Z doligez $ */ +/* $Id$ */ /* POSIX thread implementation of the "st" interface */ @@ -158,7 +158,7 @@ static INLINE int st_masterlock_waiters(st_masterlock * m) { return m->waiters; } - + /* Mutexes */ typedef pthread_mutex_t * st_mutex; @@ -321,7 +321,7 @@ static void * caml_thread_tick(void * arg) struct timeval timeout; sigset_t mask; - /* Block all signals so that we don't try to execute a Caml signal handler */ + /* Block all signals so that we don't try to execute an OCaml signal handler*/ sigfillset(&mask); pthread_sigmask(SIG_BLOCK, &mask, NULL); /* Allow async cancellation */ @@ -411,6 +411,6 @@ value caml_wait_signal(value sigs) /* ML */ return Val_int(signo); #else invalid_argument("Thread.wait_signal not implemented"); - return Val_int(0); /* not reached */ + return Val_int(0); /* not reached */ #endif } diff --git a/otherlibs/systhreads/st_stubs.c b/otherlibs/systhreads/st_stubs.c index abf055b175..23d826ee82 100644 --- a/otherlibs/systhreads/st_stubs.c +++ b/otherlibs/systhreads/st_stubs.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: posix.c 9270 2009-05-20 11:52:42Z doligez $ */ +/* $Id$ */ #include "alloc.h" #include "backtrace.h" @@ -94,7 +94,7 @@ static caml_thread_t all_threads = NULL; /* The descriptor for the currently executing thread */ static caml_thread_t curr_thread = NULL; -/* The master lock protecting the Caml runtime system */ +/* The master lock protecting the OCaml runtime system */ static st_masterlock caml_master_lock; /* Whether the ``tick'' thread is already running */ @@ -279,7 +279,7 @@ static uintnat caml_thread_stack_usage(void) sz += (value *) th->top_of_stack - (value *) th->bottom_of_stack; #else sz += th->stack_high - th->sp; -#endif +#endif } if (prev_stack_usage_hook != NULL) sz += prev_stack_usage_hook(); @@ -344,7 +344,10 @@ static value caml_thread_new_descriptor(value clos) static void caml_thread_remove_info(caml_thread_t th) { - if (th->next == th) all_threads = NULL; /* last Caml thread exiting */ + if (th->next == th) + all_threads = NULL; /* last OCaml thread exiting */ + else if (all_threads == th) + all_threads = th->next; /* PR#5295 */ th->next->prev = th->prev; th->prev->next = th->next; #ifndef NATIVE_CODE @@ -498,7 +501,7 @@ static ST_THREAD_FUNCTION caml_thread_start(void * arg) #endif /* The thread now stops running */ return 0; -} +} CAMLprim value caml_thread_new(value clos) /* ML */ { @@ -522,7 +525,7 @@ CAMLprim value caml_thread_new(value clos) /* ML */ caml_thread_remove_info(th); st_check_error(err, "Thread.create"); } - /* Create the tick thread if not already done. + /* Create the tick thread if not already done. Because of PR#4666, we start the tick thread late, only when we create the first additional thread in the current process*/ if (! caml_tick_thread_running) { @@ -578,7 +581,7 @@ CAMLexport int caml_c_thread_register(void) return 1; } -/* Unregister a thread that was created from C and registered with +/* Unregister a thread that was created from C and registered with the function above */ CAMLexport int caml_c_thread_unregister(void) @@ -646,7 +649,7 @@ CAMLprim value caml_thread_exit(value unit) /* ML */ #endif caml_thread_stop(); if (exit_buf != NULL) { - /* Native-code and (main thread or thread created by Caml) */ + /* Native-code and (main thread or thread created by OCaml) */ siglongjmp(exit_buf->buf, 1); } else { /* Bytecode, or thread created from C */ diff --git a/otherlibs/systhreads/st_win32.h b/otherlibs/systhreads/st_win32.h index 4b5755ec38..206646dfc4 100644 --- a/otherlibs/systhreads/st_win32.h +++ b/otherlibs/systhreads/st_win32.h @@ -11,10 +11,11 @@ /* */ /***********************************************************************/ -/* $Id: posix.c 9270 2009-05-20 11:52:42Z doligez $ */ +/* $Id$ */ /* Win32 implementation of the "st" interface */ +#define _WIN32_WINNT 0x0400 #include <windows.h> #include <WinError.h> #include <stdio.h> @@ -53,7 +54,7 @@ static DWORD st_initialize(void) typedef HANDLE st_thread_id; -static DWORD st_thread_create(st_thread_id * res, +static DWORD st_thread_create(st_thread_id * res, LPTHREAD_START_ROUTINE fn, void * arg) { HANDLE h = CreateThread(NULL, 0, fn, arg, 0, NULL); @@ -149,7 +150,7 @@ static INLINE int st_masterlock_waiters(st_masterlock * m) { return 1; /* info not maintained */ } - + /* Mutexes */ typedef CRITICAL_SECTION * st_mutex; @@ -366,12 +367,12 @@ static void st_check_error(DWORD retcode, char * msg) if (retcode == 0) return; if (retcode == ERROR_NOT_ENOUGH_MEMORY) raise_out_of_memory(); if (! FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS, - NULL, - retcode, - 0, - err, - sizeof(err), - NULL)) { + NULL, + retcode, + 0, + err, + sizeof(err), + NULL)) { sprintf(err, "error code %lx", retcode); } msglen = strlen(msg); @@ -409,11 +410,11 @@ static DWORD st_atfork(void (*fn)(void)) value caml_thread_sigmask(value cmd, value sigs) /* ML */ { invalid_argument("Thread.sigmask not implemented"); - return Val_int(0); /* not reached */ + return Val_int(0); /* not reached */ } value caml_wait_signal(value sigs) /* ML */ { invalid_argument("Thread.wait_signal not implemented"); - return Val_int(0); /* not reached */ + return Val_int(0); /* not reached */ } diff --git a/otherlibs/systhreads/thread.ml b/otherlibs/systhreads/thread.ml index f66396e857..ee01c9558b 100644 --- a/otherlibs/systhreads/thread.ml +++ b/otherlibs/systhreads/thread.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: thread_posix.ml 9547 2010-01-22 12:48:24Z doligez $ *) +(* $Id$ *) (* User-level threads *) @@ -63,7 +63,7 @@ let _ = at_exit (fun () -> thread_cleanup(); - (* In case of DLL-embedded Ocaml the preempt_signal handler + (* In case of DLL-embedded OCaml the preempt_signal handler will point to nowhere after DLL unloading and an accidental preempt_signal will crash the main program. So restore the default handler. *) diff --git a/otherlibs/systhreads/threads.h b/otherlibs/systhreads/threads.h index a0a4078350..ff140cd5b3 100644 --- a/otherlibs/systhreads/threads.h +++ b/otherlibs/systhreads/threads.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: posix.c 9270 2009-05-20 11:52:42Z doligez $ */ +/* $Id$ */ #ifndef CAML_THREADS_H #define CAML_THREADS_H @@ -21,22 +21,22 @@ CAMLextern void caml_leave_blocking_section (void); #define caml_acquire_runtime_system caml_leave_blocking_section #define caml_release_runtime_system caml_enter_blocking_section -/* Manage the master lock around the Caml run-time system. - Only one thread at a time can execute Caml compiled code or - Caml run-time system functions. +/* Manage the master lock around the OCaml run-time system. + Only one thread at a time can execute OCaml compiled code or + OCaml run-time system functions. - When Caml calls a C function, the current thread holds the master + When OCaml calls a C function, the current thread holds the master lock. The C function can release it by calling - [caml_release_runtime_system]. Then, another thread can execute Caml - code. However, the calling thread must not access any Caml data, - nor call any runtime system function, nor call back into Caml. + [caml_release_runtime_system]. Then, another thread can execute OCaml + code. However, the calling thread must not access any OCaml data, + nor call any runtime system function, nor call back into OCaml. - Before returning to its Caml caller, or accessing Caml data, + Before returning to its OCaml caller, or accessing OCaml data, or call runtime system functions, the current thread must re-acquire the master lock by calling [caml_acquire_runtime_system]. - Symmetrically, if a C function (not called from Caml) wishes to - call back into Caml code, it should invoke [caml_acquire_runtime_system] + Symmetrically, if a C function (not called from OCaml) wishes to + call back into OCaml code, it should invoke [caml_acquire_runtime_system] first, then do the callback, then invoke [caml_release_runtime_system]. For historical reasons, alternate names can be used: @@ -49,9 +49,9 @@ CAMLextern void caml_leave_blocking_section (void); CAMLextern int caml_c_thread_register(void); CAMLextern int caml_c_thread_unregister(void); -/* If a thread is created by C code (instead of by Caml itself), - it must be registered with the Caml runtime system before - being able to call back into Caml code or use other runtime system +/* If a thread is created by C code (instead of by OCaml itself), + it must be registered with the OCaml runtime system before + being able to call back into OCaml code or use other runtime system functions. Just call [caml_c_thread_register] once. Before the thread finishes, it must call [caml_c_thread_unregister]. Both functions return 1 on success, 0 on error. diff --git a/otherlibs/threads/.depend b/otherlibs/threads/.depend index 7ce4479a41..bc03050be3 100644 --- a/otherlibs/threads/.depend +++ b/otherlibs/threads/.depend @@ -9,24 +9,27 @@ scheduler.o: scheduler.c ../../byterun/alloc.h \ ../../byterun/mlvalues.h ../../byterun/printexc.h ../../byterun/roots.h \ ../../byterun/memory.h ../../byterun/signals.h ../../byterun/stacks.h \ ../../byterun/sys.h -condition.cmi: mutex.cmi -event.cmi: -mutex.cmi: -thread.cmi: unix.cmo -threadUnix.cmi: unix.cmo -condition.cmo: thread.cmi mutex.cmi condition.cmi -condition.cmx: thread.cmx mutex.cmx condition.cmi -event.cmo: mutex.cmi condition.cmi event.cmi -event.cmx: mutex.cmx condition.cmx event.cmi -marshal.cmo: pervasives.cmo -marshal.cmx: pervasives.cmx -mutex.cmo: thread.cmi mutex.cmi -mutex.cmx: thread.cmx mutex.cmi -pervasives.cmo: unix.cmo -pervasives.cmx: unix.cmx -thread.cmo: unix.cmo thread.cmi -thread.cmx: unix.cmx thread.cmi -threadUnix.cmo: unix.cmo thread.cmi threadUnix.cmi -threadUnix.cmx: unix.cmx thread.cmx threadUnix.cmi -unix.cmo: -unix.cmx: +condition.cmi : mutex.cmi +event.cmi : +marshal.cmi : +mutex.cmi : +pervasives.cmi : +thread.cmi : unix.cmi +threadUnix.cmi : unix.cmi +unix.cmi : +condition.cmo : thread.cmi mutex.cmi condition.cmi +condition.cmx : thread.cmx mutex.cmx condition.cmi +event.cmo : mutex.cmi condition.cmi event.cmi +event.cmx : mutex.cmx condition.cmx event.cmi +marshal.cmo : pervasives.cmi marshal.cmi +marshal.cmx : pervasives.cmx marshal.cmi +mutex.cmo : thread.cmi mutex.cmi +mutex.cmx : thread.cmx mutex.cmi +pervasives.cmo : unix.cmi pervasives.cmi +pervasives.cmx : unix.cmx pervasives.cmi +thread.cmo : unix.cmi thread.cmi +thread.cmx : unix.cmx thread.cmi +threadUnix.cmo : unix.cmi thread.cmi threadUnix.cmi +threadUnix.cmx : unix.cmx thread.cmx threadUnix.cmi +unix.cmo : unix.cmi +unix.cmx : unix.cmi diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile index 3354a275bd..5d9e620b3f 100644 --- a/otherlibs/threads/Makefile +++ b/otherlibs/threads/Makefile @@ -28,22 +28,19 @@ CAML_OBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo 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/.depend b/otherlibs/unix/.depend index 42dbc3c037..ef8832f9b6 100644 --- a/otherlibs/unix/.depend +++ b/otherlibs/unix/.depend @@ -449,9 +449,9 @@ write.o: write.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h \ ../../byterun/signals.h unixsupport.h -unix.cmi: -unixLabels.cmi: unix.cmi -unix.cmo: unix.cmi -unix.cmx: unix.cmi -unixLabels.cmo: unix.cmi unixLabels.cmi -unixLabels.cmx: unix.cmx unixLabels.cmi +unix.cmi : +unixLabels.cmi : unix.cmi +unix.cmo : unix.cmi +unix.cmx : unix.cmi +unixLabels.cmo : unix.cmi unixLabels.cmi +unixLabels.cmx : unix.cmx unixLabels.cmi diff --git a/otherlibs/unix/putenv.c b/otherlibs/unix/putenv.c index 0fc5534f5d..1238ee2b69 100644 --- a/otherlibs/unix/putenv.c +++ b/otherlibs/unix/putenv.c @@ -28,13 +28,16 @@ CAMLprim value unix_putenv(value name, value val) { mlsize_t namelen = string_length(name); mlsize_t vallen = string_length(val); - char * s = (char *) stat_alloc(namelen + 1 + vallen + 1); + char * s = (char *) caml_stat_alloc(namelen + 1 + vallen + 1); memmove (s, String_val(name), namelen); s[namelen] = '='; memmove (s + namelen + 1, String_val(val), vallen); s[namelen + 1 + vallen] = 0; - if (putenv(s) == -1) uerror("putenv", name); + if (putenv(s) == -1) { + caml_stat_free(s); + uerror("putenv", name); + } return Val_unit; } diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli index 0ecb020975..0c2780999a 100644 --- a/otherlibs/unix/unix.mli +++ b/otherlibs/unix/unix.mli @@ -122,7 +122,7 @@ val environment : unit -> string array val getenv : string -> string (** Return the value associated to a variable in the process environment. Raise [Not_found] if the variable is unbound. - (This function is identical to [Sys.getenv].) *) + (This function is identical to {!Sys.getenv}.) *) val putenv : string -> string -> unit (** [Unix.putenv name value] sets the value associated to a @@ -235,10 +235,14 @@ type open_flag = | O_TRUNC (** Truncate to 0 length if existing *) | O_EXCL (** Fail if existing *) | O_NOCTTY (** Don't make this dev a controlling tty *) - | O_DSYNC (** Writes complete as `Synchronised I/O data integrity completion' *) - | O_SYNC (** Writes complete as `Synchronised I/O file integrity completion' *) - | O_RSYNC (** Reads complete as writes (depending on O_SYNC/O_DSYNC) *) - | O_SHARE_DELETE (** Windows only: allow the file to be deleted while still open *) + | O_DSYNC (** Writes complete as `Synchronised I/O data + integrity completion' *) + | O_SYNC (** Writes complete as `Synchronised I/O file + integrity completion' *) + | O_RSYNC (** Reads complete as writes (depending on + O_SYNC/O_DSYNC) *) + | O_SHARE_DELETE (** Windows only: allow the file to be deleted + while still open *) (** The flags to {!Unix.openfile}. *) @@ -766,9 +770,11 @@ val utimes : string -> float -> float -> unit type interval_timer = ITIMER_REAL - (** decrements in real time, and sends the signal [SIGALRM] when expired.*) + (** decrements in real time, and sends the signal [SIGALRM] when + expired.*) | ITIMER_VIRTUAL - (** decrements in process virtual time, and sends [SIGVTALRM] when expired. *) + (** decrements in process virtual time, and sends [SIGVTALRM] + when expired. *) | ITIMER_PROF (** (for profiling) decrements both when the process is running and when the system is running on behalf of the @@ -1023,8 +1029,9 @@ type socket_int_option = | SO_RCVBUF (** Size of received buffer *) | SO_ERROR (** Deprecated. Use {!Unix.getsockopt_error} instead. *) | SO_TYPE (** Report the socket type *) - | SO_RCVLOWAT (** Minimum number of bytes to process for input operations *) - | SO_SNDLOWAT (** Minimum number of bytes to process for output operations *) + | SO_RCVLOWAT (** Minimum number of bytes to process for input operations*) + | SO_SNDLOWAT (** Minimum number of bytes to process for output + operations *) (** The socket options that can be consulted with {!Unix.getsockopt_int} and modified with {!Unix.setsockopt_int}. These options have an integer value. *) @@ -1059,17 +1066,21 @@ val setsockopt_int : file_descr -> socket_int_option -> int -> unit (** Same as {!Unix.setsockopt} for an integer-valued socket option. *) val getsockopt_optint : file_descr -> socket_optint_option -> int option -(** Same as {!Unix.getsockopt} for a socket option whose value is an [int option]. *) +(** Same as {!Unix.getsockopt} for a socket option whose value is an + [int option]. *) val setsockopt_optint : file_descr -> socket_optint_option -> int option -> unit -(** Same as {!Unix.setsockopt} for a socket option whose value is an [int option]. *) +(** Same as {!Unix.setsockopt} for a socket option whose value is an + [int option]. *) val getsockopt_float : file_descr -> socket_float_option -> float -(** Same as {!Unix.getsockopt} for a socket option whose value is a floating-point number. *) +(** Same as {!Unix.getsockopt} for a socket option whose value is a + floating-point number. *) val setsockopt_float : file_descr -> socket_float_option -> float -> unit -(** Same as {!Unix.setsockopt} for a socket option whose value is a floating-point number. *) +(** Same as {!Unix.setsockopt} for a socket option whose value is a + floating-point number. *) val getsockopt_error : file_descr -> error option (** Return the error condition associated with the given socket, diff --git a/otherlibs/unix/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/otherlibs/win32graph/libgraph.h b/otherlibs/win32graph/libgraph.h index 96ac954e7d..bae4b11623 100644 --- a/otherlibs/win32graph/libgraph.h +++ b/otherlibs/win32graph/libgraph.h @@ -43,8 +43,8 @@ extern int bits_per_pixel; #define DEFAULT_SCREEN_WIDTH 1024 #define DEFAULT_SCREEN_HEIGHT 768 #define BORDER_WIDTH 2 -#define WINDOW_NAME "Caml graphics" -#define ICON_NAME "Caml graphics" +#define WINDOW_NAME "OCaml graphics" +#define ICON_NAME "OCaml graphics" #define SIZE_QUEUE 256 void gr_fail(char *fmt, char *arg); diff --git a/otherlibs/win32graph/open.c b/otherlibs/win32graph/open.c index 8ffe259e5b..a6bc59d45f 100644 --- a/otherlibs/win32graph/open.c +++ b/otherlibs/win32graph/open.c @@ -238,7 +238,7 @@ static DWORD WINAPI gr_open_graph_internal(value arg) caml_gr_init_event_queue(); /* The global data structures are now correctly initialized. - Restart the Caml main thread. */ + Restart the OCaml main thread. */ open_graph_errmsg = NULL; SetEvent(open_graph_event); diff --git a/otherlibs/win32unix/accept.c b/otherlibs/win32unix/accept.c index 68c7bac7af..48d028790f 100644 --- a/otherlibs/win32unix/accept.c +++ b/otherlibs/win32unix/accept.c @@ -26,15 +26,30 @@ CAMLprim value unix_accept(sock) SOCKET sconn = Socket_val(sock); SOCKET snew; value fd = Val_unit, adr = Val_unit, res; + int oldvalue, oldvaluelen, newvalue, retcode; union sock_addr_union addr; socklen_param_type addr_len; DWORD err = 0; + oldvaluelen = sizeof(oldvalue); + retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + (char *) &oldvalue, &oldvaluelen); + if (retcode == 0) { + /* Set sockets to synchronous mode */ + newvalue = SO_SYNCHRONOUS_NONALERT; + setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + (char *) &newvalue, sizeof(newvalue)); + } addr_len = sizeof(sock_addr); enter_blocking_section(); snew = accept(sconn, &addr.s_gen, &addr_len); if (snew == INVALID_SOCKET) err = WSAGetLastError (); leave_blocking_section(); + if (retcode == 0) { + /* Restore initial mode */ + setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + (char *) &oldvalue, oldvaluelen); + } if (snew == INVALID_SOCKET) { win32_maperr(err); uerror("accept", Nothing); diff --git a/otherlibs/win32unix/close_on.c b/otherlibs/win32unix/close_on.c index 03ff2b894c..606743a287 100644 --- a/otherlibs/win32unix/close_on.c +++ b/otherlibs/win32unix/close_on.c @@ -22,8 +22,8 @@ int win_set_inherit(value fd, BOOL inherit) /* According to the MSDN, SetHandleInformation may not work for console handles on WinNT4 and earlier versions. */ if (! SetHandleInformation(Handle_val(fd), - HANDLE_FLAG_INHERIT, - inherit ? HANDLE_FLAG_INHERIT : 0)) { + HANDLE_FLAG_INHERIT, + inherit ? HANDLE_FLAG_INHERIT : 0)) { win32_maperr(GetLastError()); return -1; } diff --git a/otherlibs/win32unix/select.c b/otherlibs/win32unix/select.c index 7069d140fb..a035e66228 100644 --- a/otherlibs/win32unix/select.c +++ b/otherlibs/win32unix/select.c @@ -31,7 +31,7 @@ * It takes the following parameters into account: * - limitation on number of objects is mostly due to limitation * a WaitForMultipleObjects - * - there is always an event "hStop" to watch + * - there is always an event "hStop" to watch * * This lead to pick the following value as the biggest possible * value @@ -115,7 +115,7 @@ typedef enum _SELECTHANDLETYPE { typedef enum _SELECTMODE { SELECT_MODE_NONE = 0, SELECT_MODE_READ = 1, - SELECT_MODE_WRITE = 2, + SELECT_MODE_WRITE = 2, SELECT_MODE_EXCEPT = 4, } SELECTMODE; @@ -191,18 +191,18 @@ LPSELECTDATA select_data_new (LPSELECTDATA lpSelectData, SELECTTYPE EType) /* Allocate the data structure */ LPSELECTDATA res; DWORD i; - - res = (LPSELECTDATA)caml_stat_alloc(sizeof(SELECTDATA)); + + res = (LPSELECTDATA)caml_stat_alloc(sizeof(SELECTDATA)); /* Init common data */ list_init((LPLIST)res); list_next_set((LPLIST)res, (LPLIST)lpSelectData); res->EType = EType; res->nResultsCount = 0; - + /* Data following are dedicated to APC like call, they - will be initialized if required. For now they are set to + will be initialized if required. For now they are set to invalid values. */ res->funcWorker = NULL; @@ -255,14 +255,14 @@ DWORD select_data_result_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, int l } /* Add a query to select data, return zero if something goes wrong */ -DWORD select_data_query_add (LPSELECTDATA lpSelectData, - SELECTMODE EMode, - HANDLE hFileDescr, +DWORD select_data_query_add (LPSELECTDATA lpSelectData, + SELECTMODE EMode, + HANDLE hFileDescr, int lpOrigIdx, unsigned int uFlagsFd) { DWORD res; - DWORD i; + DWORD i; res = 0; if (lpSelectData->nQueriesCount < MAXIMUM_SELECT_OBJECTS) @@ -280,22 +280,22 @@ DWORD select_data_query_add (LPSELECTDATA lpSelectData, } /* Search for a job that has available query slots and that match provided type. - * If none is found, create a new one. Return the corresponding SELECTDATA, and + * If none is found, create a new one. Return the corresponding SELECTDATA, and * update provided SELECTDATA head, if required. */ LPSELECTDATA select_data_job_search (LPSELECTDATA *lppSelectData, SELECTTYPE EType) { LPSELECTDATA res; - + res = NULL; - + /* Search for job */ DEBUG_PRINT("Searching an available job for type %d", EType); res = *lppSelectData; while ( res != NULL && !( - res->EType == EType + res->EType == EType && res->nQueriesCount < MAXIMUM_SELECT_OBJECTS ) ) @@ -326,7 +326,7 @@ void read_console_poll(HANDLE hStop, void *_data) DWORD n; LPSELECTDATA lpSelectData; LPSELECTQUERY lpQuery; - + DEBUG_PRINT("Waiting for data on console"); record; @@ -338,7 +338,7 @@ void read_console_poll(HANDLE hStop, void *_data) events[0] = hStop; events[1] = lpQuery->hFileDescr; while (lpSelectData->EState == SELECT_STATE_NONE) - { + { waitRes = WaitForMultipleObjects(2, events, FALSE, INFINITE); if (waitRes == WAIT_OBJECT_0 || check_error(lpSelectData, waitRes == WAIT_FAILED)) { @@ -359,7 +359,7 @@ void read_console_poll(HANDLE hStop, void *_data) lpSelectData->EState = SELECT_STATE_SIGNALED; break; } - else + else { /* discard everything else and try again */ if (check_error(lpSelectData, ReadConsoleInput(lpQuery->hFileDescr, &record, 1, &n) == 0)) @@ -371,9 +371,9 @@ void read_console_poll(HANDLE hStop, void *_data) } /* Add a function to monitor console input */ -LPSELECTDATA read_console_poll_add (LPSELECTDATA lpSelectData, - SELECTMODE EMode, - HANDLE hFileDescr, +LPSELECTDATA read_console_poll_add (LPSELECTDATA lpSelectData, + SELECTMODE EMode, + HANDLE hFileDescr, int lpOrigIdx, unsigned int uFlagsFd) { @@ -414,14 +414,14 @@ void read_pipe_poll (HANDLE hStop, void *_data) { iterQuery = &(lpSelectData->aQueries[i]); res = PeekNamedPipe( - iterQuery->hFileDescr, - NULL, - 0, - NULL, - &n, + iterQuery->hFileDescr, + NULL, + 0, + NULL, + &n, NULL); - if (check_error(lpSelectData, - (res == 0) && + if (check_error(lpSelectData, + (res == 0) && (GetLastError() != ERROR_BROKEN_PIPE))) { break; @@ -435,7 +435,7 @@ void read_pipe_poll (HANDLE hStop, void *_data) }; /* Alas, nothing except polling seems to work for pipes. - Check the state & stop_worker_event every 10 ms + Check the state & stop_worker_event every 10 ms */ if (lpSelectData->EState == SELECT_STATE_NONE) { @@ -446,7 +446,7 @@ void read_pipe_poll (HANDLE hStop, void *_data) * a chance that one of the 4 first calls succeed. */ wait = 2 * wait; - if (wait > 10) + if (wait > 10) { wait = 10; }; @@ -460,23 +460,23 @@ void read_pipe_poll (HANDLE hStop, void *_data) } /* Add a function to monitor pipe input */ -LPSELECTDATA read_pipe_poll_add (LPSELECTDATA lpSelectData, - SELECTMODE EMode, - HANDLE hFileDescr, +LPSELECTDATA read_pipe_poll_add (LPSELECTDATA lpSelectData, + SELECTMODE EMode, + HANDLE hFileDescr, int lpOrigIdx, unsigned int uFlagsFd) { LPSELECTDATA res; LPSELECTDATA hd; - + hd = lpSelectData; /* Polling pipe is a non blocking operation by default. This means that each - worker can handle many pipe. We begin to try to find a worker that is + worker can handle many pipe. We begin to try to find a worker that is polling pipe, but for which there is under the limit of pipe per worker. */ DEBUG_PRINT("Searching an available worker handling pipe"); res = select_data_job_search(&hd, SELECT_TYPE_PIPE_READ); - + /* Add a new pipe to poll */ res->funcWorker = read_pipe_poll; select_data_query_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); @@ -528,22 +528,22 @@ void socket_poll (HANDLE hStop, void *_data) check_error(lpSelectData, WSAEventSelect( - (SOCKET)(iterQuery->hFileDescr), - aEvents[nEvents], + (SOCKET)(iterQuery->hFileDescr), + aEvents[nEvents], maskEvents) == SOCKET_ERROR); } - + /* Add stop event */ aEvents[nEvents] = hStop; nEvents++; if (lpSelectData->nError == 0) { - check_error(lpSelectData, + check_error(lpSelectData, WaitForMultipleObjects( - nEvents, - aEvents, - FALSE, + nEvents, + aEvents, + FALSE, INFINITE) == WAIT_FAILED); }; @@ -599,9 +599,9 @@ void socket_poll (HANDLE hStop, void *_data) } /* Add a function to monitor socket */ -LPSELECTDATA socket_poll_add (LPSELECTDATA lpSelectData, - SELECTMODE EMode, - HANDLE hFileDescr, +LPSELECTDATA socket_poll_add (LPSELECTDATA lpSelectData, + SELECTMODE EMode, + HANDLE hFileDescr, int lpOrigIdx, unsigned int uFlagsFd) { @@ -609,7 +609,7 @@ LPSELECTDATA socket_poll_add (LPSELECTDATA lpSelectData, LPSELECTDATA candidate; DWORD i; LPSELECTQUERY aQueries; - + res = lpSelectData; candidate = NULL; aQueries = NULL; @@ -695,19 +695,19 @@ LPSELECTDATA socket_poll_add (LPSELECTDATA lpSelectData, /***********************/ /* Add a static result */ -LPSELECTDATA static_poll_add (LPSELECTDATA lpSelectData, - SELECTMODE EMode, - HANDLE hFileDescr, +LPSELECTDATA static_poll_add (LPSELECTDATA lpSelectData, + SELECTMODE EMode, + HANDLE hFileDescr, int lpOrigIdx, unsigned int uFlagsFd) { LPSELECTDATA res; LPSELECTDATA hd; - + /* Look for an already initialized static element */ hd = lpSelectData; res = select_data_job_search(&hd, SELECT_TYPE_STATIC); - + /* Add a new query/result */ select_data_query_add(res, EMode, hFileDescr, lpOrigIdx, uFlagsFd); select_data_result_add(res, EMode, lpOrigIdx); @@ -738,7 +738,7 @@ static SELECTHANDLETYPE get_handle_type(value fd) { switch(GetFileType(Handle_val(fd))) { - case FILE_TYPE_DISK: + case FILE_TYPE_DISK: res = SELECT_HANDLE_DISK; break; @@ -783,8 +783,8 @@ LPSELECTDATA select_data_dispatch (LPSELECTDATA lpSelectData, SELECTMODE EMode, DEBUG_PRINT("Begin dispatching handle %x", hFileDescr); DEBUG_PRINT("Waiting for %d on handle %x", EMode, hFileDescr); - - /* There is only 2 way to have except mode: transmission of OOB data through + + /* There is only 2 way to have except mode: transmission of OOB data through a socket TCP/IP and through a strange interaction with a TTY. With windows, we only consider the TCP/IP except condition */ @@ -879,7 +879,7 @@ static value find_handle(LPSELECTRESULT iterResult, value readfds, value writefd CAMLlocal2(result, list); int i; - switch( iterResult->EMode ) + switch( iterResult->EMode ) { case SELECT_MODE_READ: list = readfds; @@ -892,12 +892,12 @@ static value find_handle(LPSELECTRESULT iterResult, value readfds, value writefd break; }; - for(i=0; list != Val_unit && i < iterResult->lpOrigIdx; ++i ) + for(i=0; list != Val_unit && i < iterResult->lpOrigIdx; ++i ) { list = Field(list, 1); } - if (list == Val_unit) + if (list == Val_unit) failwith ("select.c: original file handle not found"); result = Field(list, 0); @@ -944,12 +944,12 @@ static value fdset_to_fdlist(value fdlist, fd_set *fdset) } CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value timeout) -{ +{ /* Event associated to handle */ DWORD nEventsCount; DWORD nEventsMax; HANDLE *lpEventsDone; - + /* Data for all handles */ LPSELECTDATA lpSelectData; LPSELECTDATA iterSelectData; @@ -990,7 +990,7 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value double tm; struct timeval tv; struct timeval * tvp; - + DEBUG_PRINT("in select"); err = 0; @@ -1003,7 +1003,7 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value leave_blocking_section(); } read_list = write_list = except_list = Val_int(0); - } else { + } else { if (fdlist_to_fdset(readfds, &read) && fdlist_to_fdset(writefds, &write) && fdlist_to_fdset(exceptfds, &except)) { DEBUG_PRINT("only sockets to select on, using classic select"); if (tm < 0.0) { @@ -1040,9 +1040,9 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value writefds_len = caml_list_length(writefds); exceptfds_len = caml_list_length(exceptfds); hdsMax = MAX(readfds_len, MAX(writefds_len, exceptfds_len)); - + hdsData = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * hdsMax); - + if (tm >= 0.0) { milliseconds = 1000 * tm; @@ -1052,8 +1052,8 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value { milliseconds = INFINITE; } - - + + /* Create list of select data, based on the different list of fd to watch */ DEBUG_PRINT("Dispatch read fd"); handle_set_init(&hds, hdsData, hdsMax); @@ -1072,7 +1072,7 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value } } handle_set_reset(&hds); - + DEBUG_PRINT("Dispatch write fd"); handle_set_init(&hds, hdsData, hdsMax); i=0; @@ -1090,7 +1090,7 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value } } handle_set_reset(&hds); - + DEBUG_PRINT("Dispatch exceptional fd"); handle_set_init(&hds, hdsData, hdsMax); i=0; @@ -1108,13 +1108,13 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value } } handle_set_reset(&hds); - + /* Building the list of handle to wait for */ DEBUG_PRINT("Building events done array"); nEventsMax = list_length((LPLIST)lpSelectData); nEventsCount = 0; lpEventsDone = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * nEventsMax); - + iterSelectData = lpSelectData; while (iterSelectData != NULL) { @@ -1127,23 +1127,23 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value { hasStaticData = TRUE; }; - + /* Execute APC */ if (iterSelectData->funcWorker != NULL) { - iterSelectData->lpWorker = + iterSelectData->lpWorker = worker_job_submit( - iterSelectData->funcWorker, + iterSelectData->funcWorker, (void *)iterSelectData); - DEBUG_PRINT("Job submitted to worker %x", iterSelectData->lpWorker); + DEBUG_PRINT("Job submitted to worker %x", iterSelectData->lpWorker); lpEventsDone[nEventsCount] = worker_job_event_done(iterSelectData->lpWorker); nEventsCount++; }; iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); }; - + DEBUG_PRINT("Need to watch %d workers", nEventsCount); - + /* Processing select itself */ enter_blocking_section(); /* There are worker started, waiting to be monitored */ @@ -1158,17 +1158,17 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value case WAIT_FAILED: err = GetLastError(); break; - + case WAIT_TIMEOUT: DEBUG_PRINT("Select timeout"); break; - + default: DEBUG_PRINT("One worker is done"); break; }; } - + /* Ordering stop to every worker */ DEBUG_PRINT("Sending stop signal to every select workers"); iterSelectData = lpSelectData; @@ -1180,14 +1180,14 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value }; iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); }; - + DEBUG_PRINT("Waiting for every select worker to be done"); switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, TRUE, INFINITE)) { case WAIT_FAILED: err = GetLastError(); break; - + default: DEBUG_PRINT("Every worker is done"); break; @@ -1199,16 +1199,16 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value Sleep(milliseconds); } leave_blocking_section(); - + DEBUG_PRINT("Error status: %d (0 is ok)", err); /* Build results */ if (err == 0) { DEBUG_PRINT("Building result"); - read_list = Val_unit; + read_list = Val_unit; write_list = Val_unit; except_list = Val_unit; - + iterSelectData = lpSelectData; while (iterSelectData != NULL) { @@ -1241,7 +1241,7 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); } } - + /* Free resources */ DEBUG_PRINT("Free selectdata resources"); iterSelectData = lpSelectData; @@ -1252,12 +1252,12 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value select_data_free(lpSelectData); } lpSelectData = NULL; - + /* Free allocated events/handle set array */ DEBUG_PRINT("Free local allocated resources"); caml_stat_free(lpEventsDone); caml_stat_free(hdsData); - + DEBUG_PRINT("Raise error if required"); if (err != 0) { diff --git a/otherlibs/win32unix/socket.c b/otherlibs/win32unix/socket.c index 37ad175d26..cf6eefd63e 100644 --- a/otherlibs/win32unix/socket.c +++ b/otherlibs/win32unix/socket.c @@ -17,7 +17,7 @@ #include "unixsupport.h" int socket_domain_table[] = { - PF_UNIX, PF_INET + PF_UNIX, PF_INET /*, PF_INET6 */ }; int socket_type_table[] = { @@ -28,9 +28,30 @@ CAMLprim value unix_socket(domain, type, proto) value domain, type, proto; { SOCKET s; + int oldvalue, oldvaluelen, newvalue, retcode; + + /* IPv6 requires WinSock2, we must raise an error on PF_INET6 */ + if (Int_val(domain) >= sizeof(socket_domain_table)/sizeof(int)) { + win32_maperr(WSAEPFNOSUPPORT); + uerror("socket", Nothing); + } + oldvaluelen = sizeof(oldvalue); + retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + (char *) &oldvalue, &oldvaluelen); + if (retcode == 0) { + /* Set sockets to synchronous mode */ + newvalue = SO_SYNCHRONOUS_NONALERT; + setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + (char *) &newvalue, sizeof(newvalue)); + } s = socket(socket_domain_table[Int_val(domain)], socket_type_table[Int_val(type)], Int_val(proto)); + if (retcode == 0) { + /* Restore initial mode */ + setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + (char *) &oldvalue, oldvaluelen); + } if (s == INVALID_SOCKET) { win32_maperr(WSAGetLastError()); uerror("socket", Nothing); diff --git a/otherlibs/win32unix/times.c b/otherlibs/win32unix/times.c index 725895ec15..1946452d6c 100644 --- a/otherlibs/win32unix/times.c +++ b/otherlibs/win32unix/times.c @@ -1,35 +1,35 @@ -#include <windows.h>
-#include <mlvalues.h>
-#include "unixsupport.h"
-
-
-double to_sec(FILETIME ft) {
- ULARGE_INTEGER tmp;
-
- tmp.u.LowPart = ft.dwLowDateTime;
- tmp.u.HighPart = ft.dwHighDateTime;
-
- /* convert to seconds:
- GetProcessTimes returns number of 100-nanosecond intervals */
- return tmp.QuadPart / 1e7;
-}
-
-
-value unix_times(value unit) {
-
- value res;
- FILETIME creation, exit, stime, utime;
-
- if (!(GetProcessTimes(GetCurrentProcess(), &creation, &exit, &stime, &utime))) {
- win32_maperr(GetLastError());
- uerror("times", Nothing);
- }
-
- res = alloc_small(4 * Double_wosize, Double_array_tag);
- Store_double_field(res, 0, to_sec(utime));
- Store_double_field(res, 1, to_sec(stime));
- Store_double_field(res, 2, 0);
- Store_double_field(res, 3, 0);
- return res;
-
-}
+#include <windows.h> +#include <mlvalues.h> +#include "unixsupport.h" + + +double to_sec(FILETIME ft) { + ULARGE_INTEGER tmp; + + tmp.u.LowPart = ft.dwLowDateTime; + tmp.u.HighPart = ft.dwHighDateTime; + + /* convert to seconds: + GetProcessTimes returns number of 100-nanosecond intervals */ + return tmp.QuadPart / 1e7; +} + + +value unix_times(value unit) { + + value res; + FILETIME creation, exit, stime, utime; + + if (!(GetProcessTimes(GetCurrentProcess(), &creation, &exit, &stime, &utime))) { + win32_maperr(GetLastError()); + uerror("times", Nothing); + } + + res = alloc_small(4 * Double_wosize, Double_array_tag); + Store_double_field(res, 0, to_sec(utime)); + Store_double_field(res, 1, to_sec(stime)); + Store_double_field(res, 2, 0); + Store_double_field(res, 3, 0); + return res; + +} diff --git a/otherlibs/win32unix/unixsupport.h b/otherlibs/win32unix/unixsupport.h index f50d40c093..a5496bf26c 100644 --- a/otherlibs/win32unix/unixsupport.h +++ b/otherlibs/win32unix/unixsupport.h @@ -59,4 +59,4 @@ extern value unix_freeze_buffer (value); /* Blocking or nonblocking. By default a filedescr is in blocking state */ #define FLAGS_FD_IS_BLOCKING (1<<0) -#define UNIX_BUFFER_SIZE 16384 +#define UNIX_BUFFER_SIZE 65536 diff --git a/otherlibs/win32unix/windbug.c b/otherlibs/win32unix/windbug.c index 0370d2de7d..0cab906a22 100644 --- a/otherlibs/win32unix/windbug.c +++ b/otherlibs/win32unix/windbug.c @@ -26,7 +26,7 @@ int debug_test (void) debug = (getenv("OCAMLDEBUG") != NULL); debug_init = 1; }; -#endif +#endif return debug; } 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 87e2a8cbce..bdfa988d2a 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 ;; @@ -113,6 +113,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; @@ -122,6 +128,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 *) @@ -204,11 +213,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 @@ -299,9 +308,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 "'" @@ -321,15 +332,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 @@ -411,53 +431,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 '"' @@ -494,14 +525,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 } @@ -512,3 +541,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 6beb0dfd8e..973ab4bb85 100644 --- a/parsing/location.ml +++ b/parsing/location.ml @@ -15,8 +15,8 @@ open Lexing let absname = ref false - (* This reference should be in Clflags, but it would create an additional dependency - and make bootstrapping Camlp4 more difficult. *) + (* This reference should be in Clflags, but it would create an additional + dependency and make bootstrapping Camlp4 more difficult. *) type t = { loc_start: position; loc_end: position; loc_ghost: bool };; @@ -207,20 +207,24 @@ let absolute_path s = (* This function could go into Filename *) let rec aux s = let base = basename s in let dir = dirname s in - if base = current_dir_name then if dir = s then dir else aux dir + if dir = s then dir + else if base = current_dir_name then aux dir else if base = parent_dir_name then dirname (aux dir) else concat (aux dir) base in aux s +let show_filename file = + if !absname then absolute_path file else file + let print_filename ppf file = - Format.fprintf ppf "%s" (if !absname then absolute_path file else file) + Format.fprintf ppf "%s" (show_filename file) let reset () = num_loc_lines := 0 -let (msg_file, msg_line, msg_chars, msg_to, msg_colon, msg_head) = - ("File \"", "\", line ", ", characters ", "-", ":", "") +let (msg_file, msg_line, msg_chars, msg_to, msg_colon) = + ("File \"", "\", line ", ", characters ", "-", ":") (* return file, line, char from the given position *) let get_pos_info pos = @@ -232,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; @@ -244,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; @@ -271,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 0303c0addc..dd6a890cce 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,8 +60,20 @@ 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 885a581d45..e03b2827ea 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 /* Precedences and associativities. @@ -506,7 +479,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 */ @@ -545,13 +519,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 @@ -600,21 +574,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 @@ -628,28 +603,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 @@ -666,23 +641,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 @@ -695,14 +672,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 */ @@ -715,7 +692,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: @@ -748,9 +725,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 @@ -766,7 +743,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 @@ -779,20 +756,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 @@ -803,34 +784,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 */ @@ -839,17 +819,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 @@ -857,9 +829,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 @@ -867,7 +839,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 @@ -877,32 +850,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 } @@ -912,7 +891,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: @@ -923,7 +902,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 ()} } ; @@ -953,7 +932,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: @@ -967,7 +946,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 @@ -983,9 +962,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 @@ -1001,7 +980,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 @@ -1011,15 +990,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 @@ -1061,7 +1036,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])) } @@ -1071,7 +1046,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 @@ -1083,11 +1058,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 @@ -1097,15 +1072,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 @@ -1141,7 +1116,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 @@ -1181,7 +1156,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] } @@ -1237,24 +1212,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] } @@ -1274,19 +1250,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 @@ -1294,7 +1268,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 @@ -1302,14 +1276,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)) } @@ -1330,9 +1304,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 } ; @@ -1346,14 +1320,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 */ @@ -1374,7 +1350,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; @@ -1412,7 +1388,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: @@ -1428,7 +1404,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 } @@ -1447,7 +1423,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: @@ -1470,7 +1446,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) */ @@ -1482,7 +1458,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; @@ -1493,7 +1469,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; @@ -1501,9 +1477,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 } @@ -1535,13 +1511,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 @@ -1560,21 +1532,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 @@ -1597,11 +1569,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] } @@ -1769,6 +1741,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 */ diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 663ae7c55b..eeca81acf7 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,18 +119,20 @@ 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 (* Value descriptions *) 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; @@ -140,9 +143,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 @@ -153,18 +156,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 @@ -177,25 +189,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 @@ -206,10 +224,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 @@ -219,13 +237,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 @@ -236,9 +254,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 *) @@ -247,9 +265,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 @@ -263,14 +281,14 @@ 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 diff --git a/parsing/printast.ml b/parsing/printast.ml index d5b9933113..6507be458e 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -38,7 +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;; +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 @@ -112,6 +113,7 @@ 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;; @@ -172,9 +174,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) -> @@ -204,11 +206,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; @@ -276,7 +278,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; @@ -294,13 +296,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) -> @@ -333,12 +335,12 @@ 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 "_" + string i ppf "_" and type_declaration i ppf x = line i ppf "type_declaration %a\n" fmt_location x.ptype_loc; @@ -381,30 +383,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; @@ -415,7 +418,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; @@ -425,7 +428,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; @@ -458,35 +461,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) -> @@ -499,7 +503,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; @@ -507,12 +511,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) -> @@ -530,24 +534,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; @@ -573,8 +577,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; @@ -585,7 +589,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) -> @@ -613,26 +617,26 @@ and structure_item i ppf x = line i ppf "Pstr_value %a\n" fmt_rec_flag rf; list i pattern_x_expression_def ppf l; | Pstr_primitive (s, vd) -> - line i ppf "Pstr_primitive \"%s\"\n" s; + 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; @@ -644,15 +648,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; @@ -665,18 +669,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; @@ -693,7 +697,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) = @@ -728,7 +732,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 52ea959d4c..b8a837dbef 100644 --- a/stdlib/.depend +++ b/stdlib/.depend @@ -1,248 +1,264 @@ -arg.cmi: -array.cmi: -arrayLabels.cmi: -buffer.cmi: -callback.cmi: -camlinternalLazy.cmi: -camlinternalMod.cmi: obj.cmi -camlinternalOO.cmi: obj.cmi -char.cmi: -complex.cmi: -digest.cmi: -filename.cmi: -format.cmi: pervasives.cmi buffer.cmi -gc.cmi: -genlex.cmi: stream.cmi -hashtbl.cmi: -int32.cmi: -int64.cmi: -lazy.cmi: -lexing.cmi: -list.cmi: -listLabels.cmi: -map.cmi: -marshal.cmi: -moreLabels.cmi: set.cmi map.cmi hashtbl.cmi -nativeint.cmi: -obj.cmi: int32.cmi -oo.cmi: camlinternalOO.cmi -parsing.cmi: obj.cmi lexing.cmi -pervasives.cmi: -printexc.cmi: -printf.cmi: obj.cmi buffer.cmi -queue.cmi: -random.cmi: nativeint.cmi int64.cmi int32.cmi -scanf.cmi: pervasives.cmi -set.cmi: -sort.cmi: -stack.cmi: -stdLabels.cmi: -stream.cmi: -string.cmi: -stringLabels.cmi: -sys.cmi: -weak.cmi: hashtbl.cmi -arg.cmo: sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi arg.cmi -arg.cmx: sys.cmx string.cmx printf.cmx list.cmx buffer.cmx array.cmx arg.cmi -array.cmo: array.cmi -array.cmx: array.cmi -arrayLabels.cmo: array.cmi arrayLabels.cmi -arrayLabels.cmx: array.cmx arrayLabels.cmi -buffer.cmo: sys.cmi string.cmi buffer.cmi -buffer.cmx: sys.cmx string.cmx buffer.cmi -callback.cmo: obj.cmi callback.cmi -callback.cmx: obj.cmx callback.cmi -camlinternalLazy.cmo: obj.cmi camlinternalLazy.cmi -camlinternalLazy.cmx: obj.cmx camlinternalLazy.cmi -camlinternalMod.cmo: obj.cmi camlinternalOO.cmi array.cmi camlinternalMod.cmi -camlinternalMod.cmx: obj.cmx camlinternalOO.cmx array.cmx camlinternalMod.cmi -camlinternalOO.cmo: sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \ - array.cmi camlinternalOO.cmi -camlinternalOO.cmx: sys.cmx string.cmx obj.cmx map.cmx list.cmx char.cmx \ - array.cmx camlinternalOO.cmi -char.cmo: char.cmi -char.cmx: char.cmi -complex.cmo: complex.cmi -complex.cmx: complex.cmi -digest.cmo: string.cmi printf.cmi digest.cmi -digest.cmx: string.cmx printf.cmx digest.cmi -filename.cmo: sys.cmi string.cmi random.cmi printf.cmi buffer.cmi \ +arg.cmi : +array.cmi : +arrayLabels.cmi : +buffer.cmi : +callback.cmi : +camlinternalLazy.cmi : +camlinternalMod.cmi : obj.cmi +camlinternalOO.cmi : obj.cmi +char.cmi : +complex.cmi : +digest.cmi : +filename.cmi : +format.cmi : pervasives.cmi buffer.cmi +gc.cmi : +genlex.cmi : stream.cmi +hashtbl.cmi : +int32.cmi : +int64.cmi : +lazy.cmi : +lexing.cmi : +list.cmi : +listLabels.cmi : +map.cmi : +marshal.cmi : +moreLabels.cmi : set.cmi map.cmi hashtbl.cmi +nativeint.cmi : +obj.cmi : int32.cmi +oo.cmi : camlinternalOO.cmi +parsing.cmi : obj.cmi lexing.cmi +pervasives.cmi : +printexc.cmi : +printf.cmi : obj.cmi buffer.cmi +queue.cmi : +random.cmi : nativeint.cmi int64.cmi int32.cmi +scanf.cmi : pervasives.cmi +set.cmi : +sort.cmi : +stack.cmi : +stdLabels.cmi : +stream.cmi : +string.cmi : +stringLabels.cmi : +sys.cmi : +weak.cmi : hashtbl.cmi +arg.cmo : sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi \ + arg.cmi +arg.cmx : sys.cmx string.cmx printf.cmx list.cmx buffer.cmx array.cmx \ + arg.cmi +array.cmo : array.cmi +array.cmx : array.cmi +arrayLabels.cmo : array.cmi arrayLabels.cmi +arrayLabels.cmx : array.cmx arrayLabels.cmi +buffer.cmo : sys.cmi string.cmi buffer.cmi +buffer.cmx : sys.cmx string.cmx buffer.cmi +callback.cmo : obj.cmi callback.cmi +callback.cmx : obj.cmx callback.cmi +camlinternalLazy.cmo : obj.cmi camlinternalLazy.cmi +camlinternalLazy.cmx : obj.cmx camlinternalLazy.cmi +camlinternalMod.cmo : obj.cmi camlinternalOO.cmi array.cmi \ + camlinternalMod.cmi +camlinternalMod.cmx : obj.cmx camlinternalOO.cmx array.cmx \ + camlinternalMod.cmi +camlinternalOO.cmo : sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \ + callback.cmi array.cmi camlinternalOO.cmi +camlinternalOO.cmx : sys.cmx string.cmx obj.cmx map.cmx list.cmx char.cmx \ + callback.cmx array.cmx camlinternalOO.cmi +char.cmo : char.cmi +char.cmx : char.cmi +complex.cmo : complex.cmi +complex.cmx : complex.cmi +digest.cmo : string.cmi printf.cmi char.cmi digest.cmi +digest.cmx : string.cmx printf.cmx char.cmx digest.cmi +filename.cmo : sys.cmi string.cmi random.cmi printf.cmi 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 -format.cmx: string.cmx printf.cmx pervasives.cmx obj.cmx list.cmx buffer.cmx \ - format.cmi -gc.cmo: sys.cmi printf.cmi gc.cmi -gc.cmx: sys.cmx printf.cmx gc.cmi -genlex.cmo: string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi genlex.cmi -genlex.cmx: string.cmx stream.cmx list.cmx hashtbl.cmx char.cmx genlex.cmi -hashtbl.cmo: sys.cmi random.cmi obj.cmi array.cmi hashtbl.cmi -hashtbl.cmx: sys.cmx random.cmx obj.cmx array.cmx hashtbl.cmi -int32.cmo: pervasives.cmi int32.cmi -int32.cmx: pervasives.cmx int32.cmi -int64.cmo: pervasives.cmi int64.cmi -int64.cmx: pervasives.cmx int64.cmi -lazy.cmo: obj.cmi camlinternalLazy.cmi lazy.cmi -lazy.cmx: obj.cmx camlinternalLazy.cmx lazy.cmi -lexing.cmo: sys.cmi string.cmi array.cmi lexing.cmi -lexing.cmx: sys.cmx string.cmx array.cmx lexing.cmi -list.cmo: list.cmi -list.cmx: list.cmi -listLabels.cmo: list.cmi listLabels.cmi -listLabels.cmx: list.cmx listLabels.cmi -map.cmo: map.cmi -map.cmx: map.cmi -marshal.cmo: string.cmi marshal.cmi -marshal.cmx: string.cmx marshal.cmi -moreLabels.cmo: set.cmi map.cmi hashtbl.cmi moreLabels.cmi -moreLabels.cmx: set.cmx map.cmx hashtbl.cmx moreLabels.cmi -nativeint.cmo: sys.cmi pervasives.cmi nativeint.cmi -nativeint.cmx: sys.cmx pervasives.cmx nativeint.cmi -obj.cmo: marshal.cmi int32.cmi array.cmi obj.cmi -obj.cmx: marshal.cmx int32.cmx array.cmx obj.cmi -oo.cmo: camlinternalOO.cmi oo.cmi -oo.cmx: camlinternalOO.cmx oo.cmi -parsing.cmo: obj.cmi lexing.cmi array.cmi parsing.cmi -parsing.cmx: obj.cmx lexing.cmx array.cmx parsing.cmi -pervasives.cmo: pervasives.cmi -pervasives.cmx: pervasives.cmi -printexc.cmo: printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi -printexc.cmx: printf.cmx obj.cmx buffer.cmx array.cmx printexc.cmi -printf.cmo: string.cmi pervasives.cmi obj.cmi list.cmi char.cmi buffer.cmi \ +format.cmo : string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi \ + buffer.cmi format.cmi +format.cmx : string.cmx printf.cmx pervasives.cmx obj.cmx list.cmx \ + buffer.cmx format.cmi +gc.cmo : sys.cmi printf.cmi gc.cmi +gc.cmx : sys.cmx printf.cmx gc.cmi +genlex.cmo : string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi genlex.cmi +genlex.cmx : string.cmx stream.cmx list.cmx hashtbl.cmx char.cmx genlex.cmi +hashtbl.cmo : sys.cmi 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 +int64.cmx : pervasives.cmx int64.cmi +lazy.cmo : obj.cmi camlinternalLazy.cmi lazy.cmi +lazy.cmx : obj.cmx camlinternalLazy.cmx lazy.cmi +lexing.cmo : sys.cmi string.cmi array.cmi lexing.cmi +lexing.cmx : sys.cmx string.cmx array.cmx lexing.cmi +list.cmo : list.cmi +list.cmx : list.cmi +listLabels.cmo : list.cmi listLabels.cmi +listLabels.cmx : list.cmx listLabels.cmi +map.cmo : map.cmi +map.cmx : map.cmi +marshal.cmo : string.cmi marshal.cmi +marshal.cmx : string.cmx marshal.cmi +moreLabels.cmo : set.cmi map.cmi hashtbl.cmi moreLabels.cmi +moreLabels.cmx : set.cmx map.cmx hashtbl.cmx moreLabels.cmi +nativeint.cmo : sys.cmi pervasives.cmi nativeint.cmi +nativeint.cmx : sys.cmx pervasives.cmx nativeint.cmi +obj.cmo : marshal.cmi int32.cmi array.cmi obj.cmi +obj.cmx : marshal.cmx int32.cmx array.cmx obj.cmi +oo.cmo : camlinternalOO.cmi oo.cmi +oo.cmx : camlinternalOO.cmx oo.cmi +parsing.cmo : obj.cmi lexing.cmi array.cmi parsing.cmi +parsing.cmx : obj.cmx lexing.cmx array.cmx parsing.cmi +pervasives.cmo : pervasives.cmi +pervasives.cmx : pervasives.cmi +printexc.cmo : printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi +printexc.cmx : printf.cmx obj.cmx buffer.cmx array.cmx printexc.cmi +printf.cmo : string.cmi pervasives.cmi obj.cmi list.cmi char.cmi buffer.cmi \ array.cmi printf.cmi -printf.cmx: string.cmx pervasives.cmx obj.cmx list.cmx char.cmx buffer.cmx \ +printf.cmx : string.cmx pervasives.cmx obj.cmx list.cmx char.cmx buffer.cmx \ array.cmx printf.cmi -queue.cmo: obj.cmi queue.cmi -queue.cmx: obj.cmx queue.cmi -random.cmo: string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \ +queue.cmo : obj.cmi queue.cmi +queue.cmx : obj.cmx queue.cmi +random.cmo : string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \ digest.cmi char.cmi array.cmi random.cmi -random.cmx: string.cmx pervasives.cmx nativeint.cmx int64.cmx int32.cmx \ +random.cmx : string.cmx pervasives.cmx nativeint.cmx int64.cmx int32.cmx \ digest.cmx char.cmx array.cmx random.cmi -scanf.cmo: string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi hashtbl.cmi \ - buffer.cmi array.cmi scanf.cmi -scanf.cmx: string.cmx printf.cmx pervasives.cmx obj.cmx list.cmx hashtbl.cmx \ - buffer.cmx array.cmx scanf.cmi -set.cmo: set.cmi -set.cmx: set.cmi -sort.cmo: array.cmi sort.cmi -sort.cmx: array.cmx sort.cmi -stack.cmo: list.cmi stack.cmi -stack.cmx: list.cmx stack.cmi -stdLabels.cmo: stringLabels.cmi listLabels.cmi arrayLabels.cmi stdLabels.cmi -stdLabels.cmx: stringLabels.cmx listLabels.cmx arrayLabels.cmx stdLabels.cmi -std_exit.cmo: -std_exit.cmx: -stream.cmo: string.cmi obj.cmi list.cmi lazy.cmi stream.cmi -stream.cmx: string.cmx obj.cmx list.cmx lazy.cmx stream.cmi -string.cmo: pervasives.cmi list.cmi char.cmi string.cmi -string.cmx: pervasives.cmx list.cmx char.cmx string.cmi -stringLabels.cmo: string.cmi stringLabels.cmi -stringLabels.cmx: string.cmx stringLabels.cmi -sys.cmo: sys.cmi -sys.cmx: sys.cmi -weak.cmo: sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi -weak.cmx: sys.cmx obj.cmx hashtbl.cmx array.cmx weak.cmi -arg.cmo: sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi arg.cmi -arg.p.cmx: sys.p.cmx string.p.cmx printf.p.cmx list.p.cmx buffer.p.cmx array.p.cmx arg.cmi -array.cmo: array.cmi -array.p.cmx: array.cmi -arrayLabels.cmo: array.cmi arrayLabels.cmi -arrayLabels.p.cmx: array.p.cmx arrayLabels.cmi -buffer.cmo: sys.cmi string.cmi buffer.cmi -buffer.p.cmx: sys.p.cmx string.p.cmx buffer.cmi -callback.cmo: obj.cmi callback.cmi -callback.p.cmx: obj.p.cmx callback.cmi -camlinternalLazy.cmo: obj.cmi camlinternalLazy.cmi -camlinternalLazy.p.cmx: obj.p.cmx camlinternalLazy.cmi -camlinternalMod.cmo: obj.cmi camlinternalOO.cmi array.cmi camlinternalMod.cmi -camlinternalMod.p.cmx: obj.p.cmx camlinternalOO.p.cmx array.p.cmx camlinternalMod.cmi -camlinternalOO.cmo: sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \ - array.cmi camlinternalOO.cmi -camlinternalOO.p.cmx: sys.p.cmx string.p.cmx obj.p.cmx map.p.cmx list.p.cmx char.p.cmx \ - array.p.cmx camlinternalOO.cmi -char.cmo: char.cmi -char.p.cmx: char.cmi -complex.cmo: complex.cmi -complex.p.cmx: complex.cmi -digest.cmo: string.cmi printf.cmi digest.cmi -digest.p.cmx: string.p.cmx printf.p.cmx digest.cmi -filename.cmo: sys.cmi string.cmi random.cmi printf.cmi buffer.cmi \ +scanf.cmo : string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi \ + hashtbl.cmi buffer.cmi array.cmi scanf.cmi +scanf.cmx : string.cmx printf.cmx pervasives.cmx obj.cmx list.cmx \ + hashtbl.cmx buffer.cmx array.cmx scanf.cmi +set.cmo : set.cmi +set.cmx : set.cmi +sort.cmo : array.cmi sort.cmi +sort.cmx : array.cmx sort.cmi +stack.cmo : list.cmi stack.cmi +stack.cmx : list.cmx stack.cmi +stdLabels.cmo : stringLabels.cmi listLabels.cmi arrayLabels.cmi \ + stdLabels.cmi +stdLabels.cmx : stringLabels.cmx listLabels.cmx arrayLabels.cmx \ + stdLabels.cmi +std_exit.cmo : +std_exit.cmx : +stream.cmo : string.cmi obj.cmi list.cmi lazy.cmi stream.cmi +stream.cmx : string.cmx obj.cmx list.cmx lazy.cmx stream.cmi +string.cmo : pervasives.cmi list.cmi char.cmi string.cmi +string.cmx : pervasives.cmx list.cmx char.cmx string.cmi +stringLabels.cmo : string.cmi stringLabels.cmi +stringLabels.cmx : string.cmx stringLabels.cmi +sys.cmo : sys.cmi +sys.cmx : sys.cmi +weak.cmo : sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi +weak.cmx : sys.cmx obj.cmx hashtbl.cmx array.cmx weak.cmi +arg.cmo : sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi \ + arg.cmi +arg.p.cmx : sys.p.cmx string.p.cmx printf.p.cmx list.p.cmx buffer.p.cmx array.p.cmx \ + arg.cmi +array.cmo : array.cmi +array.p.cmx : array.cmi +arrayLabels.cmo : array.cmi arrayLabels.cmi +arrayLabels.p.cmx : array.p.cmx arrayLabels.cmi +buffer.cmo : sys.cmi string.cmi buffer.cmi +buffer.p.cmx : sys.p.cmx string.p.cmx buffer.cmi +callback.cmo : obj.cmi callback.cmi +callback.p.cmx : obj.p.cmx callback.cmi +camlinternalLazy.cmo : obj.cmi camlinternalLazy.cmi +camlinternalLazy.p.cmx : obj.p.cmx camlinternalLazy.cmi +camlinternalMod.cmo : obj.cmi camlinternalOO.cmi array.cmi \ + camlinternalMod.cmi +camlinternalMod.p.cmx : obj.p.cmx camlinternalOO.p.cmx array.p.cmx \ + camlinternalMod.cmi +camlinternalOO.cmo : sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \ + callback.cmi array.cmi camlinternalOO.cmi +camlinternalOO.p.cmx : sys.p.cmx string.p.cmx obj.p.cmx map.p.cmx list.p.cmx char.p.cmx \ + callback.p.cmx array.p.cmx camlinternalOO.cmi +char.cmo : char.cmi +char.p.cmx : char.cmi +complex.cmo : complex.cmi +complex.p.cmx : complex.cmi +digest.cmo : string.cmi printf.cmi char.cmi digest.cmi +digest.p.cmx : string.p.cmx printf.p.cmx char.p.cmx digest.cmi +filename.cmo : sys.cmi string.cmi random.cmi printf.cmi 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 -format.p.cmx: string.p.cmx printf.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx buffer.p.cmx \ - format.cmi -gc.cmo: sys.cmi printf.cmi gc.cmi -gc.p.cmx: sys.p.cmx printf.p.cmx gc.cmi -genlex.cmo: string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi genlex.cmi -genlex.p.cmx: string.p.cmx stream.p.cmx list.p.cmx hashtbl.p.cmx char.p.cmx genlex.cmi -hashtbl.cmo: sys.cmi random.cmi obj.cmi array.cmi hashtbl.cmi -hashtbl.p.cmx: sys.p.cmx random.p.cmx obj.p.cmx array.p.cmx hashtbl.cmi -int32.cmo: pervasives.cmi int32.cmi -int32.p.cmx: pervasives.p.cmx int32.cmi -int64.cmo: pervasives.cmi int64.cmi -int64.p.cmx: pervasives.p.cmx int64.cmi -lazy.cmo: obj.cmi camlinternalLazy.cmi lazy.cmi -lazy.p.cmx: obj.p.cmx camlinternalLazy.p.cmx lazy.cmi -lexing.cmo: sys.cmi string.cmi array.cmi lexing.cmi -lexing.p.cmx: sys.p.cmx string.p.cmx array.p.cmx lexing.cmi -list.cmo: list.cmi -list.p.cmx: list.cmi -listLabels.cmo: list.cmi listLabels.cmi -listLabels.p.cmx: list.p.cmx listLabels.cmi -map.cmo: map.cmi -map.p.cmx: map.cmi -marshal.cmo: string.cmi marshal.cmi -marshal.p.cmx: string.p.cmx marshal.cmi -moreLabels.cmo: set.cmi map.cmi hashtbl.cmi moreLabels.cmi -moreLabels.p.cmx: set.p.cmx map.p.cmx hashtbl.p.cmx moreLabels.cmi -nativeint.cmo: sys.cmi pervasives.cmi nativeint.cmi -nativeint.p.cmx: sys.p.cmx pervasives.p.cmx nativeint.cmi -obj.cmo: marshal.cmi int32.cmi array.cmi obj.cmi -obj.p.cmx: marshal.p.cmx int32.p.cmx array.p.cmx obj.cmi -oo.cmo: camlinternalOO.cmi oo.cmi -oo.p.cmx: camlinternalOO.p.cmx oo.cmi -parsing.cmo: obj.cmi lexing.cmi array.cmi parsing.cmi -parsing.p.cmx: obj.p.cmx lexing.p.cmx array.p.cmx parsing.cmi -pervasives.cmo: pervasives.cmi -pervasives.p.cmx: pervasives.cmi -printexc.cmo: printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi -printexc.p.cmx: printf.p.cmx obj.p.cmx buffer.p.cmx array.p.cmx printexc.cmi -printf.cmo: string.cmi pervasives.cmi obj.cmi list.cmi char.cmi buffer.cmi \ +format.cmo : string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi \ + buffer.cmi format.cmi +format.p.cmx : string.p.cmx printf.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx \ + buffer.p.cmx format.cmi +gc.cmo : sys.cmi printf.cmi gc.cmi +gc.p.cmx : sys.p.cmx printf.p.cmx gc.cmi +genlex.cmo : string.cmi stream.cmi list.cmi hashtbl.cmi char.cmi genlex.cmi +genlex.p.cmx : string.p.cmx stream.p.cmx list.p.cmx hashtbl.p.cmx char.p.cmx genlex.cmi +hashtbl.cmo : sys.cmi 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 +int64.p.cmx : pervasives.p.cmx int64.cmi +lazy.cmo : obj.cmi camlinternalLazy.cmi lazy.cmi +lazy.p.cmx : obj.p.cmx camlinternalLazy.p.cmx lazy.cmi +lexing.cmo : sys.cmi string.cmi array.cmi lexing.cmi +lexing.p.cmx : sys.p.cmx string.p.cmx array.p.cmx lexing.cmi +list.cmo : list.cmi +list.p.cmx : list.cmi +listLabels.cmo : list.cmi listLabels.cmi +listLabels.p.cmx : list.p.cmx listLabels.cmi +map.cmo : map.cmi +map.p.cmx : map.cmi +marshal.cmo : string.cmi marshal.cmi +marshal.p.cmx : string.p.cmx marshal.cmi +moreLabels.cmo : set.cmi map.cmi hashtbl.cmi moreLabels.cmi +moreLabels.p.cmx : set.p.cmx map.p.cmx hashtbl.p.cmx moreLabels.cmi +nativeint.cmo : sys.cmi pervasives.cmi nativeint.cmi +nativeint.p.cmx : sys.p.cmx pervasives.p.cmx nativeint.cmi +obj.cmo : marshal.cmi int32.cmi array.cmi obj.cmi +obj.p.cmx : marshal.p.cmx int32.p.cmx array.p.cmx obj.cmi +oo.cmo : camlinternalOO.cmi oo.cmi +oo.p.cmx : camlinternalOO.p.cmx oo.cmi +parsing.cmo : obj.cmi lexing.cmi array.cmi parsing.cmi +parsing.p.cmx : obj.p.cmx lexing.p.cmx array.p.cmx parsing.cmi +pervasives.cmo : pervasives.cmi +pervasives.p.cmx : pervasives.cmi +printexc.cmo : printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi +printexc.p.cmx : printf.p.cmx obj.p.cmx buffer.p.cmx array.p.cmx printexc.cmi +printf.cmo : string.cmi pervasives.cmi obj.cmi list.cmi char.cmi buffer.cmi \ array.cmi printf.cmi -printf.p.cmx: string.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx char.p.cmx buffer.p.cmx \ +printf.p.cmx : string.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx char.p.cmx buffer.p.cmx \ array.p.cmx printf.cmi -queue.cmo: obj.cmi queue.cmi -queue.p.cmx: obj.p.cmx queue.cmi -random.cmo: string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \ +queue.cmo : obj.cmi queue.cmi +queue.p.cmx : obj.p.cmx queue.cmi +random.cmo : string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \ digest.cmi char.cmi array.cmi random.cmi -random.p.cmx: string.p.cmx pervasives.p.cmx nativeint.p.cmx int64.p.cmx int32.p.cmx \ +random.p.cmx : string.p.cmx pervasives.p.cmx nativeint.p.cmx int64.p.cmx int32.p.cmx \ digest.p.cmx char.p.cmx array.p.cmx random.cmi -scanf.cmo: string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi hashtbl.cmi \ - buffer.cmi array.cmi scanf.cmi -scanf.p.cmx: string.p.cmx printf.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx hashtbl.p.cmx \ - buffer.p.cmx array.p.cmx scanf.cmi -set.cmo: set.cmi -set.p.cmx: set.cmi -sort.cmo: array.cmi sort.cmi -sort.p.cmx: array.p.cmx sort.cmi -stack.cmo: list.cmi stack.cmi -stack.p.cmx: list.p.cmx stack.cmi -stdLabels.cmo: stringLabels.cmi listLabels.cmi arrayLabels.cmi stdLabels.cmi -stdLabels.p.cmx: stringLabels.p.cmx listLabels.p.cmx arrayLabels.p.cmx stdLabels.cmi -std_exit.cmo: -std_exit.p.cmx: -stream.cmo: string.cmi obj.cmi list.cmi lazy.cmi stream.cmi -stream.p.cmx: string.p.cmx obj.p.cmx list.p.cmx lazy.p.cmx stream.cmi -string.cmo: pervasives.cmi list.cmi char.cmi string.cmi -string.p.cmx: pervasives.p.cmx list.p.cmx char.p.cmx string.cmi -stringLabels.cmo: string.cmi stringLabels.cmi -stringLabels.p.cmx: string.p.cmx stringLabels.cmi -sys.cmo: sys.cmi -sys.p.cmx: sys.cmi -weak.cmo: sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi -weak.p.cmx: sys.p.cmx obj.p.cmx hashtbl.p.cmx array.p.cmx weak.cmi +scanf.cmo : string.cmi printf.cmi pervasives.cmi obj.cmi list.cmi \ + hashtbl.cmi buffer.cmi array.cmi scanf.cmi +scanf.p.cmx : string.p.cmx printf.p.cmx pervasives.p.cmx obj.p.cmx list.p.cmx \ + hashtbl.p.cmx buffer.p.cmx array.p.cmx scanf.cmi +set.cmo : set.cmi +set.p.cmx : set.cmi +sort.cmo : array.cmi sort.cmi +sort.p.cmx : array.p.cmx sort.cmi +stack.cmo : list.cmi stack.cmi +stack.p.cmx : list.p.cmx stack.cmi +stdLabels.cmo : stringLabels.cmi listLabels.cmi arrayLabels.cmi \ + stdLabels.cmi +stdLabels.p.cmx : stringLabels.p.cmx listLabels.p.cmx arrayLabels.p.cmx \ + stdLabels.cmi +std_exit.cmo : +std_exit.p.cmx : +stream.cmo : string.cmi obj.cmi list.cmi lazy.cmi stream.cmi +stream.p.cmx : string.p.cmx obj.p.cmx list.p.cmx lazy.p.cmx stream.cmi +string.cmo : pervasives.cmi list.cmi char.cmi string.cmi +string.p.cmx : pervasives.p.cmx list.p.cmx char.p.cmx string.cmi +stringLabels.cmo : string.cmi stringLabels.cmi +stringLabels.p.cmx : string.p.cmx stringLabels.cmi +sys.cmo : sys.cmi +sys.p.cmx : sys.cmi +weak.cmo : sys.cmi obj.cmi hashtbl.cmi array.cmi weak.cmi +weak.p.cmx : sys.p.cmx obj.p.cmx hashtbl.p.cmx array.p.cmx weak.cmi diff --git a/stdlib/Makefile.shared b/stdlib/Makefile.shared index 0752a1b5f1..009b80a094 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/callback.mli b/stdlib/callback.mli index ca5f1f073d..c536bf8d53 100644 --- a/stdlib/callback.mli +++ b/stdlib/callback.mli @@ -30,5 +30,5 @@ val register_exception : string -> exn -> unit exception contained in the exception value [exn] under the name [n]. C code can later retrieve a handle to the exception by calling [caml_named_value(n)]. The exception - value thus obtained is suitable for passign as first argument + value thus obtained is suitable for passing as first argument to [raise_constant] or [raise_with_arg]. *) diff --git a/stdlib/camlinternalLazy.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/digest.ml b/stdlib/digest.ml index 47c7e65a7a..38df61a038 100644 --- a/stdlib/digest.ml +++ b/stdlib/digest.ml @@ -50,3 +50,19 @@ let to_hex d = String.blit (Printf.sprintf "%02x" (int_of_char d.[i])) 0 result (2*i) 2; done; result + +let from_hex s = + if String.length s <> 32 then raise (Invalid_argument "Digest.from_hex"); + let digit c = + match c with + | '0'..'9' -> Char.code c - Char.code '0' + | 'A'..'F' -> Char.code c - Char.code 'A' + 10 + | 'a'..'f' -> Char.code c - Char.code 'a' + 10 + | _ -> raise (Invalid_argument "Digest.from_hex") + in + let byte i = digit s.[i] lsl 4 + digit s.[i+1] in + let result = String.create 16 in + for i = 0 to 15 do + result.[i] <- Char.chr (byte (2 * i)); + done; + result diff --git a/stdlib/digest.mli b/stdlib/digest.mli index 01a5f8ba8a..efc0a4773c 100644 --- a/stdlib/digest.mli +++ b/stdlib/digest.mli @@ -32,7 +32,8 @@ val compare : t -> t -> int specification as {!Pervasives.compare} and the implementation shared with {!String.compare}. Along with the type [t], this function [compare] allows the module [Digest] to be passed as - argument to the functors {!Set.Make} and {!Map.Make}. *) + argument to the functors {!Set.Make} and {!Map.Make}. + @since 4.00.0 *) val string : string -> t (** Return the digest of the given string. *) @@ -61,3 +62,9 @@ val input : in_channel -> t val to_hex : t -> string (** Return the printable hexadecimal representation of the given digest. *) + +val from_hex : string -> t +(** Convert a hexadecimal representation back into the corresponding digest. + Raise [Invalid_argument] if the argument is not exactly 32 hexadecimal + characters. + @since 4.00.0 *) diff --git a/stdlib/filename.ml b/stdlib/filename.ml index 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/format.mli b/stdlib/format.mli index 5a55a1547d..491bbc3f91 100644 --- a/stdlib/format.mli +++ b/stdlib/format.mli @@ -22,7 +22,8 @@ For a gentle introduction to the basics of pretty-printing using [Format], read - {{:http://caml.inria.fr/resources/doc/guides/format.html}http://caml.inria.fr/resources/doc/guides/format.html}. + {{:http://caml.inria.fr/resources/doc/guides/format.en.html} + http://caml.inria.fr/resources/doc/guides/format.en.html}. You may consider this module as providing an extension to the [printf] facility to provide automatic line breaking. The addition of @@ -404,7 +405,7 @@ val get_all_formatter_output_functions : including line breaking and indentation functions. Useful to record the current setting and restore it afterwards. *) -(** {6:tags Changing the meaning of printing semantics tags} *) +(** {6:tagsmeaning Changing the meaning of printing semantics tags} *) type formatter_tag_functions = { mark_open_tag : tag -> string; @@ -631,13 +632,18 @@ val fprintf : formatter -> ('a, formatter, unit) format -> 'a;; For more details about tags, see the functions [open_tag] and [close_tag]. - [@\}]: close the most recently opened tag. - - [@@]: print a plain [@] character. - - [@%]: print a plain [%] character. Example: [printf "@[%s@ %d@]@." "x =" 1] is equivalent to [open_box (); print_string "x ="; print_space (); print_int 1; close_box (); print_newline ()]. It prints [x = 1] within a pretty-printing box. + + Note: the old [@@] ``pretty-printing indication'' is now deprecated, since + it had no pretty-printing indication semantics. If you need to prevent + the pretty-printing indication interpretation of a [@] character, simply + use the regular way to escape a character in format string: write [%@]. + @since 3.12.2. + *) val printf : ('a, formatter, unit) format -> 'a;; diff --git a/stdlib/gc.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/genlex.mli b/stdlib/genlex.mli index 41ce68d0fd..b1098f0977 100644 --- a/stdlib/genlex.mli +++ b/stdlib/genlex.mli @@ -37,6 +37,11 @@ [< 'Kwd "+"; n2 = parse_expr >] -> n1+n2 | ... ]} + + One should notice that the use of the [parser] keyword and associated + notation for streams are only available through camlp4 extensions. This + means that one has to preprocess its sources {i e. g.} by using the + ["-pp"] command-line switch of the compilers. *) (** The type of tokens. The lexical classes are: [Int] and [Float] diff --git a/stdlib/hashtbl.ml b/stdlib/hashtbl.ml index 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 3f1a77d54d..00d9efca37 100644 --- a/stdlib/hashtbl.mli +++ b/stdlib/hashtbl.mli @@ -25,25 +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. *) + 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]. @@ -52,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. *) @@ -84,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 @@ -95,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]. @@ -107,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. @@ -117,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]. *) } @@ -125,7 +184,7 @@ val stats : ('a, 'b) t -> statistics (** [Hashtbl.stats tbl] returns statistics about the table [tbl]: number of buckets, size of the biggest bucket, distribution of buckets by size. - @since 3.13.0 *) + @since 4.00.0 *) (** {6 Functorial interface} *) @@ -158,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 @@ -180,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 @@ -196,14 +258,15 @@ module type SeededHashedType = below. *) end (** The input signature of the functor {!Hashtbl.MakeSeeded}. - @since 3.13.0 *) + @since 4.00.0 *) 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 @@ -217,7 +280,7 @@ module type SeededS = val stats: 'a t -> statistics end (** The output signature of the functor {!Hashtbl.MakeSeeded}. - @since 3.13.0 *) + @since 4.00.0 *) module MakeSeeded (H : SeededHashedType) : SeededS with type key = H.t (** Functor building an implementation of the hashtable structure. @@ -227,8 +290,11 @@ 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. - @since 3.13.0 *) + 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 *) (** {6 The polymorphic hash functions} *) @@ -243,7 +309,7 @@ val hash : 'a -> int val seeded_hash : int -> 'a -> int (** A variant of {!Hashtbl.hash} that is further parameterized by an integer seed. - @since 3.13.0 *) + @since 4.00.0 *) val hash_param : int -> int -> 'a -> int (** [Hashtbl.hash_param meaningful total x] computes a hash value for [x], @@ -266,4 +332,4 @@ val seeded_hash_param : int -> int -> int -> 'a -> int (** A variant of {!Hashtbl.hash_param} that is further parameterized by an integer seed. Usage: [Hashtbl.seeded_hash_param meaningful total seed x]. - @since 3.13.0 *) + @since 4.00.0 *) diff --git a/stdlib/lazy.ml b/stdlib/lazy.ml index 359fcaa637..6a114245e7 100644 --- a/stdlib/lazy.ml +++ b/stdlib/lazy.ml @@ -57,13 +57,13 @@ external force : 'a t -> 'a = "%lazy_force";; let force_val = CamlinternalLazy.force_val;; -let lazy_from_fun (f : unit -> 'arg) = +let from_fun (f : unit -> 'arg) = let x = Obj.new_block Obj.lazy_tag 1 in Obj.set_field x 0 (Obj.repr f); (Obj.obj x : 'arg t) ;; -let lazy_from_val (v : 'arg) = +let from_val (v : 'arg) = let t = Obj.tag (Obj.repr v) in if t = Obj.forward_tag || t = Obj.lazy_tag || t = Obj.double_tag then begin make_forward v @@ -72,4 +72,10 @@ let lazy_from_val (v : 'arg) = end ;; -let lazy_is_val (l : 'arg t) = Obj.tag (Obj.repr l) <> Obj.lazy_tag;; +let is_val (l : 'arg t) = Obj.tag (Obj.repr l) <> Obj.lazy_tag;; + +let lazy_from_fun = from_fun;; + +let lazy_from_val = from_val;; + +let lazy_is_val = is_val;; diff --git a/stdlib/lazy.mli b/stdlib/lazy.mli index 4a3b5df0fb..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, @@ -62,15 +62,26 @@ val force_val : 'a t -> 'a;; whether [force_val x] raises the same exception or [Undefined]. *) +val from_fun : (unit -> 'a) -> 'a t;; +(** [from_fun f] is the same as [lazy (f ())] but slightly more efficient. + @since 4.00.0 *) + +val from_val : 'a -> 'a t;; +(** [from_val v] returns an already-forced suspension of [v]. + This is for special purposes only and should not be confused with + [lazy (v)]. + @since 4.00.0 *) + +val is_val : 'a t -> bool;; +(** [is_val x] returns [true] if [x] has already been forced and + did not raise an exception. + @since 4.00.0 *) + val lazy_from_fun : (unit -> 'a) -> 'a t;; -(** [lazy_from_fun f] is the same as [lazy (f ())] but slightly more - efficient. *) +(** @deprecated synonym for [from_fun]. *) val lazy_from_val : 'a -> 'a t;; -(** [lazy_from_val v] returns an already-forced suspension of [v] - This is for special purposes only and should not be confused with - [lazy (v)]. *) +(** @deprecated synonym for [from_val]. *) val lazy_is_val : 'a t -> bool;; -(** [lazy_is_val x] returns [true] if [x] has already been forced and - did not raise an exception. *) +(** @deprecated synonym for [is_val]. *) diff --git a/stdlib/lexing.mli b/stdlib/lexing.mli index 6008e127b7..a1a0690169 100644 --- a/stdlib/lexing.mli +++ b/stdlib/lexing.mli @@ -26,9 +26,12 @@ type position = { (** A value of type [position] describes a point in a source file. [pos_fname] is the file name; [pos_lnum] is the line number; [pos_bol] is the offset of the beginning of the line (number - of characters between the beginning of the file and the beginning + of characters between the beginning of the lexbuf and the beginning of the line); [pos_cnum] is the offset of the position (number of - characters between the beginning of the file and the position). + characters between the beginning of the lexbuf and the position). + The difference between [pos_cnum] and [pos_bol] is the character + offset within the line (i.e. the column number, assuming each + character is one column wide). See the documentation of type [lexbuf] for information about how the lexing engine will manage positions. @@ -149,7 +152,7 @@ val flush_input : lexbuf -> unit (** {6 } *) (** The following definitions are used by the generated scanners only. - They are not intended to be used by user programs. *) + They are not intended to be used directly by user programs. *) val sub_lexeme : lexbuf -> int -> int -> string val sub_lexeme_opt : lexbuf -> int -> int -> string option diff --git a/stdlib/list.mli b/stdlib/list.mli index 96166e25d9..855699d051 100644 --- a/stdlib/list.mli +++ b/stdlib/list.mli @@ -79,7 +79,7 @@ val iteri : (int -> 'a -> unit) -> 'a list -> unit (** Same as {!List.iter}, but the function is applied to the index of the element as first argument (counting from 0), and the element itself as second argument. - @since 3.13.0 + @since 4.00.0 *) val map : ('a -> 'b) -> 'a list -> 'b list @@ -91,7 +91,7 @@ val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list (** Same as {!List.map}, but the function is applied to the index of the element as first argument (counting from 0), and the element itself as second argument. Not tail-recursive. - @since 3.13.0 + @since 4.00.0 *) val rev_map : ('a -> 'b) -> 'a list -> 'b list diff --git a/stdlib/listLabels.mli b/stdlib/listLabels.mli index 324df1394d..b4b58045bf 100644 --- a/stdlib/listLabels.mli +++ b/stdlib/listLabels.mli @@ -76,10 +76,10 @@ val iter : f:('a -> unit) -> 'a list -> unit [begin f a1; f a2; ...; f an; () end]. *) val iteri : f:(int -> 'a -> unit) -> 'a list -> unit -(** Same as {!List.iter}, but the - function is applied to the index of the element as first argument (counting from 0), - and the element itself as second argument. - @since 3.13.0 +(** Same as {!List.iter}, but the function is applied to the index of + the element as first argument (counting from 0), and the element + itself as second argument. + @since 4.00.0 *) val map : f:('a -> 'b) -> 'a list -> 'b list @@ -88,10 +88,10 @@ val map : f:('a -> 'b) -> 'a list -> 'b list with the results returned by [f]. Not tail-recursive. *) val mapi : f:(int -> 'a -> 'b) -> 'a list -> 'b list -(** Same as {!List.map}, but the - function is applied to the index of the element as first argument (counting from 0), - and the element itself as second argument. - @since 3.13.0 +(** Same as {!List.map}, but the function is applied to the index of + the element as first argument (counting from 0), and the element + itself as second argument. + @since 4.00.0 *) val rev_map : f:('a -> 'b) -> 'a list -> 'b list 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/marshal.ml b/stdlib/marshal.ml index c42851504f..638f05434a 100644 --- a/stdlib/marshal.ml +++ b/stdlib/marshal.ml @@ -16,6 +16,7 @@ type extern_flags = No_sharing | Closures +(* note: this type definition is used in 'byterun/debugger.c' *) external to_channel: out_channel -> 'a -> extern_flags list -> unit = "caml_output_value" diff --git a/stdlib/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 9da56a2615..794c056855 100644 --- a/stdlib/pervasives.mli +++ b/stdlib/pervasives.mli @@ -320,7 +320,7 @@ external hypot : float -> float -> float of the hypotenuse of a right-angled triangle with sides of length [x] and [y], or, equivalently, the distance of the point [(x,y)] to origin. - @since 3.13.0 *) + @since 4.00.0 *) external cosh : float -> float = "caml_cosh_float" "cosh" "float" (** Hyperbolic cosine. Argument is in radians. *) @@ -351,7 +351,7 @@ external copysign : float -> float -> float and whose sign is that of [y]. If [x] is [nan], returns [nan]. If [y] is [nan], returns either [x] or [-. x], but it is not specified which. - @since 3.13.0 *) + @since 4.00.0 *) external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float" (** [mod_float a b] returns the remainder of [a] with respect to @@ -461,7 +461,9 @@ external ignore : 'a -> unit = "%ignore" (** {6 String conversion functions} *) val string_of_bool : bool -> string -(** Return the string representation of a boolean. *) +(** Return the string representation of a boolean. As the returned values + may be shared, the user should not modify them directly. +*) val bool_of_string : string -> bool (** Convert the given string to a boolean. @@ -506,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. *) @@ -875,11 +879,12 @@ external decr : int ref -> unit = "%decr" ['a] is the type of the parameters of the format, ['b] is the type of the first argument given to [%a] and [%t] printing functions, - ['c] is the type of the argument transmitted to the first argument of - "kprintf"-style functions, - ['d] is the result type for the "scanf"-style functions, - ['e] is the type of the receiver function for the "scanf"-style functions, - ['f] is the result type for the "printf"-style function. + ['c] is the type of the result of the [%a] and [%t] functions, and + also the type of the argument transmitted to the first argument + of [kprintf]-style functions, + ['d] is the result type for the [scanf]-style functions, + ['e] is the type of the receiver function for the [scanf]-style functions, + ['f] is the result type for the [printf]-style function. *) type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 @@ -923,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/queue.ml b/stdlib/queue.ml index 4e12eb3d2f..388a46c539 100644 --- a/stdlib/queue.ml +++ b/stdlib/queue.ml @@ -54,12 +54,12 @@ let clear q = q.tail <- Obj.magic None let add x q = - q.length <- q.length + 1; - if q.length = 1 then + if q.length = 0 then let rec cell = { content = x; next = cell } in + q.length <- 1; q.tail <- cell else let tail = q.tail in @@ -68,6 +68,7 @@ let add x q = content = x; next = head } in + q.length <- q.length + 1; tail.next <- cell; q.tail <- cell diff --git a/stdlib/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 9c6ecef62f..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 | '^' -> @@ -1111,7 +1111,7 @@ let make_char_bit_vect bit set = ;; (* Compute the predicate on chars corresponding to a char set. *) -let make_pred bit set stp = +let make_predicate bit set stp = let r = make_char_bit_vect bit set in List.iter (fun c -> set_bit_of_range r (int_of_char c) (bit_not bit)) stp; @@ -1131,9 +1131,9 @@ let make_setp stp char_set = (fun c -> if c == p1 || c == p2 then 1 else 0) | 3 -> let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in - if p2 = '-' then make_pred 1 set stp else + if p2 = '-' then make_predicate 1 set stp else (fun c -> if c == p1 || c == p2 || c == p3 then 1 else 0) - | _ -> make_pred 1 set stp + | _ -> make_predicate 1 set stp end | Neg_set set -> begin match String.length set with @@ -1146,9 +1146,9 @@ let make_setp stp char_set = (fun c -> if c != p1 && c != p2 then 1 else 0) | 3 -> let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in - if p2 = '-' then make_pred 0 set stp else + if p2 = '-' then make_predicate 0 set stp else (fun c -> if c != p1 && c != p2 && c != p3 then 1 else 0) - | _ -> make_pred 0 set stp + | _ -> make_predicate 0 set stp end ;; @@ -1335,18 +1335,10 @@ let scan_format ib ef fmt rv f = let rec scan_fmt ir f i = if i > lim then ir, f else match Sformat.unsafe_get fmt i with - | ' ' -> skip_whites ib; scan_fmt ir f (succ i) | '%' -> scan_skip ir f (succ i) - | '@' -> skip_indication ir f (succ i) + | ' ' -> skip_whites ib; scan_fmt ir f (succ i) | c -> check_char ib c; scan_fmt ir f (succ i) - and skip_indication ir f i = - if i < lim then - match Sformat.unsafe_get fmt i with - | '@' | '%' as c -> check_char ib c; scan_fmt ir f (succ i) - | c -> check_char ib c; scan_fmt ir f i - else incomplete_format fmt - and scan_skip ir f i = if i > lim then ir, f else match Sformat.get fmt i with @@ -1393,6 +1385,12 @@ let scan_format ib ef fmt rv f = | '%' | '@' as c -> check_char ib c; scan_fmt ir f (succ i) + | '!' -> + if not (Scanning.end_of_input ib) + then bad_input "end of input not found" else + scan_fmt ir f (succ i) + | ',' -> + scan_fmt ir f (succ i) | 's' -> let i, stp = scan_indication (succ i) in let _x = scan_string stp width ib in @@ -1451,11 +1449,6 @@ let scan_format ib ef fmt rv f = | _ -> scan_fmt ir (stack f (token_int64 conv1 ib)) (succ i) end (* This is not an integer conversion, but a regular %l, %n or %L. *) | _ -> scan_fmt ir (stack f (get_count conv0 ib)) i end - | '!' -> - if Scanning.end_of_input ib then scan_fmt ir f (succ i) - else bad_input "end of input not found" - | ',' -> - scan_fmt ir f (succ i) | '(' | '{' as conv (* ')' '}' *) -> let i = succ i in (* Find the static specification for the format to read. *) diff --git a/stdlib/scanf.mli b/stdlib/scanf.mli index 53317d66d8..410c92a27b 100644 --- a/stdlib/scanf.mli +++ b/stdlib/scanf.mli @@ -25,7 +25,8 @@ strings, files, or anything that can return characters. The more general source of characters is named a {e formatted input channel} (or {e scanning buffer}) and has type {!Scanning.in_channel}. The more general - formatted input function reads from any scanning buffer and is named [bscanf]. + formatted input function reads from any scanning buffer and is named + [bscanf]. Generally speaking, the formatted input functions have 3 arguments: - the first argument is a source of characters for the input, @@ -58,10 +59,10 @@ - if we define the receiver [f] as [let f x = x + 1], - then [bscanf Scanning.stdin "%d" f] reads an integer [n] from the standard input - and returns [f n] (that is [n + 1]). Thus, if we evaluate [bscanf stdin - "%d" f], and then enter [41] at the keyboard, we get [42] as the final - result. *) + then [bscanf Scanning.stdin "%d" f] reads an integer [n] from the + standard input and returns [f n] (that is [n + 1]). Thus, if we + evaluate [bscanf stdin "%d" f], and then enter [41] at the + keyboard, we get [42] as the final result. *) (** {7 Formatted input as a functional feature} *) @@ -78,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 @@ -116,7 +118,7 @@ val stdin : in_channel;; type file_name = string;; (** A convenient alias to designate a file name. - @since 3.13.0 + @since 4.00.0 *) val open_in : file_name -> in_channel;; @@ -132,13 +134,13 @@ val open_in : file_name -> in_channel;; *) val open_in_bin : file_name -> in_channel;; -(** [Scanning.open_in_bin fname] returns a formatted input channel for bufferized - reading in binary mode of file [fname]. +(** [Scanning.open_in_bin fname] returns a formatted input channel for + bufferized reading in binary mode of file [fname]. @since 3.12.0 *) 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 *) @@ -192,12 +194,13 @@ end;; type ('a, 'b, 'c, 'd) scanner = ('a, Scanning.in_channel, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c;; -(** The type of formatted input scanners: [('a, 'b, 'c, 'd) scanner] is the - type of a formatted input function that reads from some formatted input channel - according to some format string; more precisely, if [scan] is some - formatted input function, then [scan ic fmt f] applies [f] to the arguments - specified by the format string [fmt], when [scan] has read those arguments - from the formatted input channel [ic]. +(** The type of formatted input scanners: [('a, 'b, 'c, 'd) scanner] + is the type of a formatted input function that reads from some + formatted input channel according to some format string; more + precisely, if [scan] is some formatted input function, then [scan + ic fmt f] applies [f] to the arguments specified by the format + string [fmt], when [scan] has read those arguments from the + formatted input channel [ic]. For instance, the [scanf] function below has type [('a, 'b, 'c, 'd) scanner], since it is a formatted input function that reads from @@ -282,20 +285,20 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;; encountered,} {- the end-of-input has been reached.}} Hence, this conversion always succeeds: it returns an empty - string, if the bounding condition holds when the scan begins. + string if the bounding condition holds when the scan begins. - [S]: reads a delimited string argument (delimiters and special - escaped characters follow the lexical conventions of Caml). + escaped characters follow the lexical conventions of OCaml). - [c]: reads a single character. To test the current input character without reading it, specify a null field width, i.e. use specification [%0c]. Raise [Invalid_argument], if the field width specification is greater than 1. - [C]: reads a single delimited character (delimiters and special - escaped characters follow the lexical conventions of Caml). + escaped characters follow the lexical conventions of OCaml). - [f], [e], [E], [g], [G]: reads an optionally signed floating-point number in decimal notation, in the style [dddd.ddd e/E+-dd]. - [F]: reads a floating point number according to the lexical - conventions of Caml (hence the decimal point is mandatory if the + conventions of OCaml (hence the decimal point is mandatory if the exponent part is not mentioned). - [B]: reads a boolean argument ([true] or [false]). - [b]: reads a boolean argument (for backward compatibility; do not use @@ -319,17 +322,16 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;; range negation); hence [\[\]\]] matches a [\]] character and [\[^\]\]] matches any character that is not [\]]. Use [%%] and [%\@] to include a [%] or a [\@] in a range. - - [r]: user-defined reader. Takes the next [ri] formatted input function and - applies it to the scanning buffer [ib] to read the next argument. The - input function [ri] must therefore have type [Scanning.in_channel -> 'a] and - the argument read has type ['a]. - - [\{ fmt %\}]: reads a format string argument. - The format string read must have the same type as the format string - specification [fmt]. - For instance, ["%{ %i %}"] reads any format string that can read a value of - type [int]; hence, if [s] is the string ["fmt:\"number is %u\""], then - [Scanf.sscanf s "fmt: %{%i%}"] succeeds and returns the format string - ["number is %u"]. + - [r]: user-defined reader. Takes the next [ri] formatted input + function and applies it to the scanning buffer [ib] to read the + next argument. The input function [ri] must therefore have type + [Scanning.in_channel -> 'a] and the argument read has type ['a]. + - [\{ fmt %\}]: reads a format string argument. The format string + read must have the same type as the format string specification + [fmt]. For instance, ["%{ %i %}"] reads any format string that + can read a value of type [int]; hence, if [s] is the string + ["fmt:\"number is %u\""], then [Scanf.sscanf s "fmt: %{%i%}"] + succeeds and returns the format string ["number is %u"]. - [\( fmt %\)]: scanning format substitution. Reads a format string and then goes on scanning with the format string read, instead of using [fmt]. @@ -375,7 +377,7 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;; nothing to read in the input: in this case, it simply returns [""]. - in addition to the relevant digits, ['_'] characters may appear - inside numbers (this is reminiscent to the usual Caml lexical + inside numbers (this is reminiscent to the usual OCaml lexical conventions). If stricter scanning is desired, use the range conversion facility instead of the number conversions. @@ -430,7 +432,8 @@ val bscanf : Scanning.in_channel -> ('a, 'b, 'c, 'd) scanner;; - as a consequence, scanning a [%s] conversion never raises exception [End_of_file]: if the end of input is reached the conversion succeeds and - simply returns the characters read so far, or [""] if none were ever read. *) + simply returns the characters read so far, or [""] if none were ever read. + *) (** {6 Specialised formatted input functions} *) @@ -498,5 +501,5 @@ val unescaped : string -> string lexical conventions of OCaml, replaced by their corresponding special characters. If there is no escape sequence in the argument, still return a copy, contrary to String.escaped. - @since 3.13.0 + @since 4.00.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/stdLabels.mli b/stdlib/stdLabels.mli index cb1ba01a44..a815d35a2c 100644 --- a/stdlib/stdLabels.mli +++ b/stdlib/stdLabels.mli @@ -117,6 +117,9 @@ module String : unit val concat : sep:string -> string list -> string val iter : f:(char -> unit) -> string -> unit + val iteri : f:(int -> char -> unit) -> string -> unit + val map : f:(char -> char) -> string -> string + val trim : string -> string val escaped : string -> string val index : string -> char -> int val rindex : string -> char -> int diff --git a/stdlib/stream.ml b/stdlib/stream.ml index fc66acb3e9..07effd4a1c 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 2859e65e0e..16e7117973 100644 --- a/stdlib/stream.mli +++ b/stdlib/stream.mli @@ -27,12 +27,7 @@ exception Error of string accepted, but one of the following components is rejected. *) -(** {6 Stream builders} - - Warning: these functions create streams with fast access; it is illegal - to mix them with streams built with [[< >]]; would raise [Failure] - when accessing such mixed streams. -*) +(** {6 Stream builders} *) val from : (int -> 'a option) -> 'a t (** [Stream.from f] returns a stream built from the function [f]. @@ -90,7 +85,7 @@ val npeek : int -> 'a t -> 'a list (**/**) -(** {6 For system use only, not for the casual user} *) +(* The following is for system use only. Do not call directly. *) val iapp : 'a t -> 'a t -> 'a t val icons : 'a -> 'a t -> 'a t diff --git a/stdlib/string.ml b/stdlib/string.ml index 7eafec02fc..f3906f3533 100644 --- a/stdlib/string.ml +++ b/stdlib/string.ml @@ -85,6 +85,27 @@ external is_printable: char -> bool = "caml_is_printable" external char_code: char -> int = "%identity" external char_chr: int -> char = "%identity" +let is_space = function + | ' ' | '\012' | '\n' | '\r' | '\t' -> true + | _ -> false + +let trim s = + let len = length s in + let i = ref 0 in + while !i < len && is_space (unsafe_get s !i) do + incr i + done; + let j = ref (len - 1) in + while !j >= !i && is_space (unsafe_get s !j) do + decr j + done; + if !i = 0 && !j = len - 1 then + s + else if !j >= !i then + sub s !i (!j - !i + 1) + else + "" + let escaped s = let n = ref 0 in for i = 0 to length s - 1 do diff --git a/stdlib/string.mli b/stdlib/string.mli index 501fb181c0..c248fab18a 100644 --- a/stdlib/string.mli +++ b/stdlib/string.mli @@ -14,6 +14,7 @@ (* $Id$ *) (** String operations. + Given a string [s] of length [l], we call character number in [s] the index of a character in [s]. Indexes start at [0], and we will call a character number valid in [s] if it falls within the range @@ -25,6 +26,31 @@ Two parameters [start] and [len] are said to designate a valid substring of [s] if [len >= 0] and [start] and [start+len] are valid positions in [s]. + + OCaml strings can be modified in place, for instance via the + {!String.set} and {!String.blit} functions described below. This + possibility should be used rarely and with much care, however, since + both the OCaml compiler and most OCaml libraries share strings as if + they were immutable, rather than copying them. In particular, + string literals are shared: a single copy of the string is created + at program loading time and returned by all evaluations of the + string literal. Consider for example: + + {[ + # let f () = "foo";; + val f : unit -> string = <fun> + # (f ()).[0] <- 'b';; + - : unit = () + # f ();; + - : string = "boo" + ]} + + Likewise, many functions from the standard library can return string + literals or one of their string arguments. Therefore, the returned strings + must not be modified directly. If mutation is absolutely necessary, + it should be performed on a fresh copy of the string, as produced by + {!String.copy}. + *) external length : string -> int = "%string_length" @@ -98,13 +124,22 @@ val iteri : (int -> char -> unit) -> string -> unit (** Same as {!String.iter}, but the function is applied to the index of the element as first argument (counting from 0), and the character itself as second argument. - @since 3.13.0 + @since 4.00.0 *) val map : (char -> char) -> string -> string (** [String.map f s] applies function [f] in turn to all the characters of [s] and stores the results in a new string that - is returned. *) + is returned. + @since 4.00.0 *) + +val trim : string -> string +(** Return a copy of the argument, without leading and trailing + whitespace. The characters regarded as whitespace are: [' '], + ['\012'], ['\n'], ['\r'], and ['\t']. If there is no leading nor + trailing whitespace character in the argument, return the original + string itself, not a copy. + @since 4.00.0 *) val escaped : string -> string (** Return a copy of the argument, with special characters @@ -188,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 5a17c67dae..59b0eb7c28 100644 --- a/stdlib/stringLabels.mli +++ b/stdlib/stringLabels.mli @@ -86,11 +86,24 @@ val iter : f:(char -> unit) -> string -> unit val iteri : f:(int -> char -> unit) -> string -> unit (** Same as {!String.iter}, but the - function is applied to the index of the element as first argument (counting from 0), - and the character itself as second argument. - @since 3.13.0 + function is applied to the index of the element as first argument + (counting from 0), and the character itself as second argument. + @since 4.00.0 *) +val map : f:(char -> char) -> string -> string +(** [String.map f s] applies function [f] in turn to all + the characters of [s] and stores the results in a new string that + is returned. + @since 4.00.0 *) + +val trim : string -> string +(** Return a copy of the argument, without leading and trailing whitespace. + The characters regarded as whitespace are: [' '], ['\012'], ['\n'], + ['\r'], and ['\t']. If there is no whitespace character in the argument, + return the original string itself, not a copy. + @since 4.00.0 *) + val escaped : string -> string (** Return a copy of the argument, with special characters represented by escape sequences, following the lexical @@ -162,6 +175,8 @@ val compare: t -> t -> int (**/**) +(* The following is for system use only. Do not call directly. *) + external unsafe_get : string -> int -> char = "%string_unsafe_get" external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" external unsafe_blit : diff --git a/stdlib/sys.mli b/stdlib/sys.mli index 4913bef8ee..6f3d579785 100644 --- a/stdlib/sys.mli +++ b/stdlib/sys.mli @@ -84,6 +84,10 @@ val word_size : int (** Size of one word on the machine currently executing the OCaml program, in bits: 32 or 64. *) +val big_endian : bool +(** Whether the machine currently executing the Caml program is big-endian. + @since 4.00.0 *) + val max_string_length : int (** Maximum length of a string. *) diff --git a/stdlib/sys.mlp b/stdlib/sys.mlp index b83cbb287c..c7271794d0 100644 --- a/stdlib/sys.mlp +++ b/stdlib/sys.mlp @@ -19,11 +19,11 @@ (* System interface *) -external get_config: unit -> string * int = "caml_sys_get_config" +external get_config: unit -> string * int * bool = "caml_sys_get_config" external get_argv: unit -> string * string array = "caml_sys_get_argv" let (executable_name, argv) = get_argv() -let (os_type, word_size) = get_config() +let (os_type, word_size, big_endian) = get_config() let max_array_length = (1 lsl (word_size - 10)) - 1;; let max_string_length = word_size / 8 * max_array_length - 1;; diff --git a/testsuite/interactive/lib-gc/alloc.ml b/testsuite/interactive/lib-gc/alloc.ml index dbcb3e4fda..24a568caaf 100644 --- a/testsuite/interactive/lib-gc/alloc.ml +++ b/testsuite/interactive/lib-gc/alloc.ml @@ -48,4 +48,3 @@ let argspecs = [ Arg.parse argspecs (fun _ -> ()) "Usage: alloc [-c]";; main ();; - diff --git a/testsuite/interactive/lib-graph-2/graph_test.ml b/testsuite/interactive/lib-graph-2/graph_test.ml index 39b845675d..6c9fd49ac6 100644 --- a/testsuite/interactive/lib-graph-2/graph_test.ml +++ b/testsuite/interactive/lib-graph-2/graph_test.ml @@ -27,7 +27,7 @@ let sz = 450;; open_graph (Printf.sprintf " %ix%i" sz sz);; -(* To be defined for older versions of O'Caml +(* To be defined for older versions of OCaml Lineto, moveto and draw_rect. let rlineto x y = @@ -150,7 +150,7 @@ let x,y = current_point () in fill_rect x (y - 5) (8 * 20) 25;; set_color yellow;; go_legend ();; -draw_string "Graphics (Caml)";; +draw_string "Graphics (OCaml)";; (* Pie parts in different colors. *) let draw_green_string s = set_color green; draw_string s;; diff --git a/testsuite/lib/Makefile b/testsuite/lib/Makefile index c73bea508f..b6fc63c207 100644 --- a/testsuite/lib/Makefile +++ b/testsuite/lib/Makefile @@ -1,9 +1,14 @@ # $Id$ -compile: testing.cmi testing.cmo testing.cmx +compile: compile-targets promote: defaultpromote clean: defaultclean include ../makefiles/Makefile.common + +compile-targets: testing.cmi testing.cmo + @if [ -z "$(BYTECODE_ONLY)" ]; then \ + $(MAKE) testing.cmx; \ + fi diff --git a/testsuite/lib/testing.ml b/testsuite/lib/testing.ml index aa8933a789..4b49cfc0a1 100644 --- a/testsuite/lib/testing.ml +++ b/testsuite/lib/testing.ml @@ -30,7 +30,7 @@ at_exit finish;; let test_num = ref (-1);; let print_test_number () = - print_int !test_num; print_string " "; flush stdout;; + print_string " "; print_int !test_num; flush stdout;; let next_test () = incr test_num; @@ -93,4 +93,3 @@ let any_failure_test = test_raises_some_failure;; let scan_failure_test f x = test_raises_exc_p (function Scan_failure _ -> true | _ -> false) f x;; - diff --git a/testsuite/makefiles/Makefile.common b/testsuite/makefiles/Makefile.common index e1b15dbace..c7da5b7058 100644 --- a/testsuite/makefiles/Makefile.common +++ b/testsuite/makefiles/Makefile.common @@ -7,16 +7,16 @@ 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 -I $(TOPDIR)/stdlib +OCAMLOPT=$(OCAMLRUN) $(TOPDIR)/ocamlopt -I $(TOPDIR)/stdlib +OCAMLDOC=$(OCAMLRUN) $(TOPDIR)/ocamldoc/ocamldoc +OCAMLLEX=$(OCAMLRUN) $(TOPDIR)/lex/ocamllex +OCAMLMKLIB=$(OCAMLRUN) $(TOPDIR)/tools/ocamlmklib OCAMLYACC=$(TOPDIR)/yacc/ocamlyacc$(EXE) OCAMLBUILD=$(TOPDIR)/_build/ocamlbuild/ocamlbuild.native -DUMPOBJ=$(OCAMLRUN) $(TOPDIR)/tool/dumpobj$(EXE) -BYTECODE_ONLY=`if [ "$(ASM)" = "none" ]; then echo 'YES'; else echo ''; fi` +DUMPOBJ=$(OCAMLRUN) $(TOPDIR)/tool/dumpobj +BYTECODE_ONLY=`if [ "$(ARCH)" = "none" -o "$(ASM)" = "none" ]; then echo 'YES'; else echo ''; fi` #COMPFLAGS= #FORTRAN_COMPILER= #FORTRAN_LIBRARY= 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 e5bd430a1c..af81182253 100644 --- a/testsuite/makefiles/Makefile.several +++ b/testsuite/makefiles/Makefile.several @@ -41,19 +41,20 @@ run-all: run-file: @printf " $(DESC)" + @rm -f program program.exe @$(COMP) $(COMPFLAGS) $(FILE) -o program @if [ -f `basename $(FILE) ml`runner ]; then \ sh `basename $(FILE) ml`runner; \ 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/amd64.S b/testsuite/tests/asmcomp/amd64.S index 26db8722a9..57229e09a4 100644 --- a/testsuite/tests/asmcomp/amd64.S +++ b/testsuite/tests/asmcomp/amd64.S @@ -39,12 +39,12 @@ CALL_GEN_CODE: pushq %r13 pushq %r14 pushq %r15 - movq %rdi, %r10 - movq %rsi, %rax - movq %rdx, %rbx - movq %rcx, %rdi - movq %r8, %rsi - call *%r10 + movq %rdi, %r10 + movq %rsi, %rax + movq %rdx, %rbx + movq %rcx, %rdi + movq %r8, %rsi + call *%r10 popq %r15 popq %r14 popq %r13 @@ -59,17 +59,17 @@ CAML_C_CALL: jmp *%rax #ifdef SYS_macosx - .literal16 + .literal16 #else - .section .rodata.cst8,"aM",@progbits,8 + .section .rodata.cst8,"aM",@progbits,8 #endif .globl CAML_NEGF_MASK .align ALIGN CAML_NEGF_MASK: - .quad 0x8000000000000000, 0 + .quad 0x8000000000000000, 0 .globl CAML_ABSF_MASK .align ALIGN CAML_ABSF_MASK: - .quad 0x7FFFFFFFFFFFFFFF, 0 + .quad 0x7FFFFFFFFFFFFFFF, 0 .comm young_limit, 8 diff --git a/testsuite/tests/asmcomp/arith.cmm b/testsuite/tests/asmcomp/arith.cmm index a8bc613c77..b29812957a 100644 --- a/testsuite/tests/asmcomp/arith.cmm +++ b/testsuite/tests/asmcomp/arith.cmm @@ -217,6 +217,3 @@ (floataset d 38 (absf f)) ))))))) - - - diff --git a/testsuite/tests/asmcomp/arm.S b/testsuite/tests/asmcomp/arm.S index 0fd1a29fe6..8fab5ae92f 100644 --- a/testsuite/tests/asmcomp/arm.S +++ b/testsuite/tests/asmcomp/arm.S @@ -37,4 +37,3 @@ call_gen_code: caml_c_call: @ function to call is in r10 mov pc, r10 - diff --git a/testsuite/tests/asmcomp/checkbound.cmm b/testsuite/tests/asmcomp/checkbound.cmm index c20740c113..62828bd350 100644 --- a/testsuite/tests/asmcomp/checkbound.cmm +++ b/testsuite/tests/asmcomp/checkbound.cmm @@ -17,5 +17,3 @@ (function "checkbound1" (x: int) (checkbound x 2)) - - diff --git a/testsuite/tests/asmcomp/hppa.S b/testsuite/tests/asmcomp/hppa.S index 02f457dc75..ff3d66d59f 100644 --- a/testsuite/tests/asmcomp/hppa.S +++ b/testsuite/tests/asmcomp/hppa.S @@ -32,13 +32,13 @@ #endif #ifdef SYS_hpux - .space $PRIVATE$ - .subspa $DATA$,quad=1,align=8,access=31 - .subspa $BSS$,quad=1,align=8,access=31,zero,sort=82 - .space $TEXT$ - .subspa $LIT$,quad=0,align=8,access=44 - .subspa $CODE$,quad=0,align=8,access=44,code_only - .import $global$, data + .space $PRIVATE$ + .subspa $DATA$,quad=1,align=8,access=31 + .subspa $BSS$,quad=1,align=8,access=31,zero,sort=82 + .space $TEXT$ + .subspa $LIT$,quad=0,align=8,access=44 + .subspa $CODE$,quad=0,align=8,access=44,code_only + .import $global$, data .import $$dyncall, millicode #endif @@ -47,8 +47,8 @@ EXPORT_CODE(G(call_gen_code)) G(call_gen_code): STARTPROC - stw %r2,-20(%r30) - ldo 256(%r30), %r30 + stw %r2,-20(%r30) + ldo 256(%r30), %r30 ; Save the callee-save registers ldo -32(%r30), %r1 stws,ma %r3, -4(%r1) @@ -67,26 +67,26 @@ G(call_gen_code): stws,ma %r16, -4(%r1) stws,ma %r17, -4(%r1) stws,ma %r18, -4(%r1) - fstds,ma %fr12, -8(%r1) - fstds,ma %fr13, -8(%r1) - fstds,ma %fr14, -8(%r1) - fstds,ma %fr15, -8(%r1) - fstds,ma %fr16, -8(%r1) - fstds,ma %fr17, -8(%r1) - fstds,ma %fr18, -8(%r1) - fstds,ma %fr19, -8(%r1) - fstds,ma %fr20, -8(%r1) - fstds,ma %fr21, -8(%r1) - fstds,ma %fr22, -8(%r1) - fstds,ma %fr23, -8(%r1) - fstds,ma %fr24, -8(%r1) - fstds,ma %fr25, -8(%r1) - fstds,ma %fr26, -8(%r1) - fstds,ma %fr27, -8(%r1) - fstds,ma %fr28, -8(%r1) - fstds,ma %fr29, -8(%r1) - fstds,ma %fr30, -8(%r1) - fstds,ma %fr31, -8(%r1) + fstds,ma %fr12, -8(%r1) + fstds,ma %fr13, -8(%r1) + fstds,ma %fr14, -8(%r1) + fstds,ma %fr15, -8(%r1) + fstds,ma %fr16, -8(%r1) + fstds,ma %fr17, -8(%r1) + fstds,ma %fr18, -8(%r1) + fstds,ma %fr19, -8(%r1) + fstds,ma %fr20, -8(%r1) + fstds,ma %fr21, -8(%r1) + fstds,ma %fr22, -8(%r1) + fstds,ma %fr23, -8(%r1) + fstds,ma %fr24, -8(%r1) + fstds,ma %fr25, -8(%r1) + fstds,ma %fr26, -8(%r1) + fstds,ma %fr27, -8(%r1) + fstds,ma %fr28, -8(%r1) + fstds,ma %fr29, -8(%r1) + fstds,ma %fr30, -8(%r1) + fstds,ma %fr31, -8(%r1) ; Shuffle the arguments and call copy %r26, %r22 @@ -121,42 +121,42 @@ G(call_gen_code): ldws,ma -4(%r1), %r16 ldws,ma -4(%r1), %r17 ldws,ma -4(%r1), %r18 - fldds,ma -8(%r1), %fr12 - fldds,ma -8(%r1), %fr13 - fldds,ma -8(%r1), %fr14 - fldds,ma -8(%r1), %fr15 - fldds,ma -8(%r1), %fr16 - fldds,ma -8(%r1), %fr17 - fldds,ma -8(%r1), %fr18 - fldds,ma -8(%r1), %fr19 - fldds,ma -8(%r1), %fr20 - fldds,ma -8(%r1), %fr21 - fldds,ma -8(%r1), %fr22 - fldds,ma -8(%r1), %fr23 - fldds,ma -8(%r1), %fr24 - fldds,ma -8(%r1), %fr25 - fldds,ma -8(%r1), %fr26 - fldds,ma -8(%r1), %fr27 - fldds,ma -8(%r1), %fr28 - fldds,ma -8(%r1), %fr29 - fldds,ma -8(%r1), %fr30 - fldds,ma -8(%r1), %fr31 + fldds,ma -8(%r1), %fr12 + fldds,ma -8(%r1), %fr13 + fldds,ma -8(%r1), %fr14 + fldds,ma -8(%r1), %fr15 + fldds,ma -8(%r1), %fr16 + fldds,ma -8(%r1), %fr17 + fldds,ma -8(%r1), %fr18 + fldds,ma -8(%r1), %fr19 + fldds,ma -8(%r1), %fr20 + fldds,ma -8(%r1), %fr21 + fldds,ma -8(%r1), %fr22 + fldds,ma -8(%r1), %fr23 + fldds,ma -8(%r1), %fr24 + fldds,ma -8(%r1), %fr25 + fldds,ma -8(%r1), %fr26 + fldds,ma -8(%r1), %fr27 + fldds,ma -8(%r1), %fr28 + fldds,ma -8(%r1), %fr29 + fldds,ma -8(%r1), %fr30 + fldds,ma -8(%r1), %fr31 - ldo -256(%r30), %r30 - ldw -20(%r30), %r2 + ldo -256(%r30), %r30 + ldw -20(%r30), %r2 bv 0(%r2) nop ENDPROC - .align CODE_ALIGN - EXPORT_CODE(caml_c_call) + .align CODE_ALIGN + EXPORT_CODE(caml_c_call) G(caml_c_call): STARTPROC #ifdef SYS_hpux bl $$dyncall, %r0 nop #else - bv 0(%r22) + bv 0(%r22) nop #endif ENDPROC 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/i386nt.asm b/testsuite/tests/asmcomp/i386nt.asm index 75ae8ce737..80af32ffd0 100644 --- a/testsuite/tests/asmcomp/i386nt.asm +++ b/testsuite/tests/asmcomp/i386nt.asm @@ -1,67 +1,67 @@ -;********************************************************************* -; -; OCaml -; -; Xavier Leroy, projet Cristal, INRIA Rocquencourt -; -; Copyright 1996 Institut National de Recherche en Informatique et -; en Automatique. All rights reserved. This file is distributed -; under the terms of the Q Public License version 1.0. -; -;********************************************************************* +;*********************************************************************; +; ; +; OCaml ; +; ; +; Xavier Leroy, projet Cristal, INRIA Rocquencourt ; +; ; +; Copyright 1996 Institut National de Recherche en Informatique et ; +; en Automatique. All rights reserved. This file is distributed ; +; under the terms of the Q Public License version 1.0. ; +; ; +;*********************************************************************; ; $Id$ - .386 - .MODEL FLAT + .386 + .MODEL FLAT .CODE PUBLIC _call_gen_code ALIGN 4 _call_gen_code: - push ebp - mov ebp, esp - push ebx - push esi - push edi - mov eax, [ebp+12] - mov ebx, [ebp+16] - mov ecx, [ebp+20] - mov edx, [ebp+24] - call DWORD PTR [ebp+8] - pop edi - pop esi - pop ebx - pop ebp - ret + push ebp + mov ebp, esp + push ebx + push esi + push edi + mov eax, [ebp+12] + mov ebx, [ebp+16] + mov ecx, [ebp+20] + mov edx, [ebp+24] + call DWORD PTR [ebp+8] + pop edi + pop esi + pop ebx + pop ebp + ret PUBLIC _caml_c_call ALIGN 4 _caml_c_call: - ffree st(0) - ffree st(1) - ffree st(2) - ffree st(3) - jmp eax + ffree st(0) + ffree st(1) + ffree st(2) + ffree st(3) + jmp eax PUBLIC _caml_call_gc PUBLIC _caml_alloc PUBLIC _caml_alloc1 PUBLIC _caml_alloc2 - PUBLIC _caml_alloc3 + PUBLIC _caml_alloc3 _caml_call_gc: _caml_alloc: _caml_alloc1: _caml_alloc2: _caml_alloc3: - int 3 + int 3 .DATA - PUBLIC _caml_exception_pointer -_caml_exception_pointer dword 0 - PUBLIC _young_ptr -_young_ptr dword 0 - PUBLIC _young_limit -_young_limit dword 0 + PUBLIC _caml_exception_pointer +_caml_exception_pointer dword 0 + PUBLIC _young_ptr +_young_ptr dword 0 + PUBLIC _young_limit +_young_limit dword 0 END diff --git a/testsuite/tests/asmcomp/ia64.S b/testsuite/tests/asmcomp/ia64.S index 68d649b531..028c622f9d 100644 --- a/testsuite/tests/asmcomp/ia64.S +++ b/testsuite/tests/asmcomp/ia64.S @@ -26,7 +26,7 @@ .proc call_gen_code# call_gen_code: - /* Allocate 64 "out" registers (for the Caml code) and no locals */ + /* Allocate 64 "out" registers (for the OCaml code) and no locals */ alloc r3 = ar.pfs, 0, 0, 64, 0 /* Save PFS, return address and GP on stack */ diff --git a/testsuite/tests/asmcomp/m68k.S b/testsuite/tests/asmcomp/m68k.S index f15ddcbb40..f24ff404e7 100644 --- a/testsuite/tests/asmcomp/m68k.S +++ b/testsuite/tests/asmcomp/m68k.S @@ -19,7 +19,7 @@ | int * int * address -> void | int * int -> void | unit -> unit -| Hence arg1 -> d0, arg2 -> d1, arg3 -> a0, +| Hence arg1 -> d0, arg2 -> d1, arg3 -> a0, | and we need a special case for int -> double .text diff --git a/testsuite/tests/asmcomp/main.ml b/testsuite/tests/asmcomp/main.ml index 0555daed8d..09539f9353 100644 --- a/testsuite/tests/asmcomp/main.ml +++ b/testsuite/tests/asmcomp/main.ml @@ -57,4 +57,3 @@ let main() = ] compile_file usage let _ = (*Printexc.catch*) main (); exit 0 - diff --git a/testsuite/tests/asmcomp/mainarith.c b/testsuite/tests/asmcomp/mainarith.c index a71be4961c..3bda5ddeaf 100644 --- a/testsuite/tests/asmcomp/mainarith.c +++ b/testsuite/tests/asmcomp/mainarith.c @@ -304,4 +304,3 @@ int main(int argc, char **argv) } return 0; } - diff --git a/testsuite/tests/asmcomp/parsecmm.mly b/testsuite/tests/asmcomp/parsecmm.mly index 87db7a5fea..c19adf1c3d 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 } @@ -324,4 +325,3 @@ dataitem: | SKIP INTCONST { Cskip $2 } | ALIGN INTCONST { Calign $2 } ; - diff --git a/testsuite/tests/asmcomp/power-aix.S b/testsuite/tests/asmcomp/power-aix.S index ee8a09698d..0752100f59 100644 --- a/testsuite/tests/asmcomp/power-aix.S +++ b/testsuite/tests/asmcomp/power-aix.S @@ -123,7 +123,7 @@ .globl .caml_c_call .caml_c_call: # Preserve RTOC and return address in callee-save registers -# The C function will preserve them, and the Caml code does not +# The C function will preserve them, and the OCaml code does not # expect them to be preserved # Return address is in 25, RTOC is in 26 mflr 25 diff --git a/testsuite/tests/asmcomp/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/asmcomp/tagged-fib.cmm b/testsuite/tests/asmcomp/tagged-fib.cmm index 5ee234d9ff..67d4cba2bd 100644 --- a/testsuite/tests/asmcomp/tagged-fib.cmm +++ b/testsuite/tests/asmcomp/tagged-fib.cmm @@ -16,4 +16,3 @@ (if (< n 5) 3 (- (+ (app "fib" (- n 2) int) (app "fib" (- n 4) int)) 1))) - diff --git a/testsuite/tests/asmcomp/tagged-integr.cmm b/testsuite/tests/asmcomp/tagged-integr.cmm index 6f7562878e..663633d7a5 100644 --- a/testsuite/tests/asmcomp/tagged-integr.cmm +++ b/testsuite/tests/asmcomp/tagged-integr.cmm @@ -42,4 +42,3 @@ (store float "low" 0.0) (store float "hi" 1.0) (load float (app "integr" "square" "low" "hi" n addr))) - diff --git a/testsuite/tests/basic-float/tfloat_record.ml b/testsuite/tests/basic-float/tfloat_record.ml index 4d197f5de5..996640a00e 100644 --- a/testsuite/tests/basic-float/tfloat_record.ml +++ b/testsuite/tests/basic-float/tfloat_record.ml @@ -2,4 +2,3 @@ let s = { Float_record.f = Float_record.make 1.0 };; print_float (Float_record.from s.Float_record.f);; print_newline ();; - 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/bounds.ml b/testsuite/tests/basic-more/bounds.ml index 7fe52a1f57..edaa0c8a2c 100644 --- a/testsuite/tests/basic-more/bounds.ml +++ b/testsuite/tests/basic-more/bounds.ml @@ -24,5 +24,3 @@ let _ = print_string "Trail:"; List.iter (fun n -> print_string " "; print_int n) !trail; print_newline() - - diff --git a/testsuite/tests/basic-more/morematch.ml b/testsuite/tests/basic-more/morematch.ml index e45234d008..3b274d482e 100644 --- a/testsuite/tests/basic-more/morematch.ml +++ b/testsuite/tests/basic-more/morematch.ml @@ -51,13 +51,13 @@ test "deux" g 6 5 ; test "deux" g 9 7 ; () ;; - + let g x = match x with 1 -> 1 | 2 -> 2 | 3 -> 3 | 4 | 5 -> 4 -| 6 -> 5 +| 6 -> 5 | 7 | 8 -> 6 | 9 -> 7 | _ -> 8;; @@ -70,7 +70,7 @@ let g x= match x with | 2 -> 2 | 3 -> 3 | 4 | 5 -> 4 -| 6 -> 5 +| 6 -> 5 | 4|5|7 -> 100 | 7 | 8 -> 6 | 9 -> 7 @@ -251,7 +251,7 @@ test "fin" f (D (C,1)) (D (A,1)) ; test "fin" f (E (C,A)) (D (A,0)) ; () ;; -type length = +type length = Char of int | Pixel of int | Percent of int | No of string | Default let length = function @@ -550,7 +550,7 @@ test "flatgarde" flatgarde (2,4) 3 ; () (* Les bugs de jerome *) type f = - | ABSENT + | ABSENT | FILE | SYMLINK | DIRECTORY @@ -584,27 +584,27 @@ let replicaContent2shortString rc = ;; -test "jerome_constr" +test "jerome_constr" replicaContent2shortString (ABSENT, Unchanged) " " ; -test "jerome_constr" +test "jerome_constr" replicaContent2shortString (ABSENT, Deleted) "deleted " ; -test "jerome_constr" +test "jerome_constr" replicaContent2shortString (FILE, Modified) "changed " ; -test "jerome_constr" +test "jerome_constr" replicaContent2shortString (DIRECTORY, PropsChanged) "props " ; -test "jerome_constr" +test "jerome_constr" replicaContent2shortString (FILE, Deleted) "assert false" ; -test "jerome_constr" +test "jerome_constr" replicaContent2shortString (SYMLINK, Deleted) "assert false" ; -test "jerome_constr" +test "jerome_constr" replicaContent2shortString (SYMLINK, PropsChanged) "assert false" ; -test "jerome_constr" +test "jerome_constr" replicaContent2shortString (DIRECTORY, Deleted) "assert false" ; -test "jerome_constr" +test "jerome_constr" replicaContent2shortString (ABSENT, Created) "assert false" ; -test "jerome_constr" +test "jerome_constr" replicaContent2shortString (ABSENT, Modified) "assert false" ; -test "jerome_constr" +test "jerome_constr" replicaContent2shortString (ABSENT, PropsChanged) "assert false" ; ;; @@ -631,27 +631,27 @@ let replicaContent2shortString rc = ;; -test "jerome_variant" +test "jerome_variant" replicaContent2shortString (`ABSENT, `Unchanged) " " ; -test "jerome_variant" +test "jerome_variant" replicaContent2shortString (`ABSENT, `Deleted) "deleted " ; -test "jerome_variant" +test "jerome_variant" replicaContent2shortString (`FILE, `Modified) "changed " ; -test "jerome_variant" +test "jerome_variant" replicaContent2shortString (`DIRECTORY, `PropsChanged) "props " ; -test "jerome_variant" +test "jerome_variant" replicaContent2shortString (`FILE, `Deleted) "assert false" ; -test "jerome_variant" +test "jerome_variant" replicaContent2shortString (`SYMLINK, `Deleted) "assert false" ; -test "jerome_variant" +test "jerome_variant" replicaContent2shortString (`SYMLINK, `PropsChanged) "assert false" ; -test "jerome_variant" +test "jerome_variant" replicaContent2shortString (`DIRECTORY, `Deleted) "assert false" ; -test "jerome_variant" +test "jerome_variant" replicaContent2shortString (`ABSENT, `Created) "assert false" ; -test "jerome_variant" +test "jerome_variant" replicaContent2shortString (`ABSENT, `Modified) "assert false" ; -test "jerome_variant" +test "jerome_variant" replicaContent2shortString (`ABSENT, `PropsChanged) "assert false" ; ;; @@ -972,10 +972,10 @@ match n with type habert_a= | A of habert_c | B of habert_c - -and habert_c= {lvar:int; lassoc: habert_c;lnb:int} - - + +and habert_c= {lvar:int; lassoc: habert_c;lnb:int} + + let habert=function | (A {lnb=i}|B {lnb=i}) when i=0 -> 1 | A {lassoc=({lnb=j});lnb=i} -> 2 @@ -1000,13 +1000,13 @@ type type_expr = [ | `TVariant of string list | `TBlock of int | `TCopy of type_expr - ] + ] and recurs_type_expr = [ | `TTuple of type_expr list | `TConstr of type_expr list | `TVariant of string list - ] + ] let rec maf te = @@ -1129,7 +1129,7 @@ type bg = [ | `False | `True ] - + type vg = [ | `A | `B @@ -1142,7 +1142,7 @@ type tg = { x : bg; } -let predg x = true +let predg x = true let rec gilles o = match o with | {v = (`U data | `V data); x = `False} when predg o -> 1 diff --git a/testsuite/tests/basic-more/tbuffer.ml b/testsuite/tests/basic-more/tbuffer.ml index d48268db21..b834857584 100644 --- a/testsuite/tests/basic-more/tbuffer.ml +++ b/testsuite/tests/basic-more/tbuffer.ml @@ -24,4 +24,3 @@ Buffer.clear b; Buffer.add_substitute b identity pat1; test (String.length (Buffer.contents b) = n1) ;; - diff --git a/testsuite/tests/basic-more/tbuffer.reference b/testsuite/tests/basic-more/tbuffer.reference index e41ae64944..f0f683477f 100644 --- a/testsuite/tests/basic-more/tbuffer.reference +++ b/testsuite/tests/basic-more/tbuffer.reference @@ -1,2 +1,2 @@ -0 1 + 0 1 All tests succeeded. diff --git a/testsuite/tests/basic-more/testrandom.ml b/testsuite/tests/basic-more/testrandom.ml index 150d408898..8a7ab475cf 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_char ' '; print_int (int 1000); done; print_newline (); print_newline (); for i = 0 to 20 do - print_int (int 1000); print_char ' ' + print_char ' '; print_float (float 1000.); done let _ = exit 0 - diff --git a/testsuite/tests/basic-more/testrandom.reference b/testsuite/tests/basic-more/testrandom.reference index f063674d90..943addd1bd 100644 --- a/testsuite/tests/basic-more/testrandom.reference +++ b/testsuite/tests/basic-more/testrandom.reference @@ -1,4 +1,4 @@ -270.251355065 597.822945853 287.052171181 625.315015859 241.029649126 559.742196387 932.074421229 756.637587326 360.006556146 987.177314953 190.217751234 758.516786217 59.8488223602 328.350439075 172.627051105 944.543207513 629.424106752 868.196647048 174.382120878 78.1259713643 34.3270777955 + 344 685 182 641 439 500 104 20 921 370 217 885 949 678 615 412 401 606 428 869 289 -683 782 740 270 835 136 791 168 324 222 156 835 328 636 233 153 671 69 95 357 92 + 122.128067547 461.324792129 360.006556146 768.75882284 396.500946942 190.217751234 567.660068681 403.59226778 59.8488223602 363.816246826 764.705761642 172.627051105 481.861849093 399.173195422 629.424106752 391.547032203 676.701133948 174.382120878 994.425675487 585.00027757 34.3270777955 All tests succeeded. diff --git a/testsuite/tests/basic-more/tformat.reference b/testsuite/tests/basic-more/tformat.reference index 117423261c..819c5ba693 100644 --- a/testsuite/tests/basic-more/tformat.reference +++ b/testsuite/tests/basic-more/tformat.reference @@ -1,2 +1,2 @@ -0 + 0 All tests succeeded. diff --git a/testsuite/tests/basic-more/tprintf.ml b/testsuite/tests/basic-more/tprintf.ml index 518859da2c..8bbc9f7151 100644 --- a/testsuite/tests/basic-more/tprintf.ml +++ b/testsuite/tests/basic-more/tprintf.ml @@ -42,7 +42,7 @@ test (test1 ());; let test2 () = true (* sprintf "%1$d\n" 5 1 = " 1\n" && sprintf "%01$d\n" 5 1 = "00001\n" *);; - + test (test2 ());; (* Testing meta format string printing. *) diff --git a/testsuite/tests/basic-more/tprintf.reference b/testsuite/tests/basic-more/tprintf.reference index d804a0b893..1fb209d42c 100644 --- a/testsuite/tests/basic-more/tprintf.reference +++ b/testsuite/tests/basic-more/tprintf.reference @@ -1,2 +1,2 @@ -0 1 2 3 4 5 + 0 1 2 3 4 5 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/basic/boxedints.ml b/testsuite/tests/basic/boxedints.ml index 19574a1a4b..a84e65dee9 100644 --- a/testsuite/tests/basic/boxedints.ml +++ b/testsuite/tests/basic/boxedints.ml @@ -28,30 +28,30 @@ let test test_number answer correct_answer = module type TESTSIG = sig type t module Ops : sig - val neg: t -> t - val add: t -> t -> t - val sub: t -> t -> t - val mul: t -> t -> t - val div: t -> t -> t - val rem: t -> t -> t - val logand: t -> t -> t - val logor: t -> t -> t - val logxor: t -> t -> t - val shift_left: t -> int -> t - val shift_right: t -> int -> t - val shift_right_logical: t -> int -> t - val of_int: int -> t - val to_int: t -> int - val of_float: float -> t + val neg: t -> t + val add: t -> t -> t + val sub: t -> t -> t + val mul: t -> t -> t + val div: t -> t -> t + val rem: t -> t -> t + val logand: t -> t -> t + val logor: t -> t -> t + val logxor: t -> t -> t + val shift_left: t -> int -> t + val shift_right: t -> int -> t + val shift_right_logical: t -> int -> t + val of_int: int -> t + val to_int: t -> int + val of_float: float -> t val to_float: t -> float val zero: t val one: t val minus_one: t val min_int: t val max_int: t - val format : string -> t -> string + val format : string -> t -> string val to_string: t -> string - val of_string: string -> t + val of_string: string -> t end val testcomp: t -> t -> bool*bool*bool*bool*bool*bool*int val skip_float_tests: bool @@ -166,6 +166,7 @@ struct 9, 127531236, -365; 10, 1234567, 12345678; 11, 1234567, -12345678]; + test 12 (div min_int (of_int (-1))) min_int; testing_function "mod"; List.iter @@ -181,6 +182,7 @@ struct 9, 127531236, -365; 10, 1234567, 12345678; 11, 1234567, -12345678]; + test 12 (rem min_int (of_int (-1))) (of_int 0); testing_function "and"; List.iter @@ -345,7 +347,7 @@ struct test 5 (add (of_int (-123)) (of_int 456)) (of_int 333); test 6 (add (of_int 123) (of_int (-456))) (of_int (-333)); test 7 (add (of_int (-123)) (of_int (-456))) (of_int (-579)); - test 8 (add (of_string "0x1234567812345678") + test 8 (add (of_string "0x1234567812345678") (of_string "0x9ABCDEF09ABCDEF")) (of_string "0x1be024671be02467"); test 9 (add max_int max_int) (of_int (-2)); @@ -362,7 +364,7 @@ struct test 5 (sub (of_int (-123)) (of_int 456)) (of_int (-579)); test 6 (sub (of_int 123) (of_int (-456))) (of_int 579); test 7 (sub (of_int (-123)) (of_int (-456))) (of_int 333); - test 8 (sub (of_string "0x1234567812345678") + test 8 (sub (of_string "0x1234567812345678") (of_string "0x9ABCDEF09ABCDEF")) (of_string "0x888888908888889"); test 9 (sub max_int min_int) minus_one; @@ -400,6 +402,7 @@ struct 9, 127531236, -365; 10, 1234567, 12345678; 11, 1234567, -12345678]; + test 12 (div min_int (of_int (-1))) min_int; testing_function "mod"; List.iter @@ -415,6 +418,7 @@ struct 9, 127531236, -365; 10, 1234567, 12345678; 11, 1234567, -12345678]; + test 12 (rem min_int (of_int (-1))) (of_int 0); testing_function "and"; List.iter @@ -524,7 +528,7 @@ let _ = begin match Sys.word_size with 32 -> let module C = - Test32(struct type t = nativeint + Test32(struct type t = nativeint module Ops = Nativeint let testcomp = testcomp_nativeint let skip_float_tests = true end) @@ -533,7 +537,7 @@ let _ = let module C = Test64(struct type t = nativeint module Ops = Nativeint - let testcomp = testcomp_nativeint + let testcomp = testcomp_nativeint let skip_float_tests = true end) in () | _ -> diff --git a/testsuite/tests/basic/boxedints.reference b/testsuite/tests/basic/boxedints.reference index fe08bb2b81..009390faee 100644 --- a/testsuite/tests/basic/boxedints.reference +++ b/testsuite/tests/basic/boxedints.reference @@ -16,9 +16,9 @@ sub mul 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... div - 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... + 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... mod - 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... + 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... and 1... 2... 3... 4... 5... or @@ -55,9 +55,9 @@ sub mul 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... div - 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... + 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... mod - 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... + 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... and 1... 2... 3... 4... 5... or @@ -90,9 +90,9 @@ sub mul 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... 13... div - 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... + 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... mod - 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... + 1... 2... 3... 4... 5... 6... 7... 8... 9... 10... 11... 12... and 1... 2... 3... 4... 5... or diff --git a/testsuite/tests/basic/equality.ml b/testsuite/tests/basic/equality.ml index f69120c9ac..ebf5cf438b 100644 --- a/testsuite/tests/basic/equality.ml +++ b/testsuite/tests/basic/equality.ml @@ -102,4 +102,3 @@ let _ = test 53 eqtrue (testcmpfloat 0.0 0.0); test 54 eqtrue (testcmpfloat 1.0 0.0); test 55 eqtrue (testcmpfloat 0.0 1.0) - diff --git a/testsuite/tests/basic/includestruct.ml b/testsuite/tests/basic/includestruct.ml index 182272c1ba..15708bf970 100644 --- a/testsuite/tests/basic/includestruct.ml +++ b/testsuite/tests/basic/includestruct.ml @@ -65,7 +65,7 @@ module D = include F(struct end) let test() = print_t A; print_newline(); print_t (B 42); print_newline() end - + let _ = D.test(); D.print_t D.A; print_newline(); D.print_t (D.B 42); print_newline() @@ -89,4 +89,3 @@ module G = let _ = begin try raise (G.Exn "foo") with G.Exn s -> print_string s end; print_int ((new G.c)#m); print_newline() - diff --git a/testsuite/tests/basic/maps.ml b/testsuite/tests/basic/maps.ml index ffbaa041cb..f021e00cce 100644 --- a/testsuite/tests/basic/maps.ml +++ b/testsuite/tests/basic/maps.ml @@ -25,4 +25,3 @@ let () = print_endline "Inter"; show (IntMap.merge (fun _ l r -> match l, r with Some x, Some y when x = y -> Some x | _ -> None) m1 m2); () - diff --git a/testsuite/tests/basic/patmatch.ml b/testsuite/tests/basic/patmatch.ml index 1cc37c1c67..64e56174e0 100644 --- a/testsuite/tests/basic/patmatch.ml +++ b/testsuite/tests/basic/patmatch.ml @@ -91,7 +91,7 @@ let _ = done; for i = 0 to 255 do let c = Char.chr i in - printf "k(%s) = %s\t" (escaped c) (k c) + printf "\tk(%s) = %s" (escaped c) (k c) done; printf "\n"; printf "p([|\"hello\"|]) = %s\n" (p [|"hello"|]); @@ -103,6 +103,3 @@ let _ = printf "l([|2;3|]) = %d\n" (l [|2;3|]); printf "l([|4;5;6|]) = %d\n" (l [|4;5;6|]); exit 0 - - - diff --git a/testsuite/tests/basic/patmatch.reference b/testsuite/tests/basic/patmatch.reference index eb7dc97886..125c466fd1 100644 --- a/testsuite/tests/basic/patmatch.reference +++ b/testsuite/tests/basic/patmatch.reference @@ -57,7 +57,7 @@ h({) = ? h(|) = ? h(}) = ? h(~) = ? -k(\000) = othr k(\001) = othr k(\002) = othr k(\003) = othr k(\004) = othr k(\005) = othr k(\006) = othr k(\007) = othr k(\b) = othr k(\t) = blk k(\n) = blk k(\011) = othr k(\012) = othr k(\r) = blk k(\014) = othr k(\015) = othr k(\016) = othr k(\017) = othr k(\018) = othr k(\019) = othr k(\020) = othr k(\021) = othr k(\022) = othr k(\023) = othr k(\024) = othr k(\025) = othr k(\026) = othr k(\027) = othr k(\028) = othr k(\029) = othr k(\030) = othr k(\031) = othr k( ) = blk k(!) = oper k(\034) = othr k(#) = oper k($) = oper k(%) = oper k(&) = oper k(\') = othr k(\040) = othr k(\041) = othr k(*) = oper k(+) = oper k(\044) = othr k(\045) = othr k(\046) = othr k(/) = oper k(0) = dig k(1) = dig k(2) = dig k(3) = dig k(4) = dig k(5) = dig k(6) = dig k(7) = dig k(8) = dig k(9) = dig k(:) = oper k(\059) = othr k(<) = oper k(=) = oper k(>) = oper k(?) = oper k(@) = oper k(A) = letr k(B) = letr k(C) = letr k(D) = letr k(E) = letr k(F) = letr k(G) = letr k(H) = letr k(I) = letr k(J) = letr k(K) = letr k(L) = letr k(M) = letr k(N) = letr k(O) = letr k(P) = letr k(Q) = letr k(R) = letr k(S) = letr k(T) = letr k(U) = letr k(V) = letr k(W) = letr k(X) = letr k(Y) = letr k(Z) = letr k(\091) = othr k(\\) = oper k(\093) = othr k(^) = oper k(\095) = othr k(\096) = othr k(a) = letr k(b) = letr k(c) = letr k(d) = letr k(e) = letr k(f) = letr k(g) = letr k(h) = letr k(i) = letr k(j) = letr k(k) = letr k(l) = letr k(m) = letr k(n) = letr k(o) = letr k(p) = letr k(q) = letr k(r) = letr k(s) = letr k(t) = letr k(u) = letr k(v) = letr k(w) = letr k(x) = letr k(y) = letr k(z) = letr k(\123) = othr k(|) = oper k(\125) = othr k(~) = oper k(\127) = othr k(\128) = othr k(\129) = othr k(\130) = othr k(\131) = othr k(\132) = othr k(\133) = othr k(\134) = othr k(\135) = othr k(\136) = othr k(\137) = othr k(\138) = othr k(\139) = othr k(\140) = othr k(\141) = othr k(\142) = othr k(\143) = othr k(\144) = othr k(\145) = othr k(\146) = othr k(\147) = othr k(\148) = othr k(\149) = othr k(\150) = othr k(\151) = othr k(\152) = othr k(\153) = othr k(\154) = othr k(\155) = othr k(\156) = othr k(\157) = othr k(\158) = othr k(\159) = othr k(\160) = othr k(\161) = othr k(\162) = othr k(\163) = othr k(\164) = othr k(\165) = othr k(\166) = othr k(\167) = othr k(\168) = othr k(\169) = othr k(\170) = othr k(\171) = othr k(\172) = othr k(\173) = othr k(\174) = othr k(\175) = othr k(\176) = othr k(\177) = othr k(\178) = othr k(\179) = othr k(\180) = othr k(\181) = othr k(\182) = othr k(\183) = othr k(\184) = othr k(\185) = othr k(\186) = othr k(\187) = othr k(\188) = othr k(\189) = othr k(\190) = othr k(\191) = othr k(\192) = letr k(\193) = letr k(\194) = letr k(\195) = letr k(\196) = letr k(\197) = letr k(\198) = letr k(\199) = letr k(\200) = letr k(\201) = letr k(\202) = letr k(\203) = letr k(\204) = letr k(\205) = letr k(\206) = letr k(\207) = letr k(\208) = letr k(\209) = letr k(\210) = letr k(\211) = letr k(\212) = letr k(\213) = letr k(\214) = letr k(\215) = letr k(\216) = letr k(\217) = letr k(\218) = letr k(\219) = letr k(\220) = letr k(\221) = letr k(\222) = letr k(\223) = letr k(\224) = letr k(\225) = letr k(\226) = letr k(\227) = letr k(\228) = letr k(\229) = letr k(\230) = letr k(\231) = letr k(\232) = letr k(\233) = letr k(\234) = letr k(\235) = letr k(\236) = letr k(\237) = letr k(\238) = letr k(\239) = letr k(\240) = letr k(\241) = letr k(\242) = letr k(\243) = letr k(\244) = letr k(\245) = letr k(\246) = letr k(\247) = letr k(\248) = letr k(\249) = letr k(\250) = letr k(\251) = letr k(\252) = letr k(\253) = letr k(\254) = letr k(\255) = letr + k(\000) = othr k(\001) = othr k(\002) = othr k(\003) = othr k(\004) = othr k(\005) = othr k(\006) = othr k(\007) = othr k(\b) = othr k(\t) = blk k(\n) = blk k(\011) = othr k(\012) = othr k(\r) = blk k(\014) = othr k(\015) = othr k(\016) = othr k(\017) = othr k(\018) = othr k(\019) = othr k(\020) = othr k(\021) = othr k(\022) = othr k(\023) = othr k(\024) = othr k(\025) = othr k(\026) = othr k(\027) = othr k(\028) = othr k(\029) = othr k(\030) = othr k(\031) = othr k( ) = blk k(!) = oper k(\034) = othr k(#) = oper k($) = oper k(%) = oper k(&) = oper k(\') = othr k(\040) = othr k(\041) = othr k(*) = oper k(+) = oper k(\044) = othr k(\045) = othr k(\046) = othr k(/) = oper k(0) = dig k(1) = dig k(2) = dig k(3) = dig k(4) = dig k(5) = dig k(6) = dig k(7) = dig k(8) = dig k(9) = dig k(:) = oper k(\059) = othr k(<) = oper k(=) = oper k(>) = oper k(?) = oper k(@) = oper k(A) = letr k(B) = letr k(C) = letr k(D) = letr k(E) = letr k(F) = letr k(G) = letr k(H) = letr k(I) = letr k(J) = letr k(K) = letr k(L) = letr k(M) = letr k(N) = letr k(O) = letr k(P) = letr k(Q) = letr k(R) = letr k(S) = letr k(T) = letr k(U) = letr k(V) = letr k(W) = letr k(X) = letr k(Y) = letr k(Z) = letr k(\091) = othr k(\\) = oper k(\093) = othr k(^) = oper k(\095) = othr k(\096) = othr k(a) = letr k(b) = letr k(c) = letr k(d) = letr k(e) = letr k(f) = letr k(g) = letr k(h) = letr k(i) = letr k(j) = letr k(k) = letr k(l) = letr k(m) = letr k(n) = letr k(o) = letr k(p) = letr k(q) = letr k(r) = letr k(s) = letr k(t) = letr k(u) = letr k(v) = letr k(w) = letr k(x) = letr k(y) = letr k(z) = letr k(\123) = othr k(|) = oper k(\125) = othr k(~) = oper k(\127) = othr k(\128) = othr k(\129) = othr k(\130) = othr k(\131) = othr k(\132) = othr k(\133) = othr k(\134) = othr k(\135) = othr k(\136) = othr k(\137) = othr k(\138) = othr k(\139) = othr k(\140) = othr k(\141) = othr k(\142) = othr k(\143) = othr k(\144) = othr k(\145) = othr k(\146) = othr k(\147) = othr k(\148) = othr k(\149) = othr k(\150) = othr k(\151) = othr k(\152) = othr k(\153) = othr k(\154) = othr k(\155) = othr k(\156) = othr k(\157) = othr k(\158) = othr k(\159) = othr k(\160) = othr k(\161) = othr k(\162) = othr k(\163) = othr k(\164) = othr k(\165) = othr k(\166) = othr k(\167) = othr k(\168) = othr k(\169) = othr k(\170) = othr k(\171) = othr k(\172) = othr k(\173) = othr k(\174) = othr k(\175) = othr k(\176) = othr k(\177) = othr k(\178) = othr k(\179) = othr k(\180) = othr k(\181) = othr k(\182) = othr k(\183) = othr k(\184) = othr k(\185) = othr k(\186) = othr k(\187) = othr k(\188) = othr k(\189) = othr k(\190) = othr k(\191) = othr k(\192) = letr k(\193) = letr k(\194) = letr k(\195) = letr k(\196) = letr k(\197) = letr k(\198) = letr k(\199) = letr k(\200) = letr k(\201) = letr k(\202) = letr k(\203) = letr k(\204) = letr k(\205) = letr k(\206) = letr k(\207) = letr k(\208) = letr k(\209) = letr k(\210) = letr k(\211) = letr k(\212) = letr k(\213) = letr k(\214) = letr k(\215) = letr k(\216) = letr k(\217) = letr k(\218) = letr k(\219) = letr k(\220) = letr k(\221) = letr k(\222) = letr k(\223) = letr k(\224) = letr k(\225) = letr k(\226) = letr k(\227) = letr k(\228) = letr k(\229) = letr k(\230) = letr k(\231) = letr k(\232) = letr k(\233) = letr k(\234) = letr k(\235) = letr k(\236) = letr k(\237) = letr k(\238) = letr k(\239) = letr k(\240) = letr k(\241) = letr k(\242) = letr k(\243) = letr k(\244) = letr k(\245) = letr k(\246) = letr k(\247) = letr k(\248) = letr k(\249) = letr k(\250) = letr k(\251) = letr k(\252) = letr k(\253) = letr k(\254) = letr k(\255) = letr p([|"hello"|]) = hello p([|1.0|]) = 1.000000 q([|2|]) = 2 diff --git a/testsuite/tests/basic/recvalues.ml b/testsuite/tests/basic/recvalues.ml index c00ced8273..df32f5e702 100644 --- a/testsuite/tests/basic/recvalues.ml +++ b/testsuite/tests/basic/recvalues.ml @@ -8,7 +8,7 @@ let _ = then print_string "Test 1: passed\n" else print_string "Test 1: FAILED\n"; let one = 1 in - let rec y = (one, one+1) :: y in + let rec y = (one, one+1) :: y in if match y with (1,2) :: y' -> y == y' | _ -> false diff --git a/testsuite/tests/basic/tailcalls.ml b/testsuite/tests/basic/tailcalls.ml index 23b7353598..7e37ea714c 100644 --- a/testsuite/tests/basic/tailcalls.ml +++ b/testsuite/tests/basic/tailcalls.ml @@ -18,7 +18,7 @@ let indtailcall8 fn a b c d e f g h = fn a b c d e f g h let indtailcall16 fn a b c d e f g h i j k l m n o p = - fn a b c d e f g h i j k l m n o p + fn a b c d e f g h i j k l m n o p let _ = print_int (tailcall4 10000000 0 0 0); print_newline(); diff --git a/testsuite/tests/callback/Makefile b/testsuite/tests/callback/Makefile index a89056685a..0db946a1ed 100644 --- a/testsuite/tests/callback/Makefile +++ b/testsuite/tests/callback/Makefile @@ -12,7 +12,7 @@ run-byte: common @$(OCAMLC) -c tcallback.ml @$(OCAMLC) -o ./program -custom unix.cma callbackprim.$(O) tcallback.cmo @./program > bytecode.result - @$(DIFF) reference bytecode.result || (echo " => failed" && exit 1) + @$(DIFF) reference bytecode.result || (echo " => failed" && exit 1) @echo " => passed" run-opt: common @@ -24,7 +24,7 @@ run-opt: common $(DIFF) reference native.result || (echo " => failed" && exit 1); \ echo " => passed"; \ fi - + promote: defaultpromote clean: defaultclean diff --git a/testsuite/tests/callback/tcallback.ml b/testsuite/tests/callback/tcallback.ml index 32914119bd..e0f66fe506 100644 --- a/testsuite/tests/callback/tcallback.ml +++ b/testsuite/tests/callback/tcallback.ml @@ -65,4 +65,3 @@ let _ = print_string(tripwire mycamlparam); print_newline(); Sys.set_signal Sys.sigusr1 (Sys.Signal_handle sighandler); print_string(callbacksig ()); print_newline() - diff --git a/testsuite/tests/embedded/Makefile b/testsuite/tests/embedded/Makefile index ed33143461..ec2308dd7d 100644 --- a/testsuite/tests/embedded/Makefile +++ b/testsuite/tests/embedded/Makefile @@ -13,7 +13,7 @@ run: @./program > program.result @$(DIFF) program.reference program.result > /dev/null || (echo " => failed" && exit 1) @echo " => passed" - + promote: defaultpromote clean: defaultclean diff --git a/testsuite/tests/embedded/cmcaml.ml b/testsuite/tests/embedded/cmcaml.ml index 4ebed1e7df..65c7a610e8 100644 --- a/testsuite/tests/embedded/cmcaml.ml +++ b/testsuite/tests/embedded/cmcaml.ml @@ -1,4 +1,4 @@ -(* Caml part of the code *) +(* OCaml part of the code *) let rec fib n = if n < 2 then 1 else fib(n-1) + fib(n-2) diff --git a/testsuite/tests/embedded/cmmain.c b/testsuite/tests/embedded/cmmain.c index 87647ac50d..6c27fe1e9d 100644 --- a/testsuite/tests/embedded/cmmain.c +++ b/testsuite/tests/embedded/cmmain.c @@ -9,7 +9,7 @@ extern char * format_result(int n); int main(int argc, char ** argv) { - printf("Initializing Caml code...\n"); + printf("Initializing OCaml code...\n"); #ifdef NO_BYTECODE_FILE caml_startup(argv); #else diff --git a/testsuite/tests/embedded/program.reference b/testsuite/tests/embedded/program.reference index e2752b724f..4f27810ca9 100644 --- a/testsuite/tests/embedded/program.reference +++ b/testsuite/tests/embedded/program.reference @@ -1,4 +1,4 @@ -Initializing Caml code... +Initializing OCaml code... Back in C code... Computing fib(20)... Result = 10946 diff --git a/testsuite/tests/gc-roots/globrootsprim.c b/testsuite/tests/gc-roots/globrootsprim.c index f58fff1cc3..32a61a7cce 100644 --- a/testsuite/tests/gc-roots/globrootsprim.c +++ b/testsuite/tests/gc-roots/globrootsprim.c @@ -52,5 +52,3 @@ value gb_generational_remove(value vblock) caml_remove_generational_global_root(&(Block_val(vblock)->v)); return Val_unit; } - - diff --git a/testsuite/tests/letrec/class_1.result b/testsuite/tests/letrec/backreferences.reference index e69de29bb2..e69de29bb2 100644 --- a/testsuite/tests/letrec/class_1.result +++ b/testsuite/tests/letrec/backreferences.reference diff --git a/testsuite/tests/letrec/float_block_2.result b/testsuite/tests/letrec/class_1.reference index e69de29bb2..e69de29bb2 100644 --- a/testsuite/tests/letrec/float_block_2.result +++ b/testsuite/tests/letrec/class_1.reference diff --git a/testsuite/tests/letrec/lists.result b/testsuite/tests/letrec/float_block_2.reference index e69de29bb2..e69de29bb2 100644 --- a/testsuite/tests/letrec/lists.result +++ b/testsuite/tests/letrec/float_block_2.reference diff --git a/testsuite/tests/letrec/mixing_value_closures_1.result b/testsuite/tests/letrec/lists.reference index e69de29bb2..e69de29bb2 100644 --- a/testsuite/tests/letrec/mixing_value_closures_1.result +++ b/testsuite/tests/letrec/lists.reference diff --git a/testsuite/tests/letrec/mixing_value_closures_2.result b/testsuite/tests/letrec/mixing_value_closures_1.reference index e69de29bb2..e69de29bb2 100644 --- a/testsuite/tests/letrec/mixing_value_closures_2.result +++ b/testsuite/tests/letrec/mixing_value_closures_1.reference diff --git a/testsuite/tests/letrec/mutual_functions.result b/testsuite/tests/letrec/mixing_value_closures_2.reference index e69de29bb2..e69de29bb2 100644 --- a/testsuite/tests/letrec/mutual_functions.result +++ b/testsuite/tests/letrec/mixing_value_closures_2.reference diff --git a/testsuite/tests/letrec/mutual_functions.reference b/testsuite/tests/letrec/mutual_functions.reference new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/letrec/mutual_functions.reference diff --git a/testsuite/tests/lib-bigarray-2/bigarrf.f b/testsuite/tests/lib-bigarray-2/bigarrf.f index 5c2462c2ef..ff52de1d9f 100644 --- a/testsuite/tests/lib-bigarray-2/bigarrf.f +++ b/testsuite/tests/lib-bigarray-2/bigarrf.f @@ -24,4 +24,3 @@ 300 format(/1X, I3, 2X, 10F6.1/) 200 continue end - diff --git a/testsuite/tests/lib-bigarray-2/bigarrfml.ml b/testsuite/tests/lib-bigarray-2/bigarrfml.ml index c915622840..562cfc8a74 100644 --- a/testsuite/tests/lib-bigarray-2/bigarrfml.ml +++ b/testsuite/tests/lib-bigarray-2/bigarrfml.ml @@ -60,4 +60,3 @@ let _ = test 2 a.{2,1} 201.0; test 3 a.{1,2} 102.0; test 4 a.{5,4} 504.0; - diff --git a/testsuite/tests/lib-bigarray-2/bigarrfstub.c b/testsuite/tests/lib-bigarray-2/bigarrfstub.c index 87bd67b7bc..be142f6a92 100644 --- a/testsuite/tests/lib-bigarray-2/bigarrfstub.c +++ b/testsuite/tests/lib-bigarray-2/bigarrfstub.c @@ -57,4 +57,3 @@ value fortran_printtab(value ba) printtab_(Data_bigarray_val(ba), &dimx, &dimy); return Val_unit; } - diff --git a/testsuite/tests/lib-bigarray/bigarrays.ml b/testsuite/tests/lib-bigarray/bigarrays.ml index 85901400eb..9c790a1a6a 100644 --- a/testsuite/tests/lib-bigarray/bigarrays.ml +++ b/testsuite/tests/lib-bigarray/bigarrays.ml @@ -139,14 +139,14 @@ let _ = let from_list kind vals = let a = Array1.create kind c_layout (List.length vals) in let rec set i = function - [] -> () + [] -> () | hd :: tl -> a.{i} <- hd; set (i+1) tl in set 0 vals; a in let from_list_fortran kind vals = let a = Array1.create kind fortran_layout (List.length vals) in let rec set i = function - [] -> () + [] -> () | hd :: tl -> a.{i} <- hd; set (i+1) tl in set 1 vals; a in @@ -157,7 +157,7 @@ let _ = for i = 0 to 2 do test (i+1) a.{i} i done; test 4 true (try ignore a.{3}; false with Invalid_argument _ -> true); test 5 true (try ignore a.{-1}; false with Invalid_argument _ -> true); - + let b = Array1.create float64 fortran_layout 3 in for i = 1 to 3 do b.{i} <- float i done; for i = 1 to 3 do test (5 + i) b.{i} (float i) done; @@ -180,7 +180,7 @@ let _ = let a = Array1.create int c_layout 3 in for i = 0 to 2 do Array1.unsafe_set a i i done; for i = 0 to 2 do test (i+1) (Array1.unsafe_get a i) i done; - + let b = Array1.create float64 fortran_layout 3 in for i = 1 to 3 do Array1.unsafe_set b i (float i) done; for i = 1 to 3 do test (5 + i) (Array1.unsafe_get b i) (float i) done; @@ -459,7 +459,7 @@ let _ = test 3 true (try ignore a.{-1,0}; false with Invalid_argument _ -> true); test 4 true (try ignore a.{0,3}; false with Invalid_argument _ -> true); test 5 true (try ignore a.{0,-1}; false with Invalid_argument _ -> true); - + let b = Array2.create float32 fortran_layout 3 3 in for i = 1 to 3 do for j = 1 to 3 do b.{i,j} <- float(i-j) done done; let ok = ref true in @@ -480,7 +480,7 @@ let _ = for j = 0 to 2 do if Array2.unsafe_get a i j <> i-j then ok := false done done; test 1 true !ok; - + let b = Array2.create float32 fortran_layout 3 3 in for i = 1 to 3 do for j = 1 to 3 do Array2.unsafe_set b i j (float(i-j)) done done; let ok = ref true in @@ -611,7 +611,7 @@ let _ = if Int32.to_int a.{i,j,k} <> (i lsl 4) + (j lsl 2) + k then ok := false done done done; test 1 true !ok; - + let b = Array3.create int64 fortran_layout 2 3 4 in for i = 1 to 2 do for j = 1 to 3 do for k = 1 to 4 do b.{i,j,k} <- Int64.of_int((i lsl 4) + (j lsl 2) + k) @@ -764,7 +764,7 @@ let _ = Sys.remove mapped_file; () - + (********* End of test *********) let _ = diff --git a/testsuite/tests/lib-bigarray/fftba.ml b/testsuite/tests/lib-bigarray/fftba.ml index 10c22f1db4..f7149252c7 100644 --- a/testsuite/tests/lib-bigarray/fftba.ml +++ b/testsuite/tests/lib-bigarray/fftba.ml @@ -22,17 +22,17 @@ let fft (px : (float, float64_elt, c_layout) Array1.t) (py : (float, float64_elt, c_layout) Array1.t) np = let i = ref 2 in let m = ref 1 in - + while (!i < np) do - i := !i + !i; + i := !i + !i; m := !m + 1 done; - let n = !i in - + let n = !i in + if n <> np then begin for i = np+1 to n do - px.{i} <- 0.0; + px.{i} <- 0.0; py.{i} <- 0.0 done; print_string "Use "; print_int n; @@ -41,7 +41,7 @@ let fft (px : (float, float64_elt, c_layout) Array1.t) let n2 = ref(n+n) in for k = 1 to !m-1 do - n2 := !n2 / 2; + n2 := !n2 / 2; let n4 = !n2 / 4 in let e = tpi /. float !n2 in @@ -54,7 +54,7 @@ let fft (px : (float, float64_elt, c_layout) Array1.t) let ss3 = sin(a3) in let is = ref j in let id = ref(2 * !n2) in - + while !is < n do let i0r = ref !is in while !i0r < n do @@ -74,13 +74,13 @@ let fft (px : (float, float64_elt, c_layout) Array1.t) let r1 = r1 +. s2 in let s2 = r2 -. s1 in let r2 = r2 +. s1 in - px.{i2} <- r1*.cc1 -. s2*.ss1; + px.{i2} <- r1*.cc1 -. s2*.ss1; py.{i2} <- -.s2*.cc1 -. r1*.ss1; px.{i3} <- s3*.cc3 +. r2*.ss3; py.{i3} <- r2*.cc3 -. s3*.ss3; i0r := i0 + !id done; - is := 2 * !id - !n2 + j; + is := 2 * !id - !n2 + j; id := 4 * !id done done @@ -92,7 +92,7 @@ let fft (px : (float, float64_elt, c_layout) Array1.t) let is = ref 1 in let id = ref 4 in - + while !is < n do let i0r = ref !is in while !i0r <= n do @@ -106,7 +106,7 @@ let fft (px : (float, float64_elt, c_layout) Array1.t) py.{i1} <- r1 -. py.{i1}; i0r := i0 + !id done; - is := 2 * !id - 1; + is := 2 * !id - 1; id := 4 * !id done; @@ -115,11 +115,11 @@ let fft (px : (float, float64_elt, c_layout) Array1.t) (*************************) let j = ref 1 in - + for i = 1 to n - 1 do if i < !j then begin let xt = px.{!j} in - px.{!j} <- px.{i}; + px.{!j} <- px.{i}; px.{i} <- xt; let xt = py.{!j} in py.{!j} <- py.{i}; @@ -127,7 +127,7 @@ let fft (px : (float, float64_elt, c_layout) Array1.t) end; let k = ref(n / 2) in while !k < !j do - j := !j - !k; + j := !j - !k; k := !k / 2 done; j := !j + !k @@ -173,12 +173,12 @@ let test np = for i = 0 to np-1 do let a = abs_float(pxr.{i+1} -. float i) in if !zr < a then begin - zr := a; + zr := a; kr := i end; let a = abs_float(pxi.{i+1}) in if !zi < a then begin - zi := a; + zi := a; ki := i end done; @@ -194,4 +194,3 @@ let test np = let _ = let np = ref 16 in for i = 1 to 13 do test !np; np := !np*2 done - diff --git a/testsuite/tests/lib-bigarray/pr5115.ml b/testsuite/tests/lib-bigarray/pr5115.ml index 69cdca64d9..e75215cf75 100644 --- a/testsuite/tests/lib-bigarray/pr5115.ml +++ b/testsuite/tests/lib-bigarray/pr5115.ml @@ -10,4 +10,3 @@ let _ = let y = Array1.of_array float64 fortran_layout [| 1. |] in (f y).{1}; (f y).{1} <- 3.14 - diff --git a/testsuite/tests/lib-digest/md5.ml b/testsuite/tests/lib-digest/md5.ml index 6d4e6e0641..27aebf2a38 100644 --- a/testsuite/tests/lib-digest/md5.ml +++ b/testsuite/tests/lib-digest/md5.ml @@ -211,7 +211,7 @@ let _ = if (Array.length Sys.argv) > 1 && (Sys.argv.(1) = "-benchmark") then begin let s = String.make 50000 'a' in let num_iter = 1000 in - time "Caml implementation" num_iter + time "OCaml implementation" num_iter (fun () -> let ctx = init() in update ctx s 0 (String.length s); diff --git a/testsuite/tests/lib-dynlink-bytecode/.ignore b/testsuite/tests/lib-dynlink-bytecode/.ignore 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..089d17a5c4 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'" @@ -31,10 +32,10 @@ run: @export LD_LIBRARY_PATH=`pwd` && ./custom > custom.result @$(DIFF) custom.reference custom.result > /dev/null || (echo " => failed" && exit 1) @echo " => passed" - + promote: defaultpromote clean: defaultclean - @rm -f ./main ./static ./custom *.result + @rm -f ./main ./static ./custom *.result marshal.data include $(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..725ee80c9d 100644 --- a/testsuite/tests/lib-dynlink-bytecode/main.ml +++ b/testsuite/tests/lib-dynlink-bytecode/main.ml @@ -1,17 +1,37 @@ +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 let name = Sys.argv.(i) in Printf.printf "Loading %s\n" name; flush stdout; - try + try if name.[0] = '-' - then Dynlink.loadfile_private - (String.sub name 1 (String.length name - 1)) + then Dynlink.loadfile_private + (String.sub name 1 (String.length name - 1)) else Dynlink.loadfile name with | Dynlink.Error err -> - Printf.printf "Dynlink error: %s\n" - (Dynlink.error_message err) + Printf.printf "Dynlink error: %s\n" + (Dynlink.error_message err) | exn -> - Printf.printf "Error: %s\n" (Printexc.to_string exn) - done + Printf.printf "Error: %s\n" (Printexc.to_string exn) + 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-csharp/bytecode.reference b/testsuite/tests/lib-dynlink-csharp/bytecode.reference index 65592193a1..a76daa2309 100644 --- a/testsuite/tests/lib-dynlink-csharp/bytecode.reference +++ b/testsuite/tests/lib-dynlink-csharp/bytecode.reference @@ -1,4 +1,4 @@ -Now starting the Caml engine. +Now starting the OCaml engine. Main is running. Loading ../../../otherlibs/bigarray/bigarray.cma I'm the plugin. diff --git a/testsuite/tests/lib-dynlink-csharp/main.cs b/testsuite/tests/lib-dynlink-csharp/main.cs index a03bfd60ab..5cbb8e8689 100755 --- a/testsuite/tests/lib-dynlink-csharp/main.cs +++ b/testsuite/tests/lib-dynlink-csharp/main.cs @@ -5,7 +5,7 @@ public class M { public static extern void start_caml_engine(); public static void Main() { - System.Console.WriteLine("Now starting the Caml engine."); + System.Console.WriteLine("Now starting the OCaml engine."); start_caml_engine(); } } diff --git a/testsuite/tests/lib-dynlink-csharp/main.ml b/testsuite/tests/lib-dynlink-csharp/main.ml index fd48914a6f..ad46188277 100755 --- a/testsuite/tests/lib-dynlink-csharp/main.ml +++ b/testsuite/tests/lib-dynlink-csharp/main.ml @@ -17,7 +17,6 @@ let () = "../../../otherlibs/bigarray/bigarray.cma", "plugin.cmo" in - load s1; + load s1; load s2; print_endline "OK." - diff --git a/testsuite/tests/lib-dynlink-csharp/native.reference b/testsuite/tests/lib-dynlink-csharp/native.reference index b6c9e5c430..684f979a8f 100644 --- a/testsuite/tests/lib-dynlink-csharp/native.reference +++ b/testsuite/tests/lib-dynlink-csharp/native.reference @@ -1,4 +1,4 @@ -Now starting the Caml engine. +Now starting the OCaml engine. Main is running. Loading ../../../otherlibs/bigarray/bigarray.cmxs I'm the plugin. diff --git a/testsuite/tests/lib-dynlink-csharp/plugin.ml b/testsuite/tests/lib-dynlink-csharp/plugin.ml index 39c46f3a1c..aacf9f21bc 100755 --- a/testsuite/tests/lib-dynlink-csharp/plugin.ml +++ b/testsuite/tests/lib-dynlink-csharp/plugin.ml @@ -1,4 +1,4 @@ let f x = x.{2} - + let () = print_endline "I'm the plugin." 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..cd735abe3a 100644 --- a/testsuite/tests/lib-dynlink-native/api.ml +++ b/testsuite/tests/lib-dynlink-native/api.ml @@ -1,7 +1,7 @@ let mods = ref [] let reg_mod name = - if List.mem name !mods then + if List.mem name !mods then Printf.printf "Reloading module %s\n" name else ( mods := name :: !mods; @@ -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/b.ml b/testsuite/tests/lib-dynlink-native/b.ml index 58149e22f1..afa1bef051 100755 --- a/testsuite/tests/lib-dynlink-native/b.ml +++ b/testsuite/tests/lib-dynlink-native/b.ml @@ -2,4 +2,3 @@ let () = print_endline "B is running"; incr A.x; Printf.printf "A.x = %i\n" !A.x - diff --git a/testsuite/tests/lib-dynlink-native/bug.ml b/testsuite/tests/lib-dynlink-native/bug.ml index 02828378d0..31c0f02595 100644 --- a/testsuite/tests/lib-dynlink-native/bug.ml +++ b/testsuite/tests/lib-dynlink-native/bug.ml @@ -1,2 +1,2 @@ -let () = try raise (Invalid_argument "X") with Invalid_argument s -> +let () = try raise (Invalid_argument "X") with Invalid_argument s -> raise (Invalid_argument (s ^ s)) diff --git a/testsuite/tests/lib-dynlink-native/main.ml b/testsuite/tests/lib-dynlink-native/main.ml index b21253fb2d..8c738aeb70 100644 --- a/testsuite/tests/lib-dynlink-native/main.ml +++ b/testsuite/tests/lib-dynlink-native/main.ml @@ -1,20 +1,32 @@ +let () = + Api.add_cb (fun () -> print_endline "Callback from main") + let () = Dynlink.init (); Dynlink.allow_unsafe_modules true; for i = 1 to Array.length Sys.argv - 1 do let name = Sys.argv.(i) in Printf.printf "Loading %s\n" name; flush stdout; - try + try if name.[0] = '-' - then Dynlink.loadfile_private - (String.sub name 1 (String.length name - 1)) + then Dynlink.loadfile_private + (String.sub name 1 (String.length name - 1)) else Dynlink.loadfile name with | Dynlink.Error err -> - Printf.printf "Dynlink error: %s\n" - (Dynlink.error_message err) + Printf.printf "Dynlink error: %s\n" + (Dynlink.error_message err) | exn -> - Printf.printf "Error: %s\n" (Printexc.to_string exn) - done - - + Printf.printf "Error: %s\n" (Printexc.to_string exn) + 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/packed1.ml b/testsuite/tests/lib-dynlink-native/packed1.ml index 8f00e39dab..2ee8363391 100644 --- a/testsuite/tests/lib-dynlink-native/packed1.ml +++ b/testsuite/tests/lib-dynlink-native/packed1.ml @@ -3,4 +3,3 @@ let () = let bla = Sys.argv.(0) ^ "XXX" let mykey = Sys.argv.(0) - diff --git a/testsuite/tests/lib-dynlink-native/plugin.ml b/testsuite/tests/lib-dynlink-native/plugin.ml index 501f1bfd32..d9b0574f1b 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"; - print_endline "COUCOU"; + 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/plugin4.ml b/testsuite/tests/lib-dynlink-native/plugin4.ml index ccf4642fbb..a9f86e60a2 100644 --- a/testsuite/tests/lib-dynlink-native/plugin4.ml +++ b/testsuite/tests/lib-dynlink-native/plugin4.ml @@ -1,5 +1,3 @@ let () = Printf.printf "time = %f\n" (Unix.time ()); Api.reg_mod "Plugin" - - diff --git a/testsuite/tests/lib-dynlink-native/plugin_ref.ml b/testsuite/tests/lib-dynlink-native/plugin_ref.ml index 06001241c6..60f127357c 100644 --- a/testsuite/tests/lib-dynlink-native/plugin_ref.ml +++ b/testsuite/tests/lib-dynlink-native/plugin_ref.ml @@ -2,10 +2,9 @@ let x = ref 0 let () = Api.reg_mod "Plugin_ref"; - - Api.add_cb + + Api.add_cb (fun () -> Printf.printf "current value for ref = %i\n" !x; incr x ) - diff --git a/testsuite/tests/lib-dynlink-native/plugin_thread.ml b/testsuite/tests/lib-dynlink-native/plugin_thread.ml index a66b958f2b..6e3d9d485a 100644 --- a/testsuite/tests/lib-dynlink-native/plugin_thread.ml +++ b/testsuite/tests/lib-dynlink-native/plugin_thread.ml @@ -1,21 +1,15 @@ let () = Api.reg_mod "Plugin_thread"; let _t = - Thread.create + Thread.create (fun () -> - for i = 1 to 5 do - print_endline "Thread"; flush stdout; - Thread.delay 1.; - done + for i = 1 to 5 do + print_endline "Thread"; flush stdout; + Thread.delay 1.; + done ) () in for i = 1 to 10 do print_endline "Thread"; flush stdout; Thread.delay 0.50; done - - - - - - 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-dynlink-native/sub/plugin.ml b/testsuite/tests/lib-dynlink-native/sub/plugin.ml index 2a41493c04..d7faf9c8e2 100644 --- a/testsuite/tests/lib-dynlink-native/sub/plugin.ml +++ b/testsuite/tests/lib-dynlink-native/sub/plugin.ml @@ -4,4 +4,3 @@ let facts = [ fact 1; fact 2; fact 3; fact 4; fact 5 ] let () = Api.reg_mod "Plugin'" - diff --git a/testsuite/tests/lib-dynlink-native/sub/plugin3.ml b/testsuite/tests/lib-dynlink-native/sub/plugin3.ml index 7b0b099fe7..82c9e4866e 100644 --- a/testsuite/tests/lib-dynlink-native/sub/plugin3.ml +++ b/testsuite/tests/lib-dynlink-native/sub/plugin3.ml @@ -1,3 +1,2 @@ let () = ignore (Api.f 10) - diff --git a/testsuite/tests/lib-hashtbl/hfun.ml b/testsuite/tests/lib-hashtbl/hfun.ml index 5699587cef..8b8205e7b2 100644 --- a/testsuite/tests/lib-hashtbl/hfun.ml +++ b/testsuite/tests/lib-hashtbl/hfun.ml @@ -39,12 +39,3 @@ let _ = printf "[10..0]\t\t%08x\n" (Hashtbl.hash [10;9;8;7;6;5;4;3;2;1;0]); () - - - - - - - - - diff --git a/testsuite/tests/lib-hashtbl/htbl.ml b/testsuite/tests/lib-hashtbl/htbl.ml index 84a71beb77..f58156962c 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,3 @@ 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..80fe5b7704 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-marshal/intextaux.c b/testsuite/tests/lib-marshal/intextaux.c index 9225b90bc2..fca1fb385d 100644 --- a/testsuite/tests/lib-marshal/intextaux.c +++ b/testsuite/tests/lib-marshal/intextaux.c @@ -3,7 +3,7 @@ value marshal_to_block(value vbuf, value vlen, value v, value vflags) { - return Val_long(output_value_to_block(v, vflags, + return Val_long(output_value_to_block(v, vflags, (char *) vbuf, Long_val(vlen))); } diff --git a/testsuite/tests/lib-num/test_big_ints.ml b/testsuite/tests/lib-num/test_big_ints.ml index badc521601..9d7262060b 100644 --- a/testsuite/tests/lib-num/test_big_ints.ml +++ b/testsuite/tests/lib-num/test_big_ints.ml @@ -56,52 +56,52 @@ testing_function "add_big_int";; test 1 eq_big_int (add_big_int zero_big_int zero_big_int, zero_big_int);; test 2 -eq_big_int (add_big_int zero_big_int (big_int_of_int 1), +eq_big_int (add_big_int zero_big_int (big_int_of_int 1), big_int_of_int 1);; test 3 -eq_big_int (add_big_int (big_int_of_int 1) zero_big_int, +eq_big_int (add_big_int (big_int_of_int 1) zero_big_int, big_int_of_int 1);; test 4 -eq_big_int (add_big_int zero_big_int (big_int_of_int (-1)), +eq_big_int (add_big_int zero_big_int (big_int_of_int (-1)), big_int_of_int (-1));; test 5 -eq_big_int (add_big_int (big_int_of_int (-1)) zero_big_int, +eq_big_int (add_big_int (big_int_of_int (-1)) zero_big_int, big_int_of_int (-1));; test 6 -eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int 1), +eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int 1), big_int_of_int 2);; test 7 -eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int 2), +eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int 2), big_int_of_int 3);; test 8 -eq_big_int (add_big_int (big_int_of_int 2) (big_int_of_int 1), +eq_big_int (add_big_int (big_int_of_int 2) (big_int_of_int 1), big_int_of_int 3);; test 9 -eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int (-1)), +eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int (-1)), big_int_of_int (-2));; test 10 -eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int (-2)), +eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int (-2)), big_int_of_int (-3));; test 11 -eq_big_int (add_big_int (big_int_of_int (-2)) (big_int_of_int (-1)), +eq_big_int (add_big_int (big_int_of_int (-2)) (big_int_of_int (-1)), big_int_of_int (-3));; test 12 -eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int (-1)), +eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int (-1)), zero_big_int);; test 13 -eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int 1), +eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int 1), zero_big_int);; test 14 -eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int (-2)), +eq_big_int (add_big_int (big_int_of_int 1) (big_int_of_int (-2)), big_int_of_int (-1));; test 15 -eq_big_int (add_big_int (big_int_of_int (-2)) (big_int_of_int 1), +eq_big_int (add_big_int (big_int_of_int (-2)) (big_int_of_int 1), big_int_of_int (-1));; test 16 -eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int 2), +eq_big_int (add_big_int (big_int_of_int (-1)) (big_int_of_int 2), big_int_of_int 1);; test 17 -eq_big_int (add_big_int (big_int_of_int 2) (big_int_of_int (-1)), +eq_big_int (add_big_int (big_int_of_int 2) (big_int_of_int (-1)), big_int_of_int 1);; @@ -110,52 +110,52 @@ testing_function "sub_big_int";; test 1 eq_big_int (sub_big_int zero_big_int zero_big_int, zero_big_int);; test 2 -eq_big_int (sub_big_int zero_big_int (big_int_of_int 1), +eq_big_int (sub_big_int zero_big_int (big_int_of_int 1), big_int_of_int (-1));; test 3 -eq_big_int (sub_big_int (big_int_of_int 1) zero_big_int, +eq_big_int (sub_big_int (big_int_of_int 1) zero_big_int, big_int_of_int 1);; test 4 -eq_big_int (sub_big_int zero_big_int (big_int_of_int (-1)), +eq_big_int (sub_big_int zero_big_int (big_int_of_int (-1)), big_int_of_int 1);; test 5 -eq_big_int (sub_big_int (big_int_of_int (-1)) zero_big_int, +eq_big_int (sub_big_int (big_int_of_int (-1)) zero_big_int, big_int_of_int (-1));; test 6 -eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int 1), +eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int 1), zero_big_int);; test 7 -eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int 2), +eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int 2), big_int_of_int (-1));; test 8 -eq_big_int (sub_big_int (big_int_of_int 2) (big_int_of_int 1), +eq_big_int (sub_big_int (big_int_of_int 2) (big_int_of_int 1), big_int_of_int 1);; test 9 -eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int (-1)), +eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int (-1)), zero_big_int);; test 10 -eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int (-2)), +eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int (-2)), big_int_of_int 1);; test 11 -eq_big_int (sub_big_int (big_int_of_int (-2)) (big_int_of_int (-1)), +eq_big_int (sub_big_int (big_int_of_int (-2)) (big_int_of_int (-1)), big_int_of_int (-1));; test 12 -eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int (-1)), +eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int (-1)), big_int_of_int 2);; test 13 -eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int 1), +eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int 1), big_int_of_int (-2));; test 14 -eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int (-2)), +eq_big_int (sub_big_int (big_int_of_int 1) (big_int_of_int (-2)), big_int_of_int 3);; test 15 -eq_big_int (sub_big_int (big_int_of_int (-2)) (big_int_of_int 1), +eq_big_int (sub_big_int (big_int_of_int (-2)) (big_int_of_int 1), big_int_of_int (-3));; test 16 -eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int 2), +eq_big_int (sub_big_int (big_int_of_int (-1)) (big_int_of_int 2), big_int_of_int (-3));; test 17 -eq_big_int (sub_big_int (big_int_of_int 2) (big_int_of_int (-1)), +eq_big_int (sub_big_int (big_int_of_int 2) (big_int_of_int (-1)), big_int_of_int 3);; testing_function "mult_int_big_int";; @@ -172,21 +172,21 @@ eq_big_int (mult_int_big_int 2 (big_int_of_int 3), big_int_of_int 6);; testing_function "mult_big_int";; test 1 -eq_big_int (mult_big_int zero_big_int zero_big_int, +eq_big_int (mult_big_int zero_big_int zero_big_int, zero_big_int);; test 2 -eq_big_int (mult_big_int (big_int_of_int 2) (big_int_of_int 3), +eq_big_int (mult_big_int (big_int_of_int 2) (big_int_of_int 3), big_int_of_int 6);; test 3 -eq_big_int (mult_big_int (big_int_of_int 2) (big_int_of_int (-3)), +eq_big_int (mult_big_int (big_int_of_int 2) (big_int_of_int (-3)), big_int_of_int (-6));; -test 4 -eq_big_int (mult_big_int (big_int_of_string "12724951") - (big_int_of_string "81749606400"), +test 4 +eq_big_int (mult_big_int (big_int_of_string "12724951") + (big_int_of_string "81749606400"), big_int_of_string "1040259735709286400");; -test 5 -eq_big_int (mult_big_int (big_int_of_string "26542080") - (big_int_of_string "81749606400"), +test 5 +eq_big_int (mult_big_int (big_int_of_string "26542080") + (big_int_of_string "81749606400"), big_int_of_string "2169804593037312000");; testing_function "quomod_big_int";; @@ -201,14 +201,14 @@ let (quotient, modulo) = test 3 eq_big_int (quotient, big_int_of_int (-1)) && test 4 eq_big_int (modulo, zero_big_int);; -let (quotient, modulo) = +let (quotient, modulo) = quomod_big_int (big_int_of_int (-1)) (big_int_of_int 1) in - test 5 eq_big_int (quotient, big_int_of_int (-1)) && + test 5 eq_big_int (quotient, big_int_of_int (-1)) && test 6 eq_big_int (modulo, zero_big_int);; -let (quotient, modulo) = +let (quotient, modulo) = quomod_big_int (big_int_of_int 3) (big_int_of_int 2) in - test 7 eq_big_int (quotient, big_int_of_int 1) && + test 7 eq_big_int (quotient, big_int_of_int 1) && test 8 eq_big_int (modulo, big_int_of_int 1);; let (quotient, modulo) = @@ -221,12 +221,12 @@ let (quotient, modulo) = test 11 eq_big_int (quotient, big_int_of_int (-2)) && test 12 eq_big_int (modulo, big_int_of_int 1);; -let (quotient, modulo) = +let (quotient, modulo) = quomod_big_int (big_int_of_int 1) (big_int_of_int 2) in - test 13 eq_big_int (quotient, zero_big_int) && + test 13 eq_big_int (quotient, zero_big_int) && test 14 eq_big_int (modulo, big_int_of_int 1);; -let (quotient, modulo) = +let (quotient, modulo) = quomod_big_int (big_int_of_int (-1)) (big_int_of_int 3) in test 15 eq_big_int (quotient, minus_big_int unit_big_int) && test 16 eq_big_int (modulo, big_int_of_int 2);; @@ -236,22 +236,22 @@ failwith_test 17 Division_by_zero ;; -let (quotient, modulo) = +let (quotient, modulo) = quomod_big_int (big_int_of_int 10) (big_int_of_int 20) in test 18 eq_big_int (quotient, big_int_of_int 0) && test 19 eq_big_int (modulo, big_int_of_int 10);; -let (quotient, modulo) = +let (quotient, modulo) = quomod_big_int (big_int_of_int (-10)) (big_int_of_int 20) in test 20 eq_big_int (quotient, big_int_of_int (-1)) && test 21 eq_big_int (modulo, big_int_of_int 10);; -let (quotient, modulo) = +let (quotient, modulo) = quomod_big_int (big_int_of_int 10) (big_int_of_int (-20)) in test 22 eq_big_int (quotient, big_int_of_int 0) && test 23 eq_big_int (modulo, big_int_of_int 10);; -let (quotient, modulo) = +let (quotient, modulo) = quomod_big_int (big_int_of_int (-10)) (big_int_of_int (-20)) in test 24 eq_big_int (quotient, big_int_of_int 1) && test 25 eq_big_int (modulo, big_int_of_int 10);; @@ -260,28 +260,28 @@ let (quotient, modulo) = testing_function "gcd_big_int";; test 1 -eq_big_int (gcd_big_int zero_big_int zero_big_int, +eq_big_int (gcd_big_int zero_big_int zero_big_int, zero_big_int);; test 2 -eq_big_int (gcd_big_int zero_big_int (big_int_of_int 1), +eq_big_int (gcd_big_int zero_big_int (big_int_of_int 1), big_int_of_int 1);; test 3 -eq_big_int (gcd_big_int (big_int_of_int 1) zero_big_int, +eq_big_int (gcd_big_int (big_int_of_int 1) zero_big_int, big_int_of_int 1);; test 4 -eq_big_int (gcd_big_int (big_int_of_int 1) (big_int_of_int 2), +eq_big_int (gcd_big_int (big_int_of_int 1) (big_int_of_int 2), big_int_of_int 1);; test 5 -eq_big_int (gcd_big_int (big_int_of_int 2) (big_int_of_int 1), +eq_big_int (gcd_big_int (big_int_of_int 2) (big_int_of_int 1), big_int_of_int 1);; test 6 -eq_big_int (gcd_big_int (big_int_of_int 1) (big_int_of_int 1), +eq_big_int (gcd_big_int (big_int_of_int 1) (big_int_of_int 1), big_int_of_int 1);; test 7 -eq_big_int (gcd_big_int (big_int_of_int 9) (big_int_of_int 16), +eq_big_int (gcd_big_int (big_int_of_int 9) (big_int_of_int 16), big_int_of_int 1);; test 8 -eq_big_int (gcd_big_int (big_int_of_int 12) (big_int_of_int 16), +eq_big_int (gcd_big_int (big_int_of_int 12) (big_int_of_int 16), big_int_of_int 4);; for i = 9 to 28 do @@ -404,7 +404,7 @@ let bi1 = big_int_of_string (implode (rev l)) in let bi2 = big_int_of_string (implode (rev ("3" :: tl l))) in test 10 -eq_big_int (bi1, (add_big_int (mult_big_int bi2 (big_int_of_string "10")) +eq_big_int (bi1, (add_big_int (mult_big_int bi2 (big_int_of_string "10")) (big_int_of_string "2"))) (* test 11 && @@ -444,7 +444,7 @@ test 2 eq_big_int (big_int_of_nat (power_base_int 10 8), big_int_of_int 100000000) ;; test 3 -eq_big_int (big_int_of_nat (power_base_int 2 (length_of_int + 2)), +eq_big_int (big_int_of_nat (power_base_int 2 (length_of_int + 2)), big_int_of_nat (let nat = make_nat 2 in set_digit_nat nat 1 1; nat)) @@ -933,12 +933,11 @@ test 3 eq_int (Hashtbl.hash (minus_big_int unit_big_int), 161678167);; test 4 eq_int (Hashtbl.hash (big_int_of_string "123456789123456789"), 755417385);; -test 5 eq_int (Hashtbl.hash (sub_big_int +test 5 eq_int (Hashtbl.hash (sub_big_int (big_int_of_string "123456789123456789") (big_int_of_string "123456789123456789")), 955772237);; -test 6 eq_int (Hashtbl.hash (sub_big_int +test 6 eq_int (Hashtbl.hash (sub_big_int (big_int_of_string "123456789123456789") (big_int_of_string "123456789123456788")), 992063522);; - diff --git a/testsuite/tests/lib-num/test_nats.ml b/testsuite/tests/lib-num/test_nats.ml index b47b39f8ee..739ed37e90 100644 --- a/testsuite/tests/lib-num/test_nats.ml +++ b/testsuite/tests/lib-num/test_nats.ml @@ -3,7 +3,7 @@ open Nat;; (* Can compare nats less than 2**32 *) let equal_nat n1 n2 = - eq_nat n1 0 (num_digits_nat n1 0 1) + eq_nat n1 0 (num_digits_nat n1 0 1) n2 0 (num_digits_nat n2 0 1);; testing_function "num_digits_nat";; @@ -108,10 +108,10 @@ let set_mult_digit_nat n1 d1 l1 n2 d2 l2 n3 d3 = let s = "3333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333" in test 21 equal_nat ( nat_of_string s, -(let nat = make_nat 15 in +(let nat = make_nat 15 in set_digit_nat nat 0 3; - set_mult_digit_nat nat 0 15 - (nat_of_string (String.sub s 0 135)) 0 14 + set_mult_digit_nat nat 0 15 + (nat_of_string (String.sub s 0 135)) 0 14 (nat_of_int 10) 0; nat)) ;; diff --git a/testsuite/tests/lib-num/test_nums.ml b/testsuite/tests/lib-num/test_nums.ml index b26001bc76..24b5d264a5 100644 --- a/testsuite/tests/lib-num/test_nums.ml +++ b/testsuite/tests/lib-num/test_nums.ml @@ -12,10 +12,10 @@ eq_num (add_num (Int 1) (Int 3), Int 4);; test 2 eq_num (add_num (Int 1) (Big_int (big_int_of_int 3)), Int 4);; test 3 -eq_num (add_num (Int 1) (Ratio (ratio_of_string "3/4")), +eq_num (add_num (Int 1) (Ratio (ratio_of_string "3/4")), Ratio (ratio_of_string "7/4"));; test 4 -eq_num (add_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")), +eq_num (add_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")), Ratio (ratio_of_string "7/4"));; test 5 eq_num (add_num (Big_int (big_int_of_int 1)) (Big_int (big_int_of_int 3)), @@ -27,10 +27,10 @@ test 7 eq_num (add_num (Ratio (ratio_of_string "2/3")) (Ratio (ratio_of_string "3/4")), Ratio (ratio_of_string "17/12"));; test 8 -eq_num (add_num (Int least_int) (Int 1), +eq_num (add_num (Int least_int) (Int 1), Int (- (pred biggest_int)));; test 9 -eq_num (add_num (Int biggest_int) (Int 1), +eq_num (add_num (Int biggest_int) (Int 1), Big_int (minus_big_int (pred_big_int (big_int_of_int least_int))));; testing_function "sub_num";; @@ -40,10 +40,10 @@ eq_num (sub_num (Int 1) (Int 3), Int (-2));; test 2 eq_num (sub_num (Int 1) (Big_int (big_int_of_int 3)), Int (-2));; test 3 -eq_num (sub_num (Int 1) (Ratio (ratio_of_string "3/4")), +eq_num (sub_num (Int 1) (Ratio (ratio_of_string "3/4")), Ratio (ratio_of_string "1/4"));; test 4 -eq_num (sub_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")), +eq_num (sub_num (Big_int (big_int_of_int 1)) (Ratio (ratio_of_string "3/4")), Ratio (ratio_of_string "1/4"));; test 5 eq_num (sub_num (Big_int (big_int_of_int 1)) (Big_int (big_int_of_int 3)), @@ -55,7 +55,7 @@ test 8 eq_num (sub_num (Ratio (ratio_of_string "2/3")) (Ratio (ratio_of_string "3/4")), Ratio (ratio_of_string "-1/12"));; test 9 -eq_num (sub_num (Int least_int) (Int (-1)), +eq_num (sub_num (Int least_int) (Int (-1)), Int (- (pred biggest_int)));; test 10 eq_num (sub_num (Int (-1)) (Int biggest_int), pred_num (Int least_int));; @@ -68,12 +68,12 @@ test 2 eq_num (mult_num (Int 127) (Int (int_of_string "257")), Int (int_of_string "32639"));; test 3 -eq_num (mult_num (Int 257) (Int (int_of_string "260")), +eq_num (mult_num (Int 257) (Int (int_of_string "260")), Big_int (big_int_of_string "66820"));; test 4 eq_num (mult_num (Int 2) (Big_int (big_int_of_int 3)), Int 6);; test 5 -eq_num (mult_num (Int 10) (Ratio (ratio_of_string "3/4")), +eq_num (mult_num (Int 10) (Ratio (ratio_of_string "3/4")), Ratio (ratio_of_string "15/2"));; test 6 eq_num (mult_num (Big_int (big_int_of_int 10)) (Ratio (ratio_of_string "3/4")), @@ -93,31 +93,31 @@ testing_function "div_num";; test 1 eq_num (div_num (Int 6) (Int 3), Int 2);; test 2 -eq_num (div_num (Int (int_of_string "32639")) +eq_num (div_num (Int (int_of_string "32639")) (Int (int_of_string "257")), Int 127);; test 3 -eq_num (div_num (Big_int (big_int_of_string "66820")) - (Int (int_of_string "257")), +eq_num (div_num (Big_int (big_int_of_string "66820")) + (Int (int_of_string "257")), Int 260);; test 4 eq_num (div_num (Int 6) (Big_int (big_int_of_int 3)), Int 2);; test 5 -eq_num (div_num (Ratio (ratio_of_string "15/2")) +eq_num (div_num (Ratio (ratio_of_string "15/2")) (Int 10), - Ratio (ratio_of_string "3/4"));; + Ratio (ratio_of_string "3/4"));; test 6 eq_num (div_num (Big_int (big_int_of_int 6)) (Big_int (big_int_of_int 3)), Int 2);; -test 7 -eq_num (div_num (Ratio (ratio_of_string "15/2")) +test 7 +eq_num (div_num (Ratio (ratio_of_string "15/2")) (Big_int (big_int_of_int 10)), Ratio (ratio_of_string "3/4"));; test 8 -eq_num (div_num (Ratio (ratio_of_string "15/2")) +eq_num (div_num (Ratio (ratio_of_string "15/2")) (Ratio (ratio_of_string "3/4")), Big_int (big_int_of_int 10));; test 9 -eq_num (div_num (Ratio (ratio_of_string "1/2")) +eq_num (div_num (Ratio (ratio_of_string "1/2")) (Ratio (ratio_of_string "3/4")), Ratio (ratio_of_string "2/3"));; @@ -137,7 +137,7 @@ testing_function "num_of_ratio";; test 1 eq_num (num_of_ratio (ratio_of_string "4/2"), Int 2);; test 2 -eq_num (num_of_ratio (ratio_of_string "11811160075/11"), +eq_num (num_of_ratio (ratio_of_string "11811160075/11"), Big_int (big_int_of_string "1073741825"));; test 3 eq_num (num_of_ratio (ratio_of_string "123456789012/1234"), @@ -205,13 +205,13 @@ test 2 eq (f1 1, false);; test 3 eq (f1 (0/1), true);; -test 4 eq (f1 (let n = num_of_string "2000000000000000000000000" in n-n) , +test 4 eq (f1 (let n = num_of_string "2000000000000000000000000" in n-n) , true);; -test 5 eq (f1 (let n = num_of_string "2000000000000000000000000" in n/n-1) , +test 5 eq (f1 (let n = num_of_string "2000000000000000000000000" in n/n-1) , true);; -test 6 eq (f1 (let n = num_of_string "2000000000000000000000000" in n+1) , +test 6 eq (f1 (let n = num_of_string "2000000000000000000000000" in n+1) , false);; test 7 eq (f1 (1/2), false);; diff --git a/testsuite/tests/lib-printf/Makefile b/testsuite/tests/lib-printf/Makefile new file mode 100644 index 0000000000..94c404726f --- /dev/null +++ b/testsuite/tests/lib-printf/Makefile @@ -0,0 +1,7 @@ +#MODULES= +MAIN_MODULE=tprintf +ADD_COMPFLAGS=-I $(BASEDIR)/lib +ADD_MODULES=testing + +include ../../makefiles/Makefile.one +include ../../makefiles/Makefile.common diff --git a/testsuite/tests/lib-printf/tprintf.ml b/testsuite/tests/lib-printf/tprintf.ml new file mode 100644 index 0000000000..1e2762287f --- /dev/null +++ b/testsuite/tests/lib-printf/tprintf.ml @@ -0,0 +1,468 @@ +(*************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2011 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(*************************************************************************) + +(* $Id: tscanf.ml 10713 2010-10-08 11:53:19Z doligez $ *) + +(* + +A test file for the Printf module. + +*) + +open Testing;; +open Printf;; + +try + + printf "d/i positive\n%!"; + test (sprintf "%d/%i" 42 43 = "42/43"); + test (sprintf "%-4d/%-5i" 42 43 = "42 /43 "); + test (sprintf "%04d/%05i" 42 43 = "0042/00043"); + test (sprintf "%+d/%+i" 42 43 = "+42/+43"); + test (sprintf "% d/% i" 42 43 = " 42/ 43"); + test (sprintf "%#d/%#i" 42 43 = "42/43"); + test (sprintf "%4d/%5i" 42 43 = " 42/ 43"); + test (sprintf "%*d/%*i" 4 42 5 43 = " 42/ 43"); + test (sprintf "%-0+#4d/%-0 #5i" 42 43 = "+42 / 43 "); + + printf "\nd/i negative\n%!"; + test (sprintf "%d/%i" (-42) (-43) = "-42/-43"); + test (sprintf "%-4d/%-5i" (-42) (-43) = "-42 /-43 "); + test (sprintf "%04d/%05i" (-42) (-43) = "-042/-0043"); + test (sprintf "%+d/%+i" (-42) (-43) = "-42/-43"); + test (sprintf "% d/% i" (-42) (-43) = "-42/-43"); + test (sprintf "%#d/%#i" (-42) (-43) = "-42/-43"); + test (sprintf "%4d/%5i" (-42) (-43) = " -42/ -43"); + test (sprintf "%*d/%*i" 4 (-42) 5 (-43) = " -42/ -43"); + test (sprintf "%-0+ #4d/%-0+ #5i" (-42) (-43) = "-42 /-43 "); + + printf "\nu positive\n%!"; + test (sprintf "%u" 42 = "42"); + test (sprintf "%-4u" 42 = "42 "); + test (sprintf "%04u" 42 = "0042"); + test (sprintf "%+u" 42 = "42"); + test (sprintf "% u" 42 = "42"); + test (sprintf "%#u" 42 = "42"); + test (sprintf "%4u" 42 = " 42"); + test (sprintf "%*u" 4 42 = " 42"); + test (sprintf "%-0+ #6d" 42 = "+42 "); + + printf "\nu negative\n%!"; + begin match Sys.word_size with + | 32 -> + test (sprintf "%u" (-1) = "2147483647"); + | 64 -> + test (sprintf "%u" (-1) = "9223372036854775807"); + | _ -> test false + end; + + printf "\nx positive\n%!"; + test (sprintf "%x" 42 = "2a"); + test (sprintf "%-4x" 42 = "2a "); + test (sprintf "%04x" 42 = "002a"); + test (sprintf "%+x" 42 = "2a"); + test (sprintf "% x" 42 = "2a"); + test (sprintf "%#x" 42 = "0x2a"); + test (sprintf "%4x" 42 = " 2a"); + test (sprintf "%*x" 5 42 = " 2a"); + test (sprintf "%-0+ #*x" 5 42 = "0x2a "); + + printf "\nx negative\n%!"; + begin match Sys.word_size with + | 32 -> + test (sprintf "%x" (-42) = "7fffffd6"); + | 64 -> + test (sprintf "%x" (-42) = "7fffffffffffffd6"); + | _ -> test false + end; + + printf "\nX positive\n%!"; + test (sprintf "%X" 42 = "2A"); + test (sprintf "%-4X" 42 = "2A "); + test (sprintf "%04X" 42 = "002A"); + test (sprintf "%+X" 42 = "2A"); + test (sprintf "% X" 42 = "2A"); + test (sprintf "%#X" 42 = "0X2A"); + test (sprintf "%4X" 42 = " 2A"); + test (sprintf "%*X" 5 42 = " 2A"); + test (sprintf "%-0+ #*X" 5 42 = "0X2A "); + + printf "\nx negative\n%!"; + begin match Sys.word_size with + | 32 -> + test (sprintf "%X" (-42) = "7FFFFFD6"); + | 64 -> + test (sprintf "%X" (-42) = "7FFFFFFFFFFFFFD6"); + | _ -> test false + end; + + printf "\no positive\n%!"; + test (sprintf "%o" 42 = "52"); + test (sprintf "%-4o" 42 = "52 "); + test (sprintf "%04o" 42 = "0052"); + test (sprintf "%+o" 42 = "52"); + test (sprintf "% o" 42 = "52"); + test (sprintf "%#o" 42 = "052"); + test (sprintf "%4o" 42 = " 52"); + test (sprintf "%*o" 5 42 = " 52"); + test (sprintf "%-0+ #*o" 5 42 = "052 "); + + printf "\no negative\n%!"; + begin match Sys.word_size with + | 32 -> + test (sprintf "%o" (-42) = "17777777726"); + | 64 -> + test (sprintf "%o" (-42) = "777777777777777777726"); + | _ -> test false + end; + + printf "\ns\n%!"; + test (sprintf "%s" "foo" = "foo"); + test (sprintf "%-5s" "foo" = "foo "); + test (sprintf "%05s" "foo" = " foo"); + test (sprintf "%+s" "foo" = "foo"); + test (sprintf "% s" "foo" = "foo"); + test (sprintf "%#s" "foo" = "foo"); + test (sprintf "%5s" "foo" = " foo"); + test (sprintf "%1s" "foo" = "foo"); + test (sprintf "%*s" 6 "foo" = " foo"); + test (sprintf "%*s" 2 "foo" = "foo"); + test (sprintf "%-0+ #5s" "foo" = "foo "); + test (sprintf "%s@" "foo" = "foo@"); + test (sprintf "%s@inria.fr" "foo" = "foo@inria.fr"); + test (sprintf "%s@%s" "foo" "inria.fr" = "foo@inria.fr"); + + printf "\nS\n%!"; + test (sprintf "%S" "fo\"o" = "\"fo\\\"o\""); +(* test (sprintf "%-5S" "foo" = "\"foo\" "); padding not done *) +(* test (sprintf "%05S" "foo" = " \"foo\""); padding not done *) + test (sprintf "%+S" "foo" = "\"foo\""); + test (sprintf "% S" "foo" = "\"foo\""); + test (sprintf "%#S" "foo" = "\"foo\""); +(* test (sprintf "%5S" "foo" = " \"foo\""); padding not done *) + test (sprintf "%1S" "foo" = "\"foo\""); +(* test (sprintf "%*S" 6 "foo" = " \"foo\""); padding not done *) + test (sprintf "%*S" 2 "foo" = "\"foo\""); +(* test (sprintf "%-0+ #5S" "foo" = "\"foo\" "); padding not done *) + test (sprintf "%S@" "foo" = "\"foo\"@"); + test (sprintf "%S@inria.fr" "foo" = "\"foo\"@inria.fr"); + test (sprintf "%S@%S" "foo" "inria.fr" = "\"foo\"@\"inria.fr\""); + + printf "\nc\n%!"; + test (sprintf "%c" 'c' = "c"); +(* test (sprintf "%-4c" 'c' = "c "); padding not done *) +(* test (sprintf "%04c" 'c' = " c"); padding not done *) + test (sprintf "%+c" 'c' = "c"); + test (sprintf "% c" 'c' = "c"); + test (sprintf "%#c" 'c' = "c"); +(* test (sprintf "%4c" 'c' = " c"); padding not done *) +(* test (sprintf "%*c" 2 'c' = " c"); padding not done *) +(* test (sprintf "%-0+ #4c" 'c' = "c "); padding not done *) + + printf "\nC\n%!"; + test (sprintf "%C" 'c' = "'c'"); + test (sprintf "%C" '\'' = "'\\''"); +(* test (sprintf "%-4C" 'c' = "c "); padding not done *) +(* test (sprintf "%04C" 'c' = " c"); padding not done *) + test (sprintf "%+C" 'c' = "'c'"); + test (sprintf "% C" 'c' = "'c'"); + test (sprintf "%#C" 'c' = "'c'"); +(* test (sprintf "%4C" 'c' = " c"); padding not done *) +(* test (sprintf "%*C" 2 'c' = " c"); padding not done *) +(* test (sprintf "%-0+ #4C" 'c' = "c "); padding not done *) + + printf "\nf\n%!"; + test (sprintf "%f" (-42.42) = "-42.420000"); + test (sprintf "%-13f" (-42.42) = "-42.420000 "); + test (sprintf "%013f" (-42.42) = "-00042.420000"); + test (sprintf "%+f" 42.42 = "+42.420000"); + test (sprintf "% f" 42.42 = " 42.420000"); + test (sprintf "%#f" 42.42 = "42.420000"); + test (sprintf "%13f" 42.42 = " 42.420000"); + test (sprintf "%*f" 12 42.42 = " 42.420000"); + test (sprintf "%-0+ #12f" 42.42 = "+42.420000 "); + test (sprintf "%.3f" (-42.42) = "-42.420"); + test (sprintf "%-13.3f" (-42.42) = "-42.420 "); + test (sprintf "%013.3f" (-42.42) = "-00000042.420"); + test (sprintf "%+.3f" 42.42 = "+42.420"); + test (sprintf "% .3f" 42.42 = " 42.420"); + test (sprintf "%#.3f" 42.42 = "42.420"); + test (sprintf "%13.3f" 42.42 = " 42.420"); + test (sprintf "%*.*f" 12 3 42.42 = " 42.420"); + test (sprintf "%-0+ #12.3f" 42.42 = "+42.420 "); + + printf "\nF\n%!"; + test (sprintf "%F" 42.42 = "42.42"); + test (sprintf "%F" 42.42e42 = "4.242e+43"); + test (sprintf "%F" 42.00 = "42."); + test (sprintf "%F" 0.042 = "0.042"); +(* no padding, no precision + test (sprintf "%.3F" 42.42 = "42.420"); + test (sprintf "%12.3F" 42.42e42 = " 4.242e+43"); + test (sprintf "%.3F" 42.00 = "42.000"); + test (sprintf "%.3F" 0.0042 = "0.004"); +*) + + printf "\ne\n%!"; + test (sprintf "%e" (-42.42) = "-4.242000e+01"); + test (sprintf "%-15e" (-42.42) = "-4.242000e+01 "); + test (sprintf "%015e" (-42.42) = "-004.242000e+01"); + test (sprintf "%+e" 42.42 = "+4.242000e+01"); + test (sprintf "% e" 42.42 = " 4.242000e+01"); + test (sprintf "%#e" 42.42 = "4.242000e+01"); + test (sprintf "%15e" 42.42 = " 4.242000e+01"); + test (sprintf "%*e" 14 42.42 = " 4.242000e+01"); + test (sprintf "%-0+ #14e" 42.42 = "+4.242000e+01 "); + test (sprintf "%.3e" (-42.42) = "-4.242e+01"); + test (sprintf "%-15.3e" (-42.42) = "-4.242e+01 "); + test (sprintf "%015.3e" (-42.42) = "-000004.242e+01"); + test (sprintf "%+.3e" 42.42 = "+4.242e+01"); + test (sprintf "% .3e" 42.42 = " 4.242e+01"); + test (sprintf "%#.3e" 42.42 = "4.242e+01"); + test (sprintf "%15.3e" 42.42 = " 4.242e+01"); + test (sprintf "%*.*e" 11 3 42.42 = " 4.242e+01"); + test (sprintf "%-0+ #14.3e" 42.42 = "+4.242e+01 "); + + printf "\nE\n%!"; + test (sprintf "%E" (-42.42) = "-4.242000E+01"); + test (sprintf "%-15E" (-42.42) = "-4.242000E+01 "); + test (sprintf "%015E" (-42.42) = "-004.242000E+01"); + test (sprintf "%+E" 42.42 = "+4.242000E+01"); + test (sprintf "% E" 42.42 = " 4.242000E+01"); + test (sprintf "%#E" 42.42 = "4.242000E+01"); + test (sprintf "%15E" 42.42 = " 4.242000E+01"); + test (sprintf "%*E" 14 42.42 = " 4.242000E+01"); + test (sprintf "%-0+ #14E" 42.42 = "+4.242000E+01 "); + test (sprintf "%.3E" (-42.42) = "-4.242E+01"); + test (sprintf "%-15.3E" (-42.42) = "-4.242E+01 "); + test (sprintf "%015.3E" (-42.42) = "-000004.242E+01"); + test (sprintf "%+.3E" 42.42 = "+4.242E+01"); + test (sprintf "% .3E" 42.42 = " 4.242E+01"); + test (sprintf "%#.3E" 42.42 = "4.242E+01"); + test (sprintf "%15.3E" 42.42 = " 4.242E+01"); + test (sprintf "%*.*E" 11 3 42.42 = " 4.242E+01"); + test (sprintf "%-0+ #14.3E" 42.42 = "+4.242E+01 "); + +(* %g gives strange results that correspond to neither %f nor %e + printf "\ng\n%!"; + test (sprintf "%g" (-42.42) = "-42.42000"); + test (sprintf "%-15g" (-42.42) = "-42.42000 "); + test (sprintf "%015g" (-42.42) = "-00000042.42000"); + test (sprintf "%+g" 42.42 = "+42.42000"); + test (sprintf "% g" 42.42 = " 42.42000"); + test (sprintf "%#g" 42.42 = "42.42000"); + test (sprintf "%15g" 42.42 = " 42.42000"); + test (sprintf "%*g" 14 42.42 = " 42.42000"); + test (sprintf "%-0+ #14g" 42.42 = "+42.42000 "); + test (sprintf "%.3g" (-42.42) = "-42.420"); +*) + +(* Same for %G + printf "\nG\n%!"; +*) + + printf "\nB\n%!"; + test (sprintf "%B" true = "true"); + test (sprintf "%B" false = "false"); + + printf "\nld/li positive\n%!"; + test (sprintf "%ld/%li" 42l 43l = "42/43"); + test (sprintf "%-4ld/%-5li" 42l 43l = "42 /43 "); + test (sprintf "%04ld/%05li" 42l 43l = "0042/00043"); + test (sprintf "%+ld/%+li" 42l 43l = "+42/+43"); + test (sprintf "% ld/% li" 42l 43l = " 42/ 43"); + test (sprintf "%#ld/%#li" 42l 43l = "42/43"); + test (sprintf "%4ld/%5li" 42l 43l = " 42/ 43"); + test (sprintf "%*ld/%*li" 4 42l 5 43l = " 42/ 43"); + test (sprintf "%-0+#4ld/%-0 #5li" 42l 43l = "+42 / 43 "); + + printf "\nld/li negative\n%!"; + test (sprintf "%ld/%li" (-42l) (-43l) = "-42/-43"); + test (sprintf "%-4ld/%-5li" (-42l) (-43l) = "-42 /-43 "); + test (sprintf "%04ld/%05li" (-42l) (-43l) = "-042/-0043"); + test (sprintf "%+ld/%+li" (-42l) (-43l) = "-42/-43"); + test (sprintf "% ld/% li" (-42l) (-43l) = "-42/-43"); + test (sprintf "%#ld/%#li" (-42l) (-43l) = "-42/-43"); + test (sprintf "%4ld/%5li" (-42l) (-43l) = " -42/ -43"); + test (sprintf "%*ld/%*li" 4 (-42l) 5 (-43l) = " -42/ -43"); + test (sprintf "%-0+ #4ld/%-0+ #5li" (-42l) (-43l) = "-42 /-43 "); + + printf "\nlu positive\n%!"; + test (sprintf "%lu" 42l = "42"); + test (sprintf "%-4lu" 42l = "42 "); + test (sprintf "%04lu" 42l = "0042"); + test (sprintf "%+lu" 42l = "42"); + test (sprintf "% lu" 42l = "42"); + test (sprintf "%#lu" 42l = "42"); + test (sprintf "%4lu" 42l = " 42"); + test (sprintf "%*lu" 4 42l = " 42"); + test (sprintf "%-0+ #6ld" 42l = "+42 "); + + printf "\nlu negative\n%!"; + test (sprintf "%lu" (-1l) = "4294967295"); + + printf "\nlx positive\n%!"; + test (sprintf "%lx" 42l = "2a"); + test (sprintf "%-4lx" 42l = "2a "); + test (sprintf "%04lx" 42l = "002a"); + test (sprintf "%+lx" 42l = "2a"); + test (sprintf "% lx" 42l = "2a"); + test (sprintf "%#lx" 42l = "0x2a"); + test (sprintf "%4lx" 42l = " 2a"); + test (sprintf "%*lx" 5 42l = " 2a"); + test (sprintf "%-0+ #*lx" 5 42l = "0x2a "); + + printf "\nlx negative\n%!"; + test (sprintf "%lx" (-42l) = "ffffffd6"); + + printf "\nlX positive\n%!"; + test (sprintf "%lX" 42l = "2A"); + test (sprintf "%-4lX" 42l = "2A "); + test (sprintf "%04lX" 42l = "002A"); + test (sprintf "%+lX" 42l = "2A"); + test (sprintf "% lX" 42l = "2A"); + test (sprintf "%#lX" 42l = "0X2A"); + test (sprintf "%4lX" 42l = " 2A"); + test (sprintf "%*lX" 5 42l = " 2A"); + test (sprintf "%-0+ #*lX" 5 42l = "0X2A "); + + printf "\nlx negative\n%!"; + test (sprintf "%lX" (-42l) = "FFFFFFD6"); + + printf "\nlo positive\n%!"; + test (sprintf "%lo" 42l = "52"); + test (sprintf "%-4lo" 42l = "52 "); + test (sprintf "%04lo" 42l = "0052"); + test (sprintf "%+lo" 42l = "52"); + test (sprintf "% lo" 42l = "52"); + test (sprintf "%#lo" 42l = "052"); + test (sprintf "%4lo" 42l = " 52"); + test (sprintf "%*lo" 5 42l = " 52"); + test (sprintf "%-0+ #*lo" 5 42l = "052 "); + + printf "\nlo negative\n%!"; + test (sprintf "%lo" (-42l) = "37777777726"); + + (* Nativeint not tested: looks like too much work, and anyway it should + work like Int32 or Int64. *) + + printf "\nLd/Li positive\n%!"; + test (sprintf "%Ld/%Li" 42L 43L = "42/43"); + test (sprintf "%-4Ld/%-5Li" 42L 43L = "42 /43 "); + test (sprintf "%04Ld/%05Li" 42L 43L = "0042/00043"); + test (sprintf "%+Ld/%+Li" 42L 43L = "+42/+43"); + test (sprintf "% Ld/% Li" 42L 43L = " 42/ 43"); + test (sprintf "%#Ld/%#Li" 42L 43L = "42/43"); + test (sprintf "%4Ld/%5Li" 42L 43L = " 42/ 43"); + test (sprintf "%*Ld/%*Li" 4 42L 5 43L = " 42/ 43"); + test (sprintf "%-0+#4Ld/%-0 #5Li" 42L 43L = "+42 / 43 "); + + printf "\nLd/Li negative\n%!"; + test (sprintf "%Ld/%Li" (-42L) (-43L) = "-42/-43"); + test (sprintf "%-4Ld/%-5Li" (-42L) (-43L) = "-42 /-43 "); + test (sprintf "%04Ld/%05Li" (-42L) (-43L) = "-042/-0043"); + test (sprintf "%+Ld/%+Li" (-42L) (-43L) = "-42/-43"); + test (sprintf "% Ld/% Li" (-42L) (-43L) = "-42/-43"); + test (sprintf "%#Ld/%#Li" (-42L) (-43L) = "-42/-43"); + test (sprintf "%4Ld/%5Li" (-42L) (-43L) = " -42/ -43"); + test (sprintf "%*Ld/%*Li" 4 (-42L) 5 (-43L) = " -42/ -43"); + test (sprintf "%-0+ #4Ld/%-0+ #5Li" (-42L) (-43L) = "-42 /-43 "); + + printf "\nLu positive\n%!"; + test (sprintf "%Lu" 42L = "42"); + test (sprintf "%-4Lu" 42L = "42 "); + test (sprintf "%04Lu" 42L = "0042"); + test (sprintf "%+Lu" 42L = "42"); + test (sprintf "% Lu" 42L = "42"); + test (sprintf "%#Lu" 42L = "42"); + test (sprintf "%4Lu" 42L = " 42"); + test (sprintf "%*Lu" 4 42L = " 42"); + test (sprintf "%-0+ #6Ld" 42L = "+42 "); + + printf "\nLu negative\n%!"; + test (sprintf "%Lu" (-1L) = "18446744073709551615"); + + printf "\nLx positive\n%!"; + test (sprintf "%Lx" 42L = "2a"); + test (sprintf "%-4Lx" 42L = "2a "); + test (sprintf "%04Lx" 42L = "002a"); + test (sprintf "%+Lx" 42L = "2a"); + test (sprintf "% Lx" 42L = "2a"); + test (sprintf "%#Lx" 42L = "0x2a"); + test (sprintf "%4Lx" 42L = " 2a"); + test (sprintf "%*Lx" 5 42L = " 2a"); + test (sprintf "%-0+ #*Lx" 5 42L = "0x2a "); + + printf "\nLx negative\n%!"; + test (sprintf "%Lx" (-42L) = "ffffffffffffffd6"); + + printf "\nLX positive\n%!"; + test (sprintf "%LX" 42L = "2A"); + test (sprintf "%-4LX" 42L = "2A "); + test (sprintf "%04LX" 42L = "002A"); + test (sprintf "%+LX" 42L = "2A"); + test (sprintf "% LX" 42L = "2A"); + test (sprintf "%#LX" 42L = "0X2A"); + test (sprintf "%4LX" 42L = " 2A"); + test (sprintf "%*LX" 5 42L = " 2A"); + test (sprintf "%-0+ #*LX" 5 42L = "0X2A "); + + printf "\nLx negative\n%!"; + test (sprintf "%LX" (-42L) = "FFFFFFFFFFFFFFD6"); + + printf "\nLo positive\n%!"; + test (sprintf "%Lo" 42L = "52"); + test (sprintf "%-4Lo" 42L = "52 "); + test (sprintf "%04Lo" 42L = "0052"); + test (sprintf "%+Lo" 42L = "52"); + test (sprintf "% Lo" 42L = "52"); + test (sprintf "%#Lo" 42L = "052"); + test (sprintf "%4Lo" 42L = " 52"); + test (sprintf "%*Lo" 5 42L = " 52"); + test (sprintf "%-0+ #*Lo" 5 42L = "052 "); + + printf "\nLo negative\n%!"; + test (sprintf "%Lo" (-42L) = "1777777777777777777726"); + + printf "\na\n%!"; + let x = ref () in + let f () y = if y == x then "ok" else "wrong" in + test (sprintf "%a" f x = "ok"); + + printf "\nt\n%!"; + let f () = "ok" in + test (sprintf "%t" f = "ok"); + +(* Does not work as expected. Should be fixed to work like %s. + printf "\n{...%%}\n%!"; + let f = format_of_string "%f/%s" in + test (sprintf "%{%f%s%}" f = "%f/%s"); +*) + + printf "\n(...%%)\n%!"; + let f = format_of_string "%d/foo/%s" in + test (sprintf "%(%d%s%)" f 42 "bar" = "42/foo/bar"); + + printf "\n! %% @ , and constants\n%!"; + test (sprintf "%!" = ""); + test (sprintf "%%" = "%"); + test (sprintf "%@" = "@"); + test (sprintf "%," = ""); + test (sprintf "@" = "@"); + test (sprintf "@@" = "@@"); + test (sprintf "@%%" = "@%"); + + printf "\nend of tests\n%!"; +with e -> + printf "unexpected exception: %s\n%!" (Printexc.to_string e); + test false; +;; diff --git a/testsuite/tests/lib-printf/tprintf.reference b/testsuite/tests/lib-printf/tprintf.reference new file mode 100644 index 0000000000..c30013eb63 --- /dev/null +++ b/testsuite/tests/lib-printf/tprintf.reference @@ -0,0 +1,89 @@ +d/i positive + 0 1 2 3 4 5 6 7 8 +d/i negative + 9 10 11 12 13 14 15 16 17 +u positive + 18 19 20 21 22 23 24 25 26 +u negative + 27 +x positive + 28 29 30 31 32 33 34 35 36 +x negative + 37 +X positive + 38 39 40 41 42 43 44 45 46 +x negative + 47 +o positive + 48 49 50 51 52 53 54 55 56 +o negative + 57 +s + 58 59 60 61 62 63 64 65 66 67 68 69 70 71 +S + 72 73 74 75 76 77 78 79 80 +c + 81 82 83 84 +C + 85 86 87 88 89 +f + 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 +F + 108 109 110 111 +e + 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 +E + 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 +B + 148 149 +ld/li positive + 150 151 152 153 154 155 156 157 158 +ld/li negative + 159 160 161 162 163 164 165 166 167 +lu positive + 168 169 170 171 172 173 174 175 176 +lu negative + 177 +lx positive + 178 179 180 181 182 183 184 185 186 +lx negative + 187 +lX positive + 188 189 190 191 192 193 194 195 196 +lx negative + 197 +lo positive + 198 199 200 201 202 203 204 205 206 +lo negative + 207 +Ld/Li positive + 208 209 210 211 212 213 214 215 216 +Ld/Li negative + 217 218 219 220 221 222 223 224 225 +Lu positive + 226 227 228 229 230 231 232 233 234 +Lu negative + 235 +Lx positive + 236 237 238 239 240 241 242 243 244 +Lx negative + 245 +LX positive + 246 247 248 249 250 251 252 253 254 +Lx negative + 255 +Lo positive + 256 257 258 259 260 261 262 263 264 +Lo negative + 265 +a + 266 +t + 267 +(...%) + 268 +! % @ , and constants + 269 270 271 272 273 274 275 +end of tests + +All tests succeeded. diff --git a/testsuite/tests/lib-scanf-2/Makefile b/testsuite/tests/lib-scanf-2/Makefile index 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.ml b/testsuite/tests/lib-scanf/tscanf.ml index d929eb7474..8eb7d99361 100644 --- a/testsuite/tests/lib-scanf/tscanf.ml +++ b/testsuite/tests/lib-scanf/tscanf.ml @@ -265,15 +265,15 @@ test (test10 ()) (* %[] style *) let test11 () = - sscanf "Pierre Weis 70" "%s %s %s" + sscanf "Pierre\tWeis\t70" "%s %s %s" (fun prenom nom poids -> prenom = "Pierre" && nom = "Weis" && int_of_string poids = 70) && - sscanf "Jean-Luc de Léage 68" "%[^ ] %[^ ] %d" + sscanf "Jean-Luc\tde Léage\t68" "%[^\t] %[^\t] %d" (fun prenom nom poids -> prenom = "Jean-Luc" && nom = "de Léage" && poids = 68) && - sscanf "Daniel de Rauglaudre 66" "%s@\t %s@\t %d" + sscanf "Daniel\tde Rauglaudre\t66" "%s@\t %s@\t %d" (fun prenom nom poids -> prenom = "Daniel" && nom = "de Rauglaudre" && poids = 66) ;; @@ -585,7 +585,7 @@ and test27 () = (test27 ()) ;; -(* To scan a Caml string: +(* To scan an OCaml string: the format is "\"%s@\"". A better way would be to add a %S (String.escaped), a %C (Char.escaped). This is now available. *) @@ -950,7 +950,7 @@ test (test340 () && test35 ()) (* The prefered reader functionnals. *) -(* To read a list as in Caml (elements are ``blank + semicolon + blank'' +(* To read a list as in OCaml (elements are ``blank + semicolon + blank'' separated, and the list is enclosed in brackets). *) let rec read_elems read_elem accu ib = kscanf ib (fun ib exc -> accu) @@ -1444,12 +1444,22 @@ let test57 () = test (test57 ()) ;; -(* let test58 () = + sscanf "string1%string2" "%s@%%s" id = "string1" + && sscanf "string1%string2" "%s@%%%s" (^) = "string1string2" + && sscanf "string1@string2" "%[a-z0-9]@%s" (^) = "string1string2" + && sscanf "string1@%string2" "%[a-z0-9]%@%%%s" (^) = "string1string2" ;; test (test58 ()) ;; + +(* +let test59 () = +;; + +test (test59 ()) +;; *) (* To be continued ... diff --git a/testsuite/tests/lib-scanf/tscanf.reference b/testsuite/tests/lib-scanf/tscanf.reference index edeff6725a..18fe92baf8 100644 --- a/testsuite/tests/lib-scanf/tscanf.reference +++ b/testsuite/tests/lib-scanf/tscanf.reference @@ -1,2 +1,2 @@ -0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 + 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 All tests succeeded. diff --git a/testsuite/tests/lib-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-set/testmap.ml b/testsuite/tests/lib-set/testmap.ml index 1197fbf6d0..c54764ea7f 100644 --- a/testsuite/tests/lib-set/testmap.ml +++ b/testsuite/tests/lib-set/testmap.ml @@ -103,7 +103,7 @@ let test x v s1 s2 = check "split" (let (l, p, r) = M.split x s1 in - fun i -> + fun i -> if i < x then img i l = img i s1 else if i > x then img i r = img i s1 else p = img i s1) @@ -120,4 +120,3 @@ let rmap() = let _ = Random.init 42; for i = 1 to 25000 do test (rkey()) (rdata()) (rmap()) (rmap()) done - diff --git a/testsuite/tests/lib-set/testset.ml b/testsuite/tests/lib-set/testset.ml index c4ab0441e0..024342f808 100644 --- a/testsuite/tests/lib-set/testset.ml +++ b/testsuite/tests/lib-set/testset.ml @@ -102,7 +102,7 @@ let test x s1 s2 = check "split" (let (l, p, r) = S.split x s1 in - fun i -> + fun i -> if i < x then S.mem i l = S.mem i s1 else if i > x then S.mem i r = S.mem i s1 else p = S.mem i s1) @@ -117,4 +117,3 @@ let rset() = let _ = Random.init 42; for i = 1 to 25000 do test (relt()) (rset()) (rset()) done - diff --git a/testsuite/tests/lib-str/t01.ml b/testsuite/tests/lib-str/t01.ml index 03c85ea407..ab0c10ebb6 100644 --- a/testsuite/tests/lib-str/t01.ml +++ b/testsuite/tests/lib-str/t01.ml @@ -34,7 +34,7 @@ let start_test msg = let num_failures = ref 0 let test res1 res2 = - if res1 = res2 + if res1 = res2 then print_char '.' else begin print_string " FAIL "; incr num_failures end @@ -743,7 +743,7 @@ let automated_test() = test (Str.split_delim (Str.regexp "[ \t]+") " si non e vero\t") [""; "si"; "non"; "e"; "vero"; ""]; test (Str.full_split (Str.regexp "[ \t]+") " si non\te vero\t") - [Str.Delim " "; Str.Text "si"; + [Str.Delim " "; Str.Text "si"; Str.Delim " "; Str.Text "non"; Str.Delim "\t"; Str.Text "e"; Str.Delim " "; Str.Text "vero"; Str.Delim "\t"]; @@ -752,7 +752,7 @@ let automated_test() = (* See "REX: XML Shallow Parsing with Regular Expressions", Robert D. Cameron, Simon Fraser University, CMPT TR 1998-17. *) start_test "XML tokenization"; - begin + begin let _TextSE = "[^<]+" in let _UntilHyphen = "[^-]*-" in let _Until2Hyphens = _UntilHyphen ^ "\\([^-]" ^ _UntilHyphen ^ "\\)*-" in 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..52e367eabc --- /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-systhreads/testfork.ml b/testsuite/tests/lib-systhreads/testfork.ml index d0d253b37d..9815435305 100644 --- a/testsuite/tests/lib-systhreads/testfork.ml +++ b/testsuite/tests/lib-systhreads/testfork.ml @@ -2,7 +2,7 @@ let compute_thread c = ignore c (* - while true do + while true do print_char c; flush stdout; for i = 1 to 100000 do ignore(ref []) done done @@ -28,5 +28,3 @@ let main () = exit 0 let _ = main() - - 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/test3.runner b/testsuite/tests/lib-threads/test3.runner index 907135b622..e6d40a2478 100644 --- a/testsuite/tests/lib-threads/test3.runner +++ b/testsuite/tests/lib-threads/test3.runner @@ -1,4 +1,4 @@ ./program > test3.result & pid=$! sleep 5 -kill -9 $pid
\ No newline at end of file +kill -9 $pid 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/test4.runner b/testsuite/tests/lib-threads/test4.runner index 4f1a16d087..0559da0f80 100644 --- a/testsuite/tests/lib-threads/test4.runner +++ b/testsuite/tests/lib-threads/test4.runner @@ -1 +1 @@ -./program < test4.data > test4.result 2> /dev/null || true
\ No newline at end of file +./program < test4.data > test4.result 2> /dev/null || true 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/test5.runner b/testsuite/tests/lib-threads/test5.runner index 877d176e02..6b79d5e2da 100644 --- a/testsuite/tests/lib-threads/test5.runner +++ b/testsuite/tests/lib-threads/test5.runner @@ -1,4 +1,4 @@ ./program > test5.result & pid=$! sleep 1 -kill -9 $pid
\ No newline at end of file +kill -9 $pid 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/test7.checker b/testsuite/tests/lib-threads/test7.checker index c5eb2dcd7b..7cdb84123a 100644 --- a/testsuite/tests/lib-threads/test7.checker +++ b/testsuite/tests/lib-threads/test7.checker @@ -1 +1 @@ -test `grep -E '^-?[0123456789]+$' test7.result | wc -l` = `cat test7.result | wc -l`
\ No newline at end of file +test `grep -E '^-?[0123456789]+$' test7.result | wc -l` = `cat test7.result | wc -l` 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/testsignal.checker b/testsuite/tests/lib-threads/testsignal.checker index 2e8ef03a23..e7a5f0614a 100644 --- a/testsuite/tests/lib-threads/testsignal.checker +++ b/testsuite/tests/lib-threads/testsignal.checker @@ -1 +1 @@ -sed -e 1q testsignal.result | grep -q '^[ab]*Got ctrl-C, exiting...$' +sed -e 1q testsignal.result | grep -q '^[ab]*Got ctrl-C, exiting...$' diff --git a/testsuite/tests/lib-threads/testsignal.runner b/testsuite/tests/lib-threads/testsignal.runner index 897ef1733a..74c0d54df6 100644 --- a/testsuite/tests/lib-threads/testsignal.runner +++ b/testsuite/tests/lib-threads/testsignal.runner @@ -1,4 +1,4 @@ ./program > testsignal.result & pid=$! sleep 3 -kill -INT $pid
\ No newline at end of file +kill -INT $pid 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/lib-threads/torture.ml b/testsuite/tests/lib-threads/torture.ml index cfc5783334..02006a7a8f 100644 --- a/testsuite/tests/lib-threads/torture.ml +++ b/testsuite/tests/lib-threads/torture.ml @@ -9,9 +9,9 @@ let gc_thread () = let stdin_thread () = while true do - print_string "> "; flush stdout; + print_string ">"; flush stdout; let s = read_line() in - print_string ">>> "; print_string s; print_newline() + print_string " >>> "; print_string s; print_newline() done let writer_thread (oc, size) = diff --git a/testsuite/tests/lib-threads/torture.reference b/testsuite/tests/lib-threads/torture.reference index cd5f474fb6..f726cc4682 100644 --- a/testsuite/tests/lib-threads/torture.reference +++ b/testsuite/tests/lib-threads/torture.reference @@ -1,4 +1,4 @@ > >>> abc > >>> def > >>> ghi ->
\ No newline at end of file +>
\ No newline at end of file diff --git a/testsuite/tests/lib-threads/torture.runner b/testsuite/tests/lib-threads/torture.runner index f4ad597bff..12ceeb64ac 100644 --- a/testsuite/tests/lib-threads/torture.runner +++ b/testsuite/tests/lib-threads/torture.runner @@ -1 +1 @@ -./program < torture.data > torture.result 2> /dev/null || true
\ No newline at end of file +./program < torture.data > torture.result 2> /dev/null || true diff --git a/testsuite/tests/misc-kb/equations.ml b/testsuite/tests/misc-kb/equations.ml index 5617bc4f9d..1d905e015d 100644 --- a/testsuite/tests/misc-kb/equations.ml +++ b/testsuite/tests/misc-kb/equations.ml @@ -16,7 +16,7 @@ open Terms -type rule = +type rule = { number: int; numvars: int; lhs: term; @@ -53,7 +53,7 @@ let pretty_rule rule = let pretty_rules rules = List.iter pretty_rule rules - + (****************** Rewriting **************************) (* Top-level rewriting. Let eq:L=R be an equation, M be a term such that L<=M. @@ -112,4 +112,3 @@ let rec mrewrite_all rules m = mrewrite_all rules (mrewrite1 rules m) with Failure _ -> m - diff --git a/testsuite/tests/misc-kb/equations.mli b/testsuite/tests/misc-kb/equations.mli index 0db190b858..49b1a461e7 100644 --- a/testsuite/tests/misc-kb/equations.mli +++ b/testsuite/tests/misc-kb/equations.mli @@ -14,7 +14,7 @@ open Terms -type rule = +type rule = { number: int; numvars: int; lhs: term; diff --git a/testsuite/tests/misc-kb/kb.ml b/testsuite/tests/misc-kb/kb.ml index ff357b3ff8..5045a31881 100644 --- a/testsuite/tests/misc-kb/kb.ml +++ b/testsuite/tests/misc-kb/kb.ml @@ -37,7 +37,7 @@ let rec super m = function (* Ex : -let (m,_) = <<F(A,B)>> +let (m,_) = <<F(A,B)>> and (n,_) = <<H(F(A,x),F(x,y))>> in super m n ==> [[1],[2,Term ("B",[])]; x <- B [2],[2,Term ("A",[]); 1,Term ("B",[])]] x <- A y <- B @@ -109,7 +109,7 @@ let rec get_rule n = function (* Improved Knuth-Bendix completion procedure *) -let kb_completion greater = +let kb_completion greater = let rec kbrec j rules = let rec process failures (k,l) eqs = (**** @@ -165,7 +165,7 @@ let kb_completion greater = (strict_critical_pairs el (rename rl.numvars el)) else try - let rk = get_rule k rules in + let rk = get_rule k rules in let ek = (rk.lhs, rk.rhs) in process failures (k,l) (mutual_critical_pairs el (rename rl.numvars ek)) @@ -185,4 +185,3 @@ let kb_complete greater complete_rules rules = kb_completion greater n complete_rules [] (n,n) eqs in print_string "Canonical set found :"; print_newline(); pretty_rules (List.rev completed_rules) - diff --git a/testsuite/tests/misc-kb/kbmain.ml b/testsuite/tests/misc-kb/kbmain.ml index 580b715040..a0d4ff715b 100644 --- a/testsuite/tests/misc-kb/kbmain.ml +++ b/testsuite/tests/misc-kb/kbmain.ml @@ -72,11 +72,10 @@ let group_precedence op1 op2 = if r1 = r2 then Equal else if r1 > r2 then Greater else NotGE -let group_order = rpo group_precedence lex_ext +let group_order = rpo group_precedence lex_ext let greater pair = match group_order pair with Greater -> true | _ -> false let _ = for i = 1 to 20 do kb_complete greater [] geom_rules done - diff --git a/testsuite/tests/misc-kb/orderings.ml b/testsuite/tests/misc-kb/orderings.ml index c81746e309..6da73df8d7 100644 --- a/testsuite/tests/misc-kb/orderings.ml +++ b/testsuite/tests/misc-kb/orderings.ml @@ -16,7 +16,7 @@ open Terms -type ordering = +type ordering = Greater | Equal | NotGE @@ -65,10 +65,10 @@ let lex_ext order = function | ( _ , []) -> Greater | (x1::l1, x2::l2) -> match order (x1,x2) with - Greater -> if List.for_all (fun n' -> gt_ord order (m,n')) l2 + Greater -> if List.for_all (fun n' -> gt_ord order (m,n')) l2 then Greater else NotGE | Equal -> lexrec (l1,l2) - | NotGE -> if List.exists (fun m' -> ge_ord order (m',n)) l1 + | NotGE -> if List.exists (fun m' -> ge_ord order (m',n)) l1 then Greater else NotGE in lexrec (sons1, sons2) | _ -> failwith "lex_ext" @@ -76,9 +76,9 @@ let lex_ext order = function (* Recursive path ordering *) -let rpo op_order ext = +let rpo op_order ext = let rec rporec (m,n) = - if m = n then Equal else + if m = n then Equal else match m with Var vm -> NotGE | Term(op1,sons1) -> @@ -96,4 +96,3 @@ let rpo op_order ext = if List.exists (fun m' -> ge_ord rporec (m',n)) sons1 then Greater else NotGE in rporec - diff --git a/testsuite/tests/misc-kb/orderings.mli b/testsuite/tests/misc-kb/orderings.mli index bb44f0832d..d75c58a029 100644 --- a/testsuite/tests/misc-kb/orderings.mli +++ b/testsuite/tests/misc-kb/orderings.mli @@ -14,7 +14,7 @@ open Terms -type ordering = +type ordering = Greater | Equal | NotGE diff --git a/testsuite/tests/misc-kb/terms.ml b/testsuite/tests/misc-kb/terms.ml index 86604f9c5a..f7a1c3e7b7 100644 --- a/testsuite/tests/misc-kb/terms.ml +++ b/testsuite/tests/misc-kb/terms.ml @@ -14,7 +14,7 @@ (****************** Term manipulations *****************) -type term = +type term = Var of int | Term of string * term list @@ -22,7 +22,7 @@ let rec union l1 l2 = match l1 with [] -> l2 | a::r -> if List.mem a l2 then union r l2 else a :: union r l2 - + let rec vars = function Var n -> [n] @@ -73,7 +73,7 @@ let matching term1 term2 = (* A naive unification algorithm. *) -let compsubst subst1 subst2 = +let compsubst subst1 subst2 = (List.map (fun (v,t) -> (v, substitute subst1 t)) subst2) @ subst1 @@ -133,5 +133,3 @@ and pretty_close = function pretty_term m | m -> pretty_term m - - diff --git a/testsuite/tests/misc-kb/terms.mli b/testsuite/tests/misc-kb/terms.mli index 0f6be4c8e8..40c7710818 100644 --- a/testsuite/tests/misc-kb/terms.mli +++ b/testsuite/tests/misc-kb/terms.mli @@ -12,7 +12,7 @@ (* $Id$ *) -type term = +type term = Var of int | Term of string * term list diff --git a/testsuite/tests/misc-unsafe/almabench.ml b/testsuite/tests/misc-unsafe/almabench.ml index 73293e9ad9..e5cdf36c3b 100644 --- a/testsuite/tests/misc-unsafe/almabench.ml +++ b/testsuite/tests/misc-unsafe/almabench.ml @@ -16,7 +16,7 @@ * Longitudes, Paris, France), as detailed in Astronomy & Astrophysics * 282, 663 (1994) * - * Note that the code herein is design for the purpose of testing + * Note that the code herein is design for the purpose of testing * computational performance; error handling and other such "niceties" * is virtually non-existent. * @@ -68,7 +68,7 @@ and a = [| [| 19.2184460618; -3716e-10; 979e-10 |]; [| 30.1103868694; -16635e-10; 686e-10 |] |] -and dlm = +and dlm = [| [| 252.25090552; 5381016286.88982; -1.92789 |]; [| 181.97980085; 2106641364.33548; 0.59381 |]; [| 100.46645683; 1295977422.83429; -2.04411 |]; @@ -151,7 +151,7 @@ and sa = (* tables giving the trigonometric terms to be added to the mean elements of the mean longitudes . *) -and kq = +and kq = [| [| 3086.0; 15746.0; 69613.0; 59899.0; 75645.0; 88306.0; 12661.0; 2658.0; 0.0; 0.0 |]; [| 21863.0; 32794.0; 10931.0; 73.0; 4387.0; 26934.0; 1473.0; 2157.0; 0.0; 0.0 |]; [| 10.0; 16002.0; 21863.0; 10931.0; 1473.0; 32004.0; 4387.0; 73.0; 0.0; 0.0 |]; @@ -181,15 +181,15 @@ and sl = [| 71234.0;-41116.0; 5334.0;-4935.0;-1848.0; 66.0; 434.0;-1748.0; 3780.0; -701.0 |]; [| -47645.0; 11647.0; 2166.0; 3194.0; 679.0; 0.0; -244.0; -419.0; -2531.0; 48.0 |] |] - + (* Normalize angle into the range -pi <= A < +pi. *) let anpm a = let w = mod_float a twopi in if abs_float w >= pic then begin if a < 0.0 then - w +. twopi + w +. twopi else - w -. twopi + w -. twopi end else w @@ -204,10 +204,10 @@ let planetpv epoch np pv = and de = e.(np).(0) +. (e.(np).(1) +. e.(np).(2) *. t ) *. t and dp = anpm ((3600.0 *. pi.(np).(0) +. (pi.(np).(1) +. pi.(np).(2) *. t ) *. t ) *. a2r ) and di = (3600.0 *. dinc.(np).(0) +. (dinc.(np).(1) +. dinc.(np).(2) *. t ) *. t ) *. a2r - and doh = anpm ((3600.0 *. omega.(np).(0) +. (omega.(np).(1) +. omega.(np).(2) *. t ) *. t ) *. a2r ) - (* apply the trigonometric terms. *) + and doh = anpm ((3600.0 *. omega.(np).(0) +. (omega.(np).(1) +. omega.(np).(2) *. t ) *. t ) *. a2r ) + (* apply the trigonometric terms. *) and dmu = 0.35953620 *. t in - + (* loop invariant *) let kp = kp.(np) and kq = kq.(np) and ca = ca.(np) and sa = sa.(np) and cl = cl.(np) and sl = sl.(np) in @@ -231,20 +231,20 @@ let planetpv epoch np pv = (* iterative solution of kepler's equation to get eccentric anomaly. *) let am = !dl -. dp in let ae = ref (am +. de *. sin am) - and k = ref 0 in + and k = ref 0 in let dae = ref ((am -. !ae +. de *. sin !ae) /. (1.0 -. de *. cos !ae)) in ae := !ae +. !dae; incr k; while !k < 10 or abs_float !dae >= 1e-12 do - dae := (am -. !ae +. de *. sin !ae) /. (1.0 -. de *. cos !ae); - ae := !ae +. !dae; - incr k + dae := (am -. !ae +. de *. sin !ae) /. (1.0 -. de *. cos !ae); + ae := !ae +. !dae; + incr k done; - + (* true anomaly. *) let ae2 = !ae /. 2.0 in - let at = 2.0 *. atan2 (sqrt ((1.0 +. de) /. (1.0 -. de)) *. sin ae2) (cos ae2) - (* distance (au) and speed (radians per day). *) + let at = 2.0 *. atan2 (sqrt ((1.0 +. de) /. (1.0 -. de)) *. sin ae2) (cos ae2) + (* distance (au) and speed (radians per day). *) and r = !da *. (1.0 -. de *. cos !ae) and v = gaussk *. sqrt ((1.0 +. 1.0 /. amas.(np) ) /. (!da *. !da *. !da)) and si2 = sin (di /. 2.0) in @@ -253,7 +253,7 @@ let planetpv epoch np pv = and tl = at +. dp in let xsw = sin tl and xcw = cos tl in - let xm2 = 2.0 *. (xp *. xcw -. xq *. xsw ) + let xm2 = 2.0 *. (xp *. xcw -. xq *. xsw ) and xf = !da /. sqrt (1.0 -. de *. de) and ci2 = cos (di /. 2.0) in let xms = (de *. sin dp +. xsw) *. xf @@ -265,42 +265,42 @@ let planetpv epoch np pv = and y = r *. (xsw +. xm2 *. xq) and z = r *. (-.xm2 *. ci2) in - (* rotate to equatorial. *) - pv.(0).(0) <- x; - pv.(0).(1) <- y *. coseps -. z *. sineps; - pv.(0).(2) <- y *. sineps +. z *. coseps; + (* rotate to equatorial. *) + pv.(0).(0) <- x; + pv.(0).(1) <- y *. coseps -. z *. sineps; + pv.(0).(2) <- y *. sineps +. z *. coseps; - (* velocity (j2000 ecliptic xdot,ydot,zdot in au/d). *) - let x = v *. ((-1.0 +. 2.0 *. xp *. xp) *. xms +. xpxq2 *. xmc) - and y = v *. (( 1.0 -. 2.0 *. xq *. xq ) *. xmc -. xpxq2 *. xms) - and z = v *. (2.0 *. ci2 *. (xp *. xms +. xq *. xmc)) in + (* velocity (j2000 ecliptic xdot,ydot,zdot in au/d). *) + let x = v *. ((-1.0 +. 2.0 *. xp *. xp) *. xms +. xpxq2 *. xmc) + and y = v *. (( 1.0 -. 2.0 *. xq *. xq ) *. xmc -. xpxq2 *. xms) + and z = v *. (2.0 *. ci2 *. (xp *. xms +. xq *. xmc)) in - (* rotate to equatorial *) - pv.(1).(0) <- x; - pv.(1).(1) <- y *. coseps -. z *. sineps; - pv.(1).(2) <- y *. sineps +. z *. coseps + (* rotate to equatorial *) + pv.(1).(0) <- x; + pv.(1).(1) <- y *. coseps -. z *. sineps; + pv.(1).(2) <- y *. sineps +. z *. coseps -(* Computes RA, Declination, and distance from a state vector returned by +(* Computes RA, Declination, and distance from a state vector returned by * planetpv. *) let radecdist state rdd = (* Distance *) rdd.(2) <- sqrt (state.(0).(0) *. state.(0).(0) - +. state.(0).(1) *. state.(0).(1) - +. state.(0).(2) *. state.(0).(2)); + +. state.(0).(1) *. state.(0).(1) + +. state.(0).(2) *. state.(0).(2)); (* RA *) rdd.(0) <- atan2 state.(0).(1) state.(0).(0) *. r2h; if rdd.(0) < 0.0 then rdd.(0) <- rdd.(0) +. 24.0; - + (* Declination *) rdd.(1) <- asin (state.(0).(2) /. rdd.(2)) *. r2d - + (* Entry point. Calculate RA and Dec for noon on every day in 1900-2100 *) let _ = let jd = [| 0.0; 0.0 |] - and pv = [| [| 0.0; 0.0; 0.0 |]; [| 0.0; 0.0; 0.0 |] |] + and pv = [| [| 0.0; 0.0; 0.0 |]; [| 0.0; 0.0; 0.0 |] |] and position = [| 0.0; 0.0; 0.0 |] in (* Test *) jd.(0) <- j2000; @@ -317,8 +317,8 @@ let _ = for n = 0 to test_length - 1 do jd.(0) <- jd.(0) +. 1.0; for p = 0 to 7 do - planetpv jd p pv; - radecdist pv position; + planetpv jd p pv; + radecdist pv position; done done done diff --git a/testsuite/tests/misc-unsafe/fft.ml b/testsuite/tests/misc-unsafe/fft.ml index f0a2ed3289..d9668cb895 100644 --- a/testsuite/tests/misc-unsafe/fft.ml +++ b/testsuite/tests/misc-unsafe/fft.ml @@ -19,17 +19,17 @@ let tpi = 2.0 *. pi let fft px py np = let i = ref 2 in let m = ref 1 in - + while (!i < np) do - i := !i + !i; + i := !i + !i; m := !m + 1 done; - let n = !i in - + let n = !i in + if n <> np then begin for i = np+1 to n do - px.(i) <- 0.0; + px.(i) <- 0.0; py.(i) <- 0.0 done; print_string "Use "; print_int n; @@ -38,7 +38,7 @@ let fft px py np = let n2 = ref(n+n) in for k = 1 to !m-1 do - n2 := !n2 / 2; + n2 := !n2 / 2; let n4 = !n2 / 4 in let e = tpi /. float !n2 in @@ -51,7 +51,7 @@ let fft px py np = let ss3 = sin(a3) in let is = ref j in let id = ref(2 * !n2) in - + while !is < n do let i0r = ref !is in while !i0r < n do @@ -71,13 +71,13 @@ let fft px py np = let r1 = r1 +. s2 in let s2 = r2 -. s1 in let r2 = r2 +. s1 in - px.(i2) <- r1*.cc1 -. s2*.ss1; + px.(i2) <- r1*.cc1 -. s2*.ss1; py.(i2) <- -.s2*.cc1 -. r1*.ss1; px.(i3) <- s3*.cc3 +. r2*.ss3; py.(i3) <- r2*.cc3 -. s3*.ss3; i0r := i0 + !id done; - is := 2 * !id - !n2 + j; + is := 2 * !id - !n2 + j; id := 4 * !id done done @@ -89,7 +89,7 @@ let fft px py np = let is = ref 1 in let id = ref 4 in - + while !is < n do let i0r = ref !is in while !i0r <= n do @@ -103,7 +103,7 @@ let fft px py np = py.(i1) <- r1 -. py.(i1); i0r := i0 + !id done; - is := 2 * !id - 1; + is := 2 * !id - 1; id := 4 * !id done; @@ -112,11 +112,11 @@ let fft px py np = (*************************) let j = ref 1 in - + for i = 1 to n - 1 do if i < !j then begin let xt = px.(!j) in - px.(!j) <- px.(i); + px.(!j) <- px.(i); px.(i) <- xt; let xt = py.(!j) in py.(!j) <- py.(i); @@ -124,7 +124,7 @@ let fft px py np = end; let k = ref(n / 2) in while !k < !j do - j := !j - !k; + j := !j - !k; k := !k / 2 done; j := !j + !k @@ -170,12 +170,12 @@ let test np = for i = 0 to np-1 do let a = abs_float(pxr.(i+1) -. float i) in if !zr < a then begin - zr := a; + zr := a; kr := i end; let a = abs_float(pxi.(i+1)) in if !zi < a then begin - zi := a; + zi := a; ki := i end done; @@ -186,4 +186,3 @@ let test np = let _ = let np = ref 16 in for i = 1 to 16 do test !np; np := !np*2 done - diff --git a/testsuite/tests/misc/bdd.ml b/testsuite/tests/misc/bdd.ml index ddf99a7295..0d54bd808b 100644 --- a/testsuite/tests/misc/bdd.ml +++ b/testsuite/tests/misc/bdd.ml @@ -12,7 +12,7 @@ (* $Id$ *) -(* Translated to Caml by Xavier Leroy *) +(* Translated to OCaml by Xavier Leroy *) (* Original code written in SML by ... *) type bdd = One | Zero | Node of bdd * int * int * bdd @@ -24,8 +24,8 @@ let rec eval bdd vars = | Node(l, v, _, h) -> if vars.(v) then eval h vars else eval l vars -let getId bdd = - match bdd with +let getId bdd = + match bdd with Node(_,_,id,_) -> id | Zero -> 0 | One -> 1 @@ -42,10 +42,10 @@ let resize newSize = let newSz_1 = newSize-1 in let newArr = Array.create newSize [] in let rec copyBucket bucket = - match bucket with + match bucket with [] -> () - | n :: ns -> - match n with + | n :: ns -> + match n with | Node(l,v,_,h) -> let ind = hashVal (getId l) (getId h) v land newSz_1 in @@ -80,18 +80,18 @@ let resetUnique () = ( let mkNode low v high = let idl = getId low in - let idh = getId high + let idh = getId high in if idl = idh then low else let ind = hashVal idl idh v land (!sz_1) in let bucket = (!htab).(ind) in - let rec lookup b = - match b with + let rec lookup b = + match b with [] -> let n = Node(low, v, (incr nodeC; !nodeC), high) in insert (getId low) (getId high) v ind bucket n; n - | n :: ns -> + | n :: ns -> match n with | Node(l,v',id,h) -> if v = v' && idl = getId l && idh = getId h @@ -104,7 +104,7 @@ let mkNode low v high = type ordering = LESS | EQUAL | GREATER let cmpVar (x : int) (y : int) = - if x<y then LESS else if x>y then GREATER else EQUAL + if x<y then LESS else if x>y then GREATER else EQUAL let zero = Zero let one = One @@ -123,7 +123,7 @@ let notslot1 = Array.create cacheSize 0 let notslot2 = Array.create cacheSize one let hash x y = ((x lsl 1)+y) mod cacheSize -let rec not n = +let rec not n = match n with Zero -> One | One -> Zero @@ -134,9 +134,9 @@ match n with in notslot1.(h) <- id; notslot2.(h) <- f; f -let rec and2 n1 n2 = +let rec and2 n1 n2 = match n1 with - Node(l1, v1, i1, r1) + Node(l1, v1, i1, r1) -> (match n2 with Node(l2, v2, i2, r2) -> let h = hash i1 i2 @@ -147,8 +147,8 @@ match n1 with | LESS -> mkNode (and2 l1 n2) v1 (and2 r1 n2) | GREATER -> mkNode (and2 n1 l2) v2 (and2 n1 r2) in - andslot1.(h) <- i1; - andslot2.(h) <- i2; + andslot1.(h) <- i1; + andslot2.(h) <- i2; andslot3.(h) <- f; f | Zero -> Zero @@ -157,9 +157,9 @@ match n1 with | One -> n2 -let rec xor n1 n2 = +let rec xor n1 n2 = match n1 with - Node(l1, v1, i1, r1) + Node(l1, v1, i1, r1) -> (match n2 with Node(l2, v2, i2, r2) -> let h = hash i1 i2 @@ -174,19 +174,19 @@ match n1 with andslot2.(h) <- i2; andslot3.(h) <- f; f - | Zero -> n1 + | Zero -> n1 | One -> not n1) | Zero -> n2 | One -> not n2 -let hwb n = +let hwb n = let rec h i j = if i=j then mkVar i else xor (and2 (not(mkVar j)) (h i (j-1))) (and2 (mkVar j) (g i (j-1))) and g i j = if i=j then mkVar i - else xor (and2 (not(mkVar i)) (h (i+1) j)) + else xor (and2 (not(mkVar i)) (h (i+1) j)) (and2 (mkVar i) (g (i+1) j)) in h 0 (n-1) diff --git a/testsuite/tests/misc/boyer.ml b/testsuite/tests/misc/boyer.ml index 4f4e081300..57912d1bdd 100644 --- a/testsuite/tests/misc/boyer.ml +++ b/testsuite/tests/misc/boyer.ml @@ -29,7 +29,7 @@ let rec print_term = function print_string head.name; List.iter (fun t -> print_string " "; print_term t) argl; print_string ")" - + let lemmas = ref ([] : head list) (* Replacement for property lists *) @@ -120,13 +120,13 @@ let add t = add_lemma (cterm_to_term t) let _ = add (CProp ("equal", - [CProp ("compile",[CVar 5]); + [CProp ("compile",[CVar 5]); CProp ("reverse", [CProp ("codegen",[CProp ("optimize",[CVar 5]); CProp ("nil",[])])])])); add (CProp ("equal", - [CProp ("eqp",[CVar 23; CVar 24]); + [CProp ("eqp",[CVar 23; CVar 24]); CProp ("equal",[CProp ("fix",[CVar 23]); CProp ("fix",[CVar 24])])])); add (CProp ("equal", @@ -139,120 +139,120 @@ add (CProp [CProp ("ge",[CVar 23; CVar 24]); CProp ("le",[CVar 24; CVar 23])])); add (CProp ("equal", - [CProp ("boolean",[CVar 23]); + [CProp ("boolean",[CVar 23]); CProp ("or", - [CProp ("equal",[CVar 23; CProp ("true",[])]); + [CProp ("equal",[CVar 23; CProp ("true",[])]); CProp ("equal",[CVar 23; CProp ("false",[])])])])); add (CProp ("equal", - [CProp ("iff",[CVar 23; CVar 24]); + [CProp ("iff",[CVar 23; CVar 24]); CProp ("and", - [CProp ("implies",[CVar 23; CVar 24]); + [CProp ("implies",[CVar 23; CVar 24]); CProp ("implies",[CVar 24; CVar 23])])])); add (CProp ("equal", - [CProp ("even1",[CVar 23]); + [CProp ("even1",[CVar 23]); CProp ("if", - [CProp ("zerop",[CVar 23]); CProp ("true",[]); + [CProp ("zerop",[CVar 23]); CProp ("true",[]); CProp ("odd",[CProp ("sub1",[CVar 23])])])])); add (CProp ("equal", - [CProp ("countps_",[CVar 11; CVar 15]); + [CProp ("countps_",[CVar 11; CVar 15]); CProp ("countps_loop",[CVar 11; CVar 15; CProp ("zero",[])])])); add (CProp ("equal", - [CProp ("fact_",[CVar 8]); + [CProp ("fact_",[CVar 8]); CProp ("fact_loop",[CVar 8; CProp ("one",[])])])); add (CProp ("equal", - [CProp ("reverse_",[CVar 23]); + [CProp ("reverse_",[CVar 23]); CProp ("reverse_loop",[CVar 23; CProp ("nil",[])])])); add (CProp ("equal", - [CProp ("divides",[CVar 23; CVar 24]); + [CProp ("divides",[CVar 23; CVar 24]); CProp ("zerop",[CProp ("remainder",[CVar 24; CVar 23])])])); add (CProp ("equal", - [CProp ("assume_true",[CVar 21; CVar 0]); + [CProp ("assume_true",[CVar 21; CVar 0]); CProp ("cons",[CProp ("cons",[CVar 21; CProp ("true",[])]); CVar 0])])); add (CProp ("equal", - [CProp ("assume_false",[CVar 21; CVar 0]); + [CProp ("assume_false",[CVar 21; CVar 0]); CProp ("cons",[CProp ("cons",[CVar 21; CProp ("false",[])]); CVar 0])])); add (CProp ("equal", - [CProp ("tautology_checker",[CVar 23]); + [CProp ("tautology_checker",[CVar 23]); CProp ("tautologyp",[CProp ("normalize",[CVar 23]); CProp ("nil",[])])])); add (CProp ("equal", - [CProp ("falsify",[CVar 23]); + [CProp ("falsify",[CVar 23]); CProp ("falsify1",[CProp ("normalize",[CVar 23]); CProp ("nil",[])])])); add (CProp ("equal", - [CProp ("prime",[CVar 23]); + [CProp ("prime",[CVar 23]); CProp ("and", - [CProp ("not",[CProp ("zerop",[CVar 23])]); + [CProp ("not",[CProp ("zerop",[CVar 23])]); CProp ("not", - [CProp ("equal",[CVar 23; CProp ("add1",[CProp ("zero",[])])])]); + [CProp ("equal",[CVar 23; CProp ("add1",[CProp ("zero",[])])])]); CProp ("prime1",[CVar 23; CProp ("sub1",[CVar 23])])])])); add (CProp ("equal", - [CProp ("and",[CVar 15; CVar 16]); + [CProp ("and",[CVar 15; CVar 16]); CProp ("if", - [CVar 15; - CProp ("if",[CVar 16; CProp ("true",[]); CProp ("false",[])]); + [CVar 15; + CProp ("if",[CVar 16; CProp ("true",[]); CProp ("false",[])]); CProp ("false",[])])])); add (CProp ("equal", - [CProp ("or",[CVar 15; CVar 16]); + [CProp ("or",[CVar 15; CVar 16]); CProp ("if", - [CVar 15; CProp ("true",[]); - CProp ("if",[CVar 16; CProp ("true",[]); CProp ("false",[])]); + [CVar 15; CProp ("true",[]); + CProp ("if",[CVar 16; CProp ("true",[]); CProp ("false",[])]); CProp ("false",[])])])); add (CProp ("equal", - [CProp ("not",[CVar 15]); + [CProp ("not",[CVar 15]); CProp ("if",[CVar 15; CProp ("false",[]); CProp ("true",[])])])); add (CProp ("equal", - [CProp ("implies",[CVar 15; CVar 16]); + [CProp ("implies",[CVar 15; CVar 16]); CProp ("if", - [CVar 15; - CProp ("if",[CVar 16; CProp ("true",[]); CProp ("false",[])]); + [CVar 15; + CProp ("if",[CVar 16; CProp ("true",[]); CProp ("false",[])]); CProp ("true",[])])])); add (CProp ("equal", - [CProp ("fix",[CVar 23]); + [CProp ("fix",[CVar 23]); CProp ("if",[CProp ("numberp",[CVar 23]); CVar 23; CProp ("zero",[])])])); add (CProp ("equal", - [CProp ("if",[CProp ("if",[CVar 0; CVar 1; CVar 2]); CVar 3; CVar 4]); + [CProp ("if",[CProp ("if",[CVar 0; CVar 1; CVar 2]); CVar 3; CVar 4]); CProp ("if", - [CVar 0; CProp ("if",[CVar 1; CVar 3; CVar 4]); + [CVar 0; CProp ("if",[CVar 1; CVar 3; CVar 4]); CProp ("if",[CVar 2; CVar 3; CVar 4])])])); add (CProp ("equal", - [CProp ("zerop",[CVar 23]); + [CProp ("zerop",[CVar 23]); CProp ("or", - [CProp ("equal",[CVar 23; CProp ("zero",[])]); + [CProp ("equal",[CVar 23; CProp ("zero",[])]); CProp ("not",[CProp ("numberp",[CVar 23])])])])); add (CProp ("equal", - [CProp ("plus",[CProp ("plus",[CVar 23; CVar 24]); CVar 25]); + [CProp ("plus",[CProp ("plus",[CVar 23; CVar 24]); CVar 25]); CProp ("plus",[CVar 23; CProp ("plus",[CVar 24; CVar 25])])])); add (CProp ("equal", - [CProp ("equal",[CProp ("plus",[CVar 0; CVar 1]); CProp ("zero",[])]); + [CProp ("equal",[CProp ("plus",[CVar 0; CVar 1]); CProp ("zero",[])]); CProp ("and",[CProp ("zerop",[CVar 0]); CProp ("zerop",[CVar 1])])])); add (CProp ("equal",[CProp ("difference",[CVar 23; CVar 23]); CProp ("zero",[])])); @@ -260,90 +260,90 @@ add (CProp ("equal", [CProp ("equal", - [CProp ("plus",[CVar 0; CVar 1]); CProp ("plus",[CVar 0; CVar 2])]); + [CProp ("plus",[CVar 0; CVar 1]); CProp ("plus",[CVar 0; CVar 2])]); CProp ("equal",[CProp ("fix",[CVar 1]); CProp ("fix",[CVar 2])])])); add (CProp ("equal", [CProp - ("equal",[CProp ("zero",[]); CProp ("difference",[CVar 23; CVar 24])]); + ("equal",[CProp ("zero",[]); CProp ("difference",[CVar 23; CVar 24])]); CProp ("not",[CProp ("gt",[CVar 24; CVar 23])])])); add (CProp ("equal", - [CProp ("equal",[CVar 23; CProp ("difference",[CVar 23; CVar 24])]); + [CProp ("equal",[CVar 23; CProp ("difference",[CVar 23; CVar 24])]); CProp ("and", - [CProp ("numberp",[CVar 23]); + [CProp ("numberp",[CVar 23]); CProp ("or", - [CProp ("equal",[CVar 23; CProp ("zero",[])]); + [CProp ("equal",[CVar 23; CProp ("zero",[])]); CProp ("zerop",[CVar 24])])])])); add (CProp ("equal", [CProp ("meaning", - [CProp ("plus_tree",[CProp ("append",[CVar 23; CVar 24])]); CVar 0]); + [CProp ("plus_tree",[CProp ("append",[CVar 23; CVar 24])]); CVar 0]); CProp ("plus", - [CProp ("meaning",[CProp ("plus_tree",[CVar 23]); CVar 0]); + [CProp ("meaning",[CProp ("plus_tree",[CVar 23]); CVar 0]); CProp ("meaning",[CProp ("plus_tree",[CVar 24]); CVar 0])])])); add (CProp ("equal", [CProp ("meaning", - [CProp ("plus_tree",[CProp ("plus_fringe",[CVar 23])]); CVar 0]); + [CProp ("plus_tree",[CProp ("plus_fringe",[CVar 23])]); CVar 0]); CProp ("fix",[CProp ("meaning",[CVar 23; CVar 0])])])); add (CProp ("equal", - [CProp ("append",[CProp ("append",[CVar 23; CVar 24]); CVar 25]); + [CProp ("append",[CProp ("append",[CVar 23; CVar 24]); CVar 25]); CProp ("append",[CVar 23; CProp ("append",[CVar 24; CVar 25])])])); add (CProp ("equal", - [CProp ("reverse",[CProp ("append",[CVar 0; CVar 1])]); + [CProp ("reverse",[CProp ("append",[CVar 0; CVar 1])]); CProp ("append",[CProp ("reverse",[CVar 1]); CProp ("reverse",[CVar 0])])])); add (CProp ("equal", - [CProp ("times",[CVar 23; CProp ("plus",[CVar 24; CVar 25])]); + [CProp ("times",[CVar 23; CProp ("plus",[CVar 24; CVar 25])]); CProp ("plus", - [CProp ("times",[CVar 23; CVar 24]); + [CProp ("times",[CVar 23; CVar 24]); CProp ("times",[CVar 23; CVar 25])])])); add (CProp ("equal", - [CProp ("times",[CProp ("times",[CVar 23; CVar 24]); CVar 25]); + [CProp ("times",[CProp ("times",[CVar 23; CVar 24]); CVar 25]); CProp ("times",[CVar 23; CProp ("times",[CVar 24; CVar 25])])])); add (CProp ("equal", [CProp - ("equal",[CProp ("times",[CVar 23; CVar 24]); CProp ("zero",[])]); + ("equal",[CProp ("times",[CVar 23; CVar 24]); CProp ("zero",[])]); CProp ("or",[CProp ("zerop",[CVar 23]); CProp ("zerop",[CVar 24])])])); add (CProp ("equal", - [CProp ("exec",[CProp ("append",[CVar 23; CVar 24]); CVar 15; CVar 4]); + [CProp ("exec",[CProp ("append",[CVar 23; CVar 24]); CVar 15; CVar 4]); CProp ("exec",[CVar 24; CProp ("exec",[CVar 23; CVar 15; CVar 4]); CVar 4])])); add (CProp ("equal", - [CProp ("mc_flatten",[CVar 23; CVar 24]); + [CProp ("mc_flatten",[CVar 23; CVar 24]); CProp ("append",[CProp ("flatten",[CVar 23]); CVar 24])])); add (CProp ("equal", - [CProp ("member",[CVar 23; CProp ("append",[CVar 0; CVar 1])]); + [CProp ("member",[CVar 23; CProp ("append",[CVar 0; CVar 1])]); CProp ("or", - [CProp ("member",[CVar 23; CVar 0]); + [CProp ("member",[CVar 23; CVar 0]); CProp ("member",[CVar 23; CVar 1])])])); add (CProp ("equal", - [CProp ("member",[CVar 23; CProp ("reverse",[CVar 24])]); + [CProp ("member",[CVar 23; CProp ("reverse",[CVar 24])]); CProp ("member",[CVar 23; CVar 24])])); add (CProp ("equal", - [CProp ("length",[CProp ("reverse",[CVar 23])]); + [CProp ("length",[CProp ("reverse",[CVar 23])]); CProp ("length",[CVar 23])])); add (CProp ("equal", - [CProp ("member",[CVar 0; CProp ("intersect",[CVar 1; CVar 2])]); + [CProp ("member",[CVar 0; CProp ("intersect",[CVar 1; CVar 2])]); CProp ("and", [CProp ("member",[CVar 0; CVar 1]); CProp ("member",[CVar 0; CVar 2])])])); @@ -351,89 +351,89 @@ add (CProp ("equal",[CProp ("nth",[CProp ("zero",[]); CVar 8]); CProp ("zero",[])])); add (CProp ("equal", - [CProp ("exp",[CVar 8; CProp ("plus",[CVar 9; CVar 10])]); + [CProp ("exp",[CVar 8; CProp ("plus",[CVar 9; CVar 10])]); CProp ("times", [CProp ("exp",[CVar 8; CVar 9]); CProp ("exp",[CVar 8; CVar 10])])])); add (CProp ("equal", - [CProp ("exp",[CVar 8; CProp ("times",[CVar 9; CVar 10])]); + [CProp ("exp",[CVar 8; CProp ("times",[CVar 9; CVar 10])]); CProp ("exp",[CProp ("exp",[CVar 8; CVar 9]); CVar 10])])); add (CProp ("equal", - [CProp ("reverse_loop",[CVar 23; CVar 24]); + [CProp ("reverse_loop",[CVar 23; CVar 24]); CProp ("append",[CProp ("reverse",[CVar 23]); CVar 24])])); add (CProp ("equal", - [CProp ("reverse_loop",[CVar 23; CProp ("nil",[])]); + [CProp ("reverse_loop",[CVar 23; CProp ("nil",[])]); CProp ("reverse",[CVar 23])])); add (CProp ("equal", - [CProp ("count_list",[CVar 25; CProp ("sort_lp",[CVar 23; CVar 24])]); + [CProp ("count_list",[CVar 25; CProp ("sort_lp",[CVar 23; CVar 24])]); CProp ("plus", - [CProp ("count_list",[CVar 25; CVar 23]); + [CProp ("count_list",[CVar 25; CVar 23]); CProp ("count_list",[CVar 25; CVar 24])])])); add (CProp ("equal", [CProp ("equal", - [CProp ("append",[CVar 0; CVar 1]); CProp ("append",[CVar 0; CVar 2])]); + [CProp ("append",[CVar 0; CVar 1]); CProp ("append",[CVar 0; CVar 2])]); CProp ("equal",[CVar 1; CVar 2])])); add (CProp ("equal", [CProp ("plus", - [CProp ("remainder",[CVar 23; CVar 24]); - CProp ("times",[CVar 24; CProp ("quotient",[CVar 23; CVar 24])])]); + [CProp ("remainder",[CVar 23; CVar 24]); + CProp ("times",[CVar 24; CProp ("quotient",[CVar 23; CVar 24])])]); CProp ("fix",[CVar 23])])); add (CProp ("equal", [CProp - ("power_eval",[CProp ("big_plus",[CVar 11; CVar 8; CVar 1]); CVar 1]); + ("power_eval",[CProp ("big_plus",[CVar 11; CVar 8; CVar 1]); CVar 1]); CProp ("plus",[CProp ("power_eval",[CVar 11; CVar 1]); CVar 8])])); add (CProp ("equal", [CProp ("power_eval", - [CProp ("big_plus",[CVar 23; CVar 24; CVar 8; CVar 1]); CVar 1]); + [CProp ("big_plus",[CVar 23; CVar 24; CVar 8; CVar 1]); CVar 1]); CProp ("plus", - [CVar 8; + [CVar 8; CProp ("plus", - [CProp ("power_eval",[CVar 23; CVar 1]); + [CProp ("power_eval",[CVar 23; CVar 1]); CProp ("power_eval",[CVar 24; CVar 1])])])])); add (CProp ("equal", [CProp ("remainder",[CVar 24; CProp ("one",[])]); CProp ("zero",[])])); add (CProp ("equal", - [CProp ("lt",[CProp ("remainder",[CVar 23; CVar 24]); CVar 24]); + [CProp ("lt",[CProp ("remainder",[CVar 23; CVar 24]); CVar 24]); CProp ("not",[CProp ("zerop",[CVar 24])])])); add (CProp ("equal",[CProp ("remainder",[CVar 23; CVar 23]); CProp ("zero",[])])); add (CProp ("equal", - [CProp ("lt",[CProp ("quotient",[CVar 8; CVar 9]); CVar 8]); + [CProp ("lt",[CProp ("quotient",[CVar 8; CVar 9]); CVar 8]); CProp ("and", - [CProp ("not",[CProp ("zerop",[CVar 8])]); + [CProp ("not",[CProp ("zerop",[CVar 8])]); CProp ("or", - [CProp ("zerop",[CVar 9]); + [CProp ("zerop",[CVar 9]); CProp ("not",[CProp ("equal",[CVar 9; CProp ("one",[])])])])])])); add (CProp ("equal", - [CProp ("lt",[CProp ("remainder",[CVar 23; CVar 24]); CVar 23]); + [CProp ("lt",[CProp ("remainder",[CVar 23; CVar 24]); CVar 23]); CProp ("and", - [CProp ("not",[CProp ("zerop",[CVar 24])]); - CProp ("not",[CProp ("zerop",[CVar 23])]); + [CProp ("not",[CProp ("zerop",[CVar 24])]); + CProp ("not",[CProp ("zerop",[CVar 23])]); CProp ("not",[CProp ("lt",[CVar 23; CVar 24])])])])); add (CProp ("equal", - [CProp ("power_eval",[CProp ("power_rep",[CVar 8; CVar 1]); CVar 1]); + [CProp ("power_eval",[CProp ("power_rep",[CVar 8; CVar 1]); CVar 1]); CProp ("fix",[CVar 8])])); add (CProp ("equal", @@ -441,199 +441,199 @@ add (CProp ("power_eval", [CProp ("big_plus", - [CProp ("power_rep",[CVar 8; CVar 1]); - CProp ("power_rep",[CVar 9; CVar 1]); CProp ("zero",[]); - CVar 1]); - CVar 1]); + [CProp ("power_rep",[CVar 8; CVar 1]); + CProp ("power_rep",[CVar 9; CVar 1]); CProp ("zero",[]); + CVar 1]); + CVar 1]); CProp ("plus",[CVar 8; CVar 9])])); add (CProp ("equal", [CProp ("gcd",[CVar 23; CVar 24]); CProp ("gcd",[CVar 24; CVar 23])])); add (CProp ("equal", - [CProp ("nth",[CProp ("append",[CVar 0; CVar 1]); CVar 8]); + [CProp ("nth",[CProp ("append",[CVar 0; CVar 1]); CVar 8]); CProp ("append", - [CProp ("nth",[CVar 0; CVar 8]); + [CProp ("nth",[CVar 0; CVar 8]); CProp ("nth", [CVar 1; CProp ("difference",[CVar 8; CProp ("length",[CVar 0])])])])])); add (CProp ("equal", - [CProp ("difference",[CProp ("plus",[CVar 23; CVar 24]); CVar 23]); + [CProp ("difference",[CProp ("plus",[CVar 23; CVar 24]); CVar 23]); CProp ("fix",[CVar 24])])); add (CProp ("equal", - [CProp ("difference",[CProp ("plus",[CVar 24; CVar 23]); CVar 23]); + [CProp ("difference",[CProp ("plus",[CVar 24; CVar 23]); CVar 23]); CProp ("fix",[CVar 24])])); add (CProp ("equal", [CProp ("difference", - [CProp ("plus",[CVar 23; CVar 24]); CProp ("plus",[CVar 23; CVar 25])]); + [CProp ("plus",[CVar 23; CVar 24]); CProp ("plus",[CVar 23; CVar 25])]); CProp ("difference",[CVar 24; CVar 25])])); add (CProp ("equal", - [CProp ("times",[CVar 23; CProp ("difference",[CVar 2; CVar 22])]); + [CProp ("times",[CVar 23; CProp ("difference",[CVar 2; CVar 22])]); CProp ("difference", - [CProp ("times",[CVar 2; CVar 23]); + [CProp ("times",[CVar 2; CVar 23]); CProp ("times",[CVar 22; CVar 23])])])); add (CProp ("equal", - [CProp ("remainder",[CProp ("times",[CVar 23; CVar 25]); CVar 25]); + [CProp ("remainder",[CProp ("times",[CVar 23; CVar 25]); CVar 25]); CProp ("zero",[])])); add (CProp ("equal", [CProp ("difference", - [CProp ("plus",[CVar 1; CProp ("plus",[CVar 0; CVar 2])]); CVar 0]); + [CProp ("plus",[CVar 1; CProp ("plus",[CVar 0; CVar 2])]); CVar 0]); CProp ("plus",[CVar 1; CVar 2])])); add (CProp ("equal", [CProp ("difference", - [CProp ("add1",[CProp ("plus",[CVar 24; CVar 25])]); CVar 25]); + [CProp ("add1",[CProp ("plus",[CVar 24; CVar 25])]); CVar 25]); CProp ("add1",[CVar 24])])); add (CProp ("equal", [CProp ("lt", - [CProp ("plus",[CVar 23; CVar 24]); CProp ("plus",[CVar 23; CVar 25])]); + [CProp ("plus",[CVar 23; CVar 24]); CProp ("plus",[CVar 23; CVar 25])]); CProp ("lt",[CVar 24; CVar 25])])); add (CProp ("equal", [CProp ("lt", - [CProp ("times",[CVar 23; CVar 25]); - CProp ("times",[CVar 24; CVar 25])]); + [CProp ("times",[CVar 23; CVar 25]); + CProp ("times",[CVar 24; CVar 25])]); CProp ("and", - [CProp ("not",[CProp ("zerop",[CVar 25])]); + [CProp ("not",[CProp ("zerop",[CVar 25])]); CProp ("lt",[CVar 23; CVar 24])])])); add (CProp ("equal", - [CProp ("lt",[CVar 24; CProp ("plus",[CVar 23; CVar 24])]); + [CProp ("lt",[CVar 24; CProp ("plus",[CVar 23; CVar 24])]); CProp ("not",[CProp ("zerop",[CVar 23])])])); add (CProp ("equal", [CProp ("gcd", - [CProp ("times",[CVar 23; CVar 25]); - CProp ("times",[CVar 24; CVar 25])]); + [CProp ("times",[CVar 23; CVar 25]); + CProp ("times",[CVar 24; CVar 25])]); CProp ("times",[CVar 25; CProp ("gcd",[CVar 23; CVar 24])])])); add (CProp ("equal", - [CProp ("value",[CProp ("normalize",[CVar 23]); CVar 0]); + [CProp ("value",[CProp ("normalize",[CVar 23]); CVar 0]); CProp ("value",[CVar 23; CVar 0])])); add (CProp ("equal", [CProp ("equal", - [CProp ("flatten",[CVar 23]); - CProp ("cons",[CVar 24; CProp ("nil",[])])]); + [CProp ("flatten",[CVar 23]); + CProp ("cons",[CVar 24; CProp ("nil",[])])]); CProp ("and", [CProp ("nlistp",[CVar 23]); CProp ("equal",[CVar 23; CVar 24])])])); add (CProp ("equal", - [CProp ("listp",[CProp ("gother",[CVar 23])]); + [CProp ("listp",[CProp ("gother",[CVar 23])]); CProp ("listp",[CVar 23])])); add (CProp ("equal", - [CProp ("samefringe",[CVar 23; CVar 24]); + [CProp ("samefringe",[CVar 23; CVar 24]); CProp ("equal",[CProp ("flatten",[CVar 23]); CProp ("flatten",[CVar 24])])])); add (CProp ("equal", [CProp ("equal", - [CProp ("greatest_factor",[CVar 23; CVar 24]); CProp ("zero",[])]); + [CProp ("greatest_factor",[CVar 23; CVar 24]); CProp ("zero",[])]); CProp ("and", [CProp ("or", - [CProp ("zerop",[CVar 24]); - CProp ("equal",[CVar 24; CProp ("one",[])])]); + [CProp ("zerop",[CVar 24]); + CProp ("equal",[CVar 24; CProp ("one",[])])]); CProp ("equal",[CVar 23; CProp ("zero",[])])])])); add (CProp ("equal", [CProp ("equal", - [CProp ("greatest_factor",[CVar 23; CVar 24]); CProp ("one",[])]); + [CProp ("greatest_factor",[CVar 23; CVar 24]); CProp ("one",[])]); CProp ("equal",[CVar 23; CProp ("one",[])])])); add (CProp ("equal", - [CProp ("numberp",[CProp ("greatest_factor",[CVar 23; CVar 24])]); + [CProp ("numberp",[CProp ("greatest_factor",[CVar 23; CVar 24])]); CProp ("not", [CProp ("and", [CProp ("or", - [CProp ("zerop",[CVar 24]); - CProp ("equal",[CVar 24; CProp ("one",[])])]); + [CProp ("zerop",[CVar 24]); + CProp ("equal",[CVar 24; CProp ("one",[])])]); CProp ("not",[CProp ("numberp",[CVar 23])])])])])); add (CProp ("equal", - [CProp ("times_list",[CProp ("append",[CVar 23; CVar 24])]); + [CProp ("times_list",[CProp ("append",[CVar 23; CVar 24])]); CProp ("times", [CProp ("times_list",[CVar 23]); CProp ("times_list",[CVar 24])])])); add (CProp ("equal", - [CProp ("prime_list",[CProp ("append",[CVar 23; CVar 24])]); + [CProp ("prime_list",[CProp ("append",[CVar 23; CVar 24])]); CProp ("and", [CProp ("prime_list",[CVar 23]); CProp ("prime_list",[CVar 24])])])); add (CProp ("equal", - [CProp ("equal",[CVar 25; CProp ("times",[CVar 22; CVar 25])]); + [CProp ("equal",[CVar 25; CProp ("times",[CVar 22; CVar 25])]); CProp ("and", - [CProp ("numberp",[CVar 25]); + [CProp ("numberp",[CVar 25]); CProp ("or", - [CProp ("equal",[CVar 25; CProp ("zero",[])]); + [CProp ("equal",[CVar 25; CProp ("zero",[])]); CProp ("equal",[CVar 22; CProp ("one",[])])])])])); add (CProp ("equal", - [CProp ("ge",[CVar 23; CVar 24]); + [CProp ("ge",[CVar 23; CVar 24]); CProp ("not",[CProp ("lt",[CVar 23; CVar 24])])])); add (CProp ("equal", - [CProp ("equal",[CVar 23; CProp ("times",[CVar 23; CVar 24])]); + [CProp ("equal",[CVar 23; CProp ("times",[CVar 23; CVar 24])]); CProp ("or", - [CProp ("equal",[CVar 23; CProp ("zero",[])]); + [CProp ("equal",[CVar 23; CProp ("zero",[])]); CProp ("and", - [CProp ("numberp",[CVar 23]); + [CProp ("numberp",[CVar 23]); CProp ("equal",[CVar 24; CProp ("one",[])])])])])); add (CProp ("equal", - [CProp ("remainder",[CProp ("times",[CVar 24; CVar 23]); CVar 24]); + [CProp ("remainder",[CProp ("times",[CVar 24; CVar 23]); CVar 24]); CProp ("zero",[])])); add (CProp ("equal", - [CProp ("equal",[CProp ("times",[CVar 0; CVar 1]); CProp ("one",[])]); + [CProp ("equal",[CProp ("times",[CVar 0; CVar 1]); CProp ("one",[])]); CProp ("and", - [CProp ("not",[CProp ("equal",[CVar 0; CProp ("zero",[])])]); - CProp ("not",[CProp ("equal",[CVar 1; CProp ("zero",[])])]); - CProp ("numberp",[CVar 0]); CProp ("numberp",[CVar 1]); - CProp ("equal",[CProp ("sub1",[CVar 0]); CProp ("zero",[])]); + [CProp ("not",[CProp ("equal",[CVar 0; CProp ("zero",[])])]); + CProp ("not",[CProp ("equal",[CVar 1; CProp ("zero",[])])]); + CProp ("numberp",[CVar 0]); CProp ("numberp",[CVar 1]); + CProp ("equal",[CProp ("sub1",[CVar 0]); CProp ("zero",[])]); CProp ("equal",[CProp ("sub1",[CVar 1]); CProp ("zero",[])])])])); add (CProp ("equal", [CProp ("lt", - [CProp ("length",[CProp ("delete",[CVar 23; CVar 11])]); - CProp ("length",[CVar 11])]); + [CProp ("length",[CProp ("delete",[CVar 23; CVar 11])]); + CProp ("length",[CVar 11])]); CProp ("member",[CVar 23; CVar 11])])); add (CProp ("equal", - [CProp ("sort2",[CProp ("delete",[CVar 23; CVar 11])]); + [CProp ("sort2",[CProp ("delete",[CVar 23; CVar 11])]); CProp ("delete",[CVar 23; CProp ("sort2",[CVar 11])])])); add (CProp ("equal",[CProp ("dsort",[CVar 23]); CProp ("sort2",[CVar 23])])); add (CProp @@ -642,145 +642,145 @@ add (CProp ("length", [CProp ("cons", - [CVar 0; + [CVar 0; CProp ("cons", - [CVar 1; + [CVar 1; CProp ("cons", - [CVar 2; + [CVar 2; CProp ("cons", - [CVar 3; + [CVar 3; CProp ("cons",[CVar 4; CProp ("cons",[CVar 5; CVar 6])])])])])])]) ; CProp ("plus",[CProp ("six",[]); CProp ("length",[CVar 6])])])); add (CProp ("equal", [CProp ("difference", - [CProp ("add1",[CProp ("add1",[CVar 23])]); CProp ("two",[])]); + [CProp ("add1",[CProp ("add1",[CVar 23])]); CProp ("two",[])]); CProp ("fix",[CVar 23])])); add (CProp ("equal", [CProp ("quotient", - [CProp ("plus",[CVar 23; CProp ("plus",[CVar 23; CVar 24])]); - CProp ("two",[])]); + [CProp ("plus",[CVar 23; CProp ("plus",[CVar 23; CVar 24])]); + CProp ("two",[])]); CProp ("plus",[CVar 23; CProp ("quotient",[CVar 24; CProp ("two",[])])])])); add (CProp ("equal", - [CProp ("sigma",[CProp ("zero",[]); CVar 8]); + [CProp ("sigma",[CProp ("zero",[]); CVar 8]); CProp ("quotient", [CProp ("times",[CVar 8; CProp ("add1",[CVar 8])]); CProp ("two",[])])])); add (CProp ("equal", - [CProp ("plus",[CVar 23; CProp ("add1",[CVar 24])]); + [CProp ("plus",[CVar 23; CProp ("add1",[CVar 24])]); CProp ("if", - [CProp ("numberp",[CVar 24]); - CProp ("add1",[CProp ("plus",[CVar 23; CVar 24])]); + [CProp ("numberp",[CVar 24]); + CProp ("add1",[CProp ("plus",[CVar 23; CVar 24])]); CProp ("add1",[CVar 23])])])); add (CProp ("equal", [CProp ("equal", - [CProp ("difference",[CVar 23; CVar 24]); - CProp ("difference",[CVar 25; CVar 24])]); + [CProp ("difference",[CVar 23; CVar 24]); + CProp ("difference",[CVar 25; CVar 24])]); CProp ("if", - [CProp ("lt",[CVar 23; CVar 24]); - CProp ("not",[CProp ("lt",[CVar 24; CVar 25])]); + [CProp ("lt",[CVar 23; CVar 24]); + CProp ("not",[CProp ("lt",[CVar 24; CVar 25])]); CProp ("if", - [CProp ("lt",[CVar 25; CVar 24]); - CProp ("not",[CProp ("lt",[CVar 24; CVar 23])]); + [CProp ("lt",[CVar 25; CVar 24]); + CProp ("not",[CProp ("lt",[CVar 24; CVar 23])]); CProp ("equal",[CProp ("fix",[CVar 23]); CProp ("fix",[CVar 25])])])])]) ); add (CProp ("equal", [CProp ("meaning", - [CProp ("plus_tree",[CProp ("delete",[CVar 23; CVar 24])]); CVar 0]); + [CProp ("plus_tree",[CProp ("delete",[CVar 23; CVar 24])]); CVar 0]); CProp ("if", - [CProp ("member",[CVar 23; CVar 24]); + [CProp ("member",[CVar 23; CVar 24]); CProp ("difference", - [CProp ("meaning",[CProp ("plus_tree",[CVar 24]); CVar 0]); - CProp ("meaning",[CVar 23; CVar 0])]); + [CProp ("meaning",[CProp ("plus_tree",[CVar 24]); CVar 0]); + CProp ("meaning",[CVar 23; CVar 0])]); CProp ("meaning",[CProp ("plus_tree",[CVar 24]); CVar 0])])])); add (CProp ("equal", - [CProp ("times",[CVar 23; CProp ("add1",[CVar 24])]); + [CProp ("times",[CVar 23; CProp ("add1",[CVar 24])]); CProp ("if", - [CProp ("numberp",[CVar 24]); + [CProp ("numberp",[CVar 24]); CProp ("plus", - [CVar 23; CProp ("times",[CVar 23; CVar 24]); + [CVar 23; CProp ("times",[CVar 23; CVar 24]); CProp ("fix",[CVar 23])])])])); add (CProp ("equal", - [CProp ("nth",[CProp ("nil",[]); CVar 8]); + [CProp ("nth",[CProp ("nil",[]); CVar 8]); CProp ("if",[CProp ("zerop",[CVar 8]); CProp ("nil",[]); CProp ("zero",[])])])); add (CProp ("equal", - [CProp ("last",[CProp ("append",[CVar 0; CVar 1])]); + [CProp ("last",[CProp ("append",[CVar 0; CVar 1])]); CProp ("if", - [CProp ("listp",[CVar 1]); CProp ("last",[CVar 1]); + [CProp ("listp",[CVar 1]); CProp ("last",[CVar 1]); CProp ("if", - [CProp ("listp",[CVar 0]); - CProp ("cons",[CProp ("car",[CProp ("last",[CVar 0])]); CVar 1]); + [CProp ("listp",[CVar 0]); + CProp ("cons",[CProp ("car",[CProp ("last",[CVar 0])]); CVar 1]); CVar 1])])])); add (CProp ("equal", - [CProp ("equal",[CProp ("lt",[CVar 23; CVar 24]); CVar 25]); + [CProp ("equal",[CProp ("lt",[CVar 23; CVar 24]); CVar 25]); CProp ("if", - [CProp ("lt",[CVar 23; CVar 24]); - CProp ("equal",[CProp ("true",[]); CVar 25]); + [CProp ("lt",[CVar 23; CVar 24]); + CProp ("equal",[CProp ("true",[]); CVar 25]); CProp ("equal",[CProp ("false",[]); CVar 25])])])); add (CProp ("equal", - [CProp ("assignment",[CVar 23; CProp ("append",[CVar 0; CVar 1])]); + [CProp ("assignment",[CVar 23; CProp ("append",[CVar 0; CVar 1])]); CProp ("if", - [CProp ("assignedp",[CVar 23; CVar 0]); - CProp ("assignment",[CVar 23; CVar 0]); + [CProp ("assignedp",[CVar 23; CVar 0]); + CProp ("assignment",[CVar 23; CVar 0]); CProp ("assignment",[CVar 23; CVar 1])])])); add (CProp ("equal", - [CProp ("car",[CProp ("gother",[CVar 23])]); + [CProp ("car",[CProp ("gother",[CVar 23])]); CProp ("if", - [CProp ("listp",[CVar 23]); + [CProp ("listp",[CVar 23]); CProp ("car",[CProp ("flatten",[CVar 23])]); CProp ("zero",[])])])); add (CProp ("equal", - [CProp ("flatten",[CProp ("cdr",[CProp ("gother",[CVar 23])])]); + [CProp ("flatten",[CProp ("cdr",[CProp ("gother",[CVar 23])])]); CProp ("if", - [CProp ("listp",[CVar 23]); - CProp ("cdr",[CProp ("flatten",[CVar 23])]); + [CProp ("listp",[CVar 23]); + CProp ("cdr",[CProp ("flatten",[CVar 23])]); CProp ("cons",[CProp ("zero",[]); CProp ("nil",[])])])])); add (CProp ("equal", - [CProp ("quotient",[CProp ("times",[CVar 24; CVar 23]); CVar 24]); + [CProp ("quotient",[CProp ("times",[CVar 24; CVar 23]); CVar 24]); CProp ("if", - [CProp ("zerop",[CVar 24]); CProp ("zero",[]); + [CProp ("zerop",[CVar 24]); CProp ("zero",[]); CProp ("fix",[CVar 23])])])); add (CProp ("equal", - [CProp ("get",[CVar 9; CProp ("set",[CVar 8; CVar 21; CVar 12])]); + [CProp ("get",[CVar 9; CProp ("set",[CVar 8; CVar 21; CVar 12])]); CProp ("if", - [CProp ("eqp",[CVar 9; CVar 8]); CVar 21; + [CProp ("eqp",[CVar 9; CVar 8]); CVar 21; CProp ("get",[CVar 9; CVar 12])])])) (* Tautology checker *) @@ -822,7 +822,7 @@ let rec tautologyp x true_lst false_lst = end -let tautp x = +let tautp x = (* print_term x; print_string"\n"; *) let y = rewrite x in (* print_term y; print_string "\n"; *) diff --git a/testsuite/tests/misc/fib.ml b/testsuite/tests/misc/fib.ml index 4160004ea4..7311c8128a 100644 --- a/testsuite/tests/misc/fib.ml +++ b/testsuite/tests/misc/fib.ml @@ -17,8 +17,7 @@ let rec fib n = let _ = let n = - if Array.length Sys.argv >= 2 + if Array.length Sys.argv >= 2 then int_of_string Sys.argv.(1) else 40 in print_int(fib n); print_newline(); exit 0 - diff --git a/testsuite/tests/misc/nucleic.ml b/testsuite/tests/misc/nucleic.ml index b35360a882..624300806f 100644 --- a/testsuite/tests/misc/nucleic.ml +++ b/testsuite/tests/misc/nucleic.ml @@ -60,14 +60,14 @@ pt_theta p matrices don't have the perspective terms and are the transpose of Paul's one. See also "M\"antyl\"a, M. (1985) An Introduction to Solid Modeling, Computer Science Press" Appendix A. - + The components of a transformation matrix are named like this: - + a b c d e f g h i tx ty tz - + The components tx, ty, and tz are the translation vector. *) @@ -208,7 +208,7 @@ tfo_align p1 p2 p3 (* Numbering of atoms follows the paper: - + IUPAC-IUB Joint Commission on Biochemical Nomenclature (JCBN) (1983) Abbreviations and Symbols for the Description of Conformations of Polynucleotide Chains. Eur. J. Biochem 131, @@ -273,7 +273,7 @@ nuc_C1' = c1' let -nuc_C2 +nuc_C2 (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6,_)) @@ -287,7 +287,7 @@ nuc_C3' = c3' let -nuc_C4 +nuc_C4 (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6,_)) @@ -301,7 +301,7 @@ nuc_C4' = c4' let -nuc_N1 +nuc_N1 (N(dgf_base_tfo,p_o3'_275_tfo,p_o3'_180_tfo,p_o3'_60_tfo, p,o1p,o2p,o5',c5',h5',h5'',c4',h4',o4',c1',h1',c2',h2'',o2',h2', c3',h3',o3',n1,n3,c2,c4,c5,c6,_)) @@ -2896,13 +2896,13 @@ let rec search (partial_inst : variable list) l constr = (* -- DOMAINS ---------------------------------------------------------------*) (* Primary structure: strand A CUGCCACGUCUG, strand B CAGACGUGGCAG - + Secondary structure: strand A CUGCCACGUCUG |||||||||||| GACGGUGCAGAC strand B - + Tertiary structure: - + 5' end of strand A C1----G12 3' end of strand B U2-------A11 G3-------C10 @@ -2915,13 +2915,13 @@ let rec search (partial_inst : variable list) l constr = G3--------C10 A2-------U11 5' end of strand B C1----G12 3' end of strand A - + "helix", "stacked" and "connected" describe the spatial relationship between two consecutive nucleotides. E.g. the nucleotides C1 and U2 from the strand A. - + "wc" (stands for Watson-Crick and is a type of base-pairing), - and "wc-dumas" describe the spatial relationship between + and "wc-dumas" describe the spatial relationship between nucleotides from two chains that are growing in opposite directions. E.g. the nucleotides C1 from strand A and G12 from strand B. *) @@ -2965,7 +2965,7 @@ let reference n i partial_inst = [ mk_var i tfo_id n ] (* The transformation matrix for wc is from: - + Chandrasekaran R. et al (1989) A Re-Examination of the Crystal Structure of A-DNA Using Fiber Diffraction Data. J. Biomol. Struct. & Dynamics 6(6):1189-1202. @@ -3047,7 +3047,7 @@ let a38_g37 nucl i j partial_inst = mk_var i (dgf_base a38_g37_tfo (get_var j partial_inst) nucl) nucl -let +let stacked3' nucl i j partial_inst = (a38_g37 nucl i j partial_inst) :: (helix3' nucl i j partial_inst) @@ -3146,7 +3146,7 @@ pseudoknot_domains stacked5' rU 5 4; (* | 4.5 Angstroms *) stacked5' rC 6 5 (* <-' *) ] - + (* Pseudoknot constraint *) let @@ -3212,7 +3212,7 @@ var_most_distant_atom v = let max_dist = ref 0.0 in for i = 0 to pred (Array.length atoms) do let p = atoms.(i) in - let distance = + let distance = let pos = absolute_pos v p in sqrt ((pos.x * pos.x) + (pos.y * pos.y) + (pos.z * pos.z)) in if distance > !max_dist then max_dist := distance diff --git a/testsuite/tests/misc/sieve.ml b/testsuite/tests/misc/sieve.ml index 7f0295bb67..0cf4b31016 100644 --- a/testsuite/tests/misc/sieve.ml +++ b/testsuite/tests/misc/sieve.ml @@ -51,6 +51,6 @@ let rec do_list f = function let _ = - do_list (fun n -> print_int n; print_string " ") (sieve 50000); + do_list (fun n -> print_string " "; print_int n) (sieve 50000); print_newline(); exit 0 diff --git a/testsuite/tests/misc/sieve.reference b/testsuite/tests/misc/sieve.reference index eb96be005a..24f5cc544a 100644 --- a/testsuite/tests/misc/sieve.reference +++ b/testsuite/tests/misc/sieve.reference @@ -1 +1 @@ -2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 101 103 107 109 113 127 131 137 139 149 151 157 163 167 173 179 181 191 193 197 199 211 223 227 229 233 239 241 251 257 263 269 271 277 281 283 293 307 311 313 317 331 337 347 349 353 359 367 373 379 383 389 397 401 409 419 421 431 433 439 443 449 457 461 463 467 479 487 491 499 503 509 521 523 541 547 557 563 569 571 577 587 593 599 601 607 613 617 619 631 641 643 647 653 659 661 673 677 683 691 701 709 719 727 733 739 743 751 757 761 769 773 787 797 809 811 821 823 827 829 839 853 857 859 863 877 881 883 887 907 911 919 929 937 941 947 953 967 971 977 983 991 997 1009 1013 1019 1021 1031 1033 1039 1049 1051 1061 1063 1069 1087 1091 1093 1097 1103 1109 1117 1123 1129 1151 1153 1163 1171 1181 1187 1193 1201 1213 1217 1223 1229 1231 1237 1249 1259 1277 1279 1283 1289 1291 1297 1301 1303 1307 1319 1321 1327 1361 1367 1373 1381 1399 1409 1423 1427 1429 1433 1439 1447 1451 1453 1459 1471 1481 1483 1487 1489 1493 1499 1511 1523 1531 1543 1549 1553 1559 1567 1571 1579 1583 1597 1601 1607 1609 1613 1619 1621 1627 1637 1657 1663 1667 1669 1693 1697 1699 1709 1721 1723 1733 1741 1747 1753 1759 1777 1783 1787 1789 1801 1811 1823 1831 1847 1861 1867 1871 1873 1877 1879 1889 1901 1907 1913 1931 1933 1949 1951 1973 1979 1987 1993 1997 1999 2003 2011 2017 2027 2029 2039 2053 2063 2069 2081 2083 2087 2089 2099 2111 2113 2129 2131 2137 2141 2143 2153 2161 2179 2203 2207 2213 2221 2237 2239 2243 2251 2267 2269 2273 2281 2287 2293 2297 2309 2311 2333 2339 2341 2347 2351 2357 2371 2377 2381 2383 2389 2393 2399 2411 2417 2423 2437 2441 2447 2459 2467 2473 2477 2503 2521 2531 2539 2543 2549 2551 2557 2579 2591 2593 2609 2617 2621 2633 2647 2657 2659 2663 2671 2677 2683 2687 2689 2693 2699 2707 2711 2713 2719 2729 2731 2741 2749 2753 2767 2777 2789 2791 2797 2801 2803 2819 2833 2837 2843 2851 2857 2861 2879 2887 2897 2903 2909 2917 2927 2939 2953 2957 2963 2969 2971 2999 3001 3011 3019 3023 3037 3041 3049 3061 3067 3079 3083 3089 3109 3119 3121 3137 3163 3167 3169 3181 3187 3191 3203 3209 3217 3221 3229 3251 3253 3257 3259 3271 3299 3301 3307 3313 3319 3323 3329 3331 3343 3347 3359 3361 3371 3373 3389 3391 3407 3413 3433 3449 3457 3461 3463 3467 3469 3491 3499 3511 3517 3527 3529 3533 3539 3541 3547 3557 3559 3571 3581 3583 3593 3607 3613 3617 3623 3631 3637 3643 3659 3671 3673 3677 3691 3697 3701 3709 3719 3727 3733 3739 3761 3767 3769 3779 3793 3797 3803 3821 3823 3833 3847 3851 3853 3863 3877 3881 3889 3907 3911 3917 3919 3923 3929 3931 3943 3947 3967 3989 4001 4003 4007 4013 4019 4021 4027 4049 4051 4057 4073 4079 4091 4093 4099 4111 4127 4129 4133 4139 4153 4157 4159 4177 4201 4211 4217 4219 4229 4231 4241 4243 4253 4259 4261 4271 4273 4283 4289 4297 4327 4337 4339 4349 4357 4363 4373 4391 4397 4409 4421 4423 4441 4447 4451 4457 4463 4481 4483 4493 4507 4513 4517 4519 4523 4547 4549 4561 4567 4583 4591 4597 4603 4621 4637 4639 4643 4649 4651 4657 4663 4673 4679 4691 4703 4721 4723 4729 4733 4751 4759 4783 4787 4789 4793 4799 4801 4813 4817 4831 4861 4871 4877 4889 4903 4909 4919 4931 4933 4937 4943 4951 4957 4967 4969 4973 4987 4993 4999 5003 5009 5011 5021 5023 5039 5051 5059 5077 5081 5087 5099 5101 5107 5113 5119 5147 5153 5167 5171 5179 5189 5197 5209 5227 5231 5233 5237 5261 5273 5279 5281 5297 5303 5309 5323 5333 5347 5351 5381 5387 5393 5399 5407 5413 5417 5419 5431 5437 5441 5443 5449 5471 5477 5479 5483 5501 5503 5507 5519 5521 5527 5531 5557 5563 5569 5573 5581 5591 5623 5639 5641 5647 5651 5653 5657 5659 5669 5683 5689 5693 5701 5711 5717 5737 5741 5743 5749 5779 5783 5791 5801 5807 5813 5821 5827 5839 5843 5849 5851 5857 5861 5867 5869 5879 5881 5897 5903 5923 5927 5939 5953 5981 5987 6007 6011 6029 6037 6043 6047 6053 6067 6073 6079 6089 6091 6101 6113 6121 6131 6133 6143 6151 6163 6173 6197 6199 6203 6211 6217 6221 6229 6247 6257 6263 6269 6271 6277 6287 6299 6301 6311 6317 6323 6329 6337 6343 6353 6359 6361 6367 6373 6379 6389 6397 6421 6427 6449 6451 6469 6473 6481 6491 6521 6529 6547 6551 6553 6563 6569 6571 6577 6581 6599 6607 6619 6637 6653 6659 6661 6673 6679 6689 6691 6701 6703 6709 6719 6733 6737 6761 6763 6779 6781 6791 6793 6803 6823 6827 6829 6833 6841 6857 6863 6869 6871 6883 6899 6907 6911 6917 6947 6949 6959 6961 6967 6971 6977 6983 6991 6997 7001 7013 7019 7027 7039 7043 7057 7069 7079 7103 7109 7121 7127 7129 7151 7159 7177 7187 7193 7207 7211 7213 7219 7229 7237 7243 7247 7253 7283 7297 7307 7309 7321 7331 7333 7349 7351 7369 7393 7411 7417 7433 7451 7457 7459 7477 7481 7487 7489 7499 7507 7517 7523 7529 7537 7541 7547 7549 7559 7561 7573 7577 7583 7589 7591 7603 7607 7621 7639 7643 7649 7669 7673 7681 7687 7691 7699 7703 7717 7723 7727 7741 7753 7757 7759 7789 7793 7817 7823 7829 7841 7853 7867 7873 7877 7879 7883 7901 7907 7919 7927 7933 7937 7949 7951 7963 7993 8009 8011 8017 8039 8053 8059 8069 8081 8087 8089 8093 8101 8111 8117 8123 8147 8161 8167 8171 8179 8191 8209 8219 8221 8231 8233 8237 8243 8263 8269 8273 8287 8291 8293 8297 8311 8317 8329 8353 8363 8369 8377 8387 8389 8419 8423 8429 8431 8443 8447 8461 8467 8501 8513 8521 8527 8537 8539 8543 8563 8573 8581 8597 8599 8609 8623 8627 8629 8641 8647 8663 8669 8677 8681 8689 8693 8699 8707 8713 8719 8731 8737 8741 8747 8753 8761 8779 8783 8803 8807 8819 8821 8831 8837 8839 8849 8861 8863 8867 8887 8893 8923 8929 8933 8941 8951 8963 8969 8971 8999 9001 9007 9011 9013 9029 9041 9043 9049 9059 9067 9091 9103 9109 9127 9133 9137 9151 9157 9161 9173 9181 9187 9199 9203 9209 9221 9227 9239 9241 9257 9277 9281 9283 9293 9311 9319 9323 9337 9341 9343 9349 9371 9377 9391 9397 9403 9413 9419 9421 9431 9433 9437 9439 9461 9463 9467 9473 9479 9491 9497 9511 9521 9533 9539 9547 9551 9587 9601 9613 9619 9623 9629 9631 9643 9649 9661 9677 9679 9689 9697 9719 9721 9733 9739 9743 9749 9767 9769 9781 9787 9791 9803 9811 9817 9829 9833 9839 9851 9857 9859 9871 9883 9887 9901 9907 9923 9929 9931 9941 9949 9967 9973 10007 10009 10037 10039 10061 10067 10069 10079 10091 10093 10099 10103 10111 10133 10139 10141 10151 10159 10163 10169 10177 10181 10193 10211 10223 10243 10247 10253 10259 10267 10271 10273 10289 10301 10303 10313 10321 10331 10333 10337 10343 10357 10369 10391 10399 10427 10429 10433 10453 10457 10459 10463 10477 10487 10499 10501 10513 10529 10531 10559 10567 10589 10597 10601 10607 10613 10627 10631 10639 10651 10657 10663 10667 10687 10691 10709 10711 10723 10729 10733 10739 10753 10771 10781 10789 10799 10831 10837 10847 10853 10859 10861 10867 10883 10889 10891 10903 10909 10937 10939 10949 10957 10973 10979 10987 10993 11003 11027 11047 11057 11059 11069 11071 11083 11087 11093 11113 11117 11119 11131 11149 11159 11161 11171 11173 11177 11197 11213 11239 11243 11251 11257 11261 11273 11279 11287 11299 11311 11317 11321 11329 11351 11353 11369 11383 11393 11399 11411 11423 11437 11443 11447 11467 11471 11483 11489 11491 11497 11503 11519 11527 11549 11551 11579 11587 11593 11597 11617 11621 11633 11657 11677 11681 11689 11699 11701 11717 11719 11731 11743 11777 11779 11783 11789 11801 11807 11813 11821 11827 11831 11833 11839 11863 11867 11887 11897 11903 11909 11923 11927 11933 11939 11941 11953 11959 11969 11971 11981 11987 12007 12011 12037 12041 12043 12049 12071 12073 12097 12101 12107 12109 12113 12119 12143 12149 12157 12161 12163 12197 12203 12211 12227 12239 12241 12251 12253 12263 12269 12277 12281 12289 12301 12323 12329 12343 12347 12373 12377 12379 12391 12401 12409 12413 12421 12433 12437 12451 12457 12473 12479 12487 12491 12497 12503 12511 12517 12527 12539 12541 12547 12553 12569 12577 12583 12589 12601 12611 12613 12619 12637 12641 12647 12653 12659 12671 12689 12697 12703 12713 12721 12739 12743 12757 12763 12781 12791 12799 12809 12821 12823 12829 12841 12853 12889 12893 12899 12907 12911 12917 12919 12923 12941 12953 12959 12967 12973 12979 12983 13001 13003 13007 13009 13033 13037 13043 13049 13063 13093 13099 13103 13109 13121 13127 13147 13151 13159 13163 13171 13177 13183 13187 13217 13219 13229 13241 13249 13259 13267 13291 13297 13309 13313 13327 13331 13337 13339 13367 13381 13397 13399 13411 13417 13421 13441 13451 13457 13463 13469 13477 13487 13499 13513 13523 13537 13553 13567 13577 13591 13597 13613 13619 13627 13633 13649 13669 13679 13681 13687 13691 13693 13697 13709 13711 13721 13723 13729 13751 13757 13759 13763 13781 13789 13799 13807 13829 13831 13841 13859 13873 13877 13879 13883 13901 13903 13907 13913 13921 13931 13933 13963 13967 13997 13999 14009 14011 14029 14033 14051 14057 14071 14081 14083 14087 14107 14143 14149 14153 14159 14173 14177 14197 14207 14221 14243 14249 14251 14281 14293 14303 14321 14323 14327 14341 14347 14369 14387 14389 14401 14407 14411 14419 14423 14431 14437 14447 14449 14461 14479 14489 14503 14519 14533 14537 14543 14549 14551 14557 14561 14563 14591 14593 14621 14627 14629 14633 14639 14653 14657 14669 14683 14699 14713 14717 14723 14731 14737 14741 14747 14753 14759 14767 14771 14779 14783 14797 14813 14821 14827 14831 14843 14851 14867 14869 14879 14887 14891 14897 14923 14929 14939 14947 14951 14957 14969 14983 15013 15017 15031 15053 15061 15073 15077 15083 15091 15101 15107 15121 15131 15137 15139 15149 15161 15173 15187 15193 15199 15217 15227 15233 15241 15259 15263 15269 15271 15277 15287 15289 15299 15307 15313 15319 15329 15331 15349 15359 15361 15373 15377 15383 15391 15401 15413 15427 15439 15443 15451 15461 15467 15473 15493 15497 15511 15527 15541 15551 15559 15569 15581 15583 15601 15607 15619 15629 15641 15643 15647 15649 15661 15667 15671 15679 15683 15727 15731 15733 15737 15739 15749 15761 15767 15773 15787 15791 15797 15803 15809 15817 15823 15859 15877 15881 15887 15889 15901 15907 15913 15919 15923 15937 15959 15971 15973 15991 16001 16007 16033 16057 16061 16063 16067 16069 16073 16087 16091 16097 16103 16111 16127 16139 16141 16183 16187 16189 16193 16217 16223 16229 16231 16249 16253 16267 16273 16301 16319 16333 16339 16349 16361 16363 16369 16381 16411 16417 16421 16427 16433 16447 16451 16453 16477 16481 16487 16493 16519 16529 16547 16553 16561 16567 16573 16603 16607 16619 16631 16633 16649 16651 16657 16661 16673 16691 16693 16699 16703 16729 16741 16747 16759 16763 16787 16811 16823 16829 16831 16843 16871 16879 16883 16889 16901 16903 16921 16927 16931 16937 16943 16963 16979 16981 16987 16993 17011 17021 17027 17029 17033 17041 17047 17053 17077 17093 17099 17107 17117 17123 17137 17159 17167 17183 17189 17191 17203 17207 17209 17231 17239 17257 17291 17293 17299 17317 17321 17327 17333 17341 17351 17359 17377 17383 17387 17389 17393 17401 17417 17419 17431 17443 17449 17467 17471 17477 17483 17489 17491 17497 17509 17519 17539 17551 17569 17573 17579 17581 17597 17599 17609 17623 17627 17657 17659 17669 17681 17683 17707 17713 17729 17737 17747 17749 17761 17783 17789 17791 17807 17827 17837 17839 17851 17863 17881 17891 17903 17909 17911 17921 17923 17929 17939 17957 17959 17971 17977 17981 17987 17989 18013 18041 18043 18047 18049 18059 18061 18077 18089 18097 18119 18121 18127 18131 18133 18143 18149 18169 18181 18191 18199 18211 18217 18223 18229 18233 18251 18253 18257 18269 18287 18289 18301 18307 18311 18313 18329 18341 18353 18367 18371 18379 18397 18401 18413 18427 18433 18439 18443 18451 18457 18461 18481 18493 18503 18517 18521 18523 18539 18541 18553 18583 18587 18593 18617 18637 18661 18671 18679 18691 18701 18713 18719 18731 18743 18749 18757 18773 18787 18793 18797 18803 18839 18859 18869 18899 18911 18913 18917 18919 18947 18959 18973 18979 19001 19009 19013 19031 19037 19051 19069 19073 19079 19081 19087 19121 19139 19141 19157 19163 19181 19183 19207 19211 19213 19219 19231 19237 19249 19259 19267 19273 19289 19301 19309 19319 19333 19373 19379 19381 19387 19391 19403 19417 19421 19423 19427 19429 19433 19441 19447 19457 19463 19469 19471 19477 19483 19489 19501 19507 19531 19541 19543 19553 19559 19571 19577 19583 19597 19603 19609 19661 19681 19687 19697 19699 19709 19717 19727 19739 19751 19753 19759 19763 19777 19793 19801 19813 19819 19841 19843 19853 19861 19867 19889 19891 19913 19919 19927 19937 19949 19961 19963 19973 19979 19991 19993 19997 20011 20021 20023 20029 20047 20051 20063 20071 20089 20101 20107 20113 20117 20123 20129 20143 20147 20149 20161 20173 20177 20183 20201 20219 20231 20233 20249 20261 20269 20287 20297 20323 20327 20333 20341 20347 20353 20357 20359 20369 20389 20393 20399 20407 20411 20431 20441 20443 20477 20479 20483 20507 20509 20521 20533 20543 20549 20551 20563 20593 20599 20611 20627 20639 20641 20663 20681 20693 20707 20717 20719 20731 20743 20747 20749 20753 20759 20771 20773 20789 20807 20809 20849 20857 20873 20879 20887 20897 20899 20903 20921 20929 20939 20947 20959 20963 20981 20983 21001 21011 21013 21017 21019 21023 21031 21059 21061 21067 21089 21101 21107 21121 21139 21143 21149 21157 21163 21169 21179 21187 21191 21193 21211 21221 21227 21247 21269 21277 21283 21313 21317 21319 21323 21341 21347 21377 21379 21383 21391 21397 21401 21407 21419 21433 21467 21481 21487 21491 21493 21499 21503 21517 21521 21523 21529 21557 21559 21563 21569 21577 21587 21589 21599 21601 21611 21613 21617 21647 21649 21661 21673 21683 21701 21713 21727 21737 21739 21751 21757 21767 21773 21787 21799 21803 21817 21821 21839 21841 21851 21859 21863 21871 21881 21893 21911 21929 21937 21943 21961 21977 21991 21997 22003 22013 22027 22031 22037 22039 22051 22063 22067 22073 22079 22091 22093 22109 22111 22123 22129 22133 22147 22153 22157 22159 22171 22189 22193 22229 22247 22259 22271 22273 22277 22279 22283 22291 22303 22307 22343 22349 22367 22369 22381 22391 22397 22409 22433 22441 22447 22453 22469 22481 22483 22501 22511 22531 22541 22543 22549 22567 22571 22573 22613 22619 22621 22637 22639 22643 22651 22669 22679 22691 22697 22699 22709 22717 22721 22727 22739 22741 22751 22769 22777 22783 22787 22807 22811 22817 22853 22859 22861 22871 22877 22901 22907 22921 22937 22943 22961 22963 22973 22993 23003 23011 23017 23021 23027 23029 23039 23041 23053 23057 23059 23063 23071 23081 23087 23099 23117 23131 23143 23159 23167 23173 23189 23197 23201 23203 23209 23227 23251 23269 23279 23291 23293 23297 23311 23321 23327 23333 23339 23357 23369 23371 23399 23417 23431 23447 23459 23473 23497 23509 23531 23537 23539 23549 23557 23561 23563 23567 23581 23593 23599 23603 23609 23623 23627 23629 23633 23663 23669 23671 23677 23687 23689 23719 23741 23743 23747 23753 23761 23767 23773 23789 23801 23813 23819 23827 23831 23833 23857 23869 23873 23879 23887 23893 23899 23909 23911 23917 23929 23957 23971 23977 23981 23993 24001 24007 24019 24023 24029 24043 24049 24061 24071 24077 24083 24091 24097 24103 24107 24109 24113 24121 24133 24137 24151 24169 24179 24181 24197 24203 24223 24229 24239 24247 24251 24281 24317 24329 24337 24359 24371 24373 24379 24391 24407 24413 24419 24421 24439 24443 24469 24473 24481 24499 24509 24517 24527 24533 24547 24551 24571 24593 24611 24623 24631 24659 24671 24677 24683 24691 24697 24709 24733 24749 24763 24767 24781 24793 24799 24809 24821 24841 24847 24851 24859 24877 24889 24907 24917 24919 24923 24943 24953 24967 24971 24977 24979 24989 25013 25031 25033 25037 25057 25073 25087 25097 25111 25117 25121 25127 25147 25153 25163 25169 25171 25183 25189 25219 25229 25237 25243 25247 25253 25261 25301 25303 25307 25309 25321 25339 25343 25349 25357 25367 25373 25391 25409 25411 25423 25439 25447 25453 25457 25463 25469 25471 25523 25537 25541 25561 25577 25579 25583 25589 25601 25603 25609 25621 25633 25639 25643 25657 25667 25673 25679 25693 25703 25717 25733 25741 25747 25759 25763 25771 25793 25799 25801 25819 25841 25847 25849 25867 25873 25889 25903 25913 25919 25931 25933 25939 25943 25951 25969 25981 25997 25999 26003 26017 26021 26029 26041 26053 26083 26099 26107 26111 26113 26119 26141 26153 26161 26171 26177 26183 26189 26203 26209 26227 26237 26249 26251 26261 26263 26267 26293 26297 26309 26317 26321 26339 26347 26357 26371 26387 26393 26399 26407 26417 26423 26431 26437 26449 26459 26479 26489 26497 26501 26513 26539 26557 26561 26573 26591 26597 26627 26633 26641 26647 26669 26681 26683 26687 26693 26699 26701 26711 26713 26717 26723 26729 26731 26737 26759 26777 26783 26801 26813 26821 26833 26839 26849 26861 26863 26879 26881 26891 26893 26903 26921 26927 26947 26951 26953 26959 26981 26987 26993 27011 27017 27031 27043 27059 27061 27067 27073 27077 27091 27103 27107 27109 27127 27143 27179 27191 27197 27211 27239 27241 27253 27259 27271 27277 27281 27283 27299 27329 27337 27361 27367 27397 27407 27409 27427 27431 27437 27449 27457 27479 27481 27487 27509 27527 27529 27539 27541 27551 27581 27583 27611 27617 27631 27647 27653 27673 27689 27691 27697 27701 27733 27737 27739 27743 27749 27751 27763 27767 27773 27779 27791 27793 27799 27803 27809 27817 27823 27827 27847 27851 27883 27893 27901 27917 27919 27941 27943 27947 27953 27961 27967 27983 27997 28001 28019 28027 28031 28051 28057 28069 28081 28087 28097 28099 28109 28111 28123 28151 28163 28181 28183 28201 28211 28219 28229 28277 28279 28283 28289 28297 28307 28309 28319 28349 28351 28387 28393 28403 28409 28411 28429 28433 28439 28447 28463 28477 28493 28499 28513 28517 28537 28541 28547 28549 28559 28571 28573 28579 28591 28597 28603 28607 28619 28621 28627 28631 28643 28649 28657 28661 28663 28669 28687 28697 28703 28711 28723 28729 28751 28753 28759 28771 28789 28793 28807 28813 28817 28837 28843 28859 28867 28871 28879 28901 28909 28921 28927 28933 28949 28961 28979 29009 29017 29021 29023 29027 29033 29059 29063 29077 29101 29123 29129 29131 29137 29147 29153 29167 29173 29179 29191 29201 29207 29209 29221 29231 29243 29251 29269 29287 29297 29303 29311 29327 29333 29339 29347 29363 29383 29387 29389 29399 29401 29411 29423 29429 29437 29443 29453 29473 29483 29501 29527 29531 29537 29567 29569 29573 29581 29587 29599 29611 29629 29633 29641 29663 29669 29671 29683 29717 29723 29741 29753 29759 29761 29789 29803 29819 29833 29837 29851 29863 29867 29873 29879 29881 29917 29921 29927 29947 29959 29983 29989 30011 30013 30029 30047 30059 30071 30089 30091 30097 30103 30109 30113 30119 30133 30137 30139 30161 30169 30181 30187 30197 30203 30211 30223 30241 30253 30259 30269 30271 30293 30307 30313 30319 30323 30341 30347 30367 30389 30391 30403 30427 30431 30449 30467 30469 30491 30493 30497 30509 30517 30529 30539 30553 30557 30559 30577 30593 30631 30637 30643 30649 30661 30671 30677 30689 30697 30703 30707 30713 30727 30757 30763 30773 30781 30803 30809 30817 30829 30839 30841 30851 30853 30859 30869 30871 30881 30893 30911 30931 30937 30941 30949 30971 30977 30983 31013 31019 31033 31039 31051 31063 31069 31079 31081 31091 31121 31123 31139 31147 31151 31153 31159 31177 31181 31183 31189 31193 31219 31223 31231 31237 31247 31249 31253 31259 31267 31271 31277 31307 31319 31321 31327 31333 31337 31357 31379 31387 31391 31393 31397 31469 31477 31481 31489 31511 31513 31517 31531 31541 31543 31547 31567 31573 31583 31601 31607 31627 31643 31649 31657 31663 31667 31687 31699 31721 31723 31727 31729 31741 31751 31769 31771 31793 31799 31817 31847 31849 31859 31873 31883 31891 31907 31957 31963 31973 31981 31991 32003 32009 32027 32029 32051 32057 32059 32063 32069 32077 32083 32089 32099 32117 32119 32141 32143 32159 32173 32183 32189 32191 32203 32213 32233 32237 32251 32257 32261 32297 32299 32303 32309 32321 32323 32327 32341 32353 32359 32363 32369 32371 32377 32381 32401 32411 32413 32423 32429 32441 32443 32467 32479 32491 32497 32503 32507 32531 32533 32537 32561 32563 32569 32573 32579 32587 32603 32609 32611 32621 32633 32647 32653 32687 32693 32707 32713 32717 32719 32749 32771 32779 32783 32789 32797 32801 32803 32831 32833 32839 32843 32869 32887 32909 32911 32917 32933 32939 32941 32957 32969 32971 32983 32987 32993 32999 33013 33023 33029 33037 33049 33053 33071 33073 33083 33091 33107 33113 33119 33149 33151 33161 33179 33181 33191 33199 33203 33211 33223 33247 33287 33289 33301 33311 33317 33329 33331 33343 33347 33349 33353 33359 33377 33391 33403 33409 33413 33427 33457 33461 33469 33479 33487 33493 33503 33521 33529 33533 33547 33563 33569 33577 33581 33587 33589 33599 33601 33613 33617 33619 33623 33629 33637 33641 33647 33679 33703 33713 33721 33739 33749 33751 33757 33767 33769 33773 33791 33797 33809 33811 33827 33829 33851 33857 33863 33871 33889 33893 33911 33923 33931 33937 33941 33961 33967 33997 34019 34031 34033 34039 34057 34061 34123 34127 34129 34141 34147 34157 34159 34171 34183 34211 34213 34217 34231 34253 34259 34261 34267 34273 34283 34297 34301 34303 34313 34319 34327 34337 34351 34361 34367 34369 34381 34403 34421 34429 34439 34457 34469 34471 34483 34487 34499 34501 34511 34513 34519 34537 34543 34549 34583 34589 34591 34603 34607 34613 34631 34649 34651 34667 34673 34679 34687 34693 34703 34721 34729 34739 34747 34757 34759 34763 34781 34807 34819 34841 34843 34847 34849 34871 34877 34883 34897 34913 34919 34939 34949 34961 34963 34981 35023 35027 35051 35053 35059 35069 35081 35083 35089 35099 35107 35111 35117 35129 35141 35149 35153 35159 35171 35201 35221 35227 35251 35257 35267 35279 35281 35291 35311 35317 35323 35327 35339 35353 35363 35381 35393 35401 35407 35419 35423 35437 35447 35449 35461 35491 35507 35509 35521 35527 35531 35533 35537 35543 35569 35573 35591 35593 35597 35603 35617 35671 35677 35729 35731 35747 35753 35759 35771 35797 35801 35803 35809 35831 35837 35839 35851 35863 35869 35879 35897 35899 35911 35923 35933 35951 35963 35969 35977 35983 35993 35999 36007 36011 36013 36017 36037 36061 36067 36073 36083 36097 36107 36109 36131 36137 36151 36161 36187 36191 36209 36217 36229 36241 36251 36263 36269 36277 36293 36299 36307 36313 36319 36341 36343 36353 36373 36383 36389 36433 36451 36457 36467 36469 36473 36479 36493 36497 36523 36527 36529 36541 36551 36559 36563 36571 36583 36587 36599 36607 36629 36637 36643 36653 36671 36677 36683 36691 36697 36709 36713 36721 36739 36749 36761 36767 36779 36781 36787 36791 36793 36809 36821 36833 36847 36857 36871 36877 36887 36899 36901 36913 36919 36923 36929 36931 36943 36947 36973 36979 36997 37003 37013 37019 37021 37039 37049 37057 37061 37087 37097 37117 37123 37139 37159 37171 37181 37189 37199 37201 37217 37223 37243 37253 37273 37277 37307 37309 37313 37321 37337 37339 37357 37361 37363 37369 37379 37397 37409 37423 37441 37447 37463 37483 37489 37493 37501 37507 37511 37517 37529 37537 37547 37549 37561 37567 37571 37573 37579 37589 37591 37607 37619 37633 37643 37649 37657 37663 37691 37693 37699 37717 37747 37781 37783 37799 37811 37813 37831 37847 37853 37861 37871 37879 37889 37897 37907 37951 37957 37963 37967 37987 37991 37993 37997 38011 38039 38047 38053 38069 38083 38113 38119 38149 38153 38167 38177 38183 38189 38197 38201 38219 38231 38237 38239 38261 38273 38281 38287 38299 38303 38317 38321 38327 38329 38333 38351 38371 38377 38393 38431 38447 38449 38453 38459 38461 38501 38543 38557 38561 38567 38569 38593 38603 38609 38611 38629 38639 38651 38653 38669 38671 38677 38693 38699 38707 38711 38713 38723 38729 38737 38747 38749 38767 38783 38791 38803 38821 38833 38839 38851 38861 38867 38873 38891 38903 38917 38921 38923 38933 38953 38959 38971 38977 38993 39019 39023 39041 39043 39047 39079 39089 39097 39103 39107 39113 39119 39133 39139 39157 39161 39163 39181 39191 39199 39209 39217 39227 39229 39233 39239 39241 39251 39293 39301 39313 39317 39323 39341 39343 39359 39367 39371 39373 39383 39397 39409 39419 39439 39443 39451 39461 39499 39503 39509 39511 39521 39541 39551 39563 39569 39581 39607 39619 39623 39631 39659 39667 39671 39679 39703 39709 39719 39727 39733 39749 39761 39769 39779 39791 39799 39821 39827 39829 39839 39841 39847 39857 39863 39869 39877 39883 39887 39901 39929 39937 39953 39971 39979 39983 39989 40009 40013 40031 40037 40039 40063 40087 40093 40099 40111 40123 40127 40129 40151 40153 40163 40169 40177 40189 40193 40213 40231 40237 40241 40253 40277 40283 40289 40343 40351 40357 40361 40387 40423 40427 40429 40433 40459 40471 40483 40487 40493 40499 40507 40519 40529 40531 40543 40559 40577 40583 40591 40597 40609 40627 40637 40639 40693 40697 40699 40709 40739 40751 40759 40763 40771 40787 40801 40813 40819 40823 40829 40841 40847 40849 40853 40867 40879 40883 40897 40903 40927 40933 40939 40949 40961 40973 40993 41011 41017 41023 41039 41047 41051 41057 41077 41081 41113 41117 41131 41141 41143 41149 41161 41177 41179 41183 41189 41201 41203 41213 41221 41227 41231 41233 41243 41257 41263 41269 41281 41299 41333 41341 41351 41357 41381 41387 41389 41399 41411 41413 41443 41453 41467 41479 41491 41507 41513 41519 41521 41539 41543 41549 41579 41593 41597 41603 41609 41611 41617 41621 41627 41641 41647 41651 41659 41669 41681 41687 41719 41729 41737 41759 41761 41771 41777 41801 41809 41813 41843 41849 41851 41863 41879 41887 41893 41897 41903 41911 41927 41941 41947 41953 41957 41959 41969 41981 41983 41999 42013 42017 42019 42023 42043 42061 42071 42073 42083 42089 42101 42131 42139 42157 42169 42179 42181 42187 42193 42197 42209 42221 42223 42227 42239 42257 42281 42283 42293 42299 42307 42323 42331 42337 42349 42359 42373 42379 42391 42397 42403 42407 42409 42433 42437 42443 42451 42457 42461 42463 42467 42473 42487 42491 42499 42509 42533 42557 42569 42571 42577 42589 42611 42641 42643 42649 42667 42677 42683 42689 42697 42701 42703 42709 42719 42727 42737 42743 42751 42767 42773 42787 42793 42797 42821 42829 42839 42841 42853 42859 42863 42899 42901 42923 42929 42937 42943 42953 42961 42967 42979 42989 43003 43013 43019 43037 43049 43051 43063 43067 43093 43103 43117 43133 43151 43159 43177 43189 43201 43207 43223 43237 43261 43271 43283 43291 43313 43319 43321 43331 43391 43397 43399 43403 43411 43427 43441 43451 43457 43481 43487 43499 43517 43541 43543 43573 43577 43579 43591 43597 43607 43609 43613 43627 43633 43649 43651 43661 43669 43691 43711 43717 43721 43753 43759 43777 43781 43783 43787 43789 43793 43801 43853 43867 43889 43891 43913 43933 43943 43951 43961 43963 43969 43973 43987 43991 43997 44017 44021 44027 44029 44041 44053 44059 44071 44087 44089 44101 44111 44119 44123 44129 44131 44159 44171 44179 44189 44201 44203 44207 44221 44249 44257 44263 44267 44269 44273 44279 44281 44293 44351 44357 44371 44381 44383 44389 44417 44449 44453 44483 44491 44497 44501 44507 44519 44531 44533 44537 44543 44549 44563 44579 44587 44617 44621 44623 44633 44641 44647 44651 44657 44683 44687 44699 44701 44711 44729 44741 44753 44771 44773 44777 44789 44797 44809 44819 44839 44843 44851 44867 44879 44887 44893 44909 44917 44927 44939 44953 44959 44963 44971 44983 44987 45007 45013 45053 45061 45077 45083 45119 45121 45127 45131 45137 45139 45161 45179 45181 45191 45197 45233 45247 45259 45263 45281 45289 45293 45307 45317 45319 45329 45337 45341 45343 45361 45377 45389 45403 45413 45427 45433 45439 45481 45491 45497 45503 45523 45533 45541 45553 45557 45569 45587 45589 45599 45613 45631 45641 45659 45667 45673 45677 45691 45697 45707 45737 45751 45757 45763 45767 45779 45817 45821 45823 45827 45833 45841 45853 45863 45869 45887 45893 45943 45949 45953 45959 45971 45979 45989 46021 46027 46049 46051 46061 46073 46091 46093 46099 46103 46133 46141 46147 46153 46171 46181 46183 46187 46199 46219 46229 46237 46261 46271 46273 46279 46301 46307 46309 46327 46337 46349 46351 46381 46399 46411 46439 46441 46447 46451 46457 46471 46477 46489 46499 46507 46511 46523 46549 46559 46567 46573 46589 46591 46601 46619 46633 46639 46643 46649 46663 46679 46681 46687 46691 46703 46723 46727 46747 46751 46757 46769 46771 46807 46811 46817 46819 46829 46831 46853 46861 46867 46877 46889 46901 46919 46933 46957 46993 46997 47017 47041 47051 47057 47059 47087 47093 47111 47119 47123 47129 47137 47143 47147 47149 47161 47189 47207 47221 47237 47251 47269 47279 47287 47293 47297 47303 47309 47317 47339 47351 47353 47363 47381 47387 47389 47407 47417 47419 47431 47441 47459 47491 47497 47501 47507 47513 47521 47527 47533 47543 47563 47569 47581 47591 47599 47609 47623 47629 47639 47653 47657 47659 47681 47699 47701 47711 47713 47717 47737 47741 47743 47777 47779 47791 47797 47807 47809 47819 47837 47843 47857 47869 47881 47903 47911 47917 47933 47939 47947 47951 47963 47969 47977 47981 48017 48023 48029 48049 48073 48079 48091 48109 48119 48121 48131 48157 48163 48179 48187 48193 48197 48221 48239 48247 48259 48271 48281 48299 48311 48313 48337 48341 48353 48371 48383 48397 48407 48409 48413 48437 48449 48463 48473 48479 48481 48487 48491 48497 48523 48527 48533 48539 48541 48563 48571 48589 48593 48611 48619 48623 48647 48649 48661 48673 48677 48679 48731 48733 48751 48757 48761 48767 48779 48781 48787 48799 48809 48817 48821 48823 48847 48857 48859 48869 48871 48883 48889 48907 48947 48953 48973 48989 48991 49003 49009 49019 49031 49033 49037 49043 49057 49069 49081 49103 49109 49117 49121 49123 49139 49157 49169 49171 49177 49193 49199 49201 49207 49211 49223 49253 49261 49277 49279 49297 49307 49331 49333 49339 49363 49367 49369 49391 49393 49409 49411 49417 49429 49433 49451 49459 49463 49477 49481 49499 49523 49529 49531 49537 49547 49549 49559 49597 49603 49613 49627 49633 49639 49663 49667 49669 49681 49697 49711 49727 49739 49741 49747 49757 49783 49787 49789 49801 49807 49811 49823 49831 49843 49853 49871 49877 49891 49919 49921 49927 49937 49939 49943 49957 49991 49993 49999 + 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 101 103 107 109 113 127 131 137 139 149 151 157 163 167 173 179 181 191 193 197 199 211 223 227 229 233 239 241 251 257 263 269 271 277 281 283 293 307 311 313 317 331 337 347 349 353 359 367 373 379 383 389 397 401 409 419 421 431 433 439 443 449 457 461 463 467 479 487 491 499 503 509 521 523 541 547 557 563 569 571 577 587 593 599 601 607 613 617 619 631 641 643 647 653 659 661 673 677 683 691 701 709 719 727 733 739 743 751 757 761 769 773 787 797 809 811 821 823 827 829 839 853 857 859 863 877 881 883 887 907 911 919 929 937 941 947 953 967 971 977 983 991 997 1009 1013 1019 1021 1031 1033 1039 1049 1051 1061 1063 1069 1087 1091 1093 1097 1103 1109 1117 1123 1129 1151 1153 1163 1171 1181 1187 1193 1201 1213 1217 1223 1229 1231 1237 1249 1259 1277 1279 1283 1289 1291 1297 1301 1303 1307 1319 1321 1327 1361 1367 1373 1381 1399 1409 1423 1427 1429 1433 1439 1447 1451 1453 1459 1471 1481 1483 1487 1489 1493 1499 1511 1523 1531 1543 1549 1553 1559 1567 1571 1579 1583 1597 1601 1607 1609 1613 1619 1621 1627 1637 1657 1663 1667 1669 1693 1697 1699 1709 1721 1723 1733 1741 1747 1753 1759 1777 1783 1787 1789 1801 1811 1823 1831 1847 1861 1867 1871 1873 1877 1879 1889 1901 1907 1913 1931 1933 1949 1951 1973 1979 1987 1993 1997 1999 2003 2011 2017 2027 2029 2039 2053 2063 2069 2081 2083 2087 2089 2099 2111 2113 2129 2131 2137 2141 2143 2153 2161 2179 2203 2207 2213 2221 2237 2239 2243 2251 2267 2269 2273 2281 2287 2293 2297 2309 2311 2333 2339 2341 2347 2351 2357 2371 2377 2381 2383 2389 2393 2399 2411 2417 2423 2437 2441 2447 2459 2467 2473 2477 2503 2521 2531 2539 2543 2549 2551 2557 2579 2591 2593 2609 2617 2621 2633 2647 2657 2659 2663 2671 2677 2683 2687 2689 2693 2699 2707 2711 2713 2719 2729 2731 2741 2749 2753 2767 2777 2789 2791 2797 2801 2803 2819 2833 2837 2843 2851 2857 2861 2879 2887 2897 2903 2909 2917 2927 2939 2953 2957 2963 2969 2971 2999 3001 3011 3019 3023 3037 3041 3049 3061 3067 3079 3083 3089 3109 3119 3121 3137 3163 3167 3169 3181 3187 3191 3203 3209 3217 3221 3229 3251 3253 3257 3259 3271 3299 3301 3307 3313 3319 3323 3329 3331 3343 3347 3359 3361 3371 3373 3389 3391 3407 3413 3433 3449 3457 3461 3463 3467 3469 3491 3499 3511 3517 3527 3529 3533 3539 3541 3547 3557 3559 3571 3581 3583 3593 3607 3613 3617 3623 3631 3637 3643 3659 3671 3673 3677 3691 3697 3701 3709 3719 3727 3733 3739 3761 3767 3769 3779 3793 3797 3803 3821 3823 3833 3847 3851 3853 3863 3877 3881 3889 3907 3911 3917 3919 3923 3929 3931 3943 3947 3967 3989 4001 4003 4007 4013 4019 4021 4027 4049 4051 4057 4073 4079 4091 4093 4099 4111 4127 4129 4133 4139 4153 4157 4159 4177 4201 4211 4217 4219 4229 4231 4241 4243 4253 4259 4261 4271 4273 4283 4289 4297 4327 4337 4339 4349 4357 4363 4373 4391 4397 4409 4421 4423 4441 4447 4451 4457 4463 4481 4483 4493 4507 4513 4517 4519 4523 4547 4549 4561 4567 4583 4591 4597 4603 4621 4637 4639 4643 4649 4651 4657 4663 4673 4679 4691 4703 4721 4723 4729 4733 4751 4759 4783 4787 4789 4793 4799 4801 4813 4817 4831 4861 4871 4877 4889 4903 4909 4919 4931 4933 4937 4943 4951 4957 4967 4969 4973 4987 4993 4999 5003 5009 5011 5021 5023 5039 5051 5059 5077 5081 5087 5099 5101 5107 5113 5119 5147 5153 5167 5171 5179 5189 5197 5209 5227 5231 5233 5237 5261 5273 5279 5281 5297 5303 5309 5323 5333 5347 5351 5381 5387 5393 5399 5407 5413 5417 5419 5431 5437 5441 5443 5449 5471 5477 5479 5483 5501 5503 5507 5519 5521 5527 5531 5557 5563 5569 5573 5581 5591 5623 5639 5641 5647 5651 5653 5657 5659 5669 5683 5689 5693 5701 5711 5717 5737 5741 5743 5749 5779 5783 5791 5801 5807 5813 5821 5827 5839 5843 5849 5851 5857 5861 5867 5869 5879 5881 5897 5903 5923 5927 5939 5953 5981 5987 6007 6011 6029 6037 6043 6047 6053 6067 6073 6079 6089 6091 6101 6113 6121 6131 6133 6143 6151 6163 6173 6197 6199 6203 6211 6217 6221 6229 6247 6257 6263 6269 6271 6277 6287 6299 6301 6311 6317 6323 6329 6337 6343 6353 6359 6361 6367 6373 6379 6389 6397 6421 6427 6449 6451 6469 6473 6481 6491 6521 6529 6547 6551 6553 6563 6569 6571 6577 6581 6599 6607 6619 6637 6653 6659 6661 6673 6679 6689 6691 6701 6703 6709 6719 6733 6737 6761 6763 6779 6781 6791 6793 6803 6823 6827 6829 6833 6841 6857 6863 6869 6871 6883 6899 6907 6911 6917 6947 6949 6959 6961 6967 6971 6977 6983 6991 6997 7001 7013 7019 7027 7039 7043 7057 7069 7079 7103 7109 7121 7127 7129 7151 7159 7177 7187 7193 7207 7211 7213 7219 7229 7237 7243 7247 7253 7283 7297 7307 7309 7321 7331 7333 7349 7351 7369 7393 7411 7417 7433 7451 7457 7459 7477 7481 7487 7489 7499 7507 7517 7523 7529 7537 7541 7547 7549 7559 7561 7573 7577 7583 7589 7591 7603 7607 7621 7639 7643 7649 7669 7673 7681 7687 7691 7699 7703 7717 7723 7727 7741 7753 7757 7759 7789 7793 7817 7823 7829 7841 7853 7867 7873 7877 7879 7883 7901 7907 7919 7927 7933 7937 7949 7951 7963 7993 8009 8011 8017 8039 8053 8059 8069 8081 8087 8089 8093 8101 8111 8117 8123 8147 8161 8167 8171 8179 8191 8209 8219 8221 8231 8233 8237 8243 8263 8269 8273 8287 8291 8293 8297 8311 8317 8329 8353 8363 8369 8377 8387 8389 8419 8423 8429 8431 8443 8447 8461 8467 8501 8513 8521 8527 8537 8539 8543 8563 8573 8581 8597 8599 8609 8623 8627 8629 8641 8647 8663 8669 8677 8681 8689 8693 8699 8707 8713 8719 8731 8737 8741 8747 8753 8761 8779 8783 8803 8807 8819 8821 8831 8837 8839 8849 8861 8863 8867 8887 8893 8923 8929 8933 8941 8951 8963 8969 8971 8999 9001 9007 9011 9013 9029 9041 9043 9049 9059 9067 9091 9103 9109 9127 9133 9137 9151 9157 9161 9173 9181 9187 9199 9203 9209 9221 9227 9239 9241 9257 9277 9281 9283 9293 9311 9319 9323 9337 9341 9343 9349 9371 9377 9391 9397 9403 9413 9419 9421 9431 9433 9437 9439 9461 9463 9467 9473 9479 9491 9497 9511 9521 9533 9539 9547 9551 9587 9601 9613 9619 9623 9629 9631 9643 9649 9661 9677 9679 9689 9697 9719 9721 9733 9739 9743 9749 9767 9769 9781 9787 9791 9803 9811 9817 9829 9833 9839 9851 9857 9859 9871 9883 9887 9901 9907 9923 9929 9931 9941 9949 9967 9973 10007 10009 10037 10039 10061 10067 10069 10079 10091 10093 10099 10103 10111 10133 10139 10141 10151 10159 10163 10169 10177 10181 10193 10211 10223 10243 10247 10253 10259 10267 10271 10273 10289 10301 10303 10313 10321 10331 10333 10337 10343 10357 10369 10391 10399 10427 10429 10433 10453 10457 10459 10463 10477 10487 10499 10501 10513 10529 10531 10559 10567 10589 10597 10601 10607 10613 10627 10631 10639 10651 10657 10663 10667 10687 10691 10709 10711 10723 10729 10733 10739 10753 10771 10781 10789 10799 10831 10837 10847 10853 10859 10861 10867 10883 10889 10891 10903 10909 10937 10939 10949 10957 10973 10979 10987 10993 11003 11027 11047 11057 11059 11069 11071 11083 11087 11093 11113 11117 11119 11131 11149 11159 11161 11171 11173 11177 11197 11213 11239 11243 11251 11257 11261 11273 11279 11287 11299 11311 11317 11321 11329 11351 11353 11369 11383 11393 11399 11411 11423 11437 11443 11447 11467 11471 11483 11489 11491 11497 11503 11519 11527 11549 11551 11579 11587 11593 11597 11617 11621 11633 11657 11677 11681 11689 11699 11701 11717 11719 11731 11743 11777 11779 11783 11789 11801 11807 11813 11821 11827 11831 11833 11839 11863 11867 11887 11897 11903 11909 11923 11927 11933 11939 11941 11953 11959 11969 11971 11981 11987 12007 12011 12037 12041 12043 12049 12071 12073 12097 12101 12107 12109 12113 12119 12143 12149 12157 12161 12163 12197 12203 12211 12227 12239 12241 12251 12253 12263 12269 12277 12281 12289 12301 12323 12329 12343 12347 12373 12377 12379 12391 12401 12409 12413 12421 12433 12437 12451 12457 12473 12479 12487 12491 12497 12503 12511 12517 12527 12539 12541 12547 12553 12569 12577 12583 12589 12601 12611 12613 12619 12637 12641 12647 12653 12659 12671 12689 12697 12703 12713 12721 12739 12743 12757 12763 12781 12791 12799 12809 12821 12823 12829 12841 12853 12889 12893 12899 12907 12911 12917 12919 12923 12941 12953 12959 12967 12973 12979 12983 13001 13003 13007 13009 13033 13037 13043 13049 13063 13093 13099 13103 13109 13121 13127 13147 13151 13159 13163 13171 13177 13183 13187 13217 13219 13229 13241 13249 13259 13267 13291 13297 13309 13313 13327 13331 13337 13339 13367 13381 13397 13399 13411 13417 13421 13441 13451 13457 13463 13469 13477 13487 13499 13513 13523 13537 13553 13567 13577 13591 13597 13613 13619 13627 13633 13649 13669 13679 13681 13687 13691 13693 13697 13709 13711 13721 13723 13729 13751 13757 13759 13763 13781 13789 13799 13807 13829 13831 13841 13859 13873 13877 13879 13883 13901 13903 13907 13913 13921 13931 13933 13963 13967 13997 13999 14009 14011 14029 14033 14051 14057 14071 14081 14083 14087 14107 14143 14149 14153 14159 14173 14177 14197 14207 14221 14243 14249 14251 14281 14293 14303 14321 14323 14327 14341 14347 14369 14387 14389 14401 14407 14411 14419 14423 14431 14437 14447 14449 14461 14479 14489 14503 14519 14533 14537 14543 14549 14551 14557 14561 14563 14591 14593 14621 14627 14629 14633 14639 14653 14657 14669 14683 14699 14713 14717 14723 14731 14737 14741 14747 14753 14759 14767 14771 14779 14783 14797 14813 14821 14827 14831 14843 14851 14867 14869 14879 14887 14891 14897 14923 14929 14939 14947 14951 14957 14969 14983 15013 15017 15031 15053 15061 15073 15077 15083 15091 15101 15107 15121 15131 15137 15139 15149 15161 15173 15187 15193 15199 15217 15227 15233 15241 15259 15263 15269 15271 15277 15287 15289 15299 15307 15313 15319 15329 15331 15349 15359 15361 15373 15377 15383 15391 15401 15413 15427 15439 15443 15451 15461 15467 15473 15493 15497 15511 15527 15541 15551 15559 15569 15581 15583 15601 15607 15619 15629 15641 15643 15647 15649 15661 15667 15671 15679 15683 15727 15731 15733 15737 15739 15749 15761 15767 15773 15787 15791 15797 15803 15809 15817 15823 15859 15877 15881 15887 15889 15901 15907 15913 15919 15923 15937 15959 15971 15973 15991 16001 16007 16033 16057 16061 16063 16067 16069 16073 16087 16091 16097 16103 16111 16127 16139 16141 16183 16187 16189 16193 16217 16223 16229 16231 16249 16253 16267 16273 16301 16319 16333 16339 16349 16361 16363 16369 16381 16411 16417 16421 16427 16433 16447 16451 16453 16477 16481 16487 16493 16519 16529 16547 16553 16561 16567 16573 16603 16607 16619 16631 16633 16649 16651 16657 16661 16673 16691 16693 16699 16703 16729 16741 16747 16759 16763 16787 16811 16823 16829 16831 16843 16871 16879 16883 16889 16901 16903 16921 16927 16931 16937 16943 16963 16979 16981 16987 16993 17011 17021 17027 17029 17033 17041 17047 17053 17077 17093 17099 17107 17117 17123 17137 17159 17167 17183 17189 17191 17203 17207 17209 17231 17239 17257 17291 17293 17299 17317 17321 17327 17333 17341 17351 17359 17377 17383 17387 17389 17393 17401 17417 17419 17431 17443 17449 17467 17471 17477 17483 17489 17491 17497 17509 17519 17539 17551 17569 17573 17579 17581 17597 17599 17609 17623 17627 17657 17659 17669 17681 17683 17707 17713 17729 17737 17747 17749 17761 17783 17789 17791 17807 17827 17837 17839 17851 17863 17881 17891 17903 17909 17911 17921 17923 17929 17939 17957 17959 17971 17977 17981 17987 17989 18013 18041 18043 18047 18049 18059 18061 18077 18089 18097 18119 18121 18127 18131 18133 18143 18149 18169 18181 18191 18199 18211 18217 18223 18229 18233 18251 18253 18257 18269 18287 18289 18301 18307 18311 18313 18329 18341 18353 18367 18371 18379 18397 18401 18413 18427 18433 18439 18443 18451 18457 18461 18481 18493 18503 18517 18521 18523 18539 18541 18553 18583 18587 18593 18617 18637 18661 18671 18679 18691 18701 18713 18719 18731 18743 18749 18757 18773 18787 18793 18797 18803 18839 18859 18869 18899 18911 18913 18917 18919 18947 18959 18973 18979 19001 19009 19013 19031 19037 19051 19069 19073 19079 19081 19087 19121 19139 19141 19157 19163 19181 19183 19207 19211 19213 19219 19231 19237 19249 19259 19267 19273 19289 19301 19309 19319 19333 19373 19379 19381 19387 19391 19403 19417 19421 19423 19427 19429 19433 19441 19447 19457 19463 19469 19471 19477 19483 19489 19501 19507 19531 19541 19543 19553 19559 19571 19577 19583 19597 19603 19609 19661 19681 19687 19697 19699 19709 19717 19727 19739 19751 19753 19759 19763 19777 19793 19801 19813 19819 19841 19843 19853 19861 19867 19889 19891 19913 19919 19927 19937 19949 19961 19963 19973 19979 19991 19993 19997 20011 20021 20023 20029 20047 20051 20063 20071 20089 20101 20107 20113 20117 20123 20129 20143 20147 20149 20161 20173 20177 20183 20201 20219 20231 20233 20249 20261 20269 20287 20297 20323 20327 20333 20341 20347 20353 20357 20359 20369 20389 20393 20399 20407 20411 20431 20441 20443 20477 20479 20483 20507 20509 20521 20533 20543 20549 20551 20563 20593 20599 20611 20627 20639 20641 20663 20681 20693 20707 20717 20719 20731 20743 20747 20749 20753 20759 20771 20773 20789 20807 20809 20849 20857 20873 20879 20887 20897 20899 20903 20921 20929 20939 20947 20959 20963 20981 20983 21001 21011 21013 21017 21019 21023 21031 21059 21061 21067 21089 21101 21107 21121 21139 21143 21149 21157 21163 21169 21179 21187 21191 21193 21211 21221 21227 21247 21269 21277 21283 21313 21317 21319 21323 21341 21347 21377 21379 21383 21391 21397 21401 21407 21419 21433 21467 21481 21487 21491 21493 21499 21503 21517 21521 21523 21529 21557 21559 21563 21569 21577 21587 21589 21599 21601 21611 21613 21617 21647 21649 21661 21673 21683 21701 21713 21727 21737 21739 21751 21757 21767 21773 21787 21799 21803 21817 21821 21839 21841 21851 21859 21863 21871 21881 21893 21911 21929 21937 21943 21961 21977 21991 21997 22003 22013 22027 22031 22037 22039 22051 22063 22067 22073 22079 22091 22093 22109 22111 22123 22129 22133 22147 22153 22157 22159 22171 22189 22193 22229 22247 22259 22271 22273 22277 22279 22283 22291 22303 22307 22343 22349 22367 22369 22381 22391 22397 22409 22433 22441 22447 22453 22469 22481 22483 22501 22511 22531 22541 22543 22549 22567 22571 22573 22613 22619 22621 22637 22639 22643 22651 22669 22679 22691 22697 22699 22709 22717 22721 22727 22739 22741 22751 22769 22777 22783 22787 22807 22811 22817 22853 22859 22861 22871 22877 22901 22907 22921 22937 22943 22961 22963 22973 22993 23003 23011 23017 23021 23027 23029 23039 23041 23053 23057 23059 23063 23071 23081 23087 23099 23117 23131 23143 23159 23167 23173 23189 23197 23201 23203 23209 23227 23251 23269 23279 23291 23293 23297 23311 23321 23327 23333 23339 23357 23369 23371 23399 23417 23431 23447 23459 23473 23497 23509 23531 23537 23539 23549 23557 23561 23563 23567 23581 23593 23599 23603 23609 23623 23627 23629 23633 23663 23669 23671 23677 23687 23689 23719 23741 23743 23747 23753 23761 23767 23773 23789 23801 23813 23819 23827 23831 23833 23857 23869 23873 23879 23887 23893 23899 23909 23911 23917 23929 23957 23971 23977 23981 23993 24001 24007 24019 24023 24029 24043 24049 24061 24071 24077 24083 24091 24097 24103 24107 24109 24113 24121 24133 24137 24151 24169 24179 24181 24197 24203 24223 24229 24239 24247 24251 24281 24317 24329 24337 24359 24371 24373 24379 24391 24407 24413 24419 24421 24439 24443 24469 24473 24481 24499 24509 24517 24527 24533 24547 24551 24571 24593 24611 24623 24631 24659 24671 24677 24683 24691 24697 24709 24733 24749 24763 24767 24781 24793 24799 24809 24821 24841 24847 24851 24859 24877 24889 24907 24917 24919 24923 24943 24953 24967 24971 24977 24979 24989 25013 25031 25033 25037 25057 25073 25087 25097 25111 25117 25121 25127 25147 25153 25163 25169 25171 25183 25189 25219 25229 25237 25243 25247 25253 25261 25301 25303 25307 25309 25321 25339 25343 25349 25357 25367 25373 25391 25409 25411 25423 25439 25447 25453 25457 25463 25469 25471 25523 25537 25541 25561 25577 25579 25583 25589 25601 25603 25609 25621 25633 25639 25643 25657 25667 25673 25679 25693 25703 25717 25733 25741 25747 25759 25763 25771 25793 25799 25801 25819 25841 25847 25849 25867 25873 25889 25903 25913 25919 25931 25933 25939 25943 25951 25969 25981 25997 25999 26003 26017 26021 26029 26041 26053 26083 26099 26107 26111 26113 26119 26141 26153 26161 26171 26177 26183 26189 26203 26209 26227 26237 26249 26251 26261 26263 26267 26293 26297 26309 26317 26321 26339 26347 26357 26371 26387 26393 26399 26407 26417 26423 26431 26437 26449 26459 26479 26489 26497 26501 26513 26539 26557 26561 26573 26591 26597 26627 26633 26641 26647 26669 26681 26683 26687 26693 26699 26701 26711 26713 26717 26723 26729 26731 26737 26759 26777 26783 26801 26813 26821 26833 26839 26849 26861 26863 26879 26881 26891 26893 26903 26921 26927 26947 26951 26953 26959 26981 26987 26993 27011 27017 27031 27043 27059 27061 27067 27073 27077 27091 27103 27107 27109 27127 27143 27179 27191 27197 27211 27239 27241 27253 27259 27271 27277 27281 27283 27299 27329 27337 27361 27367 27397 27407 27409 27427 27431 27437 27449 27457 27479 27481 27487 27509 27527 27529 27539 27541 27551 27581 27583 27611 27617 27631 27647 27653 27673 27689 27691 27697 27701 27733 27737 27739 27743 27749 27751 27763 27767 27773 27779 27791 27793 27799 27803 27809 27817 27823 27827 27847 27851 27883 27893 27901 27917 27919 27941 27943 27947 27953 27961 27967 27983 27997 28001 28019 28027 28031 28051 28057 28069 28081 28087 28097 28099 28109 28111 28123 28151 28163 28181 28183 28201 28211 28219 28229 28277 28279 28283 28289 28297 28307 28309 28319 28349 28351 28387 28393 28403 28409 28411 28429 28433 28439 28447 28463 28477 28493 28499 28513 28517 28537 28541 28547 28549 28559 28571 28573 28579 28591 28597 28603 28607 28619 28621 28627 28631 28643 28649 28657 28661 28663 28669 28687 28697 28703 28711 28723 28729 28751 28753 28759 28771 28789 28793 28807 28813 28817 28837 28843 28859 28867 28871 28879 28901 28909 28921 28927 28933 28949 28961 28979 29009 29017 29021 29023 29027 29033 29059 29063 29077 29101 29123 29129 29131 29137 29147 29153 29167 29173 29179 29191 29201 29207 29209 29221 29231 29243 29251 29269 29287 29297 29303 29311 29327 29333 29339 29347 29363 29383 29387 29389 29399 29401 29411 29423 29429 29437 29443 29453 29473 29483 29501 29527 29531 29537 29567 29569 29573 29581 29587 29599 29611 29629 29633 29641 29663 29669 29671 29683 29717 29723 29741 29753 29759 29761 29789 29803 29819 29833 29837 29851 29863 29867 29873 29879 29881 29917 29921 29927 29947 29959 29983 29989 30011 30013 30029 30047 30059 30071 30089 30091 30097 30103 30109 30113 30119 30133 30137 30139 30161 30169 30181 30187 30197 30203 30211 30223 30241 30253 30259 30269 30271 30293 30307 30313 30319 30323 30341 30347 30367 30389 30391 30403 30427 30431 30449 30467 30469 30491 30493 30497 30509 30517 30529 30539 30553 30557 30559 30577 30593 30631 30637 30643 30649 30661 30671 30677 30689 30697 30703 30707 30713 30727 30757 30763 30773 30781 30803 30809 30817 30829 30839 30841 30851 30853 30859 30869 30871 30881 30893 30911 30931 30937 30941 30949 30971 30977 30983 31013 31019 31033 31039 31051 31063 31069 31079 31081 31091 31121 31123 31139 31147 31151 31153 31159 31177 31181 31183 31189 31193 31219 31223 31231 31237 31247 31249 31253 31259 31267 31271 31277 31307 31319 31321 31327 31333 31337 31357 31379 31387 31391 31393 31397 31469 31477 31481 31489 31511 31513 31517 31531 31541 31543 31547 31567 31573 31583 31601 31607 31627 31643 31649 31657 31663 31667 31687 31699 31721 31723 31727 31729 31741 31751 31769 31771 31793 31799 31817 31847 31849 31859 31873 31883 31891 31907 31957 31963 31973 31981 31991 32003 32009 32027 32029 32051 32057 32059 32063 32069 32077 32083 32089 32099 32117 32119 32141 32143 32159 32173 32183 32189 32191 32203 32213 32233 32237 32251 32257 32261 32297 32299 32303 32309 32321 32323 32327 32341 32353 32359 32363 32369 32371 32377 32381 32401 32411 32413 32423 32429 32441 32443 32467 32479 32491 32497 32503 32507 32531 32533 32537 32561 32563 32569 32573 32579 32587 32603 32609 32611 32621 32633 32647 32653 32687 32693 32707 32713 32717 32719 32749 32771 32779 32783 32789 32797 32801 32803 32831 32833 32839 32843 32869 32887 32909 32911 32917 32933 32939 32941 32957 32969 32971 32983 32987 32993 32999 33013 33023 33029 33037 33049 33053 33071 33073 33083 33091 33107 33113 33119 33149 33151 33161 33179 33181 33191 33199 33203 33211 33223 33247 33287 33289 33301 33311 33317 33329 33331 33343 33347 33349 33353 33359 33377 33391 33403 33409 33413 33427 33457 33461 33469 33479 33487 33493 33503 33521 33529 33533 33547 33563 33569 33577 33581 33587 33589 33599 33601 33613 33617 33619 33623 33629 33637 33641 33647 33679 33703 33713 33721 33739 33749 33751 33757 33767 33769 33773 33791 33797 33809 33811 33827 33829 33851 33857 33863 33871 33889 33893 33911 33923 33931 33937 33941 33961 33967 33997 34019 34031 34033 34039 34057 34061 34123 34127 34129 34141 34147 34157 34159 34171 34183 34211 34213 34217 34231 34253 34259 34261 34267 34273 34283 34297 34301 34303 34313 34319 34327 34337 34351 34361 34367 34369 34381 34403 34421 34429 34439 34457 34469 34471 34483 34487 34499 34501 34511 34513 34519 34537 34543 34549 34583 34589 34591 34603 34607 34613 34631 34649 34651 34667 34673 34679 34687 34693 34703 34721 34729 34739 34747 34757 34759 34763 34781 34807 34819 34841 34843 34847 34849 34871 34877 34883 34897 34913 34919 34939 34949 34961 34963 34981 35023 35027 35051 35053 35059 35069 35081 35083 35089 35099 35107 35111 35117 35129 35141 35149 35153 35159 35171 35201 35221 35227 35251 35257 35267 35279 35281 35291 35311 35317 35323 35327 35339 35353 35363 35381 35393 35401 35407 35419 35423 35437 35447 35449 35461 35491 35507 35509 35521 35527 35531 35533 35537 35543 35569 35573 35591 35593 35597 35603 35617 35671 35677 35729 35731 35747 35753 35759 35771 35797 35801 35803 35809 35831 35837 35839 35851 35863 35869 35879 35897 35899 35911 35923 35933 35951 35963 35969 35977 35983 35993 35999 36007 36011 36013 36017 36037 36061 36067 36073 36083 36097 36107 36109 36131 36137 36151 36161 36187 36191 36209 36217 36229 36241 36251 36263 36269 36277 36293 36299 36307 36313 36319 36341 36343 36353 36373 36383 36389 36433 36451 36457 36467 36469 36473 36479 36493 36497 36523 36527 36529 36541 36551 36559 36563 36571 36583 36587 36599 36607 36629 36637 36643 36653 36671 36677 36683 36691 36697 36709 36713 36721 36739 36749 36761 36767 36779 36781 36787 36791 36793 36809 36821 36833 36847 36857 36871 36877 36887 36899 36901 36913 36919 36923 36929 36931 36943 36947 36973 36979 36997 37003 37013 37019 37021 37039 37049 37057 37061 37087 37097 37117 37123 37139 37159 37171 37181 37189 37199 37201 37217 37223 37243 37253 37273 37277 37307 37309 37313 37321 37337 37339 37357 37361 37363 37369 37379 37397 37409 37423 37441 37447 37463 37483 37489 37493 37501 37507 37511 37517 37529 37537 37547 37549 37561 37567 37571 37573 37579 37589 37591 37607 37619 37633 37643 37649 37657 37663 37691 37693 37699 37717 37747 37781 37783 37799 37811 37813 37831 37847 37853 37861 37871 37879 37889 37897 37907 37951 37957 37963 37967 37987 37991 37993 37997 38011 38039 38047 38053 38069 38083 38113 38119 38149 38153 38167 38177 38183 38189 38197 38201 38219 38231 38237 38239 38261 38273 38281 38287 38299 38303 38317 38321 38327 38329 38333 38351 38371 38377 38393 38431 38447 38449 38453 38459 38461 38501 38543 38557 38561 38567 38569 38593 38603 38609 38611 38629 38639 38651 38653 38669 38671 38677 38693 38699 38707 38711 38713 38723 38729 38737 38747 38749 38767 38783 38791 38803 38821 38833 38839 38851 38861 38867 38873 38891 38903 38917 38921 38923 38933 38953 38959 38971 38977 38993 39019 39023 39041 39043 39047 39079 39089 39097 39103 39107 39113 39119 39133 39139 39157 39161 39163 39181 39191 39199 39209 39217 39227 39229 39233 39239 39241 39251 39293 39301 39313 39317 39323 39341 39343 39359 39367 39371 39373 39383 39397 39409 39419 39439 39443 39451 39461 39499 39503 39509 39511 39521 39541 39551 39563 39569 39581 39607 39619 39623 39631 39659 39667 39671 39679 39703 39709 39719 39727 39733 39749 39761 39769 39779 39791 39799 39821 39827 39829 39839 39841 39847 39857 39863 39869 39877 39883 39887 39901 39929 39937 39953 39971 39979 39983 39989 40009 40013 40031 40037 40039 40063 40087 40093 40099 40111 40123 40127 40129 40151 40153 40163 40169 40177 40189 40193 40213 40231 40237 40241 40253 40277 40283 40289 40343 40351 40357 40361 40387 40423 40427 40429 40433 40459 40471 40483 40487 40493 40499 40507 40519 40529 40531 40543 40559 40577 40583 40591 40597 40609 40627 40637 40639 40693 40697 40699 40709 40739 40751 40759 40763 40771 40787 40801 40813 40819 40823 40829 40841 40847 40849 40853 40867 40879 40883 40897 40903 40927 40933 40939 40949 40961 40973 40993 41011 41017 41023 41039 41047 41051 41057 41077 41081 41113 41117 41131 41141 41143 41149 41161 41177 41179 41183 41189 41201 41203 41213 41221 41227 41231 41233 41243 41257 41263 41269 41281 41299 41333 41341 41351 41357 41381 41387 41389 41399 41411 41413 41443 41453 41467 41479 41491 41507 41513 41519 41521 41539 41543 41549 41579 41593 41597 41603 41609 41611 41617 41621 41627 41641 41647 41651 41659 41669 41681 41687 41719 41729 41737 41759 41761 41771 41777 41801 41809 41813 41843 41849 41851 41863 41879 41887 41893 41897 41903 41911 41927 41941 41947 41953 41957 41959 41969 41981 41983 41999 42013 42017 42019 42023 42043 42061 42071 42073 42083 42089 42101 42131 42139 42157 42169 42179 42181 42187 42193 42197 42209 42221 42223 42227 42239 42257 42281 42283 42293 42299 42307 42323 42331 42337 42349 42359 42373 42379 42391 42397 42403 42407 42409 42433 42437 42443 42451 42457 42461 42463 42467 42473 42487 42491 42499 42509 42533 42557 42569 42571 42577 42589 42611 42641 42643 42649 42667 42677 42683 42689 42697 42701 42703 42709 42719 42727 42737 42743 42751 42767 42773 42787 42793 42797 42821 42829 42839 42841 42853 42859 42863 42899 42901 42923 42929 42937 42943 42953 42961 42967 42979 42989 43003 43013 43019 43037 43049 43051 43063 43067 43093 43103 43117 43133 43151 43159 43177 43189 43201 43207 43223 43237 43261 43271 43283 43291 43313 43319 43321 43331 43391 43397 43399 43403 43411 43427 43441 43451 43457 43481 43487 43499 43517 43541 43543 43573 43577 43579 43591 43597 43607 43609 43613 43627 43633 43649 43651 43661 43669 43691 43711 43717 43721 43753 43759 43777 43781 43783 43787 43789 43793 43801 43853 43867 43889 43891 43913 43933 43943 43951 43961 43963 43969 43973 43987 43991 43997 44017 44021 44027 44029 44041 44053 44059 44071 44087 44089 44101 44111 44119 44123 44129 44131 44159 44171 44179 44189 44201 44203 44207 44221 44249 44257 44263 44267 44269 44273 44279 44281 44293 44351 44357 44371 44381 44383 44389 44417 44449 44453 44483 44491 44497 44501 44507 44519 44531 44533 44537 44543 44549 44563 44579 44587 44617 44621 44623 44633 44641 44647 44651 44657 44683 44687 44699 44701 44711 44729 44741 44753 44771 44773 44777 44789 44797 44809 44819 44839 44843 44851 44867 44879 44887 44893 44909 44917 44927 44939 44953 44959 44963 44971 44983 44987 45007 45013 45053 45061 45077 45083 45119 45121 45127 45131 45137 45139 45161 45179 45181 45191 45197 45233 45247 45259 45263 45281 45289 45293 45307 45317 45319 45329 45337 45341 45343 45361 45377 45389 45403 45413 45427 45433 45439 45481 45491 45497 45503 45523 45533 45541 45553 45557 45569 45587 45589 45599 45613 45631 45641 45659 45667 45673 45677 45691 45697 45707 45737 45751 45757 45763 45767 45779 45817 45821 45823 45827 45833 45841 45853 45863 45869 45887 45893 45943 45949 45953 45959 45971 45979 45989 46021 46027 46049 46051 46061 46073 46091 46093 46099 46103 46133 46141 46147 46153 46171 46181 46183 46187 46199 46219 46229 46237 46261 46271 46273 46279 46301 46307 46309 46327 46337 46349 46351 46381 46399 46411 46439 46441 46447 46451 46457 46471 46477 46489 46499 46507 46511 46523 46549 46559 46567 46573 46589 46591 46601 46619 46633 46639 46643 46649 46663 46679 46681 46687 46691 46703 46723 46727 46747 46751 46757 46769 46771 46807 46811 46817 46819 46829 46831 46853 46861 46867 46877 46889 46901 46919 46933 46957 46993 46997 47017 47041 47051 47057 47059 47087 47093 47111 47119 47123 47129 47137 47143 47147 47149 47161 47189 47207 47221 47237 47251 47269 47279 47287 47293 47297 47303 47309 47317 47339 47351 47353 47363 47381 47387 47389 47407 47417 47419 47431 47441 47459 47491 47497 47501 47507 47513 47521 47527 47533 47543 47563 47569 47581 47591 47599 47609 47623 47629 47639 47653 47657 47659 47681 47699 47701 47711 47713 47717 47737 47741 47743 47777 47779 47791 47797 47807 47809 47819 47837 47843 47857 47869 47881 47903 47911 47917 47933 47939 47947 47951 47963 47969 47977 47981 48017 48023 48029 48049 48073 48079 48091 48109 48119 48121 48131 48157 48163 48179 48187 48193 48197 48221 48239 48247 48259 48271 48281 48299 48311 48313 48337 48341 48353 48371 48383 48397 48407 48409 48413 48437 48449 48463 48473 48479 48481 48487 48491 48497 48523 48527 48533 48539 48541 48563 48571 48589 48593 48611 48619 48623 48647 48649 48661 48673 48677 48679 48731 48733 48751 48757 48761 48767 48779 48781 48787 48799 48809 48817 48821 48823 48847 48857 48859 48869 48871 48883 48889 48907 48947 48953 48973 48989 48991 49003 49009 49019 49031 49033 49037 49043 49057 49069 49081 49103 49109 49117 49121 49123 49139 49157 49169 49171 49177 49193 49199 49201 49207 49211 49223 49253 49261 49277 49279 49297 49307 49331 49333 49339 49363 49367 49369 49391 49393 49409 49411 49417 49429 49433 49451 49459 49463 49477 49481 49499 49523 49529 49531 49537 49547 49549 49559 49597 49603 49613 49627 49633 49639 49663 49667 49669 49681 49697 49711 49727 49739 49741 49747 49757 49783 49787 49789 49801 49807 49811 49823 49831 49843 49853 49871 49877 49891 49919 49921 49927 49937 49939 49943 49957 49991 49993 49999 diff --git a/testsuite/tests/misc/takc.ml b/testsuite/tests/misc/takc.ml index 8f9400ebdf..89bb38755f 100644 --- a/testsuite/tests/misc/takc.ml +++ b/testsuite/tests/misc/takc.ml @@ -20,4 +20,3 @@ let rec repeat n = if n <= 0 then 0 else tak 18 12 6 + repeat(n-1) let _ = print_int (repeat 2000); print_newline(); exit 0 - diff --git a/testsuite/tests/prim-revapply/Makefile b/testsuite/tests/prim-revapply/Makefile new file mode 100644 index 0000000000..bcc2fdb011 --- /dev/null +++ b/testsuite/tests/prim-revapply/Makefile @@ -0,0 +1,4 @@ +BASEDIR=../.. + +include $(BASEDIR)/makefiles/Makefile.several +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/prim-revapply/apply.ml b/testsuite/tests/prim-revapply/apply.ml new file mode 100644 index 0000000000..1a169e18e5 --- /dev/null +++ b/testsuite/tests/prim-revapply/apply.ml @@ -0,0 +1,36 @@ +external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" + +let f x = x + x +let g x = x * x +let h x = x + 1 +let add x y = x + y + +let _ = + List.iter (fun x -> + print_int x; print_newline () + ) + [ + f @@ 3; (* 6 *) + g @@ f @@ 3; (* 36 *) + f @@ g @@ 3; (* 18 *) + h @@ g @@ f @@ 3; (* 37 *) + add 4 @@ g @@ f @@ add 3 @@ add 2 @@ 3; (* 260 *) + ] +external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" + +let f x = x + x +let g x = x * x +let h x = x + 1 +let add x y = x + y + +let _ = + List.iter (fun x -> + print_int x; print_newline () + ) + [ + f @@ 3; (* 6 *) + g @@ f @@ 3; (* 36 *) + f @@ g @@ 3; (* 18 *) + h @@ g @@ f @@ 3; (* 37 *) + add 4 @@ g @@ f @@ add 3 @@ add 2 @@ 3; (* 260 *) + ] diff --git a/testsuite/tests/prim-revapply/apply.reference b/testsuite/tests/prim-revapply/apply.reference new file mode 100644 index 0000000000..07fc0dc4ce --- /dev/null +++ b/testsuite/tests/prim-revapply/apply.reference @@ -0,0 +1,10 @@ +6 +36 +18 +37 +260 +6 +36 +18 +37 +260 diff --git a/testsuite/tests/prim-revapply/revapply.ml b/testsuite/tests/prim-revapply/revapply.ml new file mode 100644 index 0000000000..f8b0dc2e95 --- /dev/null +++ b/testsuite/tests/prim-revapply/revapply.ml @@ -0,0 +1,18 @@ +external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" + +let f x = x + x +let g x = x * x +let h x = x + 1 +let add x y = x + y + +let _ = + List.iter (fun x -> + print_int x; print_newline () + ) + [ + 3 |> f; (* 6 *) + 3 |> f |> g; (* 36 *) + 3 |> g |> f; (* 18 *) + 3 |> f |> g |> h; (* 37 *) + 3 |> add 2 |> add 3 |> f |> g |> add 4; (* 260 *) + ] diff --git a/testsuite/tests/prim-revapply/revapply.reference b/testsuite/tests/prim-revapply/revapply.reference new file mode 100644 index 0000000000..fbca4428dd --- /dev/null +++ b/testsuite/tests/prim-revapply/revapply.reference @@ -0,0 +1,5 @@ +6 +36 +18 +37 +260 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-lexyacc/gram_aux.ml b/testsuite/tests/tool-lexyacc/gram_aux.ml index c00fa9bfe1..c082ea1bc3 100644 --- a/testsuite/tests/tool-lexyacc/gram_aux.ml +++ b/testsuite/tests/tool-lexyacc/gram_aux.ml @@ -44,4 +44,3 @@ let rec subtract l1 l2 = match l1 with [] -> [] | a::l -> if List.mem a l2 then subtract l l2 else a :: subtract l l2 - diff --git a/testsuite/tests/tool-lexyacc/grammar.mly b/testsuite/tests/tool-lexyacc/grammar.mly index 8d1346f8e3..267b71e3d3 100644 --- a/testsuite/tests/tool-lexyacc/grammar.mly +++ b/testsuite/tests/tool-lexyacc/grammar.mly @@ -50,7 +50,7 @@ header: other_definitions: other_definitions Tand definition { $3::$1 } - | + | { [] } ; definition: @@ -111,4 +111,3 @@ char_class1: ; %% - diff --git a/testsuite/tests/tool-lexyacc/input b/testsuite/tests/tool-lexyacc/input index b6fdfee8df..da2f06aa7a 100644 --- a/testsuite/tests/tool-lexyacc/input +++ b/testsuite/tests/tool-lexyacc/input @@ -21,27 +21,27 @@ open Scan_aux } rule main = parse - [' ' '\010' '\013' '\009' ] + + [' ' '\010' '\013' '\009' ] + { main lexbuf } - | "(*" + | "(*" { comment_depth := 1; comment lexbuf; main lexbuf } | (['A'-'Z' 'a'-'z'] | '_' ['A'-'Z' 'a'-'z' '\'' '0'-'9']) - ( '_' ? ['A'-'Z' 'a'-'z' ''' '0'-'9'] ) * + ( '_' ? ['A'-'Z' 'a'-'z' ''' '0'-'9'] ) * { match Lexing.lexeme lexbuf with "rule" -> Trule | "parse" -> Tparse | "and" -> Tand | "eof" -> Teof | s -> Tident s } - | '"' + | '"' { reset_string_buffer(); string lexbuf; Tstring(get_stored_string()) } - | "'" + | "'" { Tchar(char lexbuf) } - | '{' + | '{' { let n1 = Lexing.lexeme_end lexbuf in brace_depth := 1; let n2 = action lexbuf in @@ -66,68 +66,68 @@ rule main = parse { raise(Lexical_error("illegal character " ^ Lexing.lexeme lexbuf)) } and action = parse - '{' + '{' { incr brace_depth; action lexbuf } - | '}' + | '}' { decr brace_depth; if !brace_depth = 0 then Lexing.lexeme_start lexbuf else action lexbuf } - | '"' + | '"' { reset_string_buffer(); string lexbuf; reset_string_buffer(); action lexbuf } | '\'' { let _ = char lexbuf in action lexbuf } - | "(*" + | "(*" { comment_depth := 1; comment lexbuf; action lexbuf } - | eof + | eof { raise (Lexical_error "unterminated action") } - | _ + | _ { action lexbuf } - + and string = parse - '"' + '"' { () } | '\\' [' ' '\010' '\013' '\009' '\026' '\012'] + { string lexbuf } - | '\\' ['\\' '"' 'n' 't' 'b' 'r'] + | '\\' ['\\' '"' 'n' 't' 'b' 'r'] { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)); string lexbuf } - | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] + | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] { store_string_char(char_for_decimal_code lexbuf 1); string lexbuf } - | eof + | eof { raise(Lexical_error "unterminated string") } - | _ + | _ { store_string_char(Lexing.lexeme_char lexbuf 0); string lexbuf } and char = parse - [^ '\\'] "'" + [^ '\\'] "'" { Lexing.lexeme_char lexbuf 0 } - | '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'" + | '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'" { char_for_backslash (Lexing.lexeme_char lexbuf 1) } - | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" + | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" { char_for_decimal_code lexbuf 1 } - | _ + | _ { raise(Lexical_error "bad character constant") } and comment = parse - "(*" + "(*" { incr comment_depth; comment lexbuf } - | "*)" + | "*)" { decr comment_depth; if !comment_depth = 0 then () else comment lexbuf } - | '"' + | '"' { reset_string_buffer(); string lexbuf; reset_string_buffer(); comment lexbuf } - | eof + | eof { raise(Lexical_error "unterminated comment") } - | _ + | _ { comment lexbuf } ;; diff --git a/testsuite/tests/tool-lexyacc/input.ml b/testsuite/tests/tool-lexyacc/input.ml index 57d17c08d1..002bf72c7e 100644 --- a/testsuite/tests/tool-lexyacc/input.ml +++ b/testsuite/tests/tool-lexyacc/input.ml @@ -309,4 +309,3 @@ and char lexbuf = and comment lexbuf = Lexing.init lexbuf; state_4 lexbuf - diff --git a/testsuite/tests/tool-lexyacc/lexgen.ml b/testsuite/tests/tool-lexyacc/lexgen.ml index d4b6f9a96e..8a3e36a612 100644 --- a/testsuite/tests/tool-lexyacc/lexgen.ml +++ b/testsuite/tests/tool-lexyacc/lexgen.ml @@ -200,7 +200,7 @@ let memory = (Hashtbl.create 131 : (transition list, int) Hashtbl.t) let todo = ref ([] : (transition list * int) list) let next = ref 0 -let get_state st = +let get_state st = try Hashtbl.find memory st with Not_found -> @@ -222,7 +222,7 @@ let goto_state = function | ps -> Goto (get_state ps) -let transition_from chars follow pos_set = +let transition_from chars follow pos_set = let tr = Array.create 256 [] and shift = Array.create 256 Backtrack in List.iter @@ -263,4 +263,3 @@ let make_dfa lexdef = Array.create (number_of_states()) (Perform 0) in List.iter (fun (auto, i) -> v.(i) <- auto) states; (initial_states, v, actions) - diff --git a/testsuite/tests/tool-lexyacc/main.reference b/testsuite/tests/tool-lexyacc/main.reference index 7711833a4c..f3dac42291 100644 --- a/testsuite/tests/tool-lexyacc/main.reference +++ b/testsuite/tests/tool-lexyacc/main.reference @@ -310,4 +310,3 @@ and char lexbuf = and comment lexbuf = Lexing.init lexbuf; state_4 lexbuf - diff --git a/testsuite/tests/tool-lexyacc/output.ml b/testsuite/tests/tool-lexyacc/output.ml index 141510c445..0956b4069c 100644 --- a/testsuite/tests/tool-lexyacc/output.ml +++ b/testsuite/tests/tool-lexyacc/output.ml @@ -137,7 +137,7 @@ let output_state state_num = function (* 3- Generating the entry points *) - + let rec output_entries = function [] -> failwith "output_entries" | (name,state_num) :: rest -> @@ -146,7 +146,7 @@ let rec output_entries = function output_string !oc (" state_" ^ string_of_int state_num ^ " lexbuf\n"); match rest with - [] -> output_string !oc "\n"; () + [] -> () | _ -> output_string !oc "\nand "; output_entries rest @@ -164,6 +164,3 @@ let output_lexdef header (initial_st, st, actions) = output_state i st.(i) done; output_entries initial_st - - - diff --git a/testsuite/tests/tool-lexyacc/scan_aux.ml b/testsuite/tests/tool-lexyacc/scan_aux.ml index 7c796f353c..54da13ede0 100644 --- a/testsuite/tests/tool-lexyacc/scan_aux.ml +++ b/testsuite/tests/tool-lexyacc/scan_aux.ml @@ -57,4 +57,3 @@ let char_for_decimal_code lexbuf i = Char.chr(100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48)) - diff --git a/testsuite/tests/tool-lexyacc/scanner.mll b/testsuite/tests/tool-lexyacc/scanner.mll index f791feaf24..c304806292 100644 --- a/testsuite/tests/tool-lexyacc/scanner.mll +++ b/testsuite/tests/tool-lexyacc/scanner.mll @@ -21,27 +21,27 @@ open Scan_aux } rule main = parse - [' ' '\010' '\013' '\009' ] + + [' ' '\010' '\013' '\009' ] + { main lexbuf } - | "(*" + | "(*" { comment_depth := 1; comment lexbuf; main lexbuf } | (['A'-'Z' 'a'-'z'] | '_' ['A'-'Z' 'a'-'z' '\'' '0'-'9']) - ( '_' ? ['A'-'Z' 'a'-'z' ''' '0'-'9'] ) * + ( '_' ? ['A'-'Z' 'a'-'z' ''' '0'-'9'] ) * { match Lexing.lexeme lexbuf with "rule" -> Trule | "parse" -> Tparse | "and" -> Tand | "eof" -> Teof | s -> Tident s } - | '"' + | '"' { reset_string_buffer(); string lexbuf; Tstring(get_stored_string()) } - | "'" + | "'" { Tchar(char lexbuf) } - | '{' + | '{' { let n1 = Lexing.lexeme_end lexbuf in brace_depth := 1; let n2 = action lexbuf in @@ -66,67 +66,67 @@ rule main = parse { raise(Lexical_error("illegal character " ^ Lexing.lexeme lexbuf)) } and action = parse - '{' + '{' { incr brace_depth; action lexbuf } - | '}' + | '}' { decr brace_depth; if !brace_depth = 0 then Lexing.lexeme_start lexbuf else action lexbuf } - | '"' + | '"' { reset_string_buffer(); string lexbuf; reset_string_buffer(); action lexbuf } | '\'' { let _ = char lexbuf in action lexbuf } - | "(*" + | "(*" { comment_depth := 1; comment lexbuf; action lexbuf } - | eof + | eof { raise (Lexical_error "unterminated action") } - | _ + | _ { action lexbuf } - + and string = parse - '"' + '"' { () } | '\\' [' ' '\010' '\013' '\009' '\026' '\012'] + { string lexbuf } - | '\\' ['\\' '"' 'n' 't' 'b' 'r'] + | '\\' ['\\' '"' 'n' 't' 'b' 'r'] { store_string_char(char_for_backslash(Lexing.lexeme_char lexbuf 1)); string lexbuf } - | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] + | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] { store_string_char(char_for_decimal_code lexbuf 1); string lexbuf } - | eof + | eof { raise(Lexical_error "unterminated string") } - | _ + | _ { store_string_char(Lexing.lexeme_char lexbuf 0); string lexbuf } and char = parse - [^ '\\'] "'" + [^ '\\'] "'" { Lexing.lexeme_char lexbuf 0 } - | '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'" + | '\\' ['\\' '\'' 'n' 't' 'b' 'r'] "'" { char_for_backslash (Lexing.lexeme_char lexbuf 1) } - | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" + | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" { char_for_decimal_code lexbuf 1 } - | _ + | _ { raise(Lexical_error "bad character constant") } and comment = parse - "(*" + "(*" { incr comment_depth; comment lexbuf } - | "*)" + | "*)" { decr comment_depth; if !comment_depth = 0 then () else comment lexbuf } - | '"' + | '"' { reset_string_buffer(); string lexbuf; reset_string_buffer(); comment lexbuf } - | eof + | eof { raise(Lexical_error "unterminated comment") } - | _ + | _ { comment lexbuf } 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..69f71eb6bc 100644 --- a/testsuite/tests/tool-ocamldoc/odoc_test.ml +++ b/testsuite/tests/tool-ocamldoc/odoc_test.ml @@ -27,64 +27,64 @@ class string_gen = inherit Odoc_info.Scan.scanner val mutable test_kinds = [] - val mutable fmt = Format.str_formatter + val mutable fmt = Format.str_formatter method must_display_types = List.mem Types_display test_kinds method set_test_kinds_from_module m = test_kinds <- List.fold_left - (fun acc (s, _) -> - match s with - "test_types_display" -> Types_display :: acc - | _ -> acc - ) - [] - ( - match m.m_info with - None -> [] - | Some i -> i.i_custom - ) + (fun acc (s, _) -> + match s with + "test_types_display" -> Types_display :: acc + | _ -> acc + ) + [] + ( + match m.m_info with + None -> [] + | Some i -> i.i_custom + ) method! scan_type t = match test_kinds with - [] -> () - | _ -> - p fmt "# type %s:\n" t.ty_name; - if self#must_display_types then - ( - p fmt "# manifest (Odoc_info.string_of_type_expr):\n<[%s]>\n" - (match t.ty_manifest with - None -> "None" - | Some e -> Odoc_info.string_of_type_expr e - ); - ); + [] -> () + | _ -> + p fmt "# type %s:\n" t.ty_name; + if self#must_display_types then + ( + p fmt "# manifest (Odoc_info.string_of_type_expr):\n<[%s]>\n" + (match t.ty_manifest with + None -> "None" + | Some e -> Odoc_info.string_of_type_expr e + ); + ); method! scan_module_pre m = p fmt "#\n# module %s:\n" m.m_name ; if self#must_display_types then - ( - p fmt "# Odoc_info.string_of_module_type:\n<[%s]>\n" - (Odoc_info.string_of_module_type m.m_type); - p fmt "# Odoc_info.string_of_module_type ~complete: true :\n<[%s]>\n" - (Odoc_info.string_of_module_type ~complete: true m.m_type); - ); + ( + p fmt "# Odoc_info.string_of_module_type:\n<[%s]>\n" + (Odoc_info.string_of_module_type m.m_type); + p fmt "# Odoc_info.string_of_module_type ~complete: true :\n<[%s]>\n" + (Odoc_info.string_of_module_type ~complete: true m.m_type); + ); true method! scan_module_type_pre m = p fmt "#\n# module type %s:\n" m.mt_name ; if self#must_display_types then - ( - p fmt "# Odoc_info.string_of_module_type:\n<[%s]>\n" - (match m.mt_type with - None -> "None" - | Some t -> Odoc_info.string_of_module_type t - ); - p fmt "# Odoc_info.string_of_module_type ~complete: true :\n<[%s]>\n" - (match m.mt_type with - None -> "None" - | Some t -> Odoc_info.string_of_module_type ~complete: true t - ); - ); + ( + p fmt "# Odoc_info.string_of_module_type:\n<[%s]>\n" + (match m.mt_type with + None -> "None" + | Some t -> Odoc_info.string_of_module_type t + ); + p fmt "# Odoc_info.string_of_module_type ~complete: true :\n<[%s]>\n" + (match m.mt_type with + None -> "None" + | Some t -> Odoc_info.string_of_module_type ~complete: true t + ); + ); true method generate (module_list: Odoc_info.Module.t_module list) = @@ -92,15 +92,15 @@ class string_gen = fmt <- Format.formatter_of_out_channel oc; ( try - List.iter - (fun m -> - self#set_test_kinds_from_module m; - self#scan_module_list [m]; - ) - module_list + List.iter + (fun m -> + self#set_test_kinds_from_module m; + self#scan_module_list [m]; + ) + module_list with - e -> - prerr_endline (Printexc.to_string e) + e -> + prerr_endline (Printexc.to_string e) ); Format.pp_print_flush fmt (); close_out oc @@ -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/tool-ocamldoc/t01.ml b/testsuite/tests/tool-ocamldoc/t01.ml index 6caf3d7afc..d253be43db 100644 --- a/testsuite/tests/tool-ocamldoc/t01.ml +++ b/testsuite/tests/tool-ocamldoc/t01.ml @@ -7,7 +7,7 @@ let x = 1 module M = struct - let y = 2 + let y = 2 end diff --git a/testsuite/tests/tool-ocamldoc/t03.ml b/testsuite/tests/tool-ocamldoc/t03.ml index 43f1857d56..3d06cc5969 100644 --- a/testsuite/tests/tool-ocamldoc/t03.ml +++ b/testsuite/tests/tool-ocamldoc/t03.ml @@ -4,4 +4,4 @@ module Bar = struct type t = int let x = 2 end;; module type MT2 = sig type t val x : t end;; module type Gee = MT2 with type t = float ;; -module T = (val (if true then (module Foo:MT2 with type t = int) else (module Bar: MT2 with type t = int)) : MT2 with type t = int);;
\ No newline at end of file +module T = (val (if true then (module Foo:MT2 with type t = int) else (module Bar: MT2 with type t = int)) : MT2 with type t = int);; diff --git a/testsuite/tests/typing-fstclassmod/fstclassmod.ml b/testsuite/tests/typing-fstclassmod/fstclassmod.ml index 905af53463..268d35d492 100644 --- a/testsuite/tests/typing-fstclassmod/fstclassmod.ml +++ b/testsuite/tests/typing-fstclassmod/fstclassmod.ml @@ -139,4 +139,3 @@ end let () = print_endline (Print.to_string int 10); print_endline (Print.to_string (pair int (pair str int)) (123, ("A", 456))) - diff --git a/testsuite/tests/typing-gadts/Makefile b/testsuite/tests/typing-gadts/Makefile index 9add15574f..9625a3fbc3 100644 --- a/testsuite/tests/typing-gadts/Makefile +++ b/testsuite/tests/typing-gadts/Makefile @@ -1,3 +1,3 @@ -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/dynamic_frisch.ml b/testsuite/tests/typing-gadts/dynamic_frisch.ml index 895be5a05c..2636d5b424 100644 --- a/testsuite/tests/typing-gadts/dynamic_frisch.ml +++ b/testsuite/tests/typing-gadts/dynamic_frisch.ml @@ -18,7 +18,7 @@ type variant = | VString of string | VList of variant list | VPair of variant * variant - + let rec variantize: type t. t ty -> t -> variant = fun ty x -> (* type t is abstract here *) @@ -31,9 +31,9 @@ let rec variantize: type t. t ty -> t -> variant = | Pair (ty1, ty2) -> VPair (variantize ty1 (fst x), variantize ty2 (snd x)) (* t = ('a, 'b) for some 'a and 'b *) - + exception VariantMismatch - + let rec devariantize: type t. t ty -> variant -> t = fun ty v -> match ty, v with @@ -54,16 +54,16 @@ type 'a ty = | List: 'a ty -> 'a list ty | Pair: ('a ty * 'b ty) -> ('a * 'b) ty | Record: 'a record -> 'a ty - + and 'a record = { path: string; fields: 'a field_ list; } - + and 'a field_ = | Field: ('a, 'b) field -> 'a field_ - + and ('a, 'b) field = { label: string; @@ -98,7 +98,7 @@ let rec variantize: type t. t ty -> t -> variant = (List.map (fun (Field{field_type; label; get}) -> (label, variantize field_type (get x))) fields) ;; - + (* Extraction *) type 'a ty = @@ -107,7 +107,7 @@ type 'a ty = | List: 'a ty -> 'a list ty | Pair: ('a ty * 'b ty) -> ('a * 'b) ty | Record: ('a, 'builder) record -> 'a ty - + and ('a, 'builder) record = { path: string; @@ -115,10 +115,10 @@ and ('a, 'builder) record = create_builder: (unit -> 'builder); of_builder: ('builder -> 'a); } - + and ('a, 'builder) field = | Field: ('a, 'builder, 'b) field_ -> ('a, 'builder) field - + and ('a, 'builder, 'b) field_ = { label: string; @@ -126,7 +126,7 @@ and ('a, 'builder, 'b) field_ = get: ('a -> 'b); set: ('builder -> 'b -> unit); } - + let rec devariantize: type t. t ty -> variant -> t = fun ty v -> match ty, v with @@ -154,7 +154,7 @@ type my_record = a: int; b: string list; } - + let my_record = let fields = [ 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..3ba7cc8b84 100644 --- a/testsuite/tests/typing-gadts/test.ml +++ b/testsuite/tests/typing-gadts/test.ml @@ -1,23 +1,23 @@ -module Exp = +module Exp = struct - type _ t = + type _ t = | IntLit : int -> int t | BoolLit : bool -> bool t | Pair : 'a t * 'b t -> ('a * 'b) t | App : ('a -> 'b) t * 'a t -> 'b t - | Abs : ('a -> 'b) -> ('a -> 'b) t + | Abs : ('a -> 'b) -> ('a -> 'b) t - let rec eval : type s . s t -> s = + let rec eval : type s . s t -> s = function - | IntLit x -> x - | BoolLit y -> y - | Pair (x,y) -> + | IntLit x -> x + | BoolLit y -> y + | Pair (x,y) -> (eval x,eval y) - | App (f,a) -> - (eval f) (eval a) - | Abs f -> f + | App (f,a) -> + (eval f) (eval a) + | Abs f -> f let discern : type a. a t -> _ = function IntLit _ -> 1 @@ -28,70 +28,70 @@ module Exp = end ;; -module List = +module List = struct type zero - type _ t = + type _ t = | Nil : zero t | Cons : 'a * 'b t -> ('a * 'b) t let head = function - | Cons (a,b) -> a + | Cons (a,b) -> a let tail = function - | Cons (a,b) -> b - let rec length : type a . a t -> int = + | Cons (a,b) -> b + let rec length : type a . a t -> int = function - | Nil -> 0 - | Cons (a,b) -> length b + | Nil -> 0 + | Cons (a,b) -> length b end ;; -module Nonexhaustive = +module Nonexhaustive = struct - type 'a u = - | C1 : int -> int u + type 'a u = + | C1 : int -> int u | C2 : bool -> bool u - - type 'a v = + + type 'a v = | C1 : int -> int v - let unexhaustive : type s . s u -> s = + let unexhaustive : type s . s u -> s = function - | C2 x -> x + | C2 x -> x - module M : sig type t type u end = + module M : sig type t type u end = struct type t = int type u = bool - end - type 'a t = - | Foo : M.t -> M.t t + end + type 'a t = + | Foo : M.t -> M.t t | Bar : M.u -> M.u t let same_type : type s . s t * s t -> bool = function - | Foo _ , Foo _ -> true - | Bar _, Bar _ -> true + | Foo _ , Foo _ -> true + | Bar _, Bar _ -> true end ;; -module Exhaustive = +module Exhaustive = struct type t = int type u = bool - type 'a v = - | Foo : t -> t v + type 'a v = + | Foo : t -> t v | Bar : u -> u v let same_type : type s . s v * s v -> bool = function - | Foo _ , Foo _ -> true - | Bar _, Bar _ -> true + | Foo _ , Foo _ -> true + | Bar _, Bar _ -> true end ;; -module Existential_escape = +module Existential_escape = struct type _ t = C : int -> int t type u = D : 'a t -> u @@ -99,46 +99,46 @@ module Existential_escape = end ;; -module Rectype = +module Rectype = struct - type (_,_) t = C : ('a,'a) t - let _ = + type (_,_) t = C : ('a,'a) t + let _ = fun (type s) -> - let a : (s, s * s) t = failwith "foo" in - match a with - C -> - () + let a : (s, s * s) t = failwith "foo" in + match a with + C -> + () end ;; -module Or_patterns = +module Or_patterns = struct - type _ t = + type _ t = | IntLit : int -> int t | BoolLit : bool -> bool t - let rec eval : type s . s t -> unit = + let rec eval : type s . s t -> unit = function - | (IntLit _ | BoolLit _) -> () + | (IntLit _ | BoolLit _) -> () end ;; -module Polymorphic_variants = +module Polymorphic_variants = struct - type _ t = + type _ t = | IntLit : int -> int t | BoolLit : bool -> bool t - let rec eval : type s . [`A] * s t -> unit = + let rec eval : type s . [`A] * s t -> unit = function - | `A, IntLit _ -> () - | `A, BoolLit _ -> () - end + | `A, IntLit _ -> () + | `A, BoolLit _ -> () + end ;; module Propagation = struct - type _ t = + type _ t = IntLit : int -> int t | BoolLit : bool -> bool t @@ -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 *) @@ -473,7 +473,7 @@ f V1;; type _ int_foo = | IF_constr : <foo:int; ..> int_foo -type _ int_bar = +type _ int_bar = | IB_constr : <bar:int; ..> int_bar ;; @@ -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..b5dcb790dd 100644 --- a/testsuite/tests/typing-gadts/test.ml.principal.reference +++ b/testsuite/tests/typing-gadts/test.ml.principal.reference @@ -18,16 +18,16 @@ val tail : ('a * 'b) t -> 'b t val length : 'a t -> int end -# Characters 206-227: +# Characters 196-224: ......function - | C2 x -> x + | C2 x -> x Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: C1 _ -Characters 469-526: +Characters 458-529: ......function - | Foo _ , Foo _ -> true - | Bar _, Bar _ -> true + | Foo _ , Foo _ -> true + | Bar _, Bar _ -> true Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (Bar _, Foo _) @@ -47,27 +47,27 @@ module Nonexhaustive : type 'a v = Foo : t -> t v | Bar : u -> u v val same_type : 's v * 's v -> bool end -# Characters 119-120: +# Characters 118-119: let eval (D x) = x ^ Error: This expression has type ex#16 t but an expression was expected of type ex#16 t The type constructor ex#16 would escape its scope -# Characters 157-158: - C -> - ^ +# Characters 174-175: + C -> + ^ Error: Recursive local constraint when unifying (s, s) t with (s, s * s) t -# Characters 174-182: - | (IntLit _ | BoolLit _) -> () - ^^^^^^^^ +# Characters 178-186: + | (IntLit _ | BoolLit _) -> () + ^^^^^^^^ Error: This pattern matches values of type int t but a pattern was expected which matches values of type s t -# Characters 213-226: - | `A, BoolLit _ -> () - ^^^^^^^^^^^^^ +# Characters 224-237: + | `A, BoolLit _ -> () + ^^^^^^^^^^^^^ Error: This pattern matches values of type ([? `A ] as 'a) * bool t but a pattern was expected which matches values of type 'a * int t -# Characters 300-301: +# Characters 299-300: | BoolLit b -> b ^ Error: This expression has type bool but an expression was expected of type s @@ -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..5406ed2a72 100644 --- a/testsuite/tests/typing-gadts/test.ml.reference +++ b/testsuite/tests/typing-gadts/test.ml.reference @@ -18,16 +18,16 @@ val tail : ('a * 'b) t -> 'b t val length : 'a t -> int end -# Characters 206-227: +# Characters 196-224: ......function - | C2 x -> x + | C2 x -> x Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: C1 _ -Characters 469-526: +Characters 458-529: ......function - | Foo _ , Foo _ -> true - | Bar _, Bar _ -> true + | Foo _ , Foo _ -> true + | Bar _, Bar _ -> true Warning 8: this pattern-matching is not exhaustive. Here is an example of a value that is not matched: (Bar _, Foo _) @@ -47,24 +47,24 @@ module Nonexhaustive : type 'a v = Foo : t -> t v | Bar : u -> u v val same_type : 's v * 's v -> bool end -# Characters 119-120: +# Characters 118-119: let eval (D x) = x ^ Error: This expression has type ex#16 t but an expression was expected of type ex#16 t The type constructor ex#16 would escape its scope -# Characters 157-158: - C -> - ^ +# Characters 174-175: + C -> + ^ Error: Recursive local constraint when unifying (s, s) t with (s, s * s) t -# Characters 174-182: - | (IntLit _ | BoolLit _) -> () - ^^^^^^^^ +# Characters 178-186: + | (IntLit _ | BoolLit _) -> () + ^^^^^^^^ Error: This pattern matches values of type int t but a pattern was expected which matches values of type s t -# Characters 213-226: - | `A, BoolLit _ -> () - ^^^^^^^^^^^^^ +# Characters 224-237: + | `A, BoolLit _ -> () + ^^^^^^^^^^^^^ Error: This pattern matches values of type ([? `A ] as 'a) * bool t but a pattern was expected which matches values of type 'a * int t # module Propagation : @@ -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-implicit_unpack/Makefile b/testsuite/tests/typing-implicit_unpack/Makefile index 5f42b70577..9625a3fbc3 100644 --- a/testsuite/tests/typing-implicit_unpack/Makefile +++ b/testsuite/tests/typing-implicit_unpack/Makefile @@ -1,4 +1,3 @@ BASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.toplevel include $(BASEDIR)/makefiles/Makefile.common - diff --git a/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml index 3910059fe2..82fca3a5d0 100644 --- a/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml +++ b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml @@ -152,7 +152,7 @@ let ssmap = let ssmap = (let module S = struct include SSMap end in (module S) : - (module + (module MapT with type key = string and type data = string and type map = SSMap.map)) ;; diff --git a/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml.reference b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml.reference index 0291292bf7..32c49a2961 100644 --- a/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml.reference +++ b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ml.reference @@ -146,15 +146,15 @@ module SSMap : val to_t : 'a -> 'a end val ssmap : - (module MapT with type data = SSMap.data and type key = SSMap.key and type map = + (module MapT with type data = string and type key = string and type map = SSMap.map) = <module> # val ssmap : - (module MapT with type data = SSMap.data and type key = String.t and type map = + (module MapT with type data = string and type key = string and type map = SSMap.map) = <module> # val ssmap : - (module MapT with type data = SSMap.data and type key = String.t and type map = + (module MapT with type data = string and type key = string and type map = SSMap.map) = <module> # val ssmap : diff --git a/testsuite/tests/typing-modules-bugs/pr5164_ok.ml b/testsuite/tests/typing-modules-bugs/pr5164_ok.ml index 7de770ed6a..5a59808ef4 100644 --- a/testsuite/tests/typing-modules-bugs/pr5164_ok.ml +++ b/testsuite/tests/typing-modules-bugs/pr5164_ok.ml @@ -1,7 +1,7 @@ module type INCLUDING = sig include module type of List include module type of ListLabels -end +end module Including_typed: INCLUDING = struct include List diff --git a/testsuite/tests/typing-modules/Makefile b/testsuite/tests/typing-modules/Makefile index 9add15574f..145025ba05 100644 --- a/testsuite/tests/typing-modules/Makefile +++ b/testsuite/tests/typing-modules/Makefile @@ -1,3 +1,2 @@ include ../../makefiles/Makefile.toplevel include ../../makefiles/Makefile.common - diff --git a/testsuite/tests/typing-modules/Test.ml b/testsuite/tests/typing-modules/Test.ml index 97a9f739c8..03505cb269 100644 --- a/testsuite/tests/typing-modules/Test.ml +++ b/testsuite/tests/typing-modules/Test.ml @@ -1,4 +1,4 @@ -(* Destructive substitutions *) +(* with module *) module type S = sig type t and s = t end;; module type S' = S with type t := int;; @@ -6,12 +6,39 @@ 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 _ -> ();; + (* Path shortening *) module Int = struct type t = int let compare : int -> int -> int = compare end;; diff --git a/testsuite/tests/typing-modules/Test.ml.principal.reference b/testsuite/tests/typing-modules/Test.ml.principal.reference index 258b3ee3de..013b844b56 100644 --- a/testsuite/tests/typing-modules/Test.ml.principal.reference +++ b/testsuite/tests/typing-modules/Test.ml.principal.reference @@ -1,9 +1,37 @@ -# 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 +# * * * * * * * * * * * * * * * * 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> +# module Int : sig type t = int val compare : t -> t -> t end +# val f : int -> int = <fun> +# Characters 3-7: + f true;; + ^^^^ +Error: This expression has type bool but an expression was expected of type + int +# type 'a u constraint 'a = bool +# Characters 11-16: + let f (x : Int.t u) = ();; + ^^^^^ +Error: This type Int.t = int should be an instance of type bool +# Characters 30-40: + let f (x : (Int.t as 'a) -> (bool as 'a)) = ();; + ^^^^^^^^^^ +Error: This alias is bound to type bool but is used as an instance of type + Int.t = int +# Characters 11-16: + type t = [Int.t | `A];; + ^^^^^ +Error: The type Int.t is not a polymorphic variant type +# Characters 10-36: + type t = [`A of Int.t | `A of bool];; + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant type contains a constructor [ `A of bool ] + which should be [ `A of int ] # diff --git a/testsuite/tests/typing-modules/Test.ml.reference b/testsuite/tests/typing-modules/Test.ml.reference index 258b3ee3de..013b844b56 100644 --- a/testsuite/tests/typing-modules/Test.ml.reference +++ b/testsuite/tests/typing-modules/Test.ml.reference @@ -1,9 +1,37 @@ -# 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 +# * * * * * * * * * * * * * * * * 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> +# module Int : sig type t = int val compare : t -> t -> t end +# val f : int -> int = <fun> +# Characters 3-7: + f true;; + ^^^^ +Error: This expression has type bool but an expression was expected of type + int +# type 'a u constraint 'a = bool +# Characters 11-16: + let f (x : Int.t u) = ();; + ^^^^^ +Error: This type Int.t = int should be an instance of type bool +# Characters 30-40: + let f (x : (Int.t as 'a) -> (bool as 'a)) = ();; + ^^^^^^^^^^ +Error: This alias is bound to type bool but is used as an instance of type + Int.t = int +# Characters 11-16: + type t = [Int.t | `A];; + ^^^^^ +Error: The type Int.t is not a polymorphic variant type +# Characters 10-36: + type t = [`A of Int.t | `A of bool];; + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant type contains a constructor [ `A of bool ] + which should be [ `A of int ] # diff --git a/testsuite/tests/typing-objects-bugs/pr3968_bad.ml b/testsuite/tests/typing-objects-bugs/pr3968_bad.ml index 3d393120a2..01c5066654 100644 --- a/testsuite/tests/typing-objects-bugs/pr3968_bad.ml +++ b/testsuite/tests/typing-objects-bugs/pr3968_bad.ml @@ -1,18 +1,18 @@ -type expr = +type expr = [ `Abs of string * expr | `App of expr * expr ] -class type exp = +class type exp = object method eval : (string, exp) Hashtbl.t -> expr end;; -class app e1 e2 : exp = +class app e1 e2 : exp = object - val l = e1 + val l = e1 val r = e2 - method eval env = + method eval env = match l with | `Abs(var,body) -> Hashtbl.add env var r; diff --git a/testsuite/tests/typing-objects-bugs/pr4018_bad.ml b/testsuite/tests/typing-objects-bugs/pr4018_bad.ml index 90ee787861..5195d46397 100644 --- a/testsuite/tests/typing-objects-bugs/pr4018_bad.ml +++ b/testsuite/tests/typing-objects-bugs/pr4018_bad.ml @@ -8,7 +8,7 @@ class ['event] subject = object (self : 'subject) val mutable observers = ([]: (('subject, 'event) observer) list) method add_observer obs = observers <- (obs :: observers) - method notify_observers (e : 'event) = + method notify_observers (e : 'event) = List.iter (fun x -> x#notify self e) observers end diff --git a/testsuite/tests/typing-objects-bugs/pr4766_ok.ml b/testsuite/tests/typing-objects-bugs/pr4766_ok.ml index c5809c1d93..726cc86669 100644 --- a/testsuite/tests/typing-objects-bugs/pr4766_ok.ml +++ b/testsuite/tests/typing-objects-bugs/pr4766_ok.ml @@ -1,9 +1,9 @@ -class virtual ['a] c = -object (s : 'a) - method virtual m : 'b +class virtual ['a] c = +object (s : 'a) + method virtual m : 'b end -let o = +let o = object (s :'a) inherit ['a] c method m = 42 diff --git a/testsuite/tests/typing-objects-bugs/yamagata021012_ok.ml b/testsuite/tests/typing-objects-bugs/yamagata021012_ok.ml index 212a1683fa..fda0d123ce 100644 --- a/testsuite/tests/typing-objects-bugs/yamagata021012_ok.ml +++ b/testsuite/tests/typing-objects-bugs/yamagata021012_ok.ml @@ -31,9 +31,9 @@ class virtual ['a, 'cursor] storage_base = method fold : 'b. ('a -> int -> 'b -> 'b) -> 'b -> 'b = fun f a0 -> let cur = self#first in let rec loop count a = - if count >= self#len then a else - let a' = f cur#get count a in - cur#incr (); loop (count + 1) a' + if count >= self#len then a else + let a' = f cur#get count a in + cur#incr (); loop (count + 1) a' in loop 0 a0 method iter proc = @@ -63,7 +63,7 @@ struct let highest_bit = 1 lsl 30 let lower_bits = highest_bit - 1 - let char_of c = + let char_of c = try Char.chr c with Invalid_argument _ -> raise Out_of_range let of_char = Char.code @@ -129,7 +129,7 @@ class text_raw buf = object (self : 'self) inherit [cursor] ustorage_base val contents = buf - method first = new cursor (self :> text_raw) 0 + method first = new cursor (self :> text_raw) 0 method len = (String.length contents) / 4 method get i = get_buf contents (4 * i) method nth i = new cursor (self :> text_raw) i 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/Makefile b/testsuite/tests/typing-objects/Makefile index 5f42b70577..9625a3fbc3 100644 --- a/testsuite/tests/typing-objects/Makefile +++ b/testsuite/tests/typing-objects/Makefile @@ -1,4 +1,3 @@ BASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.toplevel include $(BASEDIR)/makefiles/Makefile.common - diff --git a/testsuite/tests/typing-objects/Tests.ml b/testsuite/tests/typing-objects/Tests.ml index c7a5cb3d16..15bef7f9e5 100644 --- a/testsuite/tests/typing-objects/Tests.ml +++ b/testsuite/tests/typing-objects/Tests.ml @@ -159,7 +159,7 @@ e#f, e#g, e#h, e#i, e#j;; class c a = object val x = 1 val y = 1 val z = 1 val a = a end;; class d b = object val z = 2 val t = 2 val u = 2 val b = b end;; -class e () = object +class e () = object val x = 3 inherit c 5 val y = 3 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..a194f7d0f8 --- /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 42-45: + 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 52-53: + val y = 3 + ^ +Warning 13: the instance variable y is overridden. +The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) +Characters 80-83: + 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 90-91: + 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 4df2316922..d5d0bea437 100644 --- a/testsuite/tests/typing-objects/Tests.ml.reference +++ b/testsuite/tests/typing-objects/Tests.ml.reference @@ -162,26 +162,26 @@ Error: This expression has type bool but an expression was expected of type # - : 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: +# Characters 42-45: inherit c 5 ^^^ Warning 13: the following instance variables are overridden by the class c : x The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) -Characters 53-58: +Characters 52-53: 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: +Characters 80-83: inherit d 7 ^^^ Warning 13: the following instance variables are overridden by the class d : t z The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) -Characters 91-96: +Characters 90-91: val u = 3 - ^^^^^ + ^ Warning 13: the instance variable u is overridden. The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) class e : @@ -281,7 +281,7 @@ Error: This expression has type 'a t but an expression was expected of type fun (x : 'a t) -> (x : 'a); ();; ^^^^^^^^ Warning 10: this expression should have type unit. -- : ('a t as 'a) -> unit = <fun> +- : ('a t as 'a) t -> unit = <fun> # class ['a] c : unit -> object constraint 'a = (< .. > as 'b) -> unit method m : 'a end # class ['a] c : diff --git a/testsuite/tests/typing-objects/pr5619_bad.ml b/testsuite/tests/typing-objects/pr5619_bad.ml new file mode 100644 index 0000000000..2dd3eaaa59 --- /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-bugs/pr5322_ok.ml b/testsuite/tests/typing-poly-bugs/pr5322_ok.ml index a24a6769a7..d6cbca1a7a 100644 --- a/testsuite/tests/typing-poly-bugs/pr5322_ok.ml +++ b/testsuite/tests/typing-poly-bugs/pr5322_ok.ml @@ -4,4 +4,3 @@ module M : sig val x : <m : 'a. 'a> end = let ident v = v class alias = object method alias : 'a . 'a t -> 'a = ident end - diff --git a/testsuite/tests/typing-poly/Makefile b/testsuite/tests/typing-poly/Makefile index 5f42b70577..9625a3fbc3 100644 --- a/testsuite/tests/typing-poly/Makefile +++ b/testsuite/tests/typing-poly/Makefile @@ -1,4 +1,3 @@ BASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.toplevel include $(BASEDIR)/makefiles/Makefile.common - diff --git a/testsuite/tests/typing-poly/poly.ml b/testsuite/tests/typing-poly/poly.ml index 17e643ad15..b0a5f97b83 100644 --- a/testsuite/tests/typing-poly/poly.ml +++ b/testsuite/tests/typing-poly/poly.ml @@ -448,7 +448,7 @@ function `B,1 -> 1 | _,1 -> 2;; function 1,`B -> 1 | 1,_ -> 2;; (* pass typetexp, but fails during Typedecl.check_recursion *) -type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b] +type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b] and ('a, 'b) b = 'b -> unit constraint 'b = [> `A of ('a, 'b) a as 'a];; (* PR#1917: expanding may change original in Ctype.unify2 *) @@ -459,12 +459,12 @@ class type ['a, 'b] a = object method as_a: ('a, 'b) a end and ['a, 'b] b = object method a: ('a, 'b) #a as 'a - method as_b: ('a, 'b) b + method as_b: ('a, 'b) b end class type ['b] ca = object ('s) inherit ['s, 'b] a end class type ['a] cb = object ('s) inherit ['a, 's] b end - + type bt = 'b ca cb as 'b ;; @@ -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..d069595e79 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;; ^^^^^^^^^^^^^^^^^^^^ @@ -347,7 +347,7 @@ Characters 21-24: Warning 11: this match case is unused. - : int * [< `B ] -> int = <fun> # Characters 69-135: - type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b] + type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b] ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Constraints are not satisfied in this type. Type @@ -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 71befc5820..81fb347399 100644 --- a/testsuite/tests/typing-poly/poly.ml.reference +++ b/testsuite/tests/typing-poly/poly.ml.reference @@ -70,7 +70,7 @@ tl:'a ostream -> object val hd : 'a - val tl : 'a ostream + val tl : < empty : bool; fold : 'c. f:('a -> 'c -> 'c) -> init:'c -> 'c > method empty : bool method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c end @@ -119,7 +119,7 @@ val p1 : point = <obj> val cp : color_point = <obj> val c : circle = <obj> val d : float = 11.4536240470737098 -# val f : < m : 'b. 'b -> 'b > -> < m : 'b. 'b -> 'b > = <fun> +# val f : < m : 'a. 'a -> 'a > -> < m : 'b. 'b -> 'b > = <fun> # Characters 41-42: let f (x : < m : 'a. 'a -> 'a list >) = (x : < m : 'b. 'b -> 'c >) ^ @@ -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;; ^^^^^^^^^^^^^^^^^^^^ @@ -330,7 +330,7 @@ Characters 21-24: Warning 11: this match case is unused. - : int * [< `B ] -> int = <fun> # Characters 69-135: - type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b] + type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b] ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Constraints are not satisfied in this type. Type @@ -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 : @@ -593,6 +588,13 @@ Error: This field value has type unit -> unit which is less general than type 'par t = 'par val ident : 'a -> 'a class alias : object method alias : 'a t -> 'a end - val f : < m : 'a. 'a > -> < m : 'a. 'a > + 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-polyvariants-bugs/pr5057_ok.ml b/testsuite/tests/typing-polyvariants-bugs/pr5057_ok.ml index 38df770585..86cb665ad4 100644 --- a/testsuite/tests/typing-polyvariants-bugs/pr5057_ok.ml +++ b/testsuite/tests/typing-polyvariants-bugs/pr5057_ok.ml @@ -5,7 +5,7 @@ module TT = struct end let () = - let f flag = + let f flag = let module T = TT in let _ = match flag with `A -> 0 | `B r -> r in let _ = match flag with `A -> T.IntSet.mem | `B r -> r in diff --git a/testsuite/tests/typing-polyvariants-bugs/pr5057a_bad.ml b/testsuite/tests/typing-polyvariants-bugs/pr5057a_bad.ml index 35cc338635..15bb776b7f 100644 --- a/testsuite/tests/typing-polyvariants-bugs/pr5057a_bad.ml +++ b/testsuite/tests/typing-polyvariants-bugs/pr5057a_bad.ml @@ -1,6 +1,6 @@ (* This one should fail *) -let f flag = +let f flag = let module T = Set.Make(struct type t = int let compare = compare end) in let _ = match flag with `A -> 0 | `B r -> r in let _ = match flag with `A -> T.mem | `B r -> r in diff --git a/testsuite/tests/typing-private-bugs/pr5026_bad.ml b/testsuite/tests/typing-private-bugs/pr5026_bad.ml index 0e6d215d26..10699952b2 100644 --- a/testsuite/tests/typing-private-bugs/pr5026_bad.ml +++ b/testsuite/tests/typing-private-bugs/pr5026_bad.ml @@ -3,7 +3,7 @@ type -'a typed = private untyped;; type -'typing wrapped = private sexp and +'a t = 'a typed wrapped and sexp = private untyped wrapped;; -class type ['a] s3 = object +class type ['a] s3 = object val underlying : 'a t end;; class ['a] s3object r : ['a] s3 = object diff --git a/testsuite/tests/typing-private/Makefile b/testsuite/tests/typing-private/Makefile index 5f42b70577..9625a3fbc3 100644 --- a/testsuite/tests/typing-private/Makefile +++ b/testsuite/tests/typing-private/Makefile @@ -1,4 +1,3 @@ BASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.toplevel include $(BASEDIR)/makefiles/Makefile.common - diff --git a/testsuite/tests/typing-private/private.ml b/testsuite/tests/typing-private/private.ml index 636f231ba4..6f19b89d1c 100644 --- a/testsuite/tests/typing-private/private.ml +++ b/testsuite/tests/typing-private/private.ml @@ -57,18 +57,18 @@ module M3 : sig val mk : int -> t end = M;; -module M4 : sig +module M4 : sig type t = M.t = T of int val mk : int -> t end = M;; (* Error: The variant or record definition does not match that of type M.t *) -module M5 : sig +module M5 : sig type t = M.t = private T of int val mk : int -> t end = M;; -module M6 : sig +module M6 : sig type t = private T of int val mk : int -> t end = M;; diff --git a/testsuite/tests/typing-private/private.ml.reference b/testsuite/tests/typing-private/private.ml.reference index f5b85b2055..8a7b3db469 100644 --- a/testsuite/tests/typing-private/private.ml.reference +++ b/testsuite/tests/typing-private/private.ml.reference @@ -7,7 +7,7 @@ Error: This expression has type F0.t but an expression was expected of type Foobar.t # module F : sig type t = Foobar.t end -# val f : F.t -> F.t = <fun> +# val f : F.t -> Foobar.t = <fun> # module M : sig type t = < m : int > end # module M1 : sig type t = private < m : int; .. > end # module M2 : sig type t = private < m : int; .. > end @@ -73,7 +73,7 @@ Error: Signature mismatch: ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Signature mismatch: Modules do not match: - sig type t = int val f : t -> t end + sig type t = int val f : int -> t end is not included in sig type t = private Foobar.t val f : int -> t end Type declarations do not match: @@ -84,7 +84,7 @@ Error: Signature mismatch: # module M1 : sig type t = M.t val mk : int -> t end # module M2 : sig type t = M.t val mk : int -> t end # module M3 : sig type t = M.t val mk : int -> t end -# Characters 29-47: +# Characters 26-44: type t = M.t = T of int ^^^^^^^^^^^^^^^^^^ Error: This variant or record definition does not match that of type M.t diff --git a/testsuite/tests/typing-recmod/t02bad.ml b/testsuite/tests/typing-recmod/t02bad.ml index ac9d6390c2..b4301a417e 100644 --- a/testsuite/tests/typing-recmod/t02bad.ml +++ b/testsuite/tests/typing-recmod/t02bad.ml @@ -1,4 +1,3 @@ (* Bad (t = t) *) module rec A : sig type t = B.t end = struct type t = B.t end and B : sig type t = A.t end = struct type t = A.t end;; - diff --git a/testsuite/tests/typing-recmod/t08bad.ml b/testsuite/tests/typing-recmod/t08bad.ml index 7df3d47609..5ebafd11ab 100644 --- a/testsuite/tests/typing-recmod/t08bad.ml +++ b/testsuite/tests/typing-recmod/t08bad.ml @@ -2,4 +2,3 @@ module rec A : sig type 'a t = <m: 'a list B.t; n: 'a array B.t> end = struct type 'a t = <m: 'a list B.t; n: 'a array B.t> end and B : sig type 'a t = 'a A.t end = struct type 'a t = 'a A.t end;; - diff --git a/testsuite/tests/typing-recmod/t13ok.ml b/testsuite/tests/typing-recmod/t13ok.ml index 729afd516a..4fea6e1faf 100644 --- a/testsuite/tests/typing-recmod/t13ok.ml +++ b/testsuite/tests/typing-recmod/t13ok.ml @@ -1,5 +1,5 @@ (* OK *) class type [ 'node ] extension = object method node : 'node end -class type [ 'ext ] node = object constraint 'ext = 'ext node #extension end +class type [ 'ext ] node = object constraint 'ext = 'ext node #extension end class x = object method node : x node = assert false end type t = x node;; diff --git a/testsuite/tests/typing-recmod/t14bad.ml b/testsuite/tests/typing-recmod/t14bad.ml index 5c665368e8..1b92a28c5c 100644 --- a/testsuite/tests/typing-recmod/t14bad.ml +++ b/testsuite/tests/typing-recmod/t14bad.ml @@ -13,5 +13,5 @@ module PR_4261 = struct end module rec U : T with module D = U' = U - and U' : S with type t = U'.t = U + and U' : S with type t = U'.t = U end;; diff --git a/testsuite/tests/typing-recmod/t16ok.ml b/testsuite/tests/typing-recmod/t16ok.ml index f42de7b7a6..583b69bb52 100644 --- a/testsuite/tests/typing-recmod/t16ok.ml +++ b/testsuite/tests/typing-recmod/t16ok.ml @@ -28,4 +28,3 @@ module PR_4450_2 = struct let create l = new c l end end;; - diff --git a/testsuite/tests/typing-recmod/t17ok.ml b/testsuite/tests/typing-recmod/t17ok.ml index a2ea895adb..4521b66cfa 100644 --- a/testsuite/tests/typing-recmod/t17ok.ml +++ b/testsuite/tests/typing-recmod/t17ok.ml @@ -25,18 +25,17 @@ struct type t = I of int * int | D of int * Diet.t * int val compare : t -> t -> int val iter : (int -> unit) -> t -> unit - end = + end = struct type t = I of int * int | D of int * Diet.t * int let compare x1 x2 = 0 let rec iter f = function | I (l, r) -> for i = l to r do f i done | D (_, d, _) -> Diet.iter (iter f) d - end + end and Diet : SET with type t = Elt.t tree and type elt = Elt.t = MakeDiet(Elt) type t = Diet.t let iter f = Diet.iter (Elt.iter f) end - diff --git a/testsuite/tests/typing-recmod/t18ok.ml b/testsuite/tests/typing-recmod/t18ok.ml index 4f5814deb2..64fcf6aba8 100644 --- a/testsuite/tests/typing-recmod/t18ok.ml +++ b/testsuite/tests/typing-recmod/t18ok.ml @@ -22,5 +22,4 @@ and DirHash end = struct type t = DirCompare.t list - end - + end diff --git a/testsuite/tests/typing-recmod/t19ok.ml b/testsuite/tests/typing-recmod/t19ok.ml index cd2dde8ec2..62e5f45486 100644 --- a/testsuite/tests/typing-recmod/t19ok.ml +++ b/testsuite/tests/typing-recmod/t19ok.ml @@ -10,4 +10,3 @@ module PR_4758 = struct module Other = A end end - diff --git a/testsuite/tests/typing-recmod/t22ok.ml b/testsuite/tests/typing-recmod/t22ok.ml index 0aa63afdd6..de96eced55 100644 --- a/testsuite/tests/typing-recmod/t22ok.ml +++ b/testsuite/tests/typing-recmod/t22ok.ml @@ -112,7 +112,7 @@ module rec Strengthen ;; module rec Strengthen2 - : sig type t + : sig type t val f : t -> t module M : sig type u end module R : sig type v end @@ -150,7 +150,7 @@ module rec PolyRec | Node(l,r) -> 1 + max (PolyRec.depth l) (PolyRec.depth r) end ;; - + (* Wrong LHS signatures (PR#4336) *) (* @@ -212,7 +212,7 @@ and Binding : sig type t = (string * Expr.t) list val fv: t -> StringSet.t - val bv: t -> StringSet.t + val bv: t -> StringSet.t val simpl: t -> t end = struct @@ -258,7 +258,7 @@ module type HEAP = val deleteMin: heap -> heap end -module Bootstrap (MakeH: functor (Element:ORDERED) -> +module Bootstrap (MakeH: functor (Element:ORDERED) -> HEAP with module Elem = Element) (Element: ORDERED) : HEAP with module Elem = Element = struct @@ -268,7 +268,7 @@ module Bootstrap (MakeH: functor (Element:ORDERED) -> val eq: t -> t -> bool val lt: t -> t -> bool val leq: t -> t -> bool - end + end = struct type t = E | H of Elem.t * PrimH.heap let leq t1 t2 = @@ -432,7 +432,7 @@ module rec Coerce1 module A = (Coerce1: sig val f: int -> int end) let g x = x let f x = if x <= 0 then 1 else A.f (x-1) * x - end + end ;; let _ = @@ -461,7 +461,7 @@ module Coerce4(A : sig val f : int -> int end) = struct end module rec Coerce5 - : sig val blabla: int -> int val f: int -> int end + : sig val blabla: int -> int val f: int -> int end = struct let blabla x = 0 let f x = 5 end and Coerce6 : sig val at: int -> int end @@ -473,16 +473,16 @@ let _ = (* Miscellaneous bug reports *) -module rec F +module rec F : sig type t = X of int | Y of int val f: t -> bool end = struct - type t = X of int | Y of int + type t = X of int | Y of int let f = function | X _ -> false | _ -> true - end;; + end;; let _ = test 100 (F.f (F.X 1)) false; diff --git a/testsuite/tests/typing-signatures/Makefile b/testsuite/tests/typing-signatures/Makefile index 5f42b70577..9625a3fbc3 100644 --- a/testsuite/tests/typing-signatures/Makefile +++ b/testsuite/tests/typing-signatures/Makefile @@ -1,4 +1,3 @@ BASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.toplevel include $(BASEDIR)/makefiles/Makefile.common - diff --git a/testsuite/tests/typing-signatures/els.ml b/testsuite/tests/typing-signatures/els.ml index f3c9c7936a..3713b64e5c 100644 --- a/testsuite/tests/typing-signatures/els.ml +++ b/testsuite/tests/typing-signatures/els.ml @@ -45,12 +45,12 @@ module type INTERP = sig include EVALUATOR module Parser : PARSER with type chunk = Ast.chunk val dostring : state -> string -> value list - val mk : unit -> state + val mk : unit -> state end;; module type USERTYPE = sig type t - val eq : t -> t -> bool + val eq : t -> t -> bool val to_string : t -> string end;; diff --git a/testsuite/tests/typing-sigsubst/Makefile b/testsuite/tests/typing-sigsubst/Makefile index 5f42b70577..9625a3fbc3 100644 --- a/testsuite/tests/typing-sigsubst/Makefile +++ b/testsuite/tests/typing-sigsubst/Makefile @@ -1,4 +1,3 @@ BASEDIR=../.. include $(BASEDIR)/makefiles/Makefile.toplevel include $(BASEDIR)/makefiles/Makefile.common - diff --git a/testsuite/tests/typing-sigsubst/sigsubst.ml b/testsuite/tests/typing-sigsubst/sigsubst.ml 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..9625a3fbc3 100644 --- a/testsuite/tests/typing-typeparam/Makefile +++ b/testsuite/tests/typing-typeparam/Makefile @@ -1,7 +1,3 @@ -#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 36c177ed43..c7531b29f6 100644 --- a/tools/.depend +++ b/tools/.depend @@ -1,62 +1,97 @@ -depend.cmi: ../parsing/parsetree.cmi -profiling.cmi: -addlabels.cmo: ../parsing/parsetree.cmi ../parsing/parse.cmi \ +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 \ +addlabels.cmx : ../parsing/parsetree.cmi ../parsing/parse.cmx \ ../parsing/longident.cmx ../parsing/location.cmx ../parsing/asttypes.cmi -cvt_emit.cmo: -cvt_emit.cmx: -depend.cmo: ../parsing/parsetree.cmi ../parsing/longident.cmi \ - ../parsing/location.cmi depend.cmi -depend.cmx: ../parsing/parsetree.cmi ../parsing/longident.cmx \ - ../parsing/location.cmx depend.cmi -dumpobj.cmo: ../utils/tbl.cmi opnames.cmo ../bytecomp/opcodes.cmo \ - ../parsing/location.cmi ../bytecomp/lambda.cmi ../bytecomp/instruct.cmi \ - ../typing/ident.cmi ../bytecomp/emitcode.cmi ../utils/config.cmi \ - ../bytecomp/cmo_format.cmi ../bytecomp/bytesections.cmi \ - ../parsing/asttypes.cmi -dumpobj.cmx: ../utils/tbl.cmx opnames.cmx ../bytecomp/opcodes.cmx \ - ../parsing/location.cmx ../bytecomp/lambda.cmx ../bytecomp/instruct.cmx \ - ../typing/ident.cmx ../bytecomp/emitcode.cmx ../utils/config.cmx \ - ../bytecomp/cmo_format.cmi ../bytecomp/bytesections.cmx \ - ../parsing/asttypes.cmi -myocamlbuild_config.cmo: -myocamlbuild_config.cmx: -objinfo.cmo: ../utils/misc.cmi ../utils/config.cmi ../asmcomp/cmx_format.cmi \ - ../bytecomp/cmo_format.cmi ../asmcomp/clambda.cmi \ +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 ../parsing/asttypes.cmi \ + depend.cmi +depend.cmx : ../parsing/parsetree.cmi ../utils/misc.cmx \ + ../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 \ + ../utils/config.cmi ../bytecomp/cmo_format.cmi \ + ../bytecomp/bytesections.cmi ../parsing/asttypes.cmi +dumpobj.cmx : ../utils/tbl.cmx opnames.cmx ../bytecomp/opcodes.cmx \ + ../utils/misc.cmx ../parsing/location.cmx ../bytecomp/lambda.cmx \ + ../bytecomp/instruct.cmx ../typing/ident.cmx ../bytecomp/emitcode.cmx \ + ../utils/config.cmx ../bytecomp/cmo_format.cmi \ + ../bytecomp/bytesections.cmx ../parsing/asttypes.cmi +myocamlbuild_config.cmo : +myocamlbuild_config.cmx : +objinfo.cmo : ../utils/misc.cmi ../utils/config.cmi \ + ../asmcomp/cmx_format.cmi ../bytecomp/cmo_format.cmi \ + ../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 \ +objinfo.cmx : ../utils/misc.cmx ../utils/config.cmx \ + ../asmcomp/cmx_format.cmi ../bytecomp/cmo_format.cmi \ + ../typing/cmi_format.cmx ../asmcomp/clambda.cmx \ ../bytecomp/bytesections.cmx -ocaml299to3.cmo: -ocaml299to3.cmx: -ocamlcp.cmo: ../driver/main_args.cmi -ocamlcp.cmx: ../driver/main_args.cmx -ocamldep.cmo: ../parsing/syntaxerr.cmi ../parsing/parsetree.cmi \ +ocaml299to3.cmo : +ocaml299to3.cmx : +ocamlcp.cmo : ../driver/main_args.cmi +ocamlcp.cmx : ../driver/main_args.cmx +ocamldep.cmo : ../parsing/syntaxerr.cmi ../parsing/parsetree.cmi \ ../parsing/parse.cmi ../utils/misc.cmi ../parsing/longident.cmi \ ../parsing/location.cmi ../parsing/lexer.cmi depend.cmi \ ../utils/config.cmi ../utils/clflags.cmi -ocamldep.cmx: ../parsing/syntaxerr.cmx ../parsing/parsetree.cmi \ +ocamldep.cmx : ../parsing/syntaxerr.cmx ../parsing/parsetree.cmi \ ../parsing/parse.cmx ../utils/misc.cmx ../parsing/longident.cmx \ ../parsing/location.cmx ../parsing/lexer.cmx depend.cmx \ ../utils/config.cmx ../utils/clflags.cmx -ocamlmklib.cmo: myocamlbuild_config.cmo -ocamlmklib.cmx: myocamlbuild_config.cmx -ocamlmktop.cmo: ../utils/ccomp.cmi -ocamlmktop.cmx: ../utils/ccomp.cmx -ocamlprof.cmo: ../utils/warnings.cmi ../parsing/syntaxerr.cmi \ +ocamlmklib.cmo : myocamlbuild_config.cmo +ocamlmklib.cmx : myocamlbuild_config.cmx +ocamlmktop.cmo : ../utils/ccomp.cmi +ocamlmktop.cmx : ../utils/ccomp.cmx +ocamloptp.cmo : ../driver/main_args.cmi +ocamloptp.cmx : ../driver/main_args.cmx +ocamlprof.cmo : ../utils/warnings.cmi ../parsing/syntaxerr.cmi \ ../parsing/parsetree.cmi ../parsing/parse.cmi ../utils/misc.cmi \ ../parsing/location.cmi ../parsing/lexer.cmi ../utils/config.cmi \ ../utils/clflags.cmi -ocamlprof.cmx: ../utils/warnings.cmx ../parsing/syntaxerr.cmx \ +ocamlprof.cmx : ../utils/warnings.cmx ../parsing/syntaxerr.cmx \ ../parsing/parsetree.cmi ../parsing/parse.cmx ../utils/misc.cmx \ ../parsing/location.cmx ../parsing/lexer.cmx ../utils/config.cmx \ ../utils/clflags.cmx -opnames.cmo: -opnames.cmx: -primreq.cmo: ../utils/config.cmi ../bytecomp/cmo_format.cmi -primreq.cmx: ../utils/config.cmx ../bytecomp/cmo_format.cmi -profiling.cmo: profiling.cmi -profiling.cmx: profiling.cmi -scrapelabels.cmo: -scrapelabels.cmx: +opnames.cmo : +opnames.cmx : +pprintast.cmo : ../parsing/parsetree.cmi ../parsing/longident.cmi \ + ../parsing/location.cmi ../parsing/asttypes.cmi +pprintast.cmx : ../parsing/parsetree.cmi ../parsing/longident.cmx \ + ../parsing/location.cmx ../parsing/asttypes.cmi +primreq.cmo : ../utils/config.cmi ../bytecomp/cmo_format.cmi +primreq.cmx : ../utils/config.cmx ../bytecomp/cmo_format.cmi +profiling.cmo : profiling.cmi +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 ee3fa28315..8c968c70f6 100644 --- a/tools/Makefile.shared +++ b/tools/Makefile.shared @@ -23,7 +23,8 @@ INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \ COMPFLAGS= -warn-error A $(INCLUDES) LINKFLAGS=$(INCLUDES) -all: ocamldep ocamlprof ocamlcp ocamlmktop ocamlmklib dumpobj objinfo +all: ocamldep ocamlprof ocamlcp ocamloptp ocamlmktop ocamlmklib dumpobj \ + objinfo read_cmt # scrapelabels addlabels .PHONY: all @@ -69,16 +70,26 @@ ocamlprof: $(CSLPROF) profiling.cmo ocamlcp: ocamlcp.cmo $(CAMLC) $(LINKFLAGS) -o ocamlcp warnings.cmo main_args.cmo ocamlcp.cmo +ocamloptp: ocamloptp.cmo + $(CAMLC) $(LINKFLAGS) -o ocamloptp warnings.cmo main_args.cmo \ + ocamloptp.cmo + +opt:: profiling.cmx + install:: cp ocamlprof $(BINDIR)/ocamlprof$(EXE) cp ocamlcp $(BINDIR)/ocamlcp$(EXE) + cp ocamloptp $(BINDIR)/ocamloptp$(EXE) cp profiling.cmi profiling.cmo $(LIBDIR) +installopt:: + cp profiling.cmx profiling.o $(LIBDIR) + clean:: - rm -f ocamlprof ocamlcp + rm -f ocamlprof ocamlcp ocamloptp -# To help building mixed-mode libraries (Caml + C) +# To help building mixed-mode libraries (OCaml + C) ocamlmklib: myocamlbuild_config.cmo ocamlmklib.cmo $(CAMLC) $(LINKFLAGS) -o ocamlmklib myocamlbuild_config.cmo \ @@ -184,6 +195,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 @@ -219,7 +271,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 c057e72ca8..c12bde8470 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 _ @@ -298,23 +298,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; @@ -323,7 +323,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 -> () @@ -353,12 +353,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 @@ -376,7 +376,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 = @@ -393,17 +393,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 948646a823..2015f937e5 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 | Pexp_newtype (_, e) -> add_expr bv e | Pexp_pack m -> add_module bv m @@ -174,14 +180,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 @@ -198,12 +204,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 @@ -224,7 +230,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) -> @@ -250,11 +256,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; @@ -281,7 +287,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 @@ -292,13 +298,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 18f8bf82ea..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 @@ -483,8 +486,7 @@ let print_reloc (info, pos) = (* Print a .cmo file *) let dump_obj filename ic = - let buffer = String.create (String.length cmo_magic_number) in - really_input ic buffer 0 (String.length cmo_magic_number); + let buffer = Misc.input_bytes ic (String.length cmo_magic_number) in if buffer <> cmo_magic_number then begin prerr_endline "Not an object file"; exit 2 end; @@ -503,8 +505,7 @@ let dump_obj filename ic = (* Read the primitive table from an executable *) let read_primitive_table ic len = - let p = String.create len in - really_input ic p 0 len; + let p = Misc.input_bytes ic len in let rec split beg cur = if cur >= len then [] else if p.[cur] = '\000' then @@ -541,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..40a2e14620 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 (v4.3.3 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 d3cecaf453..1e0a38e108 100644 --- a/tools/objinfo.ml +++ b/tools/objinfo.ml @@ -34,8 +34,7 @@ let input_stringlist ic len = else acc in fold 0 0 [] in - let sect = String.create len in - let _ = really_input ic sect 0 len in + let sect = Misc.input_bytes ic len in get_string_list sect len let print_name_crc (name, crc) = @@ -98,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 @@ -218,8 +217,7 @@ let dump_obj filename = printf "File %s\n" filename; let ic = open_in_bin filename in let len_magic_number = String.length cmo_magic_number in - let magic_number = String.create len_magic_number in - really_input ic magic_number 0 len_magic_number; + let magic_number = Misc.input_bytes ic len_magic_number in if magic_number = cmo_magic_number then begin let cu_pos = input_binary_int ic in seek_in ic cu_pos; @@ -233,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 @@ -271,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 eba76d9dc9..577eb56470 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 @@ -103,7 +104,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\ @@ -111,6 +112,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 1e8b3b8608..7a0e2c4cf6 100644 --- a/tools/ocamldep.ml +++ b/tools/ocamldep.ml @@ -12,14 +12,14 @@ (* $Id$ *) -open Format -open Location open Longident open Parsetree (* Print the dependencies *) +type file_kind = ML | MLI;; + let load_path = ref ([] : (string * string array) list) let ml_synonyms = ref [".ml"] let mli_synonyms = ref [".mli"] @@ -27,6 +27,10 @@ let native_only = ref false let force_slash = ref false let error_occurred = ref false let raw_dependencies = ref false +let sort_files = ref false +let all_dependencies = ref false +let one_line = ref false +let files = ref [] (* Fix path to use '/' as directory separator instead of '\'. Only under Windows. *) @@ -46,17 +50,18 @@ let add_to_load_path dir = let contents = Sys.readdir dir in load_path := !load_path @ [dir, contents] with Sys_error msg -> - fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg; + Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg; error_occurred := true let add_to_synonym_list synonyms suffix = if (String.length suffix) > 1 && suffix.[0] = '.' then synonyms := suffix :: !synonyms else begin - fprintf Format.err_formatter "@[Bad suffix: '%s'@]@." suffix; + Format.fprintf Format.err_formatter "@[Bad suffix: '%s'@]@." suffix; error_occurred := true end +(* Find file 'name' (capitalized) in search path *) let find_file name = let uname = String.uncapitalize name in let rec find_in_array a pos = @@ -77,24 +82,51 @@ let rec find_file_in_list = function [] -> raise Not_found | x :: rem -> try find_file x with Not_found -> find_file_in_list rem -let find_dependency modname (byt_deps, opt_deps) = + +let find_dependency target_kind modname (byt_deps, opt_deps) = try let candidates = List.map ((^) modname) !mli_synonyms in let filename = find_file_in_list candidates in let basename = Filename.chop_extension filename in - let optname = - if List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !ml_synonyms - then basename ^ ".cmx" - else basename ^ ".cmi" in - ((basename ^ ".cmi") :: byt_deps, optname :: opt_deps) + let cmi_file = basename ^ ".cmi" in + let ml_exists = + List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !ml_synonyms in + let new_opt_dep = + if !all_dependencies then + match target_kind with + | MLI -> [ cmi_file ] + | ML -> + cmi_file :: (if ml_exists then [ basename ^ ".cmx"] else []) + else + (* this is a make-specific hack that makes .cmx to be a 'proxy' + target that would force the dependency on .cmi via transitivity *) + if ml_exists + then [ basename ^ ".cmx" ] + else [ cmi_file ] + in + ( cmi_file :: byt_deps, new_opt_dep @ opt_deps) with Not_found -> try + (* "just .ml" case *) let candidates = List.map ((^) modname) !ml_synonyms in let filename = find_file_in_list candidates in let basename = Filename.chop_extension filename in - let bytename = - basename ^ (if !native_only then ".cmx" else ".cmo") in - (bytename :: byt_deps, (basename ^ ".cmx") :: opt_deps) + let bytenames = + if !all_dependencies then + match target_kind with + | MLI -> [basename ^ ".cmi"] + | ML -> [basename ^ ".cmi";] + else + (* again, make-specific hack *) + [basename ^ (if !native_only then ".cmx" else ".cmo")] in + let optnames = + if !all_dependencies + then match target_kind with + | MLI -> [basename ^ ".cmi"] + | ML -> [basename ^ ".cmi"; basename ^ ".cmx"] + else [ basename ^ ".cmx" ] + in + (bytenames @ byt_deps, optnames @ opt_deps) with Not_found -> (byt_deps, opt_deps) @@ -128,22 +160,21 @@ let print_filename s = end ;; -let print_dependencies target_file deps = - print_filename target_file; print_string depends_on; +let print_dependencies target_files deps = let rec print_items pos = function [] -> print_string "\n" | dep :: rem -> - if pos + 1 + String.length dep <= 77 then begin - print_string " "; print_filename dep; + if !one_line || (pos + 1 + String.length dep <= 77) then begin + if pos <> 0 then print_string " "; print_filename dep; print_items (pos + String.length dep + 1) rem end else begin print_string escaped_eol; print_filename dep; print_items (String.length dep + 4) rem end in - print_items (String.length target_file + 1) deps + print_items 0 (target_files @ [depends_on] @ deps) let print_raw_dependencies source_file deps = - print_filename source_file; print_string ":"; + print_filename source_file; print_string depends_on; Depend.StringSet.iter (fun dep -> if (String.length dep > 0) @@ -165,7 +196,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; @@ -182,11 +213,10 @@ let remove_preprocessed inputfile = let is_ast_file ic ast_magic = try - let buffer = String.create (String.length ast_magic) in - really_input ic buffer 0 (String.length ast_magic); + let buffer = Misc.input_bytes ic (String.length ast_magic) in if buffer = ast_magic then true else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then - failwith "Ocaml and preprocessor have incompatible versions" + failwith "OCaml and preprocessor have incompatible versions" else false with End_of_file -> false @@ -197,6 +227,7 @@ let parse_use_file ic = else begin seek_in ic 0; let lb = Lexing.from_channel ic in + Location.init lb !Location.input_name; Parse.use_file lb end @@ -207,57 +238,93 @@ let parse_interface ic = else begin seek_in ic 0; let lb = Lexing.from_channel ic in + Location.init lb !Location.input_name; Parse.interface lb end (* Process one file *) -let ml_file_dependencies source_file = +let report_err source_file exn = + error_occurred := true; + match exn with + | Lexer.Error(err, range) -> + Format.fprintf Format.err_formatter "@[%a%a@]@." + Location.print_error range Lexer.report_error err + | Syntaxerr.Error err -> + Format.fprintf Format.err_formatter "@[%a@]@." + Syntaxerr.report_error err + | Sys_error msg -> + Format.fprintf Format.err_formatter "@[I/O error:@ %s@]@." msg + | Preprocessing_error -> + Format.fprintf Format.err_formatter + "@[Preprocessing error on file %s@]@." + source_file + | x -> raise x + +let read_parse_and_extract parse_function extract_function source_file = Depend.free_structure_names := Depend.StringSet.empty; - let input_file = preprocess source_file in - let ic = open_in_bin input_file in try - let ast = parse_use_file ic in - Depend.add_use_file Depend.StringSet.empty ast; + let input_file = preprocess source_file in + let ic = open_in_bin input_file in + 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 -> + cleanup (); raise x + with x -> + report_err source_file x; + Depend.StringSet.empty + +let ml_file_dependencies source_file = + let extracted_deps = read_parse_and_extract + parse_use_file Depend.add_use_file source_file + in + if !sort_files then + files := (source_file, ML, !Depend.free_structure_names) :: !files + else if !raw_dependencies then begin - print_raw_dependencies source_file !Depend.free_structure_names + print_raw_dependencies source_file extracted_deps end else begin let basename = Filename.chop_extension source_file in - let init_deps = - if List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !mli_synonyms - then let cmi_name = basename ^ ".cmi" in ([cmi_name], [cmi_name]) - else ([], []) in - let (byt_deps, opt_deps) = - Depend.StringSet.fold find_dependency - !Depend.free_structure_names init_deps in - print_dependencies (basename ^ ".cmo") byt_deps; - print_dependencies (basename ^ ".cmx") opt_deps - end; - close_in ic; remove_preprocessed input_file - with x -> - close_in ic; remove_preprocessed input_file; raise x + let byte_targets = [ basename ^ ".cmo" ] in + let native_targets = + if !all_dependencies + then [ basename ^ ".cmx"; basename ^ ".o" ] + else [ basename ^ ".cmx" ] in + let init_deps = if !all_dependencies then [source_file] else [] in + let cmi_name = basename ^ ".cmi" in + let init_deps, extra_targets = + if List.exists (fun ext -> Sys.file_exists (basename ^ ext)) + !mli_synonyms + then (cmi_name :: init_deps, cmi_name :: init_deps), [] + else (init_deps, init_deps), + (if !all_dependencies then [cmi_name] else []) + in + let (byt_deps, native_deps) = + Depend.StringSet.fold (find_dependency ML) + extracted_deps init_deps in + print_dependencies (byte_targets @ extra_targets) byt_deps; + print_dependencies (native_targets @ extra_targets) native_deps; + end let mli_file_dependencies source_file = - Depend.free_structure_names := Depend.StringSet.empty; - let input_file = preprocess source_file in - let ic = open_in_bin input_file in - try - let ast = parse_interface ic in - Depend.add_signature Depend.StringSet.empty ast; + let extracted_deps = read_parse_and_extract + parse_interface Depend.add_signature source_file in + if !sort_files then + files := (source_file, MLI, extracted_deps) :: !files + else if !raw_dependencies then begin - print_raw_dependencies source_file !Depend.free_structure_names + print_raw_dependencies source_file extracted_deps end else begin let basename = Filename.chop_extension source_file in let (byt_deps, opt_deps) = - Depend.StringSet.fold find_dependency - !Depend.free_structure_names ([], []) in - print_dependencies (basename ^ ".cmi") byt_deps - end; - close_in ic; remove_preprocessed input_file - with x -> - close_in ic; remove_preprocessed input_file; raise x - -type file_kind = ML | MLI;; + Depend.StringSet.fold (find_dependency MLI) + extracted_deps ([], []) in + print_dependencies [basename ^ ".cmi"] byt_deps + end let file_dependencies_as kind source_file = Location.input_name := source_file; @@ -267,22 +334,7 @@ let file_dependencies_as kind source_file = | ML -> ml_file_dependencies source_file | MLI -> mli_file_dependencies source_file end - with x -> - let report_err = function - | Lexer.Error(err, range) -> - fprintf Format.err_formatter "@[%a%a@]@." - Location.print_error range Lexer.report_error err - | Syntaxerr.Error err -> - fprintf Format.err_formatter "@[%a@]@." - Syntaxerr.report_error err - | Sys_error msg -> - fprintf Format.err_formatter "@[I/O error:@ %s@]@." msg - | Preprocessing_error -> - fprintf Format.err_formatter "@[Preprocessing error on file %s@]@." - source_file - | x -> raise x in - error_occurred := true; - report_err x + with x -> report_err source_file x let file_dependencies source_file = if List.exists (Filename.check_suffix source_file) !ml_synonyms then @@ -291,17 +343,90 @@ let file_dependencies source_file = file_dependencies_as MLI source_file else () +let sort_files_by_dependencies files = + let h = Hashtbl.create 31 in + let worklist = ref [] in + +(* Init Hashtbl with all defined modules *) + let files = List.map (fun (file, file_kind, deps) -> + let modname = Filename.chop_extension (Filename.basename file) in + modname.[0] <- Char.uppercase modname.[0]; + let key = (modname, file_kind) in + let new_deps = ref [] in + Hashtbl.add h key (file, new_deps); + worklist := key :: !worklist; + (modname, file_kind, deps, new_deps) + ) files in + +(* Keep only dependencies to defined modules *) + List.iter (fun (modname, file_kind, deps, new_deps) -> + let add_dep modname kind = + new_deps := (modname, kind) :: !new_deps; + in + Depend.StringSet.iter (fun modname -> + match file_kind with + ML -> (* ML depends both on ML and MLI *) + if Hashtbl.mem h (modname, MLI) then add_dep modname MLI; + if Hashtbl.mem h (modname, ML) then add_dep modname ML + | MLI -> (* MLI depends on MLI if exists, or ML otherwise *) + if Hashtbl.mem h (modname, MLI) then add_dep modname MLI + else if Hashtbl.mem h (modname, ML) then add_dep modname ML + ) deps; + if file_kind = ML then (* add dep from .ml to .mli *) + if Hashtbl.mem h (modname, MLI) then add_dep modname MLI + ) files; + +(* Print and remove all files with no remaining dependency. Iterate + until all files have been removed (worklist is empty) or + no file was removed during a turn (cycle). *) + let printed = ref true in + while !printed && !worklist <> [] do + let files = !worklist in + worklist := []; + printed := false; + List.iter (fun key -> + let (file, deps) = Hashtbl.find h key in + let set = !deps in + deps := []; + List.iter (fun key -> + if Hashtbl.mem h key then deps := key :: !deps + ) set; + if !deps = [] then begin + printed := true; + Printf.printf "%s " file; + Hashtbl.remove h key; + end else + worklist := key :: !worklist + ) files + done; + + if !worklist <> [] then begin + Format.fprintf Format.err_formatter + "@[Warning: cycle in dependencies. End of list is not sorted.@]@."; + Hashtbl.iter (fun _ (file, deps) -> + Format.fprintf Format.err_formatter "\t@[%s: " file; + List.iter (fun (modname, kind) -> + Format.fprintf Format.err_formatter "%s.%s " modname + (if kind=ML then "ml" else "mli"); + ) !deps; + Format.fprintf Format.err_formatter "@]@."; + Printf.printf "%s " file) h; + end; + Printf.printf "\n%!"; + () + + (* Entry point *) let usage = "Usage: ocamldep [options] <source files>\nOptions are:" let print_version () = - printf "ocamldep, version %s@." Sys.ocaml_version; + Format.printf "ocamldep, version %s@." Sys.ocaml_version; exit 0; ;; let print_version_num () = - printf "%s@." Sys.ocaml_version; + Format.printf "%s@." Sys.ocaml_version; exit 0; ;; @@ -309,31 +434,34 @@ let _ = Clflags.classic := false; add_to_load_path Filename.current_dir_name; Arg.parse [ + "-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"; - "-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"; + "<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"; + "<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)"; + " Generate dependencies for native-code only (no .cmo files)"; + "-one-line", Arg.Set one_line, + " Output one line per file, regardless of the length"; "-pp", Arg.String(fun s -> preprocessor := Some s), - "<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 5beaae3218..b795e39f74 100644 --- a/tools/ocamlmklib.mlp +++ b/tools/ocamlmklib.mlp @@ -28,11 +28,12 @@ and caml_opts = ref [] (* -ccopt to pass to ocamlc, ocamlopt *) and dynlink = ref supports_shared_libraries and failsafe = ref false (* whether to fall back on static build only *) and c_libs = ref [] (* libs to pass to mksharedlib and ocamlc -cclib *) +and c_Lopts = ref [] (* options to pass to mksharedlib and ocamlc -cclib *) and c_opts = ref [] (* options to pass to mksharedlib and ocamlc -ccopt *) and ld_opts = ref [] (* options to pass only to the linker *) and ocamlc = ref (compiler_path "ocamlc") and ocamlopt = ref (compiler_path "ocamlopt") -and output = ref "a" (* Output name for Caml part of library *) +and output = ref "a" (* Output name for OCaml part of library *) and output_c = ref "" (* Output name for C part of library *) and rpath = ref [] (* rpath options *) and verbose = ref false @@ -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 = "-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 @@ -152,15 +155,15 @@ Usage: ocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a|.obj|.lib|.dll \n -help Print this help message and exit\ \n --help Same as -help\ \n -h Same as -help\ -\n -I <dir> Add <dir> to the path searched for Caml object files\ +\n -I <dir> Add <dir> to the path searched for OCaml object files\ \n -failsafe fall back to static linking if DLL construction failed\ \n -ldopt <opt> C option passed to the shared linker only\ -\n -linkall Build Caml archive with link-all behavior\ +\n -linkall Build OCaml archive with link-all behavior\ \n -l<lib> Specify a dependent C library\ \n -L<dir> Add <dir> to the path searched for C libraries\ \n -ocamlc <cmd> Use <cmd> in place of \"ocamlc\"\ \n -ocamlopt <cmd> Use <cmd> in place of \"ocamlopt\"\ -\n -o <name> Generated Caml library is named <name>.cma or <name>.cmxa\ +\n -o <name> Generated OCaml library is named <name>.cma or <name>.cmxa\ \n -oc <name> Generated C library is named dll<name>.so or lib<name>.a\ \n -rpath <dir> Same as -dllpath <dir>\ \n -R<dir> Same as -rpath\ 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 0f44da8ca2..f3a64d6e62 100644 --- a/tools/ocamlmktop.tpl +++ b/tools/ocamlmktop.tpl @@ -13,4 +13,4 @@ # $Id$ -exec %%BINDIR%%/ocamlc -linkall toplevellib.cma "$@" topstart.cmo +exec %%BINDIR%%/ocamlc -I +compiler-libs -linkall ocamlcommon.cma ocamlbytecomp.cma ocamltoplevel.cma "$@" topstart.cmo diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml new file mode 100644 index 0000000000..74be227ad0 --- /dev/null +++ b/tools/ocamloptp.ml @@ -0,0 +1,158 @@ +(***********************************************************************) +(* *) +(* 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 _real_paths = option "-real-paths" + let _rectypes = option "-rectypes" + let _runtime_variant s = option_with_arg "-runtime-variant" s + let _S = option "-S" + let _strict_sequence = option "-strict-sequence" + let _shared = option "-shared" + let _thread = option "-thread" + let _unsafe = option "-unsafe" + let _v = option "-v" + let _version = option "-version" + let _vnum = option "-vnum" + let _verbose = option "-verbose" + let _w = option_with_arg "-w" + let _warn_error = option_with_arg "-warn-error" + let _warn_help = option "-warn-help" + let _where = option "-where" + + let _nopervasives = option "-nopervasives" + let _dparsetree = option "-dparsetree" + let _drawlambda = option "-drawlambda" + let _dlambda = option "-dlambda" + let _dclambda = option "-dclambda" + let _dcmm = option "-dcmm" + let _dsel = option "-dsel" + let _dcombine = option "-dcombine" + let _dlive = option "-dlive" + let _dspill = option "-dspill" + let _dsplit = option "-dsplit" + let _dinterf = option "-dinterf" + let _dprefer = option "-dprefer" + let _dalloc = option "-dalloc" + let _dreload = option "-dreload" + let _dscheduling = option "-dscheduling" + let _dlinear = option "-dlinear" + let _dstartup = option "-dstartup" + + let anonymous = process_file +end);; + +let add_profarg s = + profargs := (Filename.quote s) :: "-m" :: !profargs +;; + +let optlist = + ("-P", Arg.String add_profarg, + "[afilmt] Profile constructs specified by argument (default fm):\n\ + \032 a Everything\n\ + \032 f Function calls and method calls\n\ + \032 i if ... then ... else\n\ + \032 l while and for loops\n\ + \032 m match ... with\n\ + \032 t try ... with") + :: Options.list +in +Arg.parse optlist process_file usage; +if !with_impl && !with_intf then begin + fprintf stderr "ocamloptp cannot deal with both \"-impl\" and \"-intf\"\n"; + fprintf stderr "please compile interfaces and implementations separately\n"; + exit 2; +end else if !with_impl && !with_mli then begin + fprintf stderr "ocamloptp cannot deal with both \"-impl\" and .mli files\n"; + fprintf stderr "please compile interfaces and implementations separately\n"; + exit 2; +end else if !with_intf && !with_ml then begin + fprintf stderr "ocamloptp cannot deal with both \"-intf\" and .ml files\n"; + fprintf stderr "please compile interfaces and implementations separately\n"; + exit 2; +end; +if !with_impl then profargs := "-impl" :: !profargs; +if !with_intf then profargs := "-intf" :: !profargs; +let status = + Sys.command + (Printf.sprintf "ocamlopt -pp \"ocamlprof -instrument %s\" %s %s" + (String.concat " " (List.rev !profargs)) + (if !make_archive then "" else "profiling.cmx") + (String.concat " " (List.rev !compargs))) +in +exit status +;; diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml index b8a6b3fa40..1fd123ceab 100644 --- a/tools/ocamlprof.ml +++ b/tools/ocamlprof.ml @@ -282,8 +282,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 @@ -319,24 +319,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..161f8654f0 --- /dev/null +++ b/tools/pprintast.ml @@ -0,0 +1,2157 @@ +(**************************************************************************) +(* *) +(* 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 () ; + | _ -> simple_expr ppf x + + +and value_description ppf x = + pp_open_hovbox ppf indent ; + core_type ppf x.pval_type; + if ((List.length x.pval_prim) > 0) then begin + fprintf ppf " =@ " ; + list2 constant_string ppf x.pval_prim ""; + end ; + pp_close_box ppf () ; + +and type_declaration ppf x = + pp_open_hovbox ppf indent ; + (match x.ptype_manifest with + | None -> () + | Some(y) -> + core_type ppf y; + match x.ptype_kind with + | Ptype_variant _ | Ptype_record _ -> fprintf ppf " = " + | Ptype_abstract -> ()); + (match x.ptype_kind with + | Ptype_variant (first::rest) -> + pp_open_hovbox ppf indent ; + + pp_open_hvbox ppf 0 ; + type_variant_leaf ppf first true ; + type_variant_leaf_list ppf rest ; +(* string_x_core_type_list ppf lst; *) + pp_close_box ppf () ; + + pp_close_box ppf () ; + | Ptype_variant [] -> + assert false ; + | Ptype_abstract -> () + | Ptype_record l -> + + pp_open_hovbox ppf indent ; + + fprintf ppf "{" ; + pp_print_break ppf 0 indent ; + pp_open_hvbox ppf 0; + list2 type_record_field ppf l ";" ; + pp_close_box ppf () ; + fprintf ppf "@," ; + pp_close_box ppf () ; + fprintf ppf "}" ; + + pp_close_box ppf () ; + ); + list2 typedef_constraint ppf x.ptype_cstrs ~breakfirst:true "" ; + pp_close_box ppf () ; + +and exception_declaration ppf x = + match x with + | [] -> () + | first::rest -> + fprintf ppf "@ of@ "; + list2 core_type ppf x " *"; + +and class_type ppf x = + match x.pcty_desc with + | Pcty_signature (cs) -> + class_signature ppf cs; + | Pcty_constr (li, l) -> + pp_open_hovbox ppf indent ; + (match l with + | [] -> () + | _ -> fprintf ppf "[" ; + list2 core_type ppf l "," ; + fprintf ppf "]@ " ); + fprintf ppf "%a" fmt_longident li ; + pp_close_box ppf () ; + | Pcty_fun (l, co, cl) -> + pp_open_hovbox ppf indent ; + core_type ppf co ; + fprintf ppf " ->@ " ; + (match l with + | "" -> () ; + | _ -> fprintf ppf "[%s] " l ); (* todo - what's l *) + class_type ppf cl ; + pp_close_box ppf () ; + +and class_signature ppf { pcsig_self = ct; pcsig_fields = l } = + pp_open_hvbox ppf 0; + pp_open_hovbox ppf indent ; + fprintf ppf "object"; + (match ct.ptyp_desc with + | Ptyp_any -> () + | _ -> fprintf ppf "@ ("; + core_type ppf ct; + fprintf ppf ")" ); + pp_close_box ppf () ; + list2 class_type_field ppf l ~indent:indent ~breakfirst:true ""; + pp_print_break ppf 1 0; + fprintf ppf "end"; + +and class_type_field ppf x = + match x.pctf_desc with + | Pctf_inher (ct) -> (* todo: test this *) + pp_open_hovbox ppf indent ; + fprintf ppf "inherit@ " ; + class_type ppf ct ; + pp_close_box ppf () ; + | Pctf_val (s, mf, vf, ct) -> + pp_open_hovbox ppf indent ; + fprintf ppf "val %s%s%s :@ " + (match mf with + | Mutable -> "mutable " + | _ -> "") + (match vf with + | Virtual -> "virtual " + | _ -> "") + s; + core_type ppf ct ; + pp_close_box ppf () ; + | Pctf_virt (s, pf, ct) -> (* todo: test this *) + pp_open_hovbox ppf indent ; + pp_open_hovbox ppf indent ; + fprintf ppf "method@ %avirtual@ %s" fmt_private_flag pf s ; + pp_close_box ppf () ; + fprintf ppf " :@ " ; + core_type ppf ct ; + pp_close_box ppf () ; + | Pctf_meth (s, pf, ct) -> + pp_open_hovbox ppf indent ; + pp_open_hovbox ppf indent ; + fprintf ppf "method %a%s" fmt_private_flag pf s; + pp_close_box ppf () ; + fprintf ppf " :@ " ; + core_type ppf ct ; + pp_close_box ppf () ; + | Pctf_cstr (ct1, ct2) -> + pp_open_hovbox ppf indent ; + fprintf ppf "constraint@ " ; + core_type ppf ct1; + fprintf ppf " =@ " ; + core_type ppf ct2; + pp_close_box ppf () ; + +and class_description ppf x = + pp_open_hvbox ppf 0 ; + pp_open_hovbox ppf indent ; + fprintf ppf "class %a%a%s :" fmt_virtual_flag x.pci_virt + fmt_class_params_def x.pci_params x.pci_name.txt ; + pp_close_box ppf () ; + pp_print_break ppf 1 indent ; + class_type ppf x.pci_expr ; + pp_close_box ppf () ; + +and class_type_declaration ppf x = + class_type_declaration_ext ppf true x ; + +and class_type_declaration_ext ppf first x = + pp_open_hvbox ppf 0; + pp_open_hovbox ppf indent ; + fprintf ppf "%s@ %a%a%s =" (if (first) then "class type" else "and") + fmt_virtual_flag x.pci_virt fmt_class_params_def x.pci_params + x.pci_name.txt ; + pp_close_box ppf (); + pp_print_break ppf 1 indent ; + class_type ppf x.pci_expr; + pp_close_box ppf (); + +and class_type_declaration_list ppf ?(first=true) l = + if (first) then pp_open_hvbox ppf 0 ; + match l with + | [] -> if (first) then pp_close_box ppf () ; + | h :: [] -> + class_type_declaration_ext ppf first h ; + pp_close_box ppf () ; + | h :: t -> + class_type_declaration_ext ppf first h ; + pp_print_space ppf () ; + class_type_declaration_list ppf ~first:false t ; + +and class_expr ppf x = + match x.pcl_desc with + | Pcl_structure (cs) -> + class_structure ppf cs ; + | Pcl_fun (l, eo, p, e) -> + pp_open_hvbox ppf indent; + pp_open_hovbox ppf indent; + fprintf ppf "fun@ "; + pattern ppf p; + fprintf ppf " ->"; + pp_close_box ppf (); + (match (eo, l) with + | (None, "") -> () ; + | (_,_) -> + pp_open_hovbox ppf indent; + fprintf ppf " (* eo: "; + option expression ppf eo; + fprintf ppf "@ label: "; + label 0 ppf l; + fprintf ppf " *)"; + pp_close_box ppf () + ); + fprintf ppf "@ "; + class_expr ppf e; + pp_close_box ppf (); + | Pcl_let (rf, l, ce) -> + let l1 = (List.hd l) in + let l2 = (List.tl l) in + pp_open_hvbox ppf 0 ; + pp_open_hvbox ppf indent ; + fprintf ppf "let%a " fmt_rec_flag rf; + pattern_x_expression_def ppf l1; + pattern_x_expression_def_list ppf l2; + pp_close_box ppf () ; + pp_close_box ppf () ; + fprintf ppf " in" ; + pp_print_space ppf () ; + class_expr ppf ce; + | Pcl_apply (ce, l) -> + pp_open_hovbox ppf indent ; + fprintf ppf "("; + class_expr ppf ce; + list2 label_x_expression_param ppf l ~breakfirst:true ""; + fprintf ppf ")"; + pp_close_box ppf () ; + | Pcl_constr (li, l) -> + pp_open_hovbox ppf indent; + if ((List.length l) != 0) then begin + fprintf ppf "[" ; + list2 core_type ppf l "," ; + fprintf ppf "]@ " ; + end ; + fprintf ppf "%a" fmt_longident li; + pp_close_box ppf (); + | Pcl_constraint (ce, ct) -> + pp_open_hovbox ppf indent; + fprintf ppf "("; + class_expr ppf ce; + fprintf ppf "@ : "; + class_type ppf ct; + fprintf ppf ")"; + pp_close_box ppf (); + +and class_structure ppf { pcstr_pat = p; pcstr_fields = l } = + pp_open_hvbox ppf 0 ; + pp_open_hovbox ppf indent ; + fprintf ppf "object" ; + (match p.ppat_desc with + | Ppat_any -> (); + | _ -> fprintf ppf "@ " ; + pattern_in_parens ppf p ); + pp_close_box ppf () ; + list2 class_field ppf l ~indent:indent ~breakfirst:true ""; + fprintf ppf "@ end" ; + pp_close_box ppf () ; + +and override ovf = match ovf with + Override -> "!" + | Fresh -> "" + +and class_field ppf x = + match x.pcf_desc with + | Pcf_inher (ovf, ce, so) -> + pp_open_hovbox ppf indent ; + fprintf ppf "inherit%s@ " (override ovf); + class_expr ppf ce; + (match so with + | None -> (); + | Some (s) -> fprintf ppf "@ as %s" s ); + pp_close_box ppf (); + | Pcf_val (s, mf, ovf, e) -> + pp_open_hovbox ppf indent ; + fprintf ppf "val%s %a%s =@ " (override ovf) fmt_mutable_flag mf s.txt ; + expression_sequence ppf ~indent:0 e ; + pp_close_box ppf () ; + | Pcf_virt (s, pf, ct) -> + pp_open_hovbox ppf indent ; + fprintf ppf "method virtual %a%s" fmt_private_flag pf s.txt ; + fprintf ppf " :@ " ; + core_type ppf ct; + pp_close_box ppf () ; + | Pcf_valvirt (s, mf, ct) -> + pp_open_hovbox ppf indent ; + fprintf ppf "val virtual %s%s" + (match mf with + | Mutable -> "mutable " + | _ -> "") + s.txt; + fprintf ppf " :@ " ; + core_type ppf ct; + pp_close_box ppf () ; + | Pcf_meth (s, pf, ovf, e) -> + pp_open_hovbox ppf indent ; + fprintf ppf "method%s %a%s" (override ovf) fmt_private_flag pf s.txt ; + (match e.pexp_desc with + | Pexp_poly (e, Some(ct)) -> + fprintf ppf " :@ " ; + core_type ppf ct ; + fprintf ppf " =@ " ; + expression ppf e ; + | _ -> + fprintf ppf " =@ " ; + expression ppf e; + ) ; +(* special Pexp_poly handling? *) + pp_close_box ppf () ; + | Pcf_constr (ct1, ct2) -> + pp_open_hovbox ppf indent ; + fprintf ppf "constraint@ "; + core_type ppf ct1; + fprintf ppf " =@ " ; + core_type ppf ct2; + pp_close_box ppf (); +(* | Pcf_let (rf, l) -> +(* at the time that this was written, Pcf_let was commented out + of the parser, rendering this untestable. In the interest of + completeness, the following code is designed to print what + the parser seems to expect *) +(* todo: test this, eventually *) + let l1 = (List.hd l) in + let l2 = (List.tl l) in + pp_open_hvbox ppf indent ; + fprintf ppf "let%a " fmt_rec_flag rf; + pattern_x_expression_def ppf l1; + pattern_x_expression_def_list ppf l2; + fprintf ppf " in" ; + pp_close_box ppf () ; *) + | Pcf_init (e) -> + pp_open_hovbox ppf indent ; + fprintf ppf "initializer@ " ; + expression_sequence ppf ~indent:0 e ; + pp_close_box ppf () ; + +and class_fun_helper ppf e = + match e.pcl_desc with + | Pcl_fun (l, eo, p, e) -> + pattern ppf p; + fprintf ppf "@ "; + (match (eo, l) with + | (None, "") -> () ; + | (_,_) -> + fprintf ppf "(* "; + option expression ppf eo; + label 0 ppf l; + fprintf ppf " *)@ " + ); + class_fun_helper ppf e; + | _ -> + e; + +and class_declaration_list ppf ?(first=true) l = + match l with + | [] -> + if (first = false) then pp_close_box ppf (); + | cd::l -> + let s = (if first then begin pp_open_hvbox ppf 0 ; "class" end + else begin pp_print_space ppf () ; "and" end) in + class_declaration ppf ~str:s cd ; + class_declaration_list ppf ~first:false l ; + +and class_declaration ppf ?(str="class") x = + pp_open_hvbox ppf indent ; + pp_open_hovbox ppf indent ; + fprintf ppf "%s %a%a%s@ " str fmt_virtual_flag x.pci_virt + fmt_class_params_def x.pci_params x.pci_name.txt ; + let ce = + (match x.pci_expr.pcl_desc with + | Pcl_fun (l, eo, p, e) -> + class_fun_helper ppf x.pci_expr; + | _ -> x.pci_expr) in + let ce = + (match ce.pcl_desc with + | Pcl_constraint (ce, ct) -> + fprintf ppf ":@ " ; + class_type ppf ct ; + fprintf ppf "@ " ; + ce + | _ -> ce ) in + fprintf ppf "=" ; + pp_close_box ppf () ; + fprintf ppf "@ " ; + class_expr ppf ce ; + pp_close_box ppf () ; + +and module_type ppf x = + match x.pmty_desc with + | Pmty_ident (li) -> + fprintf ppf "%a" fmt_longident li; + | Pmty_signature (s) -> + pp_open_hvbox ppf 0; + fprintf ppf "sig"; + list2 signature_item ppf s ~breakfirst:true ~indent:indent ""; + pp_print_break ppf 1 0; + fprintf ppf "end"; + pp_close_box ppf (); + | Pmty_functor (s, mt1, mt2) -> + pp_open_hvbox ppf indent; + pp_open_hovbox ppf indent; + fprintf ppf "functor@ (%s : " s.txt ; + module_type ppf mt1; + fprintf ppf ") ->"; + pp_close_box ppf (); + pp_print_space ppf (); + module_type ppf mt2; + pp_close_box ppf (); + | Pmty_with (mt, l) -> + pp_open_hovbox ppf indent ; + fprintf ppf "(" ; + module_type ppf mt ; + fprintf ppf "@ with@ " ; + longident_x_with_constraint_list ppf l ; + fprintf ppf ")" ; + pp_close_box ppf () ; + | Pmty_typeof me -> + pp_open_hovbox ppf indent ; + fprintf ppf "module type of " ; + module_expr ppf me ; + pp_close_box ppf () + +and signature ppf x = list signature_item ppf x + +and signature_item ppf x = + begin + match x.psig_desc with + | Psig_type (l) -> + let first = (List.hd l) in + let rest = (List.tl l) in + pp_open_hvbox ppf 0; + pp_open_hvbox ppf 0; + fprintf ppf "type " ; + string_x_type_declaration ppf first; + pp_close_box ppf (); + type_def_list_helper ppf rest; + pp_close_box ppf (); + | Psig_value (s, vd) -> + let intro = if vd.pval_prim = [] then "val" else "external" in + pp_open_hovbox ppf indent ; + if (is_infix (fixity_of_string s.txt)) + || List.mem s.txt.[0] prefix_symbols then + fprintf ppf "%s ( %s ) :@ " + intro s.txt (* OXX done *) + else + fprintf ppf "%s %s :@ " intro s.txt; + value_description ppf vd; + pp_close_box ppf () ; + | Psig_exception (s, ed) -> + pp_open_hovbox ppf indent ; + fprintf ppf "exception %s" s.txt; + exception_declaration ppf ed; + pp_close_box ppf (); + | Psig_class (l) -> + pp_open_hvbox ppf 0 ; + list2 class_description ppf l ""; + pp_close_box ppf () ; + | Psig_module (s, mt) -> (* todo: check this *) + pp_open_hovbox ppf indent ; + pp_open_hovbox ppf indent ; + fprintf ppf "module@ %s :" s.txt ; + pp_close_box ppf () ; + pp_print_space ppf () ; + module_type ppf mt; + pp_close_box ppf () ; + | Psig_open (li) -> + pp_open_hovbox ppf indent ; + fprintf ppf "open@ %a" fmt_longident li ; + pp_close_box ppf () ; + | Psig_include (mt) -> (* todo: check this *) + pp_open_hovbox ppf indent ; + fprintf ppf "include@ " ; + module_type ppf mt; + pp_close_box ppf () ; + | Psig_modtype (s, md) -> (* todo: check this *) + pp_open_hovbox ppf indent ; + fprintf ppf "module type %s" s.txt ; + (match md with + | Pmodtype_abstract -> () + | Pmodtype_manifest (mt) -> + pp_print_space ppf () ; + fprintf ppf " = " ; + module_type ppf mt; + ); + pp_close_box ppf () ; + | Psig_class_type (l) -> + class_type_declaration_list ppf l ; + | Psig_recmodule decls -> + pp_open_hvbox ppf 0 ; + pp_open_hovbox ppf indent ; + fprintf ppf "module rec@ " ; + string_x_module_type_list ppf decls ; (* closes hov box *) + pp_close_box ppf () ; + end; + fprintf ppf "\n" + +and modtype_declaration ppf x = + match x with + | Pmodtype_abstract -> line 0 ppf "Pmodtype_abstract\n"; + | Pmodtype_manifest (mt) -> + line 0 ppf "Pmodtype_manifest\n"; + module_type ppf mt; + +and module_expr ppf x = + match x.pmod_desc with + | Pmod_structure (s) -> + pp_open_hvbox ppf 0; + fprintf ppf "struct"; + list2 structure_item ppf s ~breakfirst:true ~indent:indent ""; + pp_print_break ppf 1 0; + fprintf ppf "end"; + pp_close_box ppf (); (* bug fixed? *) + | Pmod_constraint (me, mt) -> + fprintf ppf "("; + pp_open_hovbox ppf indent; + module_expr ppf me; + fprintf ppf " :@ "; (* <-- incorrect indentation? *) + module_type ppf mt; + pp_close_box ppf (); + fprintf ppf ")"; + | Pmod_ident (li) -> + fprintf ppf "%a" fmt_longident li; + | Pmod_functor (s, mt, me) -> + pp_open_hvbox ppf indent ; + fprintf ppf "functor (%s : " s.txt; + module_type ppf mt; + fprintf ppf ") ->@ "; + module_expr ppf me; + pp_close_box ppf () ; + | Pmod_apply (me1, me2) -> + pp_open_hovbox ppf indent; + fprintf ppf "(" ; + module_expr ppf me1; + fprintf ppf ")" ; + pp_print_cut ppf (); + fprintf ppf "(" ; + module_expr ppf me2; + fprintf ppf ")" ; + pp_close_box ppf (); + | Pmod_unpack e -> + fprintf ppf "(val@ "; + pp_open_hovbox ppf indent; + expression ppf e; + pp_close_box ppf (); + fprintf ppf ")"; + +and structure ppf x = + list structure_item ppf x; + +(* +(* closes one box *) +and string_x_modtype_x_module ppf (s, _, mt, me) = +(* + (match me.pmod_desc with + | Pmod_constraint (me, ({pmty_desc=(Pmty_ident (_) + | Pmty_signature (_))} as mt)) -> + (* assert false ; *) (* 3.07 - should this ever happen here? *) + fprintf ppf "%s :@ " s ; + module_type ppf mt ; + fprintf ppf " =" ; + pp_close_box ppf () ; + pp_print_space ppf () ; + module_expr ppf me ; + | _ -> +*) + fprintf ppf "%s :@ " s; + module_type ppf mt ; + fprintf ppf " =" ; + pp_close_box ppf () ; + pp_print_space ppf () ; + module_expr ppf me ; +(* ) ; *) +*) + +(* closes one box *) +and text_x_modtype_x_module ppf (s, mt, me) = +(* + (match me.pmod_desc with + | Pmod_constraint (me, ({pmty_desc=(Pmty_ident (_) + | Pmty_signature (_))} as mt)) -> + (* assert false ; *) (* 3.07 - should this ever happen here? *) + fprintf ppf "%s :@ " s ; + module_type ppf mt ; + fprintf ppf " =" ; + pp_close_box ppf () ; + pp_print_space ppf () ; + module_expr ppf me ; + | _ -> +*) + fprintf ppf "%s :@ " s.txt; + module_type ppf mt ; + fprintf ppf " =" ; + pp_close_box ppf () ; + pp_print_space ppf () ; + module_expr ppf me ; +(* ) ; *) + +(* +(* net gain of one box (-1, +2) *) +and string_x_modtype_x_module_list ppf l = + match l with + | [] -> () + | hd :: tl -> + pp_close_box ppf () ; + pp_print_space ppf () ; + pp_open_hvbox ppf indent ; + pp_open_hovbox ppf indent ; + fprintf ppf "and " ; + string_x_modtype_x_module ppf hd; (* closes a box *) + string_x_modtype_x_module_list ppf tl ; (* net open of one box *) +*) + +(* net gain of one box (-1, +2) *) +and text_x_modtype_x_module_list ppf l = + match l with + | [] -> () + | hd :: tl -> + pp_close_box ppf () ; + pp_print_space ppf () ; + pp_open_hvbox ppf indent ; + pp_open_hovbox ppf indent ; + fprintf ppf "and " ; + text_x_modtype_x_module ppf hd; (* closes a box *) + text_x_modtype_x_module_list ppf tl ; (* net open of one box *) + +(* context: [hv [hov .]] returns [hv .] + closes inner hov box. *) +and string_x_module_type_list ppf ?(first=true) l = + match l with + | [] -> () ; + | hd :: tl -> + if (first=false) then begin + pp_print_space ppf () ; + pp_open_hovbox ppf indent ; + fprintf ppf "and " ; + end ; + string_x_module_type ppf hd ; + pp_close_box ppf () ; + string_x_module_type_list ppf ~first:false tl ; + +and string_x_module_type ppf (s, mty) = + fprintf ppf "%s :@ " s.txt ; + module_type ppf mty ; + +and structure_item ppf x = + begin + match x.pstr_desc with + | Pstr_eval (e) -> + pp_open_hvbox ppf 0 ; + fprintf ppf "let _ = " ; + expression_sequence ppf ~first:false ~indent:0 e ; + pp_close_box ppf () ; + | Pstr_type [] -> assert false + | Pstr_type (first :: rest) -> + pp_open_vbox ppf 0; + pp_open_hvbox ppf 0; + fprintf ppf "type " ; + string_x_type_declaration ppf first; + pp_close_box ppf (); + type_def_list_helper ppf rest; + pp_close_box ppf (); + | Pstr_value (rf, l) -> + let l1 = (List.hd l) in + let l2 = (List.tl l) in + pp_open_hvbox ppf 0 ; + pp_open_hvbox ppf indent ; + fprintf ppf "let%a " fmt_rec_flag rf; + pattern_x_expression_def ppf l1; + pattern_x_expression_def_list ppf l2; + pp_close_box ppf () ; + pp_close_box ppf () ; + | Pstr_exception (s, ed) -> + pp_open_hovbox ppf indent ; + fprintf ppf "exception@ %s" s.txt; + exception_declaration ppf ed; + pp_close_box ppf () ; + | Pstr_module (s, me) -> + pp_open_hvbox ppf indent; + pp_open_hovbox ppf indent ; + fprintf ppf "module %s" s.txt ; + (match me.pmod_desc with + | Pmod_constraint (me, ({pmty_desc=(Pmty_ident (_) + | Pmty_signature (_))} as mt)) -> + fprintf ppf " :@ " ; + module_type ppf mt ; + fprintf ppf " =" ; + pp_close_box ppf () ; + pp_print_space ppf () ; + module_expr ppf me ; + | _ -> + fprintf ppf " =" ; + pp_close_box ppf () ; + pp_print_space ppf () ; + module_expr ppf me ; + ) ; + pp_close_box ppf (); + | Pstr_open (li) -> + fprintf ppf "open %a" fmt_longident li; + | Pstr_modtype (s, mt) -> + pp_open_hovbox ppf indent; + fprintf ppf "module type %s =@ " s.txt; + module_type ppf mt; + pp_close_box ppf () ; (* bug fixed? *) + | Pstr_class (l) -> + class_declaration_list ppf l; + | Pstr_class_type (l) -> + class_type_declaration_list ppf l ; + | Pstr_primitive (s, vd) -> + pp_open_hovbox ppf indent ; + let need_parens = + match s.txt with + | "or" + | "mod" + | "land" + | "lor" + | "lxor" + | "lsl" + | "lsr" + | "asr" + -> true + + | _ -> + match s.txt.[0] with + 'a'..'z' -> false + | _ -> true + in + if need_parens then + fprintf ppf "external@ ( %s ) :@ " s.txt + else + fprintf ppf "external@ %s :@ " s.txt; + value_description ppf vd; + pp_close_box ppf () ; + | Pstr_include me -> + pp_open_hovbox ppf indent ; + fprintf ppf "include " ; + module_expr ppf me ; + pp_close_box ppf () ; + | Pstr_exn_rebind (s, li) -> (* todo: check this *) + pp_open_hovbox ppf indent ; + fprintf ppf "exception@ %s =@ %a" s.txt fmt_longident li ; + pp_close_box ppf () ; + | Pstr_recmodule decls -> (* 3.07 *) + let l1 = (List.hd decls) in + let l2 = (List.tl decls) in + pp_open_hvbox ppf 0; (* whole recmodule box *) + pp_open_hvbox ppf indent ; (* this definition box *) + pp_open_hovbox ppf indent ; (* first line box *) + fprintf ppf "module rec " ; + text_x_modtype_x_module ppf l1; (* closes a box *) + text_x_modtype_x_module_list ppf l2; (* net opens one box *) + pp_close_box ppf () ; + pp_close_box ppf () ; + pp_close_box ppf () ; + end; + fprintf ppf "\n" + +and type_def_list_helper ppf l = + match l with + | [] -> () + | first :: rest -> + pp_print_space ppf () ; + pp_open_hovbox ppf indent ; + fprintf ppf "and " ; + string_x_type_declaration ppf first; + pp_close_box ppf () ; + type_def_list_helper ppf rest ; + +and string_x_type_declaration ppf (s, td) = + let l = td.ptype_params in + (match (List.length l) with + | 0 -> () + | 1 -> list2 type_var_option_print ppf l "" ; + fprintf ppf " " ; + | _ -> pp_open_hovbox ppf indent ; + fprintf ppf "(" ; + list2 type_var_option_print ppf l "," ; + fprintf ppf ")" ; + pp_close_box ppf (); + fprintf ppf " " ; + ); + fprintf ppf "%s" s.txt ; + (match (td.ptype_kind, td.ptype_manifest) with + | Ptype_abstract, None -> () + | Ptype_record _, _ -> fprintf ppf " = " ; + | _ , _ -> fprintf ppf " =" ; + pp_print_break ppf 1 indent ; + ); + type_declaration ppf td; + +and longident_x_with_constraint_list ?(first=true) ppf l = + match l with + | [] -> () ; + | h :: [] -> + if (first = false) then fprintf ppf "@ and " ; + longident_x_with_constraint ppf h ; + | h :: t -> + if (first = false) then fprintf ppf "@ and " ; + longident_x_with_constraint ppf h ; + fprintf ppf "@ and " ; + longident_x_with_constraint ppf h ; + longident_x_with_constraint_list ~first:false ppf t; + +and string_x_core_type_ands ?(first=true) ppf l = + match l with + | [] -> () ; + | h :: [] -> + if (first = false) then fprintf ppf "@ and " ; + string_x_core_type ppf h ; + | h :: t -> + if (first = false) then fprintf ppf "@ and " ; + string_x_core_type ppf h; + string_x_core_type_ands ~first:false ppf t; + +and string_x_core_type ppf (s, ct) = + fprintf ppf "%a@ =@ %a" fmt_longident s core_type ct + +and longident_x_with_constraint ppf (li, wc) = + match wc with + | Pwith_type (td) -> + fprintf ppf "type@ %a =@ " fmt_longident li; + type_declaration ppf td ; + | Pwith_module (li2) -> + fprintf ppf "module %a =@ %a" fmt_longident li fmt_longident li2; + | Pwith_typesubst td -> + fprintf ppf "type@ %a :=@ " fmt_longident li; + type_declaration ppf td ; + | Pwith_modsubst (li2) -> + fprintf ppf "module %a :=@ %a" fmt_longident li fmt_longident li2; + +and typedef_constraint ppf (ct1, ct2, l) = + pp_open_hovbox ppf indent ; + fprintf ppf "constraint@ " ; + core_type ppf ct1; + fprintf ppf " =@ " ; + core_type ppf ct2; + pp_close_box ppf () ; + +and type_variant_leaf ppf (s, l,_, _) first = (* TODO *) + if (first) then begin + pp_print_if_newline ppf (); + pp_print_string ppf " "; + end else begin + pp_print_space ppf (); + fprintf ppf "| " ; + end ; + pp_open_hovbox ppf indent ; + fprintf ppf "%s" s.txt ; + if ((List.length l) > 0) then begin + fprintf ppf "@ of@ " ; + list2 core_type ppf l " *" + end ; + pp_close_box ppf (); + +and type_variant_leaf_list ppf list = + match list with + | [] -> () + | first :: rest -> + type_variant_leaf ppf first false ; + type_variant_leaf_list ppf rest ; + +and type_record_field ppf (s, mf, ct,_) = + pp_open_hovbox ppf indent ; + fprintf ppf "%a%s:" fmt_mutable_flag mf s.txt ; + core_type ppf ct ; + pp_close_box ppf () ; + +and longident_x_pattern ppf (li, p) = + pp_open_hovbox ppf indent ; + fprintf ppf "%a =@ " fmt_longident li; + pattern ppf p; + pp_close_box ppf () ; + + + +and pattern_x_expression_case_list + ppf ?(first:bool=true) ?(special_first_case=bar_on_first_case) + (l:(pattern * expression) list) = + match l with + | [] -> () + | (p,e)::[] -> (* last time *) + if (first=false) then + fprintf ppf "| " ; + pp_open_hvbox ppf indent ; + let (e,w) = + (match e with + | {pexp_desc = Pexp_when (e1, e2)} -> (e2, Some (e1)) + | _ -> (e, None)) in + pattern_with_when ppf w p ; + fprintf ppf " ->@ " ; + pp_open_hvbox ppf 0 ; + expression_sequence ppf ~indent:0 e ; + pp_close_box ppf () ; + pp_close_box ppf () ; + | (p,e)::r -> (* not last *) + pp_open_hvbox ppf (indent + 2) ; + if ((first=true) & (special_first_case=false)) then begin + pp_print_if_newline ppf () ; + pp_print_string ppf " " + end else + fprintf ppf "| " ; + let (e,w) = + (match e with + | {pexp_desc = Pexp_when (e1, e2)} -> (e2, Some (e1)) + | _ -> (e, None)) in + pattern_with_when ppf w p ; + fprintf ppf " ->@ " ; + pp_open_hvbox ppf 0 ; + expression_sequence ppf ~indent:0 e ; + pp_close_box ppf () ; + pp_close_box ppf () ; + pp_print_break ppf 1 0; + (pattern_x_expression_case_list ppf ~first:false r); + +and pattern_x_expression_def ppf (p, e) = + pattern ppf p ; + fprintf ppf " =@ " ; + expression ppf e; + +and pattern_list_helper ppf p = + match p with + | {ppat_desc = Ppat_construct ({ txt = Longident.Lident("::") }, + Some ({ppat_desc = Ppat_tuple([pat1; pat2])}), + _)} + -> pattern ppf pat1 ; + fprintf ppf "@ ::@ " ; + pattern_list_helper ppf pat2 ; + | _ -> pattern ppf p ; + +and string_x_expression ppf (s, e) = + pp_open_hovbox ppf indent ; + fprintf ppf "%s =@ " s.txt ; + expression ppf e ; + pp_close_box ppf () ; + +and longident_x_expression ppf (li, e) = + pp_open_hovbox ppf indent ; + fprintf ppf "%a =@ " fmt_longident li; + simple_expr ppf e; + pp_close_box ppf () ; + +and label_x_expression_param ppf (l,e) = + match l with + | "" -> simple_expr ppf e ; + | lbl -> + if ((String.get lbl 0) = '?') then begin + fprintf ppf "%s:" lbl ; + simple_expr ppf e ; + end else begin + fprintf ppf "~%s:" lbl ; + simple_expr ppf e ; + end ; + +and expression_in_parens ppf e = + let already_has_parens = + (match e.pexp_desc with + Pexp_apply ({pexp_desc=Pexp_ident ({ txt = Longident.Ldot ( + Longident.Lident(modname), funname) })},_) + -> (match modname,funname with + | "Array","get" -> false; + | "Array","set" -> false; + | _,_ -> true) ; + | Pexp_apply ({pexp_desc=Pexp_ident ({ txt = Longident.Lident(funname) })},_) + -> (match funname with + | "!" -> false; + | _ -> true); + | Pexp_apply (_,_) -> true; + | Pexp_match (_,_) -> true; + | Pexp_tuple (_) -> true ; + | Pexp_constraint (_,_,_) -> true ; + | _ -> false) in + if (already_has_parens) then expression ppf e + else begin + fprintf ppf "(" ; + expression ppf e ; + fprintf ppf ")" ; + end ; + +and pattern_in_parens ppf p = + let already_has_parens = + match p.ppat_desc with + | Ppat_alias (_,_) -> true + | Ppat_tuple (_) -> true + | Ppat_or (_,_) -> true + | Ppat_constraint (_,_) -> true + | _ -> false in + if (already_has_parens) then pattern ppf p + else begin + fprintf ppf "(" ; + pattern ppf p ; + fprintf ppf ")" ; + end; + +and pattern_constr_params_option ppf po = + match po with + | None -> (); + | Some pat -> + pp_print_space ppf (); + pattern_in_parens ppf pat; + +and type_variant_helper ppf x = + match x with + | Rtag (l, b, ctl) -> (* is b important? *) + pp_open_hovbox ppf indent ; + fprintf ppf "`%s" l ; + if ((List.length ctl) != 0) then begin + fprintf ppf " of@ " ; + list2 core_type ppf ctl " *" ; + end ; + pp_close_box ppf () ; + | Rinherit (ct) -> + core_type ppf ct + +(* prints a list of definitions as found in a let statement + note! breaks "open and close boxes in same function" convention, however + does always open and close the same number of boxes. (i.e. no "net + gain or loss" of box depth. *) +and pattern_x_expression_def_list ppf l = + match l with + | [] -> () + | hd :: tl -> + pp_close_box ppf () ; + pp_print_space ppf () ; + pp_open_hvbox ppf indent ; + fprintf ppf "and " ; + pattern_x_expression_def ppf hd; + pattern_x_expression_def_list ppf tl ; + +(* end an if statement by printing an else phrase if there is an "else" + statement in the ast. otherwise just close the box. *) +(* added: special case for "else if" case *) + +and expression_eo ppf eo extra = + match eo with + | None -> (); + | Some x -> + if extra then fprintf ppf " " + else fprintf ppf "@ " ; + match x.pexp_desc with + | Pexp_ifthenelse (e1, e2, eo) -> (* ... else if ...*) + fprintf ppf "else" ; + expression_elseif ppf (e1, e2, eo) + | Pexp_sequence (e1, e2) -> + fprintf ppf "else" ; + expression_ifbegin ppf x; (* ... else begin ... end*) + | _ -> (* ... else ... *) + pp_open_hvbox ppf indent ; + fprintf ppf "else@ " ; + expression ppf x ; + pp_close_box ppf () ; + +and expression_elseif ppf (e1,e2,eo) = + fprintf ppf " " ; + expression_if_common ppf e1 e2 eo ; + +and expression_ifbegin ppf e = + fprintf ppf " begin"; + pp_print_break ppf 1 indent ; (* "@;<1 2>"; *) + expression_sequence ppf e; + pp_print_break ppf 1 0 ; (* fprintf ppf "@;<1 0>" *) + fprintf ppf "end"; + +and expression_if_common ppf e1 e2 eo = + match eo, e2.pexp_desc with + | None, Pexp_sequence (_, _) -> + fprintf ppf "if@ " ; + expression ppf e1; + fprintf ppf "@ then@ " ; + expression_ifbegin ppf e2 + | None, _ -> + fprintf ppf "if@ " ; + expression ppf e1; + fprintf ppf "@ then@ " ; + simple_expr ppf e2 + | Some _, Pexp_sequence _ -> + fprintf ppf "if " ; + expression ppf e1; + fprintf ppf "@ then@ " ; + expression_ifbegin ppf e2; + expression_eo ppf eo true; (* ... then begin ... end *) + | Some _, _ -> + pp_open_hvbox ppf indent ; + fprintf ppf "if " ; + expression ppf e1; + fprintf ppf " then@ " ; + simple_expr ppf e2; + pp_close_box ppf () ; + expression_eo ppf eo false; + +and expression_sequence ppf ?(skip=1) ?(indent=indent) ?(first=true) expr = + if (first = true) then begin + pp_open_hvbox ppf 0 ; + expression_sequence ppf ~skip:skip ~indent:0 ~first:false expr ; + pp_close_box ppf () ; + end else + match expr.pexp_desc with + | Pexp_sequence (e1, e2) -> + simple_expr ppf e1 ; + fprintf ppf ";" ; + pp_print_break ppf skip indent ; (* "@;<1 2>" ; *) + expression_sequence ppf ~skip:skip ~indent:indent ~first:false e2 ; + | _ -> + expression ppf expr ; + +and expression_list_helper ppf exp = + match exp with + | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("[]") }, None, _)} + -> () ; + | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("::") }, + Some({pexp_desc = Pexp_tuple([exp1 ; exp2])}), _)} + -> fprintf ppf ";@ " ; + simple_expr ppf exp1 ; + expression_list_helper ppf exp2 ; + | {pexp_desc = _} + -> assert false; + +and expression_list_nonterminal ppf exp = + match exp with + | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("[]") }, None, _)} + -> fprintf ppf "[]" ; (* assert false; *) + | {pexp_desc = Pexp_construct ({ txt = Longident.Lident("::") }, + Some({pexp_desc = Pexp_tuple([exp1 ; exp2])}), _)} + -> simple_expr ppf exp1; + fprintf ppf " ::@ "; + expression_list_nonterminal ppf exp2; + | {pexp_desc = _} + -> expression ppf exp; +; + +and directive_argument ppf x = + match x with + | Pdir_none -> () + | Pdir_string (s) -> fprintf ppf "@ \"%s\"" s; + | Pdir_int (i) -> fprintf ppf "@ %d" i; + | Pdir_ident (li) -> fprintf ppf "@ %a" fmt_longident_aux li; + | Pdir_bool (b) -> fprintf ppf "@ %s" (string_of_bool b); + +and string_x_core_type_list ppf (s, l) = + string ppf s; + list core_type ppf l; + +and string_list_x_location ppf (l, loc) = + line 0 ppf "<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..7485ea6488 --- /dev/null +++ b/tools/read_cmt.ml @@ -0,0 +1,80 @@ +(***********************************************************************) +(* *) +(* 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..b2191b4d5f --- /dev/null +++ b/tools/typedtreeIter.ml @@ -0,0 +1,645 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(**************************************************************************) + +(* +TODO: + - 2012/05/10: Follow camlp4 way of building map and iter using classes + and inheritance ? +*) + +open Asttypes +open Typedtree + +module type IteratorArgument = sig + + val enter_structure : structure -> unit + val enter_value_description : value_description -> unit + val enter_type_declaration : type_declaration -> unit + val enter_exception_declaration : + exception_declaration -> unit + val enter_pattern : pattern -> unit + val enter_expression : expression -> unit + val enter_package_type : package_type -> unit + val enter_signature : signature -> unit + val enter_signature_item : signature_item -> unit + val enter_modtype_declaration : modtype_declaration -> unit + val enter_module_type : module_type -> unit + val enter_module_expr : module_expr -> unit + val enter_with_constraint : with_constraint -> unit + val enter_class_expr : class_expr -> unit + val enter_class_signature : class_signature -> unit + val enter_class_declaration : class_declaration -> unit + val enter_class_description : class_description -> unit + val enter_class_type_declaration : class_type_declaration -> unit + val enter_class_type : class_type -> unit + val enter_class_type_field : class_type_field -> unit + val enter_core_type : core_type -> unit + val enter_core_field_type : core_field_type -> unit + val enter_class_structure : class_structure -> unit + val enter_class_field : class_field -> unit + val enter_structure_item : structure_item -> unit + + + val leave_structure : structure -> unit + val leave_value_description : value_description -> unit + val leave_type_declaration : type_declaration -> unit + val leave_exception_declaration : + exception_declaration -> unit + val leave_pattern : pattern -> unit + val leave_expression : expression -> unit + val leave_package_type : package_type -> unit + val leave_signature : signature -> unit + val leave_signature_item : signature_item -> unit + val leave_modtype_declaration : modtype_declaration -> unit + val leave_module_type : module_type -> unit + val leave_module_expr : module_expr -> unit + val leave_with_constraint : with_constraint -> unit + val leave_class_expr : class_expr -> unit + val leave_class_signature : class_signature -> unit + val leave_class_declaration : class_declaration -> unit + val leave_class_description : class_description -> unit + val leave_class_type_declaration : class_type_declaration -> unit + val leave_class_type : class_type -> unit + val leave_class_type_field : class_type_field -> unit + val leave_core_type : core_type -> unit + val leave_core_field_type : core_field_type -> unit + val leave_class_structure : class_structure -> unit + val leave_class_field : class_field -> unit + val leave_structure_item : structure_item -> unit + + val enter_bindings : rec_flag -> unit + val enter_binding : pattern -> expression -> unit + val leave_binding : pattern -> expression -> unit + val leave_bindings : rec_flag -> unit + + end + +module MakeIterator(Iter : IteratorArgument) : sig + + val iter_structure : structure -> unit + val iter_signature : signature -> unit + val iter_structure_item : structure_item -> unit + val iter_signature_item : signature_item -> unit + val iter_expression : expression -> unit + val iter_module_type : module_type -> unit + val iter_pattern : pattern -> unit + val iter_class_expr : class_expr -> unit + + end = struct + + let may_iter f v = + match v with + None -> () + | Some x -> f x + + + open Misc + open Asttypes + + let rec iter_structure str = + Iter.enter_structure str; + List.iter iter_structure_item str.str_items; + Iter.leave_structure str + + + and iter_binding (pat, exp) = + Iter.enter_binding pat exp; + iter_pattern pat; + iter_expression exp; + Iter.leave_binding pat exp + + and iter_bindings rec_flag list = + Iter.enter_bindings rec_flag; + List.iter iter_binding list; + Iter.leave_bindings rec_flag + + and iter_structure_item item = + Iter.enter_structure_item item; + begin + match item.str_desc with + Tstr_eval exp -> iter_expression exp + | Tstr_value (rec_flag, list) -> + iter_bindings rec_flag list + | Tstr_primitive (id, _, v) -> iter_value_description v + | Tstr_type list -> + List.iter (fun (id, _, decl) -> iter_type_declaration decl) list + | Tstr_exception (id, _, decl) -> iter_exception_declaration decl + | Tstr_exn_rebind (id, _, p, _) -> () + | Tstr_module (id, _, mexpr) -> + iter_module_expr mexpr + | Tstr_recmodule list -> + List.iter (fun (id, _, mtype, mexpr) -> + iter_module_type mtype; + iter_module_expr mexpr) list + | Tstr_modtype (id, _, mtype) -> + iter_module_type mtype + | Tstr_open _ -> () + | Tstr_class list -> + List.iter (fun (ci, _, _) -> + Iter.enter_class_declaration ci; + iter_class_expr ci.ci_expr; + Iter.leave_class_declaration ci; + ) list + | Tstr_class_type list -> + List.iter (fun (id, _, ct) -> + Iter.enter_class_type_declaration ct; + iter_class_type ct.ci_expr; + Iter.leave_class_type_declaration ct; + ) list + | Tstr_include (mexpr, _) -> + iter_module_expr mexpr + end; + Iter.leave_structure_item item + + and iter_value_description v = + Iter.enter_value_description v; + iter_core_type v.val_desc; + Iter.leave_value_description v + + and iter_type_declaration decl = + Iter.enter_type_declaration decl; + List.iter (fun (ct1, ct2, loc) -> + iter_core_type ct1; + iter_core_type ct2 + ) decl.typ_cstrs; + begin match decl.typ_kind with + Ttype_abstract -> () + | Ttype_variant list -> + List.iter (fun (s, _, cts, loc) -> + List.iter iter_core_type cts + ) list + | Ttype_record list -> + List.iter (fun (s, _, mut, ct, loc) -> + iter_core_type ct + ) list + end; + begin match decl.typ_manifest with + None -> () + | Some ct -> iter_core_type ct + end; + Iter.leave_type_declaration decl + + and iter_exception_declaration decl = + Iter.enter_exception_declaration decl; + List.iter iter_core_type decl.exn_params; + Iter.leave_exception_declaration decl; + + and iter_pattern pat = + Iter.enter_pattern pat; + List.iter (fun (cstr, _) -> match cstr with + | Tpat_type _ -> () + | Tpat_unpack -> () + | Tpat_constraint ct -> iter_core_type ct) pat.pat_extra; + begin + match pat.pat_desc with + Tpat_any -> () + | Tpat_var (id, _) -> () + | Tpat_alias (pat1, _, _) -> iter_pattern pat1 + | Tpat_constant cst -> () + | Tpat_tuple list -> + List.iter iter_pattern list + | Tpat_construct (path, _, _, args, _) -> + List.iter iter_pattern args + | Tpat_variant (label, pato, _) -> + begin match pato with + None -> () + | Some pat -> iter_pattern pat + end + | Tpat_record (list, closed) -> + List.iter (fun (path, _, _, pat) -> iter_pattern pat) list + | Tpat_array list -> List.iter iter_pattern list + | Tpat_or (p1, p2, _) -> iter_pattern p1; iter_pattern p2 + | Tpat_lazy p -> iter_pattern p + end; + Iter.leave_pattern pat + + and option f x = match x with None -> () | Some e -> f e + + and iter_expression exp = + Iter.enter_expression exp; + List.iter (function (cstr, _) -> + match cstr with + Texp_constraint (cty1, cty2) -> + option iter_core_type cty1; option iter_core_type cty2 + | Texp_open (path, _, _) -> () + | Texp_poly cto -> option iter_core_type cto + | Texp_newtype s -> ()) + exp.exp_extra; + begin + match exp.exp_desc with + Texp_ident (path, _, _) -> () + | Texp_constant cst -> () + | Texp_let (rec_flag, list, exp) -> + iter_bindings rec_flag list; + iter_expression exp + | Texp_function (label, cases, _) -> + iter_bindings Nonrecursive cases + | Texp_apply (exp, list) -> + iter_expression exp; + List.iter (fun (label, expo, _) -> + match expo with + None -> () + | Some exp -> iter_expression exp + ) list + | Texp_match (exp, list, _) -> + iter_expression exp; + iter_bindings Nonrecursive list + | Texp_try (exp, list) -> + iter_expression exp; + iter_bindings Nonrecursive list + | Texp_tuple list -> + List.iter iter_expression list + | Texp_construct (path, _, _, args, _) -> + List.iter iter_expression args + | Texp_variant (label, expo) -> + begin match expo with + None -> () + | Some exp -> iter_expression exp + end + | Texp_record (list, expo) -> + List.iter (fun (path, _, _, exp) -> + iter_expression exp + ) list; + begin match expo with + None -> () + | Some exp -> iter_expression exp + end + | Texp_field (exp, path, _, label) -> + iter_expression exp + | Texp_setfield (exp1, path, _ , label, exp2) -> + iter_expression exp1; + iter_expression exp2 + | Texp_array list -> + List.iter iter_expression list + | Texp_ifthenelse (exp1, exp2, expo) -> + iter_expression exp1; + iter_expression exp2; + begin match expo with + None -> () + | Some exp -> iter_expression exp + end + | Texp_sequence (exp1, exp2) -> + iter_expression exp1; + iter_expression exp2 + | Texp_while (exp1, exp2) -> + iter_expression exp1; + iter_expression exp2 + | Texp_for (id, _, exp1, exp2, dir, exp3) -> + iter_expression exp1; + iter_expression exp2; + iter_expression exp3 + | Texp_when (exp1, exp2) -> + iter_expression exp1; + iter_expression exp2 + | Texp_send (exp, meth, expo) -> + iter_expression exp; + begin + match expo with + None -> () + | Some exp -> iter_expression exp + end + | Texp_new (path, _, _) -> () + | Texp_instvar (_, path, _) -> () + | Texp_setinstvar (_, _, _, exp) -> + iter_expression exp + | Texp_override (_, list) -> + List.iter (fun (path, _, exp) -> + iter_expression exp + ) list + | Texp_letmodule (id, _, mexpr, exp) -> + iter_module_expr mexpr; + iter_expression exp + | Texp_assert exp -> iter_expression exp + | Texp_assertfalse -> () + | Texp_lazy exp -> iter_expression exp + | Texp_object (cl, _) -> + iter_class_structure cl + | Texp_pack (mexpr) -> + iter_module_expr mexpr + end; + Iter.leave_expression exp; + + and iter_package_type pack = + Iter.enter_package_type pack; + List.iter (fun (s, ct) -> iter_core_type ct) pack.pack_fields; + Iter.leave_package_type pack; + + and iter_signature sg = + Iter.enter_signature sg; + List.iter iter_signature_item sg.sig_items; + Iter.leave_signature sg; + + and iter_signature_item item = + Iter.enter_signature_item item; + begin + match item.sig_desc with + Tsig_value (id, _, v) -> + iter_value_description v + | Tsig_type list -> + List.iter (fun (id, _, decl) -> + iter_type_declaration decl + ) list + | Tsig_exception (id, _, decl) -> + iter_exception_declaration decl + | Tsig_module (id, _, mtype) -> + iter_module_type mtype + | Tsig_recmodule list -> + List.iter (fun (id, _, mtype) -> iter_module_type mtype) list + | Tsig_modtype (id, _, mdecl) -> + iter_modtype_declaration mdecl + | Tsig_open _ -> () + | Tsig_include (mty,_) -> iter_module_type mty + | Tsig_class list -> + List.iter iter_class_description list + | Tsig_class_type list -> + List.iter iter_class_type_declaration list + end; + Iter.leave_signature_item item; + + and iter_modtype_declaration mdecl = + Iter.enter_modtype_declaration mdecl; + begin + match mdecl with + Tmodtype_abstract -> () + | Tmodtype_manifest mtype -> iter_module_type mtype + end; + Iter.leave_modtype_declaration mdecl; + + + and iter_class_description cd = + Iter.enter_class_description cd; + iter_class_type cd.ci_expr; + Iter.leave_class_description cd; + + and iter_class_type_declaration cd = + Iter.enter_class_type_declaration cd; + iter_class_type cd.ci_expr; + Iter.leave_class_type_declaration cd; + + and iter_module_type mty = + Iter.enter_module_type mty; + begin + match mty.mty_desc with + Tmty_ident (path, _) -> () + | Tmty_signature sg -> iter_signature sg + | Tmty_functor (id, _, mtype1, mtype2) -> + iter_module_type mtype1; iter_module_type mtype2 + | Tmty_with (mtype, list) -> + iter_module_type mtype; + List.iter (fun (path, _, withc) -> + iter_with_constraint withc + ) list + | Tmty_typeof mexpr -> + iter_module_expr mexpr + end; + Iter.leave_module_type mty; + + and iter_with_constraint cstr = + Iter.enter_with_constraint cstr; + begin + match cstr with + Twith_type decl -> iter_type_declaration decl + | Twith_module _ -> () + | Twith_typesubst decl -> iter_type_declaration decl + | Twith_modsubst _ -> () + end; + Iter.leave_with_constraint cstr; + + and iter_module_expr mexpr = + Iter.enter_module_expr mexpr; + begin + match mexpr.mod_desc with + Tmod_ident (p, _) -> () + | Tmod_structure st -> iter_structure st + | Tmod_functor (id, _, mtype, mexpr) -> + iter_module_type mtype; + iter_module_expr mexpr + | Tmod_apply (mexp1, mexp2, _) -> + iter_module_expr mexp1; + iter_module_expr mexp2 + | Tmod_constraint (mexpr, _, Tmodtype_implicit, _ ) -> + iter_module_expr mexpr + | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> + iter_module_expr mexpr; + iter_module_type mtype + | Tmod_unpack (exp, mty) -> + iter_expression exp +(* iter_module_type mty *) + end; + Iter.leave_module_expr mexpr; + + and iter_class_expr cexpr = + Iter.enter_class_expr cexpr; + begin + match cexpr.cl_desc with + | Tcl_constraint (cl, None, _, _, _ ) -> + iter_class_expr cl; + | Tcl_structure clstr -> iter_class_structure clstr + | Tcl_fun (label, pat, priv, cl, partial) -> + iter_pattern pat; + List.iter (fun (id, _, exp) -> iter_expression exp) priv; + iter_class_expr cl + + | Tcl_apply (cl, args) -> + iter_class_expr cl; + List.iter (fun (label, expo, _) -> + match expo with + None -> () + | Some exp -> iter_expression exp + ) args + + | Tcl_let (rec_flat, bindings, ivars, cl) -> + iter_bindings rec_flat bindings; + List.iter (fun (id, _, exp) -> iter_expression exp) ivars; + iter_class_expr cl + + | Tcl_constraint (cl, Some clty, vals, meths, concrs) -> + iter_class_expr cl; + iter_class_type clty + + | Tcl_ident (_, _, tyl) -> + List.iter iter_core_type tyl + end; + Iter.leave_class_expr cexpr; + + and iter_class_type ct = + Iter.enter_class_type ct; + begin + match ct.cltyp_desc with + Tcty_signature csg -> iter_class_signature csg + | Tcty_constr (path, _, list) -> + List.iter iter_core_type list + | Tcty_fun (label, ct, cl) -> + iter_core_type ct; + iter_class_type cl + end; + Iter.leave_class_type ct; + + and iter_class_signature cs = + Iter.enter_class_signature cs; + iter_core_type cs.csig_self; + List.iter iter_class_type_field cs.csig_fields; + Iter.leave_class_signature cs + + + and iter_class_type_field ctf = + Iter.enter_class_type_field ctf; + begin + match ctf.ctf_desc with + Tctf_inher ct -> iter_class_type ct + | Tctf_val (s, mut, virt, ct) -> + iter_core_type ct + | Tctf_virt (s, priv, ct) -> + iter_core_type ct + | Tctf_meth (s, priv, ct) -> + iter_core_type ct + | Tctf_cstr (ct1, ct2) -> + iter_core_type ct1; + iter_core_type ct2 + end; + Iter.leave_class_type_field ctf + + and iter_core_type ct = + Iter.enter_core_type ct; + begin + match ct.ctyp_desc with + Ttyp_any -> () + | Ttyp_var s -> () + | Ttyp_arrow (label, ct1, ct2) -> + iter_core_type ct1; + iter_core_type ct2 + | Ttyp_tuple list -> List.iter iter_core_type list + | Ttyp_constr (path, _, list) -> + List.iter iter_core_type list + | Ttyp_object list -> + List.iter iter_core_field_type list + | Ttyp_class (path, _, list, labels) -> + List.iter iter_core_type list + | Ttyp_alias (ct, s) -> + iter_core_type ct + | Ttyp_variant (list, bool, labels) -> + List.iter iter_row_field list + | Ttyp_poly (list, ct) -> iter_core_type ct + | Ttyp_package pack -> iter_package_type pack + end; + Iter.leave_core_type ct; + + and iter_core_field_type cft = + Iter.enter_core_field_type cft; + begin match cft.field_desc with + Tcfield_var -> () + | Tcfield (s, ct) -> iter_core_type ct + end; + Iter.leave_core_field_type cft; + + and iter_class_structure cs = + Iter.enter_class_structure cs; + iter_pattern cs.cstr_pat; + List.iter iter_class_field cs.cstr_fields; + Iter.leave_class_structure cs; + + + and iter_row_field rf = + match rf with + Ttag (label, bool, list) -> + List.iter iter_core_type list + | Tinherit ct -> iter_core_type ct + + and iter_class_field cf = + Iter.enter_class_field cf; + begin + match cf.cf_desc with + Tcf_inher (ovf, cl, super, _vals, _meths) -> + iter_class_expr cl + | Tcf_constr (cty, cty') -> + iter_core_type cty; + iter_core_type cty' + | Tcf_val (lab, _, _, mut, Tcfk_virtual cty, override) -> + iter_core_type cty + | Tcf_val (lab, _, _, mut, Tcfk_concrete exp, override) -> + iter_expression exp + | Tcf_meth (lab, _, priv, Tcfk_virtual cty, override) -> + iter_core_type cty + | Tcf_meth (lab, _, priv, Tcfk_concrete exp, override) -> + iter_expression exp +(* | Tcf_let (rec_flag, bindings, exps) -> + iter_bindings rec_flag bindings; + List.iter (fun (id, _, exp) -> iter_expression exp) exps; *) + | Tcf_init exp -> + iter_expression exp + end; + Iter.leave_class_field cf; + + end + +module DefaultIteratorArgument = struct + + let enter_structure _ = () + let enter_value_description _ = () + let enter_type_declaration _ = () + let enter_exception_declaration _ = () + let enter_pattern _ = () + let enter_expression _ = () + let enter_package_type _ = () + let enter_signature _ = () + let enter_signature_item _ = () + let enter_modtype_declaration _ = () + let enter_module_type _ = () + let enter_module_expr _ = () + let enter_with_constraint _ = () + let enter_class_expr _ = () + let enter_class_signature _ = () + let enter_class_declaration _ = () + let enter_class_description _ = () + let enter_class_type_declaration _ = () + let enter_class_type _ = () + let enter_class_type_field _ = () + let enter_core_type _ = () + let enter_core_field_type _ = () + let enter_class_structure _ = () + let enter_class_field _ = () + let enter_structure_item _ = () + + + let leave_structure _ = () + let leave_value_description _ = () + let leave_type_declaration _ = () + let leave_exception_declaration _ = () + let leave_pattern _ = () + let leave_expression _ = () + let leave_package_type _ = () + let leave_signature _ = () + let leave_signature_item _ = () + let leave_modtype_declaration _ = () + let leave_module_type _ = () + let leave_module_expr _ = () + let leave_with_constraint _ = () + let leave_class_expr _ = () + let leave_class_signature _ = () + let leave_class_declaration _ = () + let leave_class_description _ = () + let leave_class_type_declaration _ = () + let leave_class_type _ = () + let leave_class_type_field _ = () + let leave_core_type _ = () + let leave_core_field_type _ = () + let leave_class_structure _ = () + let leave_class_field _ = () + let leave_structure_item _ = () + + let enter_binding _ _ = () + let leave_binding _ _ = () + + let enter_bindings _ = () + let leave_bindings _ = () + + end diff --git a/tools/typedtreeIter.mli b/tools/typedtreeIter.mli new file mode 100644 index 0000000000..be9c6effb1 --- /dev/null +++ b/tools/typedtreeIter.mli @@ -0,0 +1,94 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(**************************************************************************) + +open Asttypes +open Typedtree + + +module type IteratorArgument = sig + val enter_structure : structure -> unit + val enter_value_description : value_description -> unit + val enter_type_declaration : type_declaration -> unit + val enter_exception_declaration : + exception_declaration -> unit + val enter_pattern : pattern -> unit + val enter_expression : expression -> unit + val enter_package_type : package_type -> unit + val enter_signature : signature -> unit + val enter_signature_item : signature_item -> unit + val enter_modtype_declaration : modtype_declaration -> unit + val enter_module_type : module_type -> unit + val enter_module_expr : module_expr -> unit + val enter_with_constraint : with_constraint -> unit + val enter_class_expr : class_expr -> unit + val enter_class_signature : class_signature -> unit + val enter_class_declaration : class_declaration -> unit + val enter_class_description : class_description -> unit + val enter_class_type_declaration : class_type_declaration -> unit + val enter_class_type : class_type -> unit + val enter_class_type_field : class_type_field -> unit + val enter_core_type : core_type -> unit + val enter_core_field_type : core_field_type -> unit + val enter_class_structure : class_structure -> unit + val enter_class_field : class_field -> unit + val enter_structure_item : structure_item -> unit + + + val leave_structure : structure -> unit + val leave_value_description : value_description -> unit + val leave_type_declaration : type_declaration -> unit + val leave_exception_declaration : + exception_declaration -> unit + val leave_pattern : pattern -> unit + val leave_expression : expression -> unit + val leave_package_type : package_type -> unit + val leave_signature : signature -> unit + val leave_signature_item : signature_item -> unit + val leave_modtype_declaration : modtype_declaration -> unit + val leave_module_type : module_type -> unit + val leave_module_expr : module_expr -> unit + val leave_with_constraint : with_constraint -> unit + val leave_class_expr : class_expr -> unit + val leave_class_signature : class_signature -> unit + val leave_class_declaration : class_declaration -> unit + val leave_class_description : class_description -> unit + val leave_class_type_declaration : class_type_declaration -> unit + val leave_class_type : class_type -> unit + val leave_class_type_field : class_type_field -> unit + val leave_core_type : core_type -> unit + val leave_core_field_type : core_field_type -> unit + val leave_class_structure : class_structure -> unit + val leave_class_field : class_field -> unit + val leave_structure_item : structure_item -> unit + + val enter_bindings : rec_flag -> unit + val enter_binding : pattern -> expression -> unit + val leave_binding : pattern -> expression -> unit + val leave_bindings : rec_flag -> unit + + end + +module MakeIterator : + functor + (Iter : IteratorArgument) -> + sig + val iter_structure : structure -> unit + val iter_signature : signature -> unit + val iter_structure_item : structure_item -> unit + val iter_signature_item : signature_item -> unit + val iter_expression : expression -> unit + val iter_module_type : module_type -> unit + val iter_pattern : pattern -> unit + val iter_class_expr : class_expr -> unit + end + +module DefaultIteratorArgument : IteratorArgument diff --git a/tools/untypeast.ml b/tools/untypeast.ml new file mode 100644 index 0000000000..7bac998409 --- /dev/null +++ b/tools/untypeast.ml @@ -0,0 +1,545 @@ +(**************************************************************************) +(* *) +(* 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) + 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) + 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/expunge.ml b/toplevel/expunge.ml index 9cdcbf89e1..ad4af050bd 100644 --- a/toplevel/expunge.ml +++ b/toplevel/expunge.ml @@ -33,7 +33,7 @@ let to_keep = ref StringSet.empty let negate = Sys.argv.(3) = "-v" -let keep = +let keep = if negate then fun name -> is_exn name || not (StringSet.mem name !to_keep) else fun name -> is_exn name || (StringSet.mem name !to_keep) diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index 9d4311c85d..3f8cdda450 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,15 +249,15 @@ 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 = - match ret_type with - Some t -> - begin match (Ctype.repr t).desc with - Tconstr (_,params,_) -> - params - | _ -> assert false end - | None -> decl.type_params - in + let type_params = + match ret_type with + Some t -> + begin match (Ctype.repr t).desc with + Tconstr (_,params,_) -> + params + | _ -> assert false end + | None -> decl.type_params + in let ty_args = List.map (function ty -> @@ -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 @@ -351,10 +351,10 @@ 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 + Cstr_exception (p, _) -> p | _ -> raise Not_found in (* Make sure this is the right exception and not an homonym, by evaluating the exception found and comparing with the identifier contained in the exception bucket *) diff --git a/toplevel/genprintval.mli b/toplevel/genprintval.mli index 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/opttoploop.ml b/toplevel/opttoploop.ml index 1fa5a3fd08..8d83908d00 100644 --- a/toplevel/opttoploop.ml +++ b/toplevel/opttoploop.ml @@ -363,6 +363,7 @@ let refill_lexbuf buffer len = let prompt = if !Clflags.noprompt then "" else if !first_line then "# " + else if !Clflags.nopromptcont then "" else if Lexer.in_comment () then "* " else " " in diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml index 1200516847..ab7eeb0708 100644 --- a/toplevel/opttopmain.ml +++ b/toplevel/opttopmain.ml @@ -74,6 +74,7 @@ module Options = Main_args.Make_opttop_options (struct let _noassert = set noassert let _nolabels = set classic let _noprompt = set noprompt + let _nopromptcont = set nopromptcont let _nostdlib = set no_std_include let _principal = set principal let _real_paths = set real_paths diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index 57d1f1e119..2d7fde696a 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 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 @@ -101,8 +111,7 @@ let rec load_file recursive ppf name = and really_load_file recursive ppf name filename ic = let ic = open_in_bin filename in - let buffer = String.create (String.length Config.cmo_magic_number) in - really_input ic buffer 0 (String.length Config.cmo_magic_number); + let buffer = Misc.input_bytes ic (String.length Config.cmo_magic_number) in try if buffer = Config.cmo_magic_number then begin let compunit_pos = input_binary_int ic in (* Go to descriptor *) 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 f2b4e59dc0..a974a90292 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 (); @@ -231,14 +232,13 @@ let execute_phrase print_outcome ppf phr = | Result v -> if print_outcome then Printtyp.wrap_printing_env oldenv (fun () -> - 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; @@ -353,6 +353,7 @@ let refill_lexbuf buffer len = let prompt = if !Clflags.noprompt then "" else if !first_line then "# " + else if !Clflags.nopromptcont then "" else if Lexer.in_comment () then "* " else " " in @@ -423,6 +424,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/toplevel/topmain.ml b/toplevel/topmain.ml index 78af569941..ea70401e8d 100644 --- a/toplevel/topmain.ml +++ b/toplevel/topmain.ml @@ -71,6 +71,7 @@ module Options = Main_args.Make_bytetop_options (struct let _noassert = set noassert let _nolabels = set classic let _noprompt = set noprompt + let _nopromptcont = set nopromptcont let _nostdlib = set no_std_include let _principal = set principal let _real_paths = set real_paths diff --git a/typing/btype.ml b/typing/btype.ml index c9bdbf04d4..aa1190e754 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 && @@ -255,8 +265,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) @@ -269,7 +279,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) @@ -330,11 +340,11 @@ let unmark_type_decl decl = begin match decl.type_kind with Type_abstract -> () | Type_variant cstrs -> - List.iter - (fun (c, tl, ret_type_opt) -> - List.iter unmark_type tl; - Misc.may unmark_type ret_type_opt) - cstrs + List.iter + (fun (c, tl, ret_type_opt) -> + List.iter unmark_type tl; + Misc.may unmark_type ret_type_opt) + cstrs | Type_record(lbls, rep) -> List.iter (fun (c, mut, t) -> unmark_type t) lbls end; @@ -349,11 +359,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..dee54102f0 --- /dev/null +++ b/typing/cmt_format.ml @@ -0,0 +1,1010 @@ +(***********************************************************************) +(* *) +(* 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 + + and map_structure_item item = + let item = Map.enter_structure_item item in + let str_desc = + match item.str_desc with + Tstr_eval exp -> Tstr_eval (map_expression exp) + | Tstr_value (rec_flag, list) -> + Tstr_value (rec_flag, map_bindings rec_flag list) + | Tstr_primitive (id, name, v) -> + Tstr_primitive (id, name, map_value_description v) + | Tstr_type list -> + Tstr_type (List.map ( + fun (id, name, decl) -> + (id, name, map_type_declaration decl) ) list) + | Tstr_exception (id, name, decl) -> + Tstr_exception (id, name, map_exception_declaration decl) + | Tstr_exn_rebind (id, name, path, lid) -> + Tstr_exn_rebind (id, name, path, lid) + | Tstr_module (id, name, mexpr) -> + Tstr_module (id, name, map_module_expr mexpr) + | Tstr_recmodule list -> + let list = + List.map (fun (id, name, mtype, mexpr) -> + (id, name, map_module_type mtype, map_module_expr mexpr) + ) list + in + Tstr_recmodule list + | Tstr_modtype (id, name, mtype) -> + Tstr_modtype (id, name, map_module_type mtype) + | Tstr_open (path, lid) -> Tstr_open (path, lid) + | Tstr_class list -> + let list = + List.map (fun (ci, string_list, virtual_flag) -> + let ci = Map.enter_class_infos ci in + let ci_expr = map_class_expr ci.ci_expr in + (Map.leave_class_infos { ci with ci_expr = ci_expr}, + string_list, virtual_flag) + ) list + in + Tstr_class list + | Tstr_class_type list -> + let list = List.map (fun (id, name, ct) -> + let ct = Map.enter_class_infos ct in + let ci_expr = map_class_type ct.ci_expr in + (id, name, Map.leave_class_infos { ct with ci_expr = ci_expr}) + ) list in + Tstr_class_type list + | Tstr_include (mexpr, idents) -> + Tstr_include (map_module_expr mexpr, idents) + in + Map.leave_structure_item { item with str_desc = str_desc} + + and map_value_description v = + let v = Map.enter_value_description v in + let val_desc = map_core_type v.val_desc in + Map.leave_value_description { v with val_desc = val_desc } + + and map_type_declaration decl = + let decl = Map.enter_type_declaration decl in + let typ_cstrs = List.map (fun (ct1, ct2, loc) -> + (map_core_type ct1, + map_core_type ct2, + loc) + ) decl.typ_cstrs in + let typ_kind = match decl.typ_kind with + Ttype_abstract -> Ttype_abstract + | Ttype_variant list -> + let list = List.map (fun (s, name, cts, loc) -> + (s, name, List.map map_core_type cts, loc) + ) list in + Ttype_variant list + | Ttype_record list -> + let list = + List.map (fun (s, name, mut, ct, loc) -> + (s, name, mut, map_core_type ct, loc) + ) list in + Ttype_record list + in + let typ_manifest = + match decl.typ_manifest with + None -> None + | Some ct -> Some (map_core_type ct) + in + Map.leave_type_declaration { decl with typ_cstrs = typ_cstrs; + typ_kind = typ_kind; typ_manifest = typ_manifest } + + and map_exception_declaration decl = + let decl = Map.enter_exception_declaration decl in + let exn_params = List.map map_core_type decl.exn_params in + let decl = { exn_params = exn_params; + exn_exn = decl.exn_exn; + exn_loc = decl.exn_loc } in + Map.leave_exception_declaration decl; + + and map_pattern pat = + let pat = Map.enter_pattern pat in + let pat_desc = + match pat.pat_desc with + | Tpat_alias (pat1, p, text) -> + let pat1 = map_pattern pat1 in + Tpat_alias (pat1, p, text) + | Tpat_tuple list -> Tpat_tuple (List.map map_pattern list) + | Tpat_construct (path, lid, cstr_decl, args, arity) -> + Tpat_construct (path, lid, cstr_decl, + List.map map_pattern args, arity) + | Tpat_variant (label, pato, rowo) -> + let pato = match pato with + None -> pato + | Some pat -> Some (map_pattern pat) + in + Tpat_variant (label, pato, rowo) + | Tpat_record (list, closed) -> + Tpat_record (List.map (fun (path, lid, lab_desc, pat) -> + (path, lid, lab_desc, map_pattern pat) ) list, closed) + | Tpat_array list -> Tpat_array (List.map map_pattern list) + | Tpat_or (p1, p2, rowo) -> + Tpat_or (map_pattern p1, map_pattern p2, rowo) + | Tpat_lazy p -> Tpat_lazy (map_pattern p) + | Tpat_constant _ + | Tpat_any + | Tpat_var _ -> pat.pat_desc + + in + let pat_extra = List.map map_pat_extra pat.pat_extra in + Map.leave_pattern { pat with pat_desc = pat_desc; pat_extra = pat_extra } + + and map_pat_extra pat_extra = + match pat_extra with + | Tpat_constraint ct, loc -> (Tpat_constraint (map_core_type ct), loc) + | (Tpat_type _ | Tpat_unpack), _ -> pat_extra + + and map_expression exp = + let exp = Map.enter_expression exp in + let exp_desc = + match exp.exp_desc with + Texp_ident (_, _, _) + | Texp_constant _ -> exp.exp_desc + | Texp_let (rec_flag, list, exp) -> + Texp_let (rec_flag, + map_bindings rec_flag list, + map_expression exp) + | Texp_function (label, cases, partial) -> + Texp_function (label, map_bindings Nonrecursive cases, partial) + | Texp_apply (exp, list) -> + Texp_apply (map_expression exp, + List.map (fun (label, expo, optional) -> + let expo = + match expo with + None -> expo + | Some exp -> Some (map_expression exp) + in + (label, expo, optional) + ) list ) + | Texp_match (exp, list, partial) -> + Texp_match ( + map_expression exp, + map_bindings Nonrecursive list, + partial + ) + | Texp_try (exp, list) -> + Texp_try ( + map_expression exp, + map_bindings Nonrecursive list + ) + | Texp_tuple list -> + Texp_tuple (List.map map_expression list) + | Texp_construct (path, lid, cstr_desc, args, arity) -> + Texp_construct (path, lid, cstr_desc, + List.map map_expression args, arity ) + | Texp_variant (label, expo) -> + let expo =match expo with + None -> expo + | Some exp -> Some (map_expression exp) + in + Texp_variant (label, expo) + | Texp_record (list, expo) -> + let list = + List.map (fun (path, lid, lab_desc, exp) -> + (path, lid, lab_desc, map_expression exp) + ) list in + let expo = match expo with + None -> expo + | Some exp -> Some (map_expression exp) + in + Texp_record (list, expo) + | Texp_field (exp, path, lid, label) -> + Texp_field (map_expression exp, path, lid, label) + | Texp_setfield (exp1, path, lid, label, exp2) -> + Texp_setfield ( + map_expression exp1, + path, lid, + label, + map_expression exp2) + | Texp_array list -> + Texp_array (List.map map_expression list) + | Texp_ifthenelse (exp1, exp2, expo) -> + Texp_ifthenelse ( + map_expression exp1, + map_expression exp2, + match expo with + None -> expo + | Some exp -> Some (map_expression exp) + ) + | Texp_sequence (exp1, exp2) -> + Texp_sequence ( + map_expression exp1, + map_expression exp2 + ) + | Texp_while (exp1, exp2) -> + Texp_while ( + map_expression exp1, + map_expression exp2 + ) + | Texp_for (id, name, exp1, exp2, dir, exp3) -> + Texp_for ( + id, name, + map_expression exp1, + map_expression exp2, + dir, + map_expression exp3 + ) + | Texp_when (exp1, exp2) -> + Texp_when ( + map_expression exp1, + map_expression exp2 + ) + | Texp_send (exp, meth, expo) -> + Texp_send (map_expression exp, meth, may_map map_expression expo) + | Texp_new (path, lid, cl_decl) -> exp.exp_desc + | Texp_instvar (_, path, _) -> exp.exp_desc + | Texp_setinstvar (path, lid, path2, exp) -> + Texp_setinstvar (path, lid, path2, map_expression exp) + | Texp_override (path, list) -> + Texp_override ( + path, + List.map (fun (path, lid, exp) -> + (path, lid, map_expression exp) + ) list + ) + | Texp_letmodule (id, name, mexpr, exp) -> + Texp_letmodule ( + id, name, + map_module_expr mexpr, + map_expression exp + ) + | Texp_assert exp -> Texp_assert (map_expression exp) + | Texp_assertfalse -> exp.exp_desc + | Texp_lazy exp -> Texp_lazy (map_expression exp) + | Texp_object (cl, string_list) -> + Texp_object (map_class_structure cl, string_list) + | Texp_pack (mexpr) -> + Texp_pack (map_module_expr mexpr) + in + let exp_extra = List.map map_exp_extra exp.exp_extra in + Map.leave_expression { + exp with + exp_desc = exp_desc; + exp_extra = exp_extra } + + and map_exp_extra exp_extra = + let loc = snd exp_extra in + match fst exp_extra with + | Texp_constraint (Some ct, None) -> + Texp_constraint (Some (map_core_type ct), None), loc + | Texp_constraint (None, Some ct) -> + Texp_constraint (None, Some (map_core_type ct)), loc + | Texp_constraint (Some ct1, Some ct2) -> + Texp_constraint (Some (map_core_type ct1), + Some (map_core_type ct2)), loc + | Texp_poly (Some ct) -> + Texp_poly (Some ( map_core_type ct )), loc + | Texp_newtype _ + | Texp_constraint (None, None) + | Texp_open _ + | Texp_poly None -> exp_extra + + + and map_package_type pack = + let pack = Map.enter_package_type pack in + let pack_fields = List.map ( + fun (s, ct) -> (s, map_core_type ct) ) pack.pack_fields in + Map.leave_package_type { pack with pack_fields = pack_fields } + + and map_signature sg = + let sg = Map.enter_signature sg in + let sig_items = List.map map_signature_item sg.sig_items in + Map.leave_signature { sg with sig_items = sig_items } + + and map_signature_item item = + let item = Map.enter_signature_item item in + let sig_desc = + match item.sig_desc with + Tsig_value (id, name, v) -> + Tsig_value (id, name, map_value_description v) + | Tsig_type list -> Tsig_type ( + List.map (fun (id, name, decl) -> + (id, name, map_type_declaration decl) + ) list + ) + | Tsig_exception (id, name, decl) -> + Tsig_exception (id, name, map_exception_declaration decl) + | Tsig_module (id, name, mtype) -> + Tsig_module (id, name, map_module_type mtype) + | Tsig_recmodule list -> + Tsig_recmodule (List.map ( + fun (id, name, mtype) -> + (id, name, map_module_type mtype) ) list) + | Tsig_modtype (id, name, mdecl) -> + Tsig_modtype (id, name, map_modtype_declaration mdecl) + | Tsig_open (path, lid) -> item.sig_desc + | Tsig_include (mty, lid) -> Tsig_include (map_module_type mty, lid) + | Tsig_class list -> Tsig_class (List.map map_class_description list) + | Tsig_class_type list -> + Tsig_class_type (List.map map_class_type_declaration list) + in + Map.leave_signature_item { item with sig_desc = sig_desc } + + and map_modtype_declaration mdecl = + let mdecl = Map.enter_modtype_declaration mdecl in + let mdecl = + match mdecl with + Tmodtype_abstract -> Tmodtype_abstract + | Tmodtype_manifest mtype -> + Tmodtype_manifest (map_module_type mtype) + in + Map.leave_modtype_declaration mdecl + + + and map_class_description cd = + let cd = Map.enter_class_description cd in + let ci_expr = map_class_type cd.ci_expr in + Map.leave_class_description { cd with ci_expr = ci_expr} + + and map_class_type_declaration cd = + let cd = Map.enter_class_type_declaration cd in + let ci_expr = map_class_type cd.ci_expr in + Map.leave_class_type_declaration { cd with ci_expr = ci_expr } + + and map_module_type mty = + let mty = Map.enter_module_type mty in + let mty_desc = + match mty.mty_desc with + Tmty_ident (path, lid) -> mty.mty_desc + | Tmty_signature sg -> Tmty_signature (map_signature sg) + | Tmty_functor (id, name, mtype1, mtype2) -> + Tmty_functor (id, name, map_module_type mtype1, + map_module_type mtype2) + | Tmty_with (mtype, list) -> + Tmty_with (map_module_type mtype, + List.map (fun (path, lid, withc) -> + (path, lid, map_with_constraint withc) + ) list) + | Tmty_typeof mexpr -> + Tmty_typeof (map_module_expr mexpr) + in + Map.leave_module_type { mty with mty_desc = mty_desc} + + and map_with_constraint cstr = + let cstr = Map.enter_with_constraint cstr in + let cstr = + match cstr with + Twith_type decl -> Twith_type (map_type_declaration decl) + | Twith_typesubst decl -> Twith_typesubst (map_type_declaration decl) + | Twith_module (path, lid) -> cstr + | Twith_modsubst (path, lid) -> cstr + in + Map.leave_with_constraint cstr + + and map_module_expr mexpr = + let mexpr = Map.enter_module_expr mexpr in + let mod_desc = + match mexpr.mod_desc with + Tmod_ident (p, lid) -> mexpr.mod_desc + | Tmod_structure st -> Tmod_structure (map_structure st) + | Tmod_functor (id, name, mtype, mexpr) -> + Tmod_functor (id, name, map_module_type mtype, + map_module_expr mexpr) + | Tmod_apply (mexp1, mexp2, coercion) -> + Tmod_apply (map_module_expr mexp1, map_module_expr mexp2, coercion) + | Tmod_constraint (mexpr, mod_type, Tmodtype_implicit, coercion ) -> + Tmod_constraint (map_module_expr mexpr, mod_type, + Tmodtype_implicit, coercion) + | Tmod_constraint (mexpr, mod_type, + Tmodtype_explicit mtype, coercion) -> + Tmod_constraint (map_module_expr mexpr, mod_type, + Tmodtype_explicit (map_module_type mtype), + coercion) + | Tmod_unpack (exp, mod_type) -> + Tmod_unpack (map_expression exp, mod_type) + in + Map.leave_module_expr { mexpr with mod_desc = mod_desc } + + and map_class_expr cexpr = + let cexpr = Map.enter_class_expr cexpr in + let cl_desc = + match cexpr.cl_desc with + | Tcl_constraint (cl, None, string_list1, string_list2, concr ) -> + Tcl_constraint (map_class_expr cl, None, string_list1, + string_list2, concr) + | Tcl_structure clstr -> Tcl_structure (map_class_structure clstr) + | Tcl_fun (label, pat, priv, cl, partial) -> + Tcl_fun (label, map_pattern pat, + List.map (fun (id, name, exp) -> + (id, name, map_expression exp)) priv, + map_class_expr cl, partial) + + | Tcl_apply (cl, args) -> + Tcl_apply (map_class_expr cl, + List.map (fun (label, expo, optional) -> + (label, may_map map_expression expo, + optional) + ) args) + | Tcl_let (rec_flat, bindings, ivars, cl) -> + Tcl_let (rec_flat, map_bindings rec_flat bindings, + List.map (fun (id, name, exp) -> + (id, name, map_expression exp)) ivars, + map_class_expr cl) + + | Tcl_constraint (cl, Some clty, vals, meths, concrs) -> + Tcl_constraint ( map_class_expr cl, + Some (map_class_type clty), vals, meths, concrs) + + | Tcl_ident (id, name, tyl) -> + Tcl_ident (id, name, List.map map_core_type tyl) + in + Map.leave_class_expr { cexpr with cl_desc = cl_desc } + + and map_class_type ct = + let ct = Map.enter_class_type ct in + let cltyp_desc = + match ct.cltyp_desc with + Tcty_signature csg -> Tcty_signature (map_class_signature csg) + | Tcty_constr (path, lid, list) -> + Tcty_constr (path, lid, List.map map_core_type list) + | Tcty_fun (label, ct, cl) -> + Tcty_fun (label, map_core_type ct, map_class_type cl) + in + Map.leave_class_type { ct with cltyp_desc = cltyp_desc } + + and map_class_signature cs = + let cs = Map.enter_class_signature cs in + let csig_self = map_core_type cs.csig_self in + let csig_fields = List.map map_class_type_field cs.csig_fields in + Map.leave_class_signature { cs with + csig_self = csig_self; csig_fields = csig_fields } + + + and map_class_type_field ctf = + let ctf = Map.enter_class_type_field ctf in + let ctf_desc = + match ctf.ctf_desc with + Tctf_inher ct -> Tctf_inher (map_class_type ct) + | Tctf_val (s, mut, virt, ct) -> + Tctf_val (s, mut, virt, map_core_type ct) + | Tctf_virt (s, priv, ct) -> + Tctf_virt (s, priv, map_core_type ct) + | Tctf_meth (s, priv, ct) -> + Tctf_meth (s, priv, map_core_type ct) + | Tctf_cstr (ct1, ct2) -> + Tctf_cstr (map_core_type ct1, map_core_type ct2) + in + Map.leave_class_type_field { ctf with ctf_desc = ctf_desc } + + and map_core_type ct = + let ct = Map.enter_core_type ct in + let ctyp_desc = + match ct.ctyp_desc with + Ttyp_any + | Ttyp_var _ -> ct.ctyp_desc + | Ttyp_arrow (label, ct1, ct2) -> + Ttyp_arrow (label, map_core_type ct1, map_core_type ct2) + | Ttyp_tuple list -> Ttyp_tuple (List.map map_core_type list) + | Ttyp_constr (path, lid, list) -> + Ttyp_constr (path, lid, List.map map_core_type list) + | Ttyp_object list -> Ttyp_object (List.map map_core_field_type list) + | Ttyp_class (path, lid, list, labels) -> + Ttyp_class (path, lid, List.map map_core_type list, labels) + | Ttyp_alias (ct, s) -> Ttyp_alias (map_core_type ct, s) + | Ttyp_variant (list, bool, labels) -> + Ttyp_variant (List.map map_row_field list, bool, labels) + | Ttyp_poly (list, ct) -> Ttyp_poly (list, map_core_type ct) + | Ttyp_package pack -> Ttyp_package (map_package_type pack) + in + Map.leave_core_type { ct with ctyp_desc = ctyp_desc } + + and map_core_field_type cft = + let cft = Map.enter_core_field_type cft in + let field_desc = match cft.field_desc with + Tcfield_var -> Tcfield_var + | Tcfield (s, ct) -> Tcfield (s, map_core_type ct) + in + Map.leave_core_field_type { cft with field_desc = field_desc } + + and map_class_structure cs = + let cs = Map.enter_class_structure cs in + let cstr_pat = map_pattern cs.cstr_pat in + let cstr_fields = List.map map_class_field cs.cstr_fields in + Map.leave_class_structure { cs with cstr_pat = cstr_pat; + cstr_fields = cstr_fields } + + and map_row_field rf = + match rf with + Ttag (label, bool, list) -> + Ttag (label, bool, List.map map_core_type list) + | Tinherit ct -> Tinherit (map_core_type ct) + + and map_class_field cf = + let cf = Map.enter_class_field cf in + let cf_desc = + match cf.cf_desc with + Tcf_inher (ovf, cl, super, vals, meths) -> + Tcf_inher (ovf, map_class_expr cl, super, vals, meths) + | Tcf_constr (cty, cty') -> + Tcf_constr (map_core_type cty, map_core_type cty') + | Tcf_val (lab, name, mut, ident, Tcfk_virtual cty, override) -> + Tcf_val (lab, name, mut, ident, Tcfk_virtual (map_core_type cty), + override) + | Tcf_val (lab, name, mut, ident, Tcfk_concrete exp, override) -> + Tcf_val (lab, name, mut, ident, Tcfk_concrete (map_expression exp), + override) + | Tcf_meth (lab, name, priv, Tcfk_virtual cty, override) -> + Tcf_meth (lab, name, priv, Tcfk_virtual (map_core_type cty), + override) + | Tcf_meth (lab, name, priv, Tcfk_concrete exp, override) -> + Tcf_meth (lab, name, priv, Tcfk_concrete (map_expression exp), + override) + | Tcf_init exp -> Tcf_init (map_expression exp) + in + Map.leave_class_field { cf with cf_desc = cf_desc } + + end + +module DefaultMapArgument = struct + + let enter_structure t = t + let enter_value_description t = t + let enter_type_declaration t = t + let enter_exception_declaration t = t + let enter_pattern t = t + let enter_expression t = t + let enter_package_type t = t + let enter_signature t = t + let enter_signature_item t = t + let enter_modtype_declaration t = t + let enter_module_type t = t + let enter_module_expr t = t + let enter_with_constraint t = t + let enter_class_expr t = t + let enter_class_signature t = t + let enter_class_description t = t + let enter_class_type_declaration t = t + let enter_class_infos t = t + let enter_class_type t = t + let enter_class_type_field t = t + let enter_core_type t = t + let enter_core_field_type t = t + let enter_class_structure t = t + let enter_class_field t = t + let enter_structure_item t = t + + + let leave_structure t = t + let leave_value_description t = t + let leave_type_declaration t = t + let leave_exception_declaration t = t + let leave_pattern t = t + let leave_expression t = t + let leave_package_type t = t + let leave_signature t = t + let leave_signature_item t = t + let leave_modtype_declaration t = t + let leave_module_type t = t + let leave_module_expr t = t + let leave_with_constraint t = t + let leave_class_expr t = t + let leave_class_signature t = t + let leave_class_description t = t + let leave_class_type_declaration t = t + let leave_class_infos t = t + let leave_class_type t = t + let leave_class_type_field t = t + let leave_core_type t = t + let leave_core_field_type t = t + let leave_class_structure t = t + let leave_class_field t = t + let leave_structure_item t = t + + end + +end + +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 e1c95b473e..c577d52410 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; @@ -893,8 +906,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 @@ -983,7 +996,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 @@ -1008,7 +1023,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 @@ -1017,9 +1032,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 = @@ -1028,7 +1043,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; @@ -1046,7 +1061,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 @@ -1056,16 +1071,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) @@ -1096,18 +1111,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 @@ -1334,7 +1349,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 @@ -1421,10 +1436,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 @@ -1474,7 +1492,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 @@ -1777,26 +1795,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; @@ -1816,16 +1834,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 *) @@ -1836,7 +1856,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 -> @@ -1936,40 +1956,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 []) | [],[] -> () @@ -1977,12 +1999,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 []) | [], [] -> () @@ -2006,27 +2028,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 @@ -2042,7 +2065,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 @@ -2051,12 +2074,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 @@ -2134,7 +2157,7 @@ and unify3 env t1 t1' t2 t2' = | (Tvar _, _) -> occur !env t1 t2'; occur_univar !env t2; - link_type t1' t2; + link_type t1' t2; | (_, Tvar _) -> occur !env t2 t1'; occur_univar !env t1; @@ -2142,14 +2165,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; @@ -2163,7 +2187,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 @@ -2171,19 +2195,19 @@ and unify3 env t1 t1' t2 t2' = | (Tconstr ((Path.Pident p) as path,[],_), Tconstr ((Path.Pident p') as path',[],_)) when is_abstract_newtype !env path && is_abstract_newtype !env path' - && !generate_equations -> - let source,destination = + && !generate_equations -> + let source,destination = if find_newtype_level !env path > find_newtype_level !env path' then p,t2' else p',t1' in add_gadt_equation env source destination | (Tconstr ((Path.Pident p) as path,[],_), _) - when is_abstract_newtype !env path && !generate_equations -> + when is_abstract_newtype !env path && !generate_equations -> reify env t2'; local_non_recursive_abbrev !env (Path.Pident p) t2'; add_gadt_equation env p t2' | (_, Tconstr ((Path.Pident p) as path,[],_)) - when is_abstract_newtype !env path && !generate_equations -> + when is_abstract_newtype !env path && !generate_equations -> reify env t1' ; local_non_recursive_abbrev !env (Path.Pident p) t1'; add_gadt_equation env p t1' @@ -2197,7 +2221,7 @@ and unify3 env t1 t1' t2 t2' = (* XXX One should do some kind of unification... *) begin match (repr t2').desc with Tobject (_, {contents = Some (_, va::_)}) when - (match (repr va).desc with + (match (repr va).desc with Tvar _|Tunivar _|Tnil -> true | _ -> false) -> () | Tobject (_, nm2) -> set_name nm2 !nm1 | _ -> () @@ -2206,7 +2230,10 @@ and unify3 env t1 t1' t2 t2' = unify_row env row1 row2 | (Tfield(f,kind,_,rem), Tnil) | (Tnil, Tfield(f,kind,_,rem)) -> begin match field_kind_repr kind with - Fvar r when f <> dummy_method -> set_kind r Fabsent + Fvar r when f <> dummy_method -> + set_kind r Fabsent; + if d2 = Tnil then unify env rem t2' + else unify env (newty2 rem.level Tnil) rem | _ -> raise (Unify []) end | (Tnil, Tnil) -> @@ -2220,20 +2247,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 = @@ -2274,9 +2301,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))) @@ -2313,11 +2340,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 @@ -2351,8 +2379,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; @@ -2361,7 +2389,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 @@ -2375,7 +2403,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))) @@ -2393,7 +2421,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 -> @@ -2414,8 +2442,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; @@ -2469,7 +2497,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 | _ -> @@ -2808,7 +2836,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')) @@ -3053,16 +3081,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 (env, 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 @@ -3186,18 +3214,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 (env, 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 @@ -3312,14 +3340,16 @@ let match_class_declarations env patt_params patt_type subj_params subj_type = raise (Failure [CM_Type_parameter_mismatch (env, 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 @@ -3981,11 +4011,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 @@ -4034,15 +4064,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 d5560cd0b6..5b78013956 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 @@ -116,10 +115,11 @@ val instance_def: type_expr -> type_expr val instance_list: Env.t -> type_expr list -> type_expr list (* Take an instance of a list of type schemes *) val instance_constructor: - ?in_pattern:Env.t ref * int -> + ?in_pattern:Env.t ref * int -> 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 -> @@ -153,7 +153,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. *) @@ -175,7 +176,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 *) @@ -197,7 +198,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] @@ -228,7 +229,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 4b4f234c89..3435ffd33f 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -23,7 +23,7 @@ open Btype (* Simplified version of Ctype.free_vars *) let rec free_vars ty = let ret = ref TypeSet.empty in - let rec loop ty = + let rec loop ty = let ty = repr ty in if ty.level >= lowest_level then begin ty.level <- pivot_level - ty.level; @@ -35,7 +35,7 @@ let rec free_vars ty = iter_row loop row; if not (static_row row) then loop row.row_more | _ -> - iter_type_expr loop ty + iter_type_expr loop ty end in loop ty; @@ -52,46 +52,46 @@ let constructor_descrs ty_res cstrs priv = let rec describe_constructors idx_const idx_nonconst = function [] -> [] | (name, ty_args, ty_res_opt) :: rem -> - let ty_res = - match ty_res_opt with - | Some ty_res' -> ty_res' - | None -> ty_res - in + let ty_res = + match ty_res_opt with + | Some ty_res' -> ty_res' + | None -> ty_res + in let (tag, descr_rem) = match ty_args with [] -> (Cstr_constant idx_const, describe_constructors (idx_const+1) idx_nonconst rem) | _ -> (Cstr_block idx_nonconst, describe_constructors idx_const (idx_nonconst+1) rem) in - let existentials = - match ty_res_opt with - | None -> [] - | Some type_ret -> - let res_vars = free_vars type_ret in - let arg_vars = free_vars (newgenty (Ttuple ty_args)) in - TypeSet.elements (TypeSet.diff arg_vars res_vars) - in - let cstr = - { cstr_res = ty_res; - cstr_existentials = existentials; + let existentials = + match ty_res_opt with + | None -> [] + | Some type_ret -> + let res_vars = free_vars type_ret in + let arg_vars = free_vars (newgenty (Ttuple ty_args)) in + TypeSet.elements (TypeSet.diff arg_vars res_vars) + in + let cstr = + { cstr_res = ty_res; + cstr_existentials = existentials; cstr_args = ty_args; cstr_arity = List.length ty_args; cstr_tag = tag; cstr_consts = !num_consts; cstr_nonconsts = !num_nonconsts; - cstr_normal = !num_normal; + cstr_normal = !num_normal; cstr_private = priv; - cstr_generalized = ty_res_opt <> None - } in + cstr_generalized = ty_res_opt <> None + } in (name, cstr) :: descr_rem in - describe_constructors 0 0 cstrs + describe_constructors 0 0 cstrs let exception_descr path_exc decl = { cstr_res = Predef.type_exn; cstr_existentials = []; - cstr_args = decl; - cstr_arity = List.length decl; - cstr_tag = Cstr_exception path_exc; + cstr_args = decl.exn_args; + cstr_arity = List.length decl.exn_args; + cstr_tag = Cstr_exception (path_exc, decl.exn_loc); cstr_consts = -1; cstr_nonconsts = -1; cstr_private = Public; @@ -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 0d6255359e..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 -> type_expr list -> constructor_description + 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 0120fe03ea..963e4f0cb1 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,28 +137,30 @@ module EnvTbl = (fun () -> f x) (fun () -> current_slot := old_slot) - let keys (tbl, _) = + let keys tbl = Ident.keys 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; 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 @@ -118,14 +171,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 = { @@ -137,14 +191,20 @@ 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 = [] } + cltypes = EnvTbl.empty; + summary = Env_empty; local_constraints = false; gadt_instances = []; + in_signature = false; + } + +let in_signature env = {env with in_signature = true} let diff_keys is_local tbl1 tbl2 = let keys2 = EnvTbl.keys tbl2 in @@ -161,13 +221,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 @@ -176,6 +232,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) @@ -191,8 +250,6 @@ let current_unit = ref "" (* Persistent structure descriptions *) -type pers_flags = Rectypes - type pers_struct = { ps_name: string; ps_sig: signature; @@ -202,7 +259,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 *) @@ -219,29 +276,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 = String.create (String.length cmi_magic_number) in - really_input ic buffer 0 (String.length cmi_magic_number); - 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; @@ -256,17 +299,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 := ""; @@ -275,6 +327,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 @@ -292,7 +350,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 @@ -300,7 +360,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 -> @@ -313,7 +375,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 -> @@ -324,6 +388,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 = @@ -365,8 +431,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 @@ -377,13 +443,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 @@ -404,7 +473,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) @@ -414,7 +483,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) @@ -430,14 +499,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 @@ -445,7 +514,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) @@ -460,7 +529,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) @@ -476,7 +545,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 @@ -493,9 +562,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 = @@ -513,8 +582,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 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 = @@ -530,7 +603,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 = @@ -543,6 +618,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 @@ -552,20 +634,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 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 +let mark_constructor usage env name desc = + match desc.cstr_tag with + | Cstr_exception (_, loc) -> + begin + try Hashtbl.find used_constructors ("exn", loc, name) usage + with Not_found -> () + end + | _ -> + let ty_path = ty_path desc.cstr_res in + let ty_decl = try find_type ty_path env with Not_found -> assert false in + let ty_name = Path.last ty_path in + mark_constructor_used usage ty_name ty_decl name let lookup_label lid env = - let desc = lookup_label lid env in + 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 @@ -584,9 +673,9 @@ let lookup_cltype lid env = (* Iter on an environment (ignoring the body of functors) *) let iter_env proj1 proj2 f env = - Ident.iter (fun id -> f (Pident id)) (fst (proj1 env)); + Ident.iter (fun id (x,_) -> f (Pident id) x) (proj1 env); let rec iter_components path path' mcomps = - match Lazy.force mcomps with + match EnvLazy.force !components_of_module_maker' mcomps with Structure_comps comps -> Tbl.iter (fun s (d, n) -> f (Pdot (path, s, n)) (Pdot (path', s, n), d)) @@ -598,8 +687,8 @@ let iter_env proj1 proj2 f env = | Functor_comps _ -> () in Ident.iter - (fun id (path, comps) -> iter_components (Pident id) path comps) - (fst env.components) + (fun id ((path, comps), _) -> iter_components (Pident id) path comps) + env.components let iter_types f = iter_env (fun env -> env.types) (fun sc -> sc.comp_types) f @@ -652,7 +741,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 +752,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 +776,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 +813,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 +831,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 +843,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) - (List.map snd constructors, nopos) c.comp_constrs_by_path; + let constructors = constructors_of_type path decl' in + c.comp_constrs_by_path <- + Tbl.add (Ident.name id) + (List.map snd constructors, nopos) c.comp_constrs_by_path; List.iter (fun (name, descr) -> - c.comp_constrs <- Tbl.add name (descr, nopos) c.comp_constrs) + c.comp_constrs <- + Tbl.add (Ident.name name) (descr, nopos) c.comp_constrs) constructors; - let labels = labels_of_type path decl' in + 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 +878,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 +905,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 +931,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 +944,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 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 env.in_signature && 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; @@ -901,8 +1001,29 @@ and store_type_infos id path info env = summary = Env_type(env.summary, id, info) } 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 ("", false)) + then begin + let ty = "exn" in + let c = Ident.name id in + let k = (ty, loc, c) in + if not (Hashtbl.mem used_constructors k) then begin + let used = constructor_usages () in + Hashtbl.add used_constructors k (add_constructor_usage used); + !add_delayed_check_forward + (fun () -> + if not env.in_signature && 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 = @@ -946,7 +1067,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 *) @@ -1000,13 +1122,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 @@ -1023,25 +1145,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 @@ -1053,8 +1175,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 () -> @@ -1062,8 +1185,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 *) @@ -1092,29 +1215,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; @@ -1123,6 +1246,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 @@ -1130,19 +1325,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 20a8509e21..8a92525b7e 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 @@ -26,12 +37,13 @@ val iter_types: (Path.t -> Path.t * type_declaration -> unit) -> t -> unit (* 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 @@ -51,24 +63,25 @@ 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 (* 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. *) @@ -79,21 +92,24 @@ val add_signature: signature -> t -> t (* Insertion of all fields of a signature, relative to the given path. Used to implement open. *) -val open_signature: ?loc:Location.t -> 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 @@ -102,10 +118,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. *) @@ -124,25 +140,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 @@ -153,16 +163,57 @@ 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 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 096aab46e9..3328200da3 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 7f319af1fb..8f1092c49d 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]) -> - [Field_type cstr1] + 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 - compare_variants env decl1 decl2 (n+1) rem1 rem2 - else [Field_type cstr1] - - + [Field_type cstr1] + | _ -> + if Misc.for_all2 + (fun ty1 ty2 -> + Ctype.equal env true (ty1::decl1.type_params) + (ty2::decl2.type_params)) + (arg1) (arg2) + then + compare_variants env decl1 decl2 (n+1) rem1 rem2 + else [Field_type cstr1] + + let rec compare_records env decl1 decl2 n labels1 labels2 = match labels1, labels2 with [], [] -> [] | [], (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 ed2 + Misc.for_all2 (fun ty1 ty2 -> Ctype.equal env false [ty1] [ty2]) + ed1.exn_args ed2.exn_args (* Inclusion between class types *) let encode_val (mut, ty) rem = 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 0fb233a90b..2ee7090185 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,14 @@ 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, env, Type_declarations(id, decl1, decl2, err)]) (* Inclusion between exception declarations *) let exception_declarations env cxt subst id decl1 decl2 = + 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 () @@ -113,13 +114,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 *) @@ -149,13 +150,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 = @@ -171,9 +172,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 @@ -183,7 +184,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 @@ -192,14 +193,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 = @@ -219,7 +220,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, @@ -231,13 +232,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 @@ -255,31 +256,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 | _ -> @@ -292,12 +294,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, env, Modtype_infos(id, info1, info2)) :: reasons)) @@ -372,8 +374,9 @@ let include_err ppf = function fprintf ppf "@[<hv 2>Exception declarations do not match:@ \ %a@;<1 -2>is not included in@ %a@]" - (exception_declaration id) d1 - (exception_declaration id) d2 + (exception_declaration id) d1 + (exception_declaration id) d2; + show_locs ppf (d1.exn_loc, d2.exn_loc) | Module_types(mty1, mty2)-> fprintf ppf "@[<hv 2>Modules do not match:@ \ diff --git a/typing/includemod.mli b/typing/includemod.mli index 6dc9217462..355679c33c 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/mtype.ml b/typing/mtype.ml index 57ed4e2901..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,36 +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) -> - Tsig_exception(id, List.map (Ctype.nondep_type env mid) 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) -> + let d = {exn_args = List.map (Ctype.nondep_type env mid) d.exn_args; + exn_loc = d.exn_loc} in + 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 @@ -158,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 015d1d6085..ea6b96a7ef 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 @@ -153,10 +155,10 @@ open Format ;; let get_constr_name tag ty tenv = match tag with -| Cstr_exception path -> Path.name path +| Cstr_exception (path, _) -> Path.name path | _ -> try - let name,_,_ = get_constr tag ty tenv in name + let name,_,_ = get_constr tag ty tenv in 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,28 +618,29 @@ 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 -> - if generalized_constructor x then loop xs else x :: loop xs + if generalized_constructor x then loop xs else x :: loop xs in loop env let full_match ignore_generalized closing env = match env with -| ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _},_)},_)::_ -> +| ({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 || @@ -674,8 +698,8 @@ 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,_) - :: _ -> + 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 @@ -722,35 +749,36 @@ let rec adt_path env ty = | {type_kind=Type_variant constr_list} -> begin match (Ctype.repr ty).desc with | Tconstr (path,_,_) -> - path + path | _ -> assert false end | {type_manifest = Some _} -> adt_path env (Ctype.expand_head_once env (clean_copy ty)) | _ -> raise Not_an_adt ;; -let rec map_filter f = +let rec map_filter f = function [] -> [] | x :: xs -> - match f x with - | None -> map_filter f xs - | Some y -> y :: map_filter f xs + match f x with + | None -> map_filter f xs + | Some y -> y :: map_filter f xs (* Sends back a pattern that complements constructor tags all_tag *) -let complete_constrs p all_tags = +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 - map_filter + let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in + let constrs = + Env.find_constructors (adt_path p.pat_env p.pat_type) p.pat_env in + map_filter (fun cnstr -> - if List.mem cnstr.cstr_tag not_tags then Some cnstr else None) - constrs + if List.mem cnstr.cstr_tag not_tags then Some cnstr else None) + constrs with | Datarepr.Constr_not_found -> - fatal_error "Parmatch.complete_constr: constr_not_found" + fatal_error "Parmatch.complete_constr: constr_not_found" end | _ -> fatal_error "Parmatch.complete_constr" @@ -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*")))}, - [])) + (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,20 +928,20 @@ 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 - let pats = List.map (pat_of_constr p) cnstrs in + let cnstrs = complete_constrs p all_tags in + let pats = List.map (pat_of_constr p) cnstrs in (* List.iter (Format.eprintf "%a@." top_pretty) pats; Format.eprintf "@.@."; *) pats | _ -> assert false - + (* Core function : Is the last row of pattern matrix pss + qs satisfiable ? @@ -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 - match others with - Rnone -> Rsome sofar - | Rsome sofar' -> - Rsome (sofar @ sofar') - + | 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,23 +1085,46 @@ 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 -> - f x y :: iter2 x ys + f x y :: iter2 x ys in let rec iter = function - [] -> [] + [] -> [] | 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 -> @@ -1092,11 +1147,11 @@ let rec exhaust_gadt ext pss n = match pss with with | Rsome r -> Rsome (List.map (fun row -> (set_args p row)) r) | r -> r in - let before = try_many_gadt try_non_omega constrs in + let before = try_many_gadt try_non_omega constrs in if - full_match_gadt constrs && not (should_extend ext constrs) + full_match_gadt constrs && not (should_extend ext constrs) then - before + before else (* D = filter_extra pss is the default matrix @@ -1111,38 +1166,37 @@ let rec exhaust_gadt ext pss n = match pss with | Rnone -> before | Rsome r -> try - let missing_trailing = build_other_gadt ext constrs in - let before = - match before with - Rnone -> [] - | Rsome lst -> lst - in - let dug = - combinations - (fun head tail -> - head :: tail) - missing_trailing - r - in - Rsome (dug @ before) + let missing_trailing = build_other_gadt ext constrs in + let before = + match before with + Rnone -> [] + | Rsome lst -> lst + in + let dug = + combinations + (fun head tail -> head :: tail) + missing_trailing + r + in + Rsome (dug @ before) with (* cannot occur, since constructors don't make a full signature *) | Empty -> fatal_error "Parmatch.exhaust" end -let exhaust_gadt ext pss n = - let ret = exhaust_gadt ext pss n in +let exhaust_gadt ext pss n = + let ret = exhaust_gadt ext pss n in match ret with Rnone -> Rnone | Rsome lst -> (* The following line is needed to compile stdlib/printf.ml *) if lst = [] then Rsome (omegas n) else - let singletons = - List.map - (function - [x] -> x - | _ -> assert false) - lst + let singletons = + List.map + (function + [x] -> x + | _ -> assert false) + lst in Rsome [orify_many singletons] @@ -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,114 +1728,117 @@ let check_partial_all v casel = (************************) - let rec get_first f = + let rec get_first f = function | [] -> None - | x :: xs -> - match f x with - | None -> get_first f xs - | x -> x + | x :: xs -> + match f x with + | None -> get_first f xs + | x -> x (* conversion from Typedtree.pattern to Parsetree.pattern list *) module Conv = struct open Parsetree - let mkpat desc = + 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 -> - List.map - (fun lst -> x :: lst) - (select ys) - @ - select (xs::ys) + List.map + (fun lst -> x :: lst) + (select ys) + @ + select (xs::ys) | _ -> [] - let name_counter = ref 0 - let fresh () = - let current = !name_counter in + 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 + loop a @ loop b | Tpat_any | Tpat_constant _ | Tpat_var _ -> - [mkpat Ppat_any] - | Tpat_alias (p,_) -> loop p + [mkpat Ppat_any] + | Tpat_alias (p,_,_) -> loop p | Tpat_tuple lst -> - let results = select (List.map loop lst) in - List.map - (fun lst -> mkpat (Ppat_tuple lst)) - results - | Tpat_construct (cstr,lst) -> - let id = fresh () in - Hashtbl.add constrs id cstr; - let results = select (List.map loop lst) in - begin match lst with - [] -> - [mkpat (Ppat_construct(Longident.Lident id, None, false))] + let results = select (List.map loop lst) in + List.map + (fun lst -> mkpat (Ppat_tuple lst)) + results + | 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(lid, None, false))] | _ -> - List.map - (fun lst -> - let arg = - match lst with - [] -> assert false - | [x] -> Some x - | _ -> Some (mkpat (Ppat_tuple lst)) - in - mkpat (Ppat_construct(Longident.Lident id, arg, false))) - results + List.map + (fun lst -> + let arg = + match lst with + [] -> assert false + | [x] -> Some x + | _ -> Some (mkpat (Ppat_tuple lst)) + in + mkpat (Ppat_construct(lid, arg, false))) + results end | Tpat_variant(label,p_opt,row_desc) -> - begin match p_opt with - | None -> - [mkpat (Ppat_variant(label, None))] - | Some p -> - let results = loop p in - List.map - (fun p -> - mkpat (Ppat_variant(label, Some p))) - results + begin match p_opt with + | None -> + [mkpat (Ppat_variant(label, None))] + | Some p -> + let results = loop p in + List.map + (fun p -> + mkpat (Ppat_variant(label, Some p))) + results end - | Tpat_record subpatterns -> - let pats = - select - (List.map (fun (_,x) -> (loop x)) subpatterns) - in - let label_idents = - List.map - (fun (lbl,_) -> - let id = fresh () in - Hashtbl.add labels id lbl; - Longident.Lident id) - subpatterns - in - List.map - (fun lst -> - let lst = List.combine label_idents lst in - mkpat (Ppat_record (lst, Open))) - pats + | Tpat_record (subpatterns, _closed_flag) -> + let pats = + select + (List.map (fun (_,_,_,x) -> (loop x)) subpatterns) + in + let label_idents = + List.map + (fun (lbl_path,_,lbl,_) -> + let id = fresh () in + Hashtbl.add labels id (lbl_path, lbl); + Longident.Lident id) + subpatterns + in + List.map + (fun lst -> + 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 - List.map (fun lst -> mkpat (Ppat_array lst)) results + let results = select (List.map loop lst) in + List.map (fun lst -> mkpat (Ppat_array lst)) results | Tpat_lazy p -> - let results = loop p in - List.map (fun p -> mkpat (Ppat_lazy p)) results + 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,44 +1862,48 @@ 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 - | Some pred -> - let (patterns,constrs,labels) = Conv.conv u in - get_first (pred constrs labels) patterns - | None -> Some u - in - begin match v with - None -> Total - | Some v -> + let v = + match pred with + | Some pred -> + 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 + begin match v with + None -> Total + | Some v -> let errmsg = try - let buf = Buffer.create 16 in - let fmt = formatter_of_buffer buf in - top_pretty fmt v; - begin match check_partial_all v casel with - | None -> () - | Some _ -> + let buf = Buffer.create 16 in + let fmt = formatter_of_buffer buf in + top_pretty fmt v; + begin match check_partial_all v casel with + | None -> () + | Some _ -> (* This is 'Some loc', where loc is the location of a possibly matching clause. Forget about loc, because printing two locations is a pain in the top-level *) Buffer.add_string buf "\n(However, some guarded clause may match this value.)" - end ; - Buffer.contents buf + end ; + Buffer.contents buf with _ -> - "" in + "" in Location.prerr_warning loc (Warnings.Partial_match errmsg) ; Partial end | _ -> fatal_error "Parmatch.check_partial" end -let do_check_partial_normal loc casel pss = +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 @@ -1967,26 +2030,26 @@ 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 *) (********************************) @@ -1996,23 +2059,23 @@ 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 let total = do_check_partial loc casel pss in if - total = Total && Warnings.is_active (Warnings.Fragile_match "") + total = Total && Warnings.is_active (Warnings.Fragile_match "") then begin - do_check_fragile loc casel pss + do_check_fragile loc casel pss 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 = @@ -2020,7 +2083,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 0cfaad7b81..640dab42b2 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 8ba37fab0c..f951bb8b3e 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 @@ -66,24 +76,31 @@ and type_int32 = newgenty (Tconstr(path_int32, [], ref Mnil)) and type_int64 = newgenty (Tconstr(path_int64, [], ref Mnil)) and type_lazy_t t = newgenty (Tconstr(path_lazy_t, [t], ref Mnil)) -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 = []; @@ -97,7 +114,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; @@ -106,7 +123,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; @@ -136,7 +153,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; @@ -162,7 +180,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; @@ -180,6 +198,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 add_exception ident_match_failure [newgenty (Ttuple[type_string; type_int; type_int])] ( add_exception ident_out_of_memory [] ( @@ -224,4 +244,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 43e37965c8..ced95d8474 100644 --- a/typing/predef.mli +++ b/typing/predef.mli @@ -63,3 +63,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 9a16344f38..3fd5221a41 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -521,7 +521,8 @@ let rec tree_of_typexp sch ty = | Tunivar _ -> Otyp_var (false, name_of_type ty) | Tpackage (p, n, tyl) -> - let n = List.map (fun li -> String.concat "." (Longident.flatten li)) n in + 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; @@ -660,11 +661,11 @@ 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 mark_loops args; - may mark_loops ret_type_opt) - cstrs + List.iter + (fun (_, args,ret_type_opt) -> + List.iter mark_loops args; + may mark_loops ret_type_opt) + cstrs | Type_record(l, rep) -> List.iter (fun (_, _, ty) -> mark_loops ty) l end; @@ -720,6 +721,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 := []; @@ -727,7 +729,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 @@ -735,7 +737,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) @@ -746,8 +748,8 @@ let type_declaration id ppf decl = (* Print an exception declaration *) let tree_of_exception_declaration id decl = - reset_and_mark_loops_list decl; - let tyl = tree_of_typlist false decl in + reset_and_mark_loops_list decl.exn_args; + let tyl = tree_of_typlist false decl.exn_args in Osig_exception (Ident.name id, tyl) let exception_declaration id ppf decl = @@ -792,14 +794,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 @@ -810,13 +812,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) @@ -824,7 +826,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 @@ -856,7 +858,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 @@ -948,19 +950,19 @@ let wrap_env fenv ftree arg = let rec filter_rem_sig item rem = match item, rem with - | Tsig_class _, ctydecl :: tydecl1 :: tydecl2 :: rem -> + | Sig_class _, ctydecl :: tydecl1 :: tydecl2 :: rem -> ([ctydecl; tydecl1; tydecl2], rem) - | Tsig_cltype _, tydecl1 :: tydecl2 :: rem -> + | Sig_class_type _, tydecl1 :: tydecl2 :: rem -> ([tydecl1; tydecl2], rem) | _ -> ([], rem) 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, wrap_env (Env.add_module param ty_arg) tree_of_modtype ty_res) @@ -974,21 +976,21 @@ and tree_of_signature_rec = function let (sg, rem) = filter_rem_sig item rem in let trees = match item with - | Tsig_value(id, decl) -> + | Sig_value(id, decl) -> [tree_of_value_description id decl] - | Tsig_type(id, _, _) when is_row_name (Ident.name id) -> + | Sig_type(id, _, _) when is_row_name (Ident.name id) -> [] - | Tsig_type(id, decl, rs) -> + | Sig_type(id, decl, rs) -> [Osig_type(tree_of_type_decl id decl, tree_of_rec rs)] - | Tsig_exception(id, decl) -> + | Sig_exception(id, decl) -> [tree_of_exception_declaration id decl] - | Tsig_module(id, mty, rs) -> + | Sig_module(id, mty, rs) -> [Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs)] - | Tsig_modtype(id, decl) -> + | Sig_modtype(id, decl) -> [tree_of_modtype_declaration id decl] - | Tsig_class(id, decl, rs) -> + | Sig_class(id, decl, rs) -> [tree_of_class_declaration id decl rs] - | Tsig_cltype(id, decl, rs) -> + | Sig_class_type(id, decl, rs) -> [tree_of_cltype_declaration id decl rs] in set_printing_env (Env.add_signature (item :: sg) !printing_env); @@ -997,8 +999,8 @@ and tree_of_signature_rec = 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) @@ -1100,7 +1102,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 8ec33a454c..7b58b9bbf3 100644 --- a/typing/printtyp.mli +++ b/typing/printtyp.mli @@ -43,20 +43,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..d89d25b53e --- /dev/null +++ b/typing/printtyped.ml @@ -0,0 +1,761 @@ +(***********************************************************************) +(* *) +(* 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 + +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 + +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 +;; + +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 c79a48c2ec..0e67340f68 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 cd8a24e350..8643d6d35d 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,8 +175,8 @@ let type_declaration s decl = | Type_variant cstrs -> Type_variant (List.map - (fun (n, args, ret_type) -> - (n, List.map (typexp s) args, may_map (typexp s) ret_type)) + (fun (n, args, ret_type) -> + (n, List.map (typexp s) args, may_map (typexp s) ret_type)) cstrs) | Type_record(lbls, rep) -> Type_record @@ -180,8 +184,8 @@ let type_declaration s decl = rep) end; type_manifest = - begin - match decl.type_manifest with + begin + match decl.type_manifest with None -> None | Some ty -> Some(typexp s ty) end; @@ -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 = @@ -251,41 +255,43 @@ let value_description s descr = val_loc = if s.for_saving then Location.none else descr.val_loc; } -let exception_declaration s tyl = - List.map (type_expr s) tyl +let exception_declaration s descr = + { exn_args = List.map (type_expr s) descr.exn_args; + exn_loc = if s.for_saving then Location.none else descr.exn_loc; + } let rec rename_bound_idents s idents = function [] -> (List.rev idents, s) - | 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 = @@ -298,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 f5e6085ad0..48200115e0 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 @@ -52,6 +51,16 @@ type error = exception Error of Location.t * Env.t * error +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 } + + (**********************) (* Useful constants *) @@ -62,7 +71,7 @@ exception Error of Location.t * Env.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 = @@ -220,7 +233,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 @@ -232,7 +246,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 @@ -253,7 +267,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 @@ -281,9 +295,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, val_env, 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, val_env, Field_type_mismatch ("method", lab, trace))); + end; + cty let delayed_meth_specs = ref [] @@ -296,24 +314,44 @@ let declare_method val_env meths self_type lab priv sty loc = raise(Error(loc, val_env, 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, val_env, 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, val_env, 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 } @@ -328,42 +366,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. *) @@ -377,45 +429,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, env, Unbound_class_type_2 lid)); + raise(Error(scty.pcty_loc, env, Unbound_class_type_2 lid.txt)); let (params, clty) = Ctype.instance_class decl.clty_params decl.clty_type in if List.length params <> List.length styl then raise(Error(scty.pcty_loc, env, - 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, env, Parameter_mismatch trace))) - styl params; - Tcty_constr (path, params, clty) + raise(Error(sty.ptyp_loc, env, 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 := []; @@ -426,14 +495,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) = @@ -471,31 +542,37 @@ 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, val_env, No_overriding ("instance variable", lab))) + raise(Error(loc, val_env, + No_overriding ("instance variable", lab.txt))) end; if !Clflags.principal then Ctype.begin_def (); let exp = @@ -505,36 +582,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, val_env, No_overriding("method", lab))) + raise(Error(loc, val_env, 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 _ -> @@ -549,9 +632,10 @@ let rec class_field cl_num self_type meths vars end | _ -> assert false with Ctype.Unify trace -> - raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace))) + raise(Error(loc, val_env, + 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 @@ -563,17 +647,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 @@ -585,14 +674,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 @@ -633,7 +726,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 @@ -642,7 +735,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) @@ -695,18 +788,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, val_env, Unbound_class_2 lid)); + raise(Error(scl.pcl_loc, val_env, Unbound_class_2 lid.txt)); let tyl = List.map - (fun sty -> transl_simple_type val_env false sty, sty.ptyp_loc) + (fun sty -> transl_simple_type val_env false sty) styl in let (params, clty) = @@ -715,51 +812,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, val_env, - 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, val_env, Parameter_mismatch trace))) + raise(Error(cty'.ctyp_loc, val_env, 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 @@ -775,30 +875,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 @@ -806,16 +906,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 @@ -833,7 +933,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 @@ -877,7 +977,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)::_ -> @@ -888,7 +988,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) = @@ -897,7 +997,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} @@ -910,14 +1010,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; } @@ -927,18 +1028,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} @@ -954,16 +1055,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, val_env, 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} (*******************************) @@ -1029,7 +1133,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; @@ -1076,7 +1180,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, env, Repeated_parameter)) in @@ -1160,7 +1264,7 @@ let class_infos define_class kind (Ctype.instance env constr_type) with Ctype.Unify trace -> raise(Error(cl.pci_loc, env, - Constructor_type_mismatch (cl.pci_name, trace))) + Constructor_type_mismatch (cl.pci_name.txt, trace))) end; (* Class and class type temporary definitions *) @@ -1291,23 +1395,38 @@ let final_decl env define_class raise(Error(cl.pci_loc, env, 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) ( @@ -1318,8 +1437,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 = @@ -1341,8 +1460,8 @@ let check_coercions env if not (Ctype.opened_object cl_ty) then raise(Error(loc, env, 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) (*******************************) @@ -1351,8 +1470,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 ()); @@ -1380,7 +1499,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 @@ -1394,30 +1513,33 @@ 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 Ctype.unify env ty (Ctype.instance env body) - with exn -> assert (exn = Not_found) + with + 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; @@ -1440,7 +1562,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' } diff --git a/typing/typeclass.mli b/typing/typeclass.mli index b898284a80..c1a1b22988 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 6055eaff0f..8e17d0029d 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 @@ -84,7 +84,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. @@ -93,14 +93,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 = @@ -141,7 +147,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 and module_expr me = @@ -172,7 +178,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 @@ -180,10 +186,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 @@ -193,7 +200,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 @@ -217,15 +224,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], _)} @@ -296,6 +308,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 @@ -317,7 +330,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; @@ -341,11 +354,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 := []; @@ -355,25 +369,27 @@ 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, Env.empty, 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, Env.empty, Multiply_bound_variable name.txt)); + let id = Ident.create name.txt in + pattern_variables := + (id, ty, name, loc, is_as_variable) :: !pattern_variables; if is_module then begin (* Note: unpack patterns enter a variable of the same name *) if not !allow_modules then raise (Error (loc, Env.empty, 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 = @@ -383,7 +399,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 @@ -396,9 +412,9 @@ let enter_orpat_variables loc env p1_vs p2_vs = (x2,x1)::unify_vars rem1 rem2 end | [],[] -> [] - | (x,_,_,_)::_, [] -> raise (Error (loc, env, Orpat_vars x)) - | [],(x,_,_,_)::_ -> raise (Error (loc, env, Orpat_vars x)) - | (x,_,_,_)::_, (y,_,_,_)::_ -> + | (x,_,_,_,_)::_, [] -> raise (Error (loc, env, Orpat_vars x)) + | [],(x,_,_,_,_)::_ -> raise (Error (loc, env, Orpat_vars x)) + | (x,_,_,_,_)::_, (y,_,_,_,_)::_ -> let min_var = if Ident.name x < Ident.name y then x else y in @@ -407,11 +423,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 @@ -424,11 +440,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; @@ -477,7 +493,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) @@ -491,7 +507,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 @@ -499,38 +515,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 @@ -544,10 +563,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, Env.empty, Label_multiply_defined (Longident.Lident label.lbl_name))) @@ -595,28 +614,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) -> @@ -624,11 +645,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) -> @@ -639,15 +663,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 -> @@ -657,16 +681,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, !env, Unexpected_existential)); (* if constructor is gadt, we must verify that the expected type has the @@ -685,7 +710,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, !env, Constructor_arity_mismatch(lid, + raise(Error(loc, !env, Constructor_arity_mismatch(lid.txt, constr.cstr_arity, List.length sargs))); let (ty_args, ty_res) = instance_constructor ~in_pattern:(env, get_newtype_level ()) constr @@ -696,8 +721,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) -> @@ -713,11 +738,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 (); @@ -737,14 +762,14 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = if List.exists instantiated vars then raise (Error(loc, !env, 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 -> @@ -755,7 +780,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) -> @@ -770,28 +795,52 @@ 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) -> - let ty, force = Typetexp.transl_simple_type_delayed !env sty in + (* Separate when not already separated by !principal *) + let separate = true in + if separate then begin_def(); + 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(); + generalize_structure ty; + instance !env ty, instance !env ty + end else ty, ty + in unify_pat_types loc !env ty expected_ty; - let p = type_pat sp expected_ty in + let p = type_pat sp expected_ty' in + (*Format.printf "%a@.%a@." + Printtyp.raw_type_expr ty + Printtyp.raw_type_expr p.pat_type;*) pattern_force := force :: !pattern_force; - p + if separate then + match p.pat_desc with + Tpat_var (id,s) -> + {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 = @@ -838,11 +887,11 @@ 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 - Env.add_annot id (Annot.Iref_internal loc) e1 - ) + let e1 = Env.add_value ?check id + {val_type = ty; val_kind = Val_reg; Types.val_loc = loc} env in + Env.add_annot id (Annot.Iref_internal loc) e1) pv env, get_ref module_variables) @@ -850,7 +899,10 @@ let type_pattern ~lev env spat scope expected_ty = reset_pattern scope true; let new_env = ref env in let pat = type_pat ~allow_existentials:true ~lev new_env spat expected_ty in - let new_env, unpacks = add_pattern_variables ~check:(fun s -> Warnings.Unused_var_strict s) ~check_as:(fun s -> Warnings.Unused_var s) !new_env in + let new_env, unpacks = + add_pattern_variables !new_env + ~check:(fun s -> Warnings.Unused_var_strict s) + ~check_as:(fun s -> Warnings.Unused_var s) in (pat, new_env, get_ref pattern_force, unpacks) let type_pattern_list env spatl scope expected_tys allow = @@ -872,13 +924,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) -> - let check s = if as_var then Warnings.Unused_var s else Warnings.Unused_var_strict s in + (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) @@ -890,8 +944,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 @@ -903,19 +957,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) + ~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 @@ -931,50 +986,58 @@ let force_delayed_checks () = reset_delayed_checks (); Btype.backtrack snap +let fst3 (x, _, _) = x +let snd3 (_, x, _) = x (* Generalization criterion for expressions *) 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 @@ -984,21 +1047,22 @@ 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 *) ) - items + str.str_items | Tmod_apply _ -> false and is_nonexpansive_opt = function @@ -1221,7 +1285,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 @@ -1322,26 +1386,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 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 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(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 @@ -1362,7 +1430,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 @@ -1413,6 +1482,7 @@ and type_expect ?in_function env sexp ty_expected = let loc = sexp.pexp_loc in (* Record the expression type before unifying it with the expected type *) let rue exp = + Cmt_format.add_saved_type (Cmt_format.Partial_expression exp); Stypes.record (Stypes.Ti_expr exp); unify_exp env exp (instance env ty_expected); exp @@ -1421,13 +1491,13 @@ and type_expect ?in_function env sexp ty_expected = | Pexp_ident lid -> 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 @@ -1435,25 +1505,28 @@ and type_expect ?in_function 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, env, Masked_instance_variable lid)) + raise(Error(loc, env, Masked_instance_variable lid.txt)) | _ -> - Texp_ident(path, desc) - end; - exp_loc = loc; + Texp_ident(path, lid, desc) + end; + exp_loc = loc; exp_extra = []; exp_type = instance env desc.val_type; exp_env = env } end | Pexp_constant(Const_string s as cst) -> rue { exp_desc = Texp_constant cst; - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = (* Terrible hack for format strings *) begin match (repr (expand_head env ty_expected)).desc with @@ -1465,7 +1538,7 @@ and type_expect ?in_function env sexp ty_expected = | Pexp_constant cst -> 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 -> @@ -1485,7 +1558,7 @@ and type_expect ?in_function env sexp ty_expected = type_expect new_env (wrap_unpacks sbody unpacks) ty_expected in re { exp_desc = Texp_let(rec_flag, pat_exp_list, body); - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = body.exp_type; exp_env = env } | Pexp_function (l, Some default, [spat, sbody]) -> @@ -1494,14 +1567,16 @@ and type_expect ?in_function 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 = { @@ -1509,7 +1584,7 @@ and type_expect ?in_function 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 ) @@ -1520,7 +1595,7 @@ and type_expect ?in_function 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); } @@ -1571,8 +1646,8 @@ and type_expect ?in_function 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) -> @@ -1580,9 +1655,9 @@ and type_expect ?in_function env sexp ty_expected = if !Clflags.principal then begin_def (); let funct = type_exp env sfunct in if !Clflags.principal then begin - end_def (); - generalize_structure funct.exp_type - end; + end_def (); + generalize_structure funct.exp_type + end; let rec lower_args seen ty_fun = let ty = expand_head env ty_fun in if List.memq ty seen then () else @@ -1601,7 +1676,7 @@ and type_expect ?in_function 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 } | Pexp_match(sarg, caselist) -> @@ -1615,7 +1690,7 @@ and type_expect ?in_function env sexp ty_expected = in re { exp_desc = Texp_match(arg, cases, partial); - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = instance env ty_expected; exp_env = env } | Pexp_try(sbody, caselist) -> @@ -1624,7 +1699,7 @@ and type_expect ?in_function env sexp ty_expected = type_cases 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 -> @@ -1636,7 +1711,7 @@ and type_expect ?in_function 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 } @@ -1654,7 +1729,7 @@ and type_expect ?in_function 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 @@ -1665,7 +1740,7 @@ and type_expect ?in_function 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 = (); @@ -1676,24 +1751,25 @@ and type_expect ?in_function env sexp ty_expected = end | Pexp_record(lid_sexp_list, opt_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, env, Label_multiply_defined lid)) + then raise(Error(loc, env, 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 @@ -1712,10 +1788,10 @@ and type_expect ?in_function 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 [] -> [] @@ -1730,29 +1806,30 @@ and type_expect ?in_function 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) -> let arg = type_exp 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) -> let record = type_exp env srecord in - let label = Typetexp.find_label env loc lid in - let (label, newval) = - type_label_exp false env loc record.exp_type (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, env, Label_not_mutable lid)); + raise(Error(loc, env, 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) -> @@ -1762,7 +1839,7 @@ and type_expect ?in_function env sexp ty_expected = let argl = List.map (fun sarg -> type_expect env sarg ty) sargl in re { exp_desc = Texp_array argl; - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = instance env ty_expected; exp_env = env } | Pexp_ifthenelse(scond, sifso, sifnot) -> @@ -1772,7 +1849,7 @@ and type_expect ?in_function env sexp ty_expected = let ifso = type_expect 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 -> @@ -1782,7 +1859,7 @@ and type_expect ?in_function env sexp ty_expected = unify_exp env ifnot ifso.exp_type; re { exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot); - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = ifso.exp_type; exp_env = env } end @@ -1791,7 +1868,7 @@ and type_expect ?in_function env sexp ty_expected = let exp2 = type_expect env sexp2 ty_expected in re { exp_desc = Texp_sequence(exp1, exp2); - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = exp2.exp_type; exp_env = env } | Pexp_while(scond, sbody) -> @@ -1799,45 +1876,48 @@ and type_expect ?in_function env sexp ty_expected = 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 = type_expect env slow Predef.type_int in let high = type_expect env shigh Predef.type_int in let (id, new_env) = - Env.enter_value param {val_type = instance_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 let body = type_statement new_env sbody in rue { - exp_desc = Texp_for(id, low, high, dir, body); - exp_loc = loc; + 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 } | Pexp_constraint(sarg, sty, sty') -> - let separate = !Clflags.principal || Env.has_local_constraints env in - let (arg, ty') = + + let separate = true (* always separate, 1% slowdown for lablgtk *) + (* !Clflags.principal || Env.has_local_constraints env *) in + let (arg, ty',cty,cty') = match (sty, sty') with (None, None) -> (* Case actually unused *) let arg = type_exp 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 = type_exp env sarg in let gen = @@ -1850,7 +1930,7 @@ and type_expect ?in_function 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; @@ -1883,14 +1963,16 @@ and type_expect ?in_function 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'' () @@ -1901,38 +1983,41 @@ and type_expect ?in_function 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) -> let cond = type_expect env scond Predef.type_bool in let body = type_expect env sbody ty_expected in re { exp_desc = Texp_when(cond, body); - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = body.exp_type; exp_env = env } | Pexp_send (e, met) -> if !Clflags.principal then begin_def (); let obj = type_exp 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, env, Undefined_inherited_method met)) @@ -1951,25 +2036,31 @@ and type_expect ?in_function 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 @@ -1995,54 +2086,55 @@ and type_expect ?in_function env sexp ty_expected = assert false in rue { - exp_desc = exp; - exp_loc = loc; + 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, env, Undefined_method (obj.exp_type, met))) end | Pexp_new cl -> - 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, env, Virtual_class cl)) + raise(Error(loc, env, 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) -> 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 = type_expect env snewval (instance env desc.val_type) in + let newval = + type_expect env snewval (instance env desc.val_type) in let (path_self, _) = Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env in 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, env, Instance_variable_not_mutable(true,lab))) + raise(Error(loc, env, Instance_variable_not_mutable(true,lab.txt))) | _ -> - raise(Error(loc, env, Instance_variable_not_mutable(false,lab))) + raise(Error(loc, env, Instance_variable_not_mutable(false,lab.txt))) with Not_found -> - raise(Error(loc, env, Unbound_instance_variable lab)) + raise(Error(loc, env, Unbound_instance_variable lab.txt)) end | Pexp_override lst -> 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, env, - Value_multiply_overridden lab)); + Value_multiply_overridden lab.txt)); lab::l) lst [] in @@ -2057,17 +2149,17 @@ and type_expect ?in_function env sexp ty_expected = (path_self, _) -> let type_override (lab, snewval) = begin try - let (id, _, _, ty) = Vars.find lab !vars in - (Path.Pident id, type_expect env snewval (instance env ty)) + let (id, _, _, ty) = Vars.find lab.txt !vars in + (Path.Pident id, lab, type_expect env snewval (instance env ty)) with Not_found -> - raise(Error(loc, env, Unbound_instance_variable lab)) + raise(Error(loc, env, 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 } | _ -> @@ -2080,7 +2172,7 @@ and type_expect ?in_function 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 = type_expect new_env sbody ty_expected in @@ -2094,25 +2186,25 @@ and type_expect ?in_function env sexp ty_expected = begin try Ctype.unify_var new_env ty body.exp_type with Unify _ -> - raise(Error(loc, env, Scoping_let_module(name, body.exp_type))) + raise(Error(loc, env, Scoping_let_module(name.txt, body.exp_type))) end; re { - exp_desc = Texp_letmodule(id, modl, body); - exp_loc = loc; + exp_desc = Texp_letmodule(id, name, modl, body); + exp_loc = loc; exp_extra = []; exp_type = ty; exp_env = env } | Pexp_assert (e) -> let cond = type_expect env e Predef.type_bool in rue { exp_desc = Texp_assert (cond); - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = instance_def Predef.type_unit; exp_env = env; } | Pexp_assertfalse -> re { exp_desc = Texp_assertfalse; - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = instance env ty_expected; exp_env = env; } @@ -2123,25 +2215,25 @@ and type_expect ?in_function env sexp ty_expected = let arg = type_expect env e ty in re { exp_desc = Texp_lazy arg; - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = instance env ty_expected; exp_env = env; } | Pexp_object s -> let desc, sign, meths = !type_object env loc s in rue { - exp_desc = Texp_object (desc, sign, meths); - exp_loc = loc; + exp_desc = Texp_object (desc, (*sign,*) meths); + exp_loc = loc; exp_extra = []; exp_type = sign.cty_self; exp_env = env; } | Pexp_poly(sbody, sty) -> 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 (); @@ -2149,11 +2241,11 @@ and type_expect ?in_function 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 = type_expect 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 (); @@ -2166,15 +2258,19 @@ and type_expect ?in_function env sexp ty_expected = let exp = type_expect env sbody ty'' in end_def (); check_univars env false "method" exp ty_expected vars; - re { exp with exp_type = instance env ty } + { exp with exp_type = instance env ty } | Tvar _ -> let exp = type_exp env sbody in let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in unify_exp env exp ty; - re exp + exp | _ -> assert false - end + in + re { exp with exp_extra = (Texp_poly cty, loc) :: exp.exp_extra } | Pexp_newtype(name, sbody) -> + 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 = { @@ -2188,9 +2284,6 @@ and type_expect ?in_function 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()); @@ -2217,7 +2310,8 @@ and type_expect ?in_function 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 -> let (p, nl, tl) = match Ctype.expand_head env (instance env ty_expected) with @@ -2236,13 +2330,18 @@ and type_expect ?in_function env sexp ty_expected = let (modl, tl') = !type_package env m p nl tl in rue { exp_desc = Texp_pack modl; - exp_loc = loc; + exp_loc = loc; exp_extra = []; exp_type = newty (Tpackage (p, nl, tl')); exp_env = env } | Pexp_open (lid, e) -> - type_expect (!type_open env sexp.pexp_loc lid) e ty_expected + let (path, newenv) = !type_open env sexp.pexp_loc lid in + let exp = type_expect newenv e ty_expected in + { exp with + exp_extra = (Texp_open (path, lid, newenv), loc) :: exp.exp_extra; + } -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 @@ -2257,7 +2356,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 , env, Label_mismatch(lid_of_label label, trace))) + raise(Error(lid.loc , env, Label_mismatch(lid_of_label label, trace))) end; (* Instantiate so that we can generalize internal nodes *) let ty_arg = instance_def ty_arg in @@ -2267,9 +2366,11 @@ 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, env, - if create then Private_type ty_expected - else Private_label (lid_of_label label, ty_expected))); + if create then + raise (Error(loc, env, Private_type ty_expected)) + else + raise (Error(lid.loc, env, + 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 @@ -2290,7 +2391,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 *) @@ -2298,11 +2399,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) -> - type_expect env sarg ty_expected' - | {desc = Tarrow("",ty_arg,ty_res,_); level = lv}, _ -> + let rec is_inferred sexp = + match sexp.pexp_desc with + Pexp_ident _ | Pexp_apply _ | Pexp_send _ | Pexp_field _ -> true + | Pexp_open (_, e) -> is_inferred e + | _ -> false + in + match expand_head env ty_expected' with + {desc = Tarrow("",ty_arg,ty_res,_); level = lv} when is_inferred sarg -> (* apply optional arguments when expected type is "" *) (* we must be very careful about not breaking the semantics *) if !Clflags.principal then begin_def (); @@ -2337,17 +2441,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"); @@ -2374,10 +2484,15 @@ 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 + let rec type_unknown_args + (args : + (Asttypes.label * (unit -> Typedtree.expression) option * + Typedtree.optional) list) + omitted ty_fun = function [] -> (List.map - (function None, x -> None, x | Some f, x -> Some (f ()), x) + (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 -> @@ -2387,7 +2502,7 @@ and type_application env funct sargs = Tvar _ -> let t1 = newvar () and t2 = newvar () in let not_identity = function - Texp_ident(_,{val_kind=Val_prim + Texp_ident(_,_,{val_kind=Val_prim {Primitive.prim_name="%identity"}}) -> false | _ -> true @@ -2421,7 +2536,7 @@ and type_application env funct sargs = unify_exp env arg1 (type_option(newvar())); arg1 in - type_unknown_args ((Some arg1, optional) :: args) omitted ty2 sargl + type_unknown_args ((l1, Some arg1, optional) :: args) omitted ty2 sargl in let ignore_labels = !Clflags.classic || @@ -2511,7 +2626,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 @@ -2524,7 +2639,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 = type_expect env sarg ty_arg in @@ -2535,7 +2650,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 @@ -2544,8 +2659,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 -> [] @@ -2554,14 +2669,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, env, 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 @@ -2584,7 +2699,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, env, 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) *) @@ -2620,7 +2736,7 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist = 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, @@ -2630,16 +2746,18 @@ and type_cases ?in_function 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()) +(* Format.printf "@[%i %i@ %a@]@." lev (get_current_level()) Printtyp.raw_type_expr ty_arg; *) let pat_env_list = List.map @@ -2695,7 +2813,7 @@ and type_cases ?in_function 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()) +(* Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level()) Printtyp.raw_type_expr ty_res'; *) let exp = type_expect ?in_function ext_env sexp ty_res' in (pat, {exp with exp_type = instance env ty_res'})) @@ -2721,13 +2839,16 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist = (* Typing of let bindings *) -and type_let ?(check = fun s -> Warnings.Unused_var s) ?(check_strict = fun s -> Warnings.Unused_var_strict s) env rec_flag spat_sexp_list scope allow = +and type_let ?(check = fun s -> Warnings.Unused_var s) + ?(check_strict = fun s -> Warnings.Unused_var_strict s) + env rec_flag spat_sexp_list scope allow = begin_def(); if !Clflags.principal then begin_def (); let is_fake_let = match spat_sexp_list with - | [_, {pexp_desc=Pexp_match({pexp_desc=Pexp_ident(Longident.Lident "*opt*")},_)}] -> + | [_, {pexp_desc=Pexp_match( + {pexp_desc=Pexp_ident({ txt = Longident.Lident "*opt*"})},_)}] -> true (* the fake let-declaration introduced by fun ?(x = e) -> ... *) | _ -> false @@ -2743,9 +2864,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) ?(check_strict = fun 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 @@ -2753,6 +2872,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) ?(check_strict = fun s -> let (pat_list, new_env, force, unpacks) = type_pattern_list env spatl scope nvs allow in let is_recursive = (rec_flag = Recursive) in + (* If recursive, first unify with an approximation of the expression *) if is_recursive then List.iter2 (fun pat (_, sexp) -> @@ -2764,6 +2884,15 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) ?(check_strict = fun s -> | _ -> pat in unify_pat env pat (type_approx env sexp)) pat_list spat_sexp_list; + (* Polymorphic variant processing *) + List.iter + (fun pat -> + if has_variants pat then begin + Parmatch.pressure_variants env [pat]; + iter_pattern finalize_variant pat + end) + pat_list; + (* Generalize the structure *) let pat_list = if !Clflags.principal then begin end_def (); @@ -2773,59 +2902,60 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) ?(check_strict = fun s -> {pat with pat_type = instance env pat.pat_type}) pat_list end else pat_list in - (* Polymoprhic variant processing *) - List.iter - (fun pat -> - if has_variants pat then begin - Parmatch.pressure_variants env [pat]; - iter_pattern finalize_variant pat - end) - pat_list; (* Only bind pattern variables after generalizing *) List.iter (fun f -> f()) force; let exp_env = 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' events on the bound identifiers and record them in a slot corresponding - to the current definition (!current_slot). In effect, this creates a dependency - graph between definitions. + to the current definition (!current_slot). + In effect, this creates a dependency graph between definitions. - - After type checking the definition (!current_slot = Mone), when one of the bound identifier is - effectively used, we trigger again all the events recorded in the corresponding - slot. The effect is to traverse the transitive closure of the graph created + - 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 in the first step. - We also keep track of whether *all* variables in a given pattern are unused. - If this is the case, for local declarations, the issued warning is 26, not 27. + We also keep track of whether *all* variables in a given pattern + are unused. If this is the case, for local declarations, the issued + warning is 26, not 27. *) List.map (fun pat -> if not warn_unused then pat, None else - let some_used = ref false in (* has one of the identifier of this pattern been used? *) + let some_used = ref false in + (* has one of the identifier of this pattern been used? *) let slot = ref [] in List.iter - (fun id -> - let vd = Env.find_value (Path.Pident id) new_env in (* note: Env.find_value does not trigger the value_used event *) + (fun (id,_) -> + let vd = Env.find_value (Path.Pident id) new_env in + (* note: Env.find_value does not trigger the value_used event *) let name = Ident.name id in let used = ref false in if not (name = "" || name.[0] = '_' || name.[0] = '#') then add_delayed_check (fun () -> if not !used then - Location.prerr_warning vd.val_loc + 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) @@ -2861,6 +2991,10 @@ and type_let ?(check = fun s -> Warnings.Unused_var s) ?(check_strict = fun s -> | _ -> type_expect 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; @@ -2904,7 +3038,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 @@ -2932,10 +3066,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 -> @@ -2971,7 +3104,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 -> diff --git a/typing/typecore.mli b/typing/typecore.mli index 2905fb12e1..da9422c076 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -34,7 +34,7 @@ val type_expression: Env.t -> Parsetree.expression -> Typedtree.expression 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 -> @@ -75,7 +75,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 @@ -111,13 +111,15 @@ val report_error: Env.t -> formatter -> error -> unit (* Forward declaration, to be filled in by Typemod.type_module *) val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref (* Forward declaration, to be filled in by Typemod.type_open *) -val type_open: (Env.t -> Location.t -> Longident.t -> 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 4aefed468a..67a13c8d15 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) + None -> Ctype.new_global_var ~name:"_" () + | 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 (env, 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 (env, 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 *) @@ -250,10 +277,10 @@ let generalize_decl decl = () | Type_variant v -> List.iter - (fun (_, tyl, ret_type) -> - List.iter Ctype.generalize tyl; - may Ctype.generalize ret_type) - v + (fun (_, tyl, ret_type) -> + List.iter Ctype.generalize tyl; + may Ctype.generalize ret_type) + v | Type_record(r, rep) -> List.iter (fun (_, _, ty) -> Ctype.generalize ty) r end; @@ -302,20 +329,20 @@ let check_constraints env (_, sdecl) (_, decl) = (fun (name, tyl, ret_type) -> let (styl, sret_type) = try - let (_, sty, sret_type, _) = - List.find (fun (n,_,_,_) -> n = name) pl - in (sty, sret_type) + let (_, sty, sret_type, _) = + List.find (fun (n,_,_,_) -> n.txt = Ident.name name) pl + in (sty, sret_type) with Not_found -> assert false in List.iter2 (fun sty ty -> check_constraints_rec env sty.ptyp_loc visited ty) styl tyl; - match sret_type, ret_type with - | Some sr, Some r -> - check_constraints_rec env sr.ptyp_loc visited r - | _ -> - () ) - l + match sret_type, ret_type with + | Some sr, Some r -> + check_constraints_rec env sr.ptyp_loc visited r + | _ -> + () ) + l | Type_record (l, _) -> let rec find_pl = function Ptype_record pl -> pl @@ -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 (env, 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 (env, 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) @@ -518,7 +553,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)) @@ -599,7 +634,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)) @@ -663,8 +698,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 @@ -687,20 +722,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 @@ -728,15 +764,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 @@ -764,12 +800,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; @@ -791,21 +834,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 *) @@ -816,41 +864,54 @@ 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 excdecl = +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; - types + 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.Positive env (Longident.last lid) cdescr; match cdescr.cstr_tag with - Cstr_exception path -> (path, cdescr.cstr_args) + Cstr_exception (path, _) -> + (path, {exn_args = cdescr.cstr_args; Types.exn_loc = loc}) | _ -> raise(Error(loc, Not_an_exception 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 @@ -860,11 +921,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 @@ -872,26 +938,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; - 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 (env, 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; @@ -910,7 +982,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 *) @@ -935,7 +1016,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 @@ -945,6 +1026,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) @@ -1039,12 +1121,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 521c2ecbd6..c2b62fa239 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -14,28 +14,32 @@ (* 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 -> 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 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 @@ -46,10 +50,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 0feca199a3..fda05b0417 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 and meth = @@ -90,60 +112,98 @@ 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 and module_coercion = @@ -152,15 +212,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 @@ -170,14 +396,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) @@ -192,12 +419,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 @@ -206,27 +434,33 @@ 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) 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 0c5efa8ea8..81242993d9 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 and meth = @@ -89,63 +111,98 @@ 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 and module_coercion = @@ -154,14 +211,190 @@ 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 val pat_bound_idents: pattern -> Ident.t list +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 45decc2121..034d6caf2e 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 * Env.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, env, 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, env, 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, env, With_no_component lid)) - | (Tsig_type(id, decl, rs) :: rem, [s], + raise(Error(loc, env, With_no_component lid.txt)) + | (Sig_type(id, decl, rs) :: rem, [s], Pwith_type ({ptype_kind = Ptype_abstract} as sdecl)) when Ident.name id = s && Typedecl.is_fixed_type sdecl -> let decl_row = @@ -124,87 +136,106 @@ let merge_constraint initial_env loc sg lid constr = List.map (fun (c,n) -> (not n, not c, not c)) sdecl.ptype_variance; type_loc = Location.none; - type_newtype_level = None } + type_newtype_level = None } and id_row = Ident.create (s^"#row") in let initial_env = Env.add_type id_row decl_row initial_env in - let newdecl = Typedecl.transl_with_constraint + 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, initial_env, 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, initial_env, With_mismatch(lid, explanation))) + raise(Error(loc, initial_env, With_mismatch(lid.txt, explanation))) (* Add recursion flags on declarations arising from a mutually recursive block. *) @@ -223,6 +254,12 @@ let rec map_rec' fn decls 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 @@ -232,19 +269,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 @@ -254,28 +292,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 @@ -287,10 +326,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 @@ -298,17 +337,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 @@ -326,23 +366,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 *) @@ -351,28 +391,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 @@ -381,53 +448,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 name desc env - ~check:(fun s -> Warnings.Unused_value_declaration s) 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 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 arg = Typedecl.transl_exception env item.psig_loc sarg in + 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 @@ -435,63 +524,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 (* @@ -500,7 +614,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) @@ -510,7 +624,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 @@ -518,23 +632,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, env, 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, env, Non_generalizable_module md.mod_type)) | _ -> () @@ -549,11 +664,11 @@ 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 (* Helpers for typing recursive modules *) @@ -568,9 +683,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 @@ -610,7 +726,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 @@ -635,8 +751,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 @@ -644,11 +760,12 @@ let check_recmodule_inclusion env bindings = with Includemod.Error msg -> raise(Error(modl.mod_loc, env, 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 @@ -661,50 +778,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, env, 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, env, 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 } @@ -712,15 +837,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) -> @@ -729,7 +854,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 @@ -758,7 +883,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 @@ -792,20 +918,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 @@ -824,136 +954,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) - | {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)} :: srem -> - let arg = Typedecl.transl_exception env sarg in - let (id, newenv) = Env.enter_exception name arg env in + | Pstr_exception(name, sarg) -> + let arg = Typedecl.transl_exception env loc sarg in + let (id, newenv) = Env.enter_exception name.txt arg.exn_exn env in let (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 @@ -962,29 +1101,36 @@ 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) 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. @@ -994,26 +1140,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 @@ -1022,23 +1168,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, env, 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 @@ -1054,7 +1205,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) @@ -1068,15 +1219,16 @@ 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, env, 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 () = @@ -1090,6 +1242,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 @@ -1113,9 +1267,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 @@ -1125,11 +1281,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. *) @@ -1140,7 +1312,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 = @@ -1161,14 +1333,16 @@ 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, Env.empty, 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 *) @@ -1178,7 +1352,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 @@ -1233,11 +1413,13 @@ let report_error ppf = function contains type variables that cannot be generalized@]" modtype mty | Implementation_is_required intf_name -> fprintf ppf - "@[The interface %s@ declares values, not just types.@ \ - An implementation must be provided.@]" intf_name + "@[The interface %a@ declares values, not just types.@ \ + An implementation must be provided.@]" + Location.print_filename intf_name | Interface_not_compiled intf_name -> fprintf ppf - "@[Could not find the .cmi file for interface@ %s.@]" intf_name + "@[Could not find the .cmi file for interface@ %a.@]" + Location.print_filename intf_name | Not_allowed_in_functor_body -> fprintf ppf "This kind of expression is not allowed within the body of a functor." diff --git a/typing/typemod.mli b/typing/typemod.mli index 2324a8e160..6db904d0f3 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 1342bb2938..712ca0a63f 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -121,7 +121,7 @@ type constructor_description = and constructor_tag = Cstr_constant of int (* Constant constructor (an int) *) | Cstr_block of int (* Regular constructor (a block) *) - | Cstr_exception of Path.t (* Exception constructor *) + | Cstr_exception of Path.t * Location.t (* Exception constructor *) (* Record label descriptions *) @@ -155,19 +155,21 @@ 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 = type_expr list +type exception_declaration = + { exn_args: type_expr list; + exn_loc: Location.t } (* Type expressions for the class language *) 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; @@ -183,7 +185,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; @@ -192,24 +194,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 1dc67ac08d..33c1c80127 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -109,7 +109,7 @@ type constructor_description = cstr_args: type_expr list; (* Type of the arguments *) cstr_arity: int; (* Number of arguments *) cstr_tag: constructor_tag; (* Tag for heap blocks *) - cstr_consts: int; (* Number of constant constructors *) + cstr_consts: int; (* Number of constant constructors *) cstr_nonconsts: int; (* Number of non-const constructors *) cstr_normal: int; (* Number of non generalized constrs *) cstr_generalized: bool; (* Constrained return type? *) @@ -118,7 +118,7 @@ type constructor_description = and constructor_tag = Cstr_constant of int (* Constant constructor (an int) *) | Cstr_block of int (* Regular constructor (a block) *) - | Cstr_exception of Path.t (* Exception constructor *) + | Cstr_exception of Path.t * Location.t (* Exception constructor *) (* Record label descriptions *) @@ -153,19 +153,21 @@ 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 = type_expr list +type exception_declaration = + { exn_args: type_expr list; + exn_loc: Location.t } (* Type expressions for the class language *) 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; @@ -180,7 +182,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; @@ -189,24 +191,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 ad837d1d20..7d2f0b50ec 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 = @@ -389,21 +421,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 @@ -415,7 +451,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 @@ -439,9 +475,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 -> @@ -460,13 +497,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; @@ -486,28 +525,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 = @@ -564,7 +612,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 = @@ -581,7 +629,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 -> @@ -592,13 +640,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 = @@ -606,7 +655,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 0c1c80de39..8743b32e45 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 e6337576d9..81573f3f3d 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -34,11 +34,13 @@ and classic = ref false (* -nolabels *) and nopervasives = ref false (* -nopervasives *) and preprocessor = ref(None : string option) (* -pp *) let annotations = ref false (* -annot *) +let binary_annotations = ref false (* -annot *) and use_threads = ref false (* -thread *) and use_vmthreads = ref false (* -vmthread *) and noassert = ref false (* -noassert *) and verbose = ref false (* -verbose *) and noprompt = ref false (* -noprompt *) +and nopromptcont = ref false (* -nopromptcont *) and init_file = ref (None : string option) (* -init *) and use_prims = ref "" (* -use-prims ... *) and use_runtime = ref "" (* -use-runtime ... *) @@ -58,6 +60,7 @@ and error_size = ref 500 (* -error-size *) let dump_parsetree = ref false (* -dparsetree *) and dump_rawlambda = ref false (* -drawlambda *) and dump_lambda = ref false (* -dlambda *) +and dump_clambda = ref false (* -dclambda *) and dump_instr = ref false (* -dinstr *) let keep_asm_file = ref false (* -S *) diff --git a/utils/clflags.mli b/utils/clflags.mli index a33dee5823..40e0014189 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -31,11 +31,13 @@ val classic : bool ref val nopervasives : bool ref val preprocessor : string option ref val annotations : bool ref +val binary_annotations : bool ref val use_threads : bool ref val use_vmthreads : bool ref val noassert : bool ref val verbose : bool ref val noprompt : bool ref +val nopromptcont : bool ref val init_file : string option ref val use_prims : string ref val use_runtime : string ref @@ -55,6 +57,7 @@ val error_size : int ref val dump_parsetree : bool ref val dump_rawlambda : bool ref val dump_lambda : bool ref +val dump_clambda : bool ref val dump_instr : bool ref val keep_asm_file : bool ref val optimize_for_speed : bool ref diff --git a/utils/config.mlbuild b/utils/config.mlbuild index 367c204e7b..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) @@ -89,6 +90,7 @@ let model = C.model let system = C.system let asm = C.asm +let asm_cfi_supported = C.asm_cfi_supported let ext_obj = C.ext_obj let ext_asm = C.ext_asm @@ -122,6 +124,7 @@ let print_config oc = p "model" model; p "system" system; p "asm" asm; + p_bool "asm_cfi_supported" asm_cfi_supported; p "ext_obj" ext_obj; p "ext_asm" ext_asm; p "ext_lib" ext_lib; diff --git a/utils/config.mli b/utils/config.mli index 78fe77c6af..a201dd43df 100644 --- a/utils/config.mli +++ b/utils/config.mli @@ -75,6 +75,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. *) @@ -99,6 +101,9 @@ val asm: string (* The assembler (and flags) to use for assembling ocamlopt-generated code. *) +val asm_cfi_supported: bool + (* Whether assembler understands CFI directives *) + val ext_obj: string (* Extension for object files, e.g. [.o] under Unix. *) val ext_asm: string diff --git a/utils/config.mlp b/utils/config.mlp index 35e56e7513..f59243e95f 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -51,14 +51,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) @@ -78,6 +79,7 @@ let model = "%%MODEL%%" let system = "%%SYSTEM%%" let asm = "%%ASM%%" +let asm_cfi_supported = %%ASM_CFI_SUPPORTED%% let ext_obj = "%%EXT_OBJ%%" let ext_asm = "%%EXT_ASM%%" @@ -111,6 +113,7 @@ let print_config oc = p "model" model; p "system" system; p "asm" asm; + p_bool "asm_cfi_supported" asm_cfi_supported; p "ext_obj" ext_obj; p "ext_asm" ext_asm; p "ext_lib" ext_lib; diff --git a/utils/misc.ml b/utils/misc.ml index c75ac31308..f2891ee258 100644 --- a/utils/misc.ml +++ b/utils/misc.ml @@ -21,12 +21,10 @@ let fatal_error msg = (* Exceptions *) -let try_finally f1 f2 = - try - let result = f1 () in - f2 (); - result - with x -> f2 (); raise x +let try_finally work cleanup = + let result = (try work () with e -> cleanup (); raise e) in + cleanup (); + result ;; (* List functions *) @@ -143,6 +141,25 @@ 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 = + let result = String.create n in + really_input ic result 0 n; + result +;; + (* Integer operations *) let rec log2 n = @@ -199,3 +216,11 @@ 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 f1b869086b..b982a9444f 100644 --- a/utils/misc.mli +++ b/utils/misc.mli @@ -65,6 +65,13 @@ 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 + before all the bytes are read. *) val log2: int -> int (* [log2 n] returns [s] such that [n = 1 lsl s] @@ -106,3 +113,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 a7babcc40f..02621ea67f 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -56,7 +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_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 @@ -103,9 +105,11 @@ let number = function | Unused_for_index _ -> 35 | Unused_ancestor _ -> 36 | Unused_constructor _ -> 37 + | Unused_exception _ -> 38 + | Unused_rec_flag -> 39 ;; -let last_warning_number = 37;; +let last_warning_number = 39 (* Must be the max number returned by the [number] function. *) let letter = function @@ -121,7 +125,7 @@ let letter = function | 'h' -> [] | 'i' -> [] | 'j' -> [] - | 'k' -> [32; 33; 34; 35; 36; 37] + | 'k' -> [32; 33; 34; 35; 36; 37; 38; 39] | 'l' -> [6] | 'm' -> [7] | 'n' -> [] @@ -200,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-33-34-35-36-37";; +let defaults_w = "+a-4-6-7-9-27-29-32..39";; let defaults_warn_error = "-a";; let () = parse_options false defaults_w;; @@ -233,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." @@ -260,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 -> @@ -283,7 +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_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;; @@ -328,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."; @@ -346,11 +366,13 @@ let descriptions = 21, "Non-returning statement."; 22, "Camlp4 warning."; 23, "Useless record \"with\" clause."; - 24, "Bad module name: the source file name is not a valid OCaml module name."; + 24, "Bad module name: the source file name is not a valid OCaml module \ + name."; 25, "Pattern-matching with all clauses guarded. Exhaustiveness cannot be\n\ - \ checked"; - 26, "Suspicious unused variable: unused variable that is bound with \"let\"\n\ - \ or \"as\", and doesn't start with an underscore (\"_\") character."; + \ checked."; + 26, "Suspicious unused variable: unused variable that is bound\n\ + \ with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\ + \ character."; 27, "Innocuous unused variable: unused variable that is not bound with\n\ \ \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\ \ character."; @@ -365,6 +387,8 @@ let descriptions = 35, "Unused for-loop index."; 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 99c153ffd6..fbffb33dfc 100644 --- a/utils/warnings.mli +++ b/utils/warnings.mli @@ -51,7 +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_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/win32caml/libgraph.h b/win32caml/libgraph.h index 1df232988c..1202f178bc 100644 --- a/win32caml/libgraph.h +++ b/win32caml/libgraph.h @@ -50,8 +50,8 @@ extern int bits_per_pixel; #define DEFAULT_SCREEN_WIDTH 1024 #define DEFAULT_SCREEN_HEIGHT 768 #define BORDER_WIDTH 2 -#define WINDOW_NAME "Caml graphics" -#define ICON_NAME "Caml graphics" +#define WINDOW_NAME "OCaml graphics" +#define ICON_NAME "OCaml graphics" #define DEFAULT_EVENT_MASK \ (ExposureMask | KeyPressMask | StructureNotifyMask) #define DEFAULT_FONT "fixed" diff --git a/win32caml/ocaml.c b/win32caml/ocaml.c index 04899473f7..59ebd035bc 100644 --- a/win32caml/ocaml.c +++ b/win32caml/ocaml.c @@ -1564,7 +1564,7 @@ int WINAPI WinMain(HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLine if (!Setup(&hAccelTable)) return 0; // Need to set up a console so that we can send ctrl-break signal - // to inferior Caml + // to inferior OCaml AllocConsole(); GetConsoleTitle(consoleTitle,sizeof(consoleTitle)); hwndConsole = FindWindow(NULL,consoleTitle); diff --git a/win32caml/startocaml.c b/win32caml/startocaml.c index d457dd41b0..1b4218bb36 100644 --- a/win32caml/startocaml.c +++ b/win32caml/startocaml.c @@ -56,7 +56,7 @@ int AskYesOrNo(char *msg) int r; hwnd = hwndMain; - r = MessageBox(hwnd, msg, "Ocaml", MB_YESNO | MB_SETFOREGROUND); + r = MessageBox(hwnd, msg, "OCaml", MB_YESNO | MB_SETFOREGROUND); if (r == IDYES) return (TRUE); return (FALSE); @@ -151,7 +151,7 @@ int GetOcamlPath(void) || _access(path, 0) != 0) { /* Registry key doesn't exist or contains invalid path */ /* Ask user */ - if (!BrowseForFile("Ocaml interpreter|ocaml.exe", path)) { + if (!BrowseForFile("OCaml interpreter|ocaml.exe", path)) { ShowDbgMsg("Impossible to find ocaml.exe. I quit"); exit(0); } @@ -340,7 +340,7 @@ void *SafeMalloc(int size) error: sprintf(message,"Can't allocate %d bytes",size); - MessageBox(NULL, message, "Ocaml", MB_OK); + MessageBox(NULL, message, "OCaml", MB_OK); exit(-1); } result = malloc(size); @@ -357,7 +357,7 @@ void InterruptOcaml(void) if (!GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pi.dwProcessId)) { char message[1024]; sprintf(message, "GenerateConsole failed: %lu\n", GetLastError()); - MessageBox(NULL, message, "Ocaml", MB_OK); + MessageBox(NULL, message, "OCaml", MB_OK); } WriteToPipe(" "); } 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 diff --git a/yacc/main.c b/yacc/main.c index 8616b9b3da..282dc0b232 100644 --- a/yacc/main.c +++ b/yacc/main.c @@ -331,7 +331,7 @@ void create_file_names(void) if (action_fd == -1) open_error(action_file_name); entry_fd = mkstemp(entry_file_name); - if (entry_fd == -1) + if (entry_fd == -1) open_error(entry_file_name); text_fd = mkstemp(text_file_name); if (text_fd == -1) diff --git a/yacc/skeleton.c b/yacc/skeleton.c index 8048999d7d..ffc47a3f00 100644 --- a/yacc/skeleton.c +++ b/yacc/skeleton.c @@ -19,6 +19,7 @@ char *header[] = { "open Parsing;;", + "let _ = parse_error;;", /* avoid warning 33 (PR#5719) */ 0 }; |