From 1f8b6b4ffe0a39426821a377f7b018fcfa5bdc9f Mon Sep 17 00:00:00 2001 From: Packit Date: Sep 16 2020 08:18:02 +0000 Subject: ocaml-camlp4-4.07.0 base --- diff --git a/.depend b/.depend new file mode 100644 index 0000000..ab2130d --- /dev/null +++ b/.depend @@ -0,0 +1,1023 @@ +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.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/ast_helper.cmi : parsing/parsetree.cmi parsing/longident.cmi \ + parsing/location.cmi parsing/asttypes.cmi +parsing/ast_mapper.cmi : parsing/parsetree.cmi parsing/location.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/location.cmi +parsing/parsetree.cmi : parsing/longident.cmi parsing/location.cmi \ + parsing/asttypes.cmi +parsing/pprintast.cmi : parsing/parsetree.cmi parsing/longident.cmi \ + parsing/asttypes.cmi +parsing/printast.cmi : parsing/parsetree.cmi +parsing/syntaxerr.cmi : parsing/location.cmi +parsing/ast_helper.cmo : parsing/parsetree.cmi parsing/longident.cmi \ + parsing/location.cmi parsing/asttypes.cmi parsing/ast_helper.cmi +parsing/ast_helper.cmx : parsing/parsetree.cmi parsing/longident.cmx \ + parsing/location.cmx parsing/asttypes.cmi parsing/ast_helper.cmi +parsing/ast_mapper.cmo : parsing/parsetree.cmi parsing/location.cmi \ + utils/config.cmi parsing/ast_helper.cmi parsing/ast_mapper.cmi +parsing/ast_mapper.cmx : parsing/parsetree.cmi parsing/location.cmx \ + utils/config.cmx parsing/ast_helper.cmx parsing/ast_mapper.cmi +parsing/lexer.cmo : utils/warnings.cmi parsing/parser.cmi utils/misc.cmi \ + parsing/location.cmi parsing/lexer.cmi +parsing/lexer.cmx : utils/warnings.cmx parsing/parser.cmx utils/misc.cmx \ + 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.cmi +parsing/location.cmx : utils/warnings.cmx utils/terminfo.cmx \ + parsing/location.cmi +parsing/longident.cmo : utils/misc.cmi parsing/longident.cmi +parsing/longident.cmx : utils/misc.cmx parsing/longident.cmi +parsing/parse.cmo : parsing/syntaxerr.cmi parsing/parser.cmi \ + parsing/location.cmi parsing/lexer.cmi parsing/parse.cmi +parsing/parse.cmx : parsing/syntaxerr.cmx parsing/parser.cmx \ + parsing/location.cmx parsing/lexer.cmx parsing/parse.cmi +parsing/parser.cmo : parsing/syntaxerr.cmi parsing/parsetree.cmi \ + parsing/longident.cmi parsing/location.cmi utils/clflags.cmi \ + parsing/asttypes.cmi parsing/ast_helper.cmi parsing/parser.cmi +parsing/parser.cmx : parsing/syntaxerr.cmx parsing/parsetree.cmi \ + parsing/longident.cmx parsing/location.cmx utils/clflags.cmx \ + parsing/asttypes.cmi parsing/ast_helper.cmx parsing/parser.cmi +parsing/pprintast.cmo : parsing/parsetree.cmi parsing/longident.cmi \ + parsing/location.cmi parsing/asttypes.cmi parsing/pprintast.cmi +parsing/pprintast.cmx : parsing/parsetree.cmi parsing/longident.cmx \ + parsing/location.cmx parsing/asttypes.cmi parsing/pprintast.cmi +parsing/printast.cmo : parsing/parsetree.cmi parsing/longident.cmi \ + parsing/location.cmi parsing/asttypes.cmi parsing/printast.cmi +parsing/printast.cmx : parsing/parsetree.cmi parsing/longident.cmx \ + 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/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 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 parsing/asttypes.cmi +typing/envaux.cmi : typing/subst.cmi typing/path.cmi typing/env.cmi +typing/ident.cmi : +typing/includeclass.cmi : typing/types.cmi typing/env.cmi typing/ctype.cmi +typing/includecore.cmi : typing/types.cmi typing/typedtree.cmi \ + 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/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/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/env.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 \ + 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/typedtree.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/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi typing/env.cmi parsing/asttypes.cmi +typing/typedtreeIter.cmi : typing/typedtree.cmi parsing/asttypes.cmi +typing/typedtreeMap.cmi : typing/typedtree.cmi +typing/typemod.cmi : typing/types.cmi typing/typedtree.cmi \ + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/includemod.cmi typing/ident.cmi typing/env.cmi +typing/types.cmi : typing/primitive.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi parsing/asttypes.cmi +typing/typetexp.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/ident.cmi typing/btype.cmi +typing/btype.cmx : typing/types.cmx typing/path.cmx utils/misc.cmx \ + typing/ident.cmx typing/btype.cmi +typing/cmi_format.cmo : typing/types.cmi utils/misc.cmi parsing/location.cmi \ + utils/config.cmi typing/cmi_format.cmi +typing/cmi_format.cmx : typing/types.cmx utils/misc.cmx parsing/location.cmx \ + utils/config.cmx typing/cmi_format.cmi +typing/cmt_format.cmo : typing/types.cmi typing/typedtreeMap.cmi \ + typing/typedtree.cmi utils/misc.cmi parsing/location.cmi \ + parsing/lexer.cmi typing/env.cmi utils/config.cmi typing/cmi_format.cmi \ + utils/clflags.cmi typing/cmt_format.cmi +typing/cmt_format.cmx : typing/types.cmx typing/typedtreeMap.cmx \ + typing/typedtree.cmx utils/misc.cmx parsing/location.cmx \ + parsing/lexer.cmx typing/env.cmx utils/config.cmx typing/cmi_format.cmx \ + utils/clflags.cmx typing/cmt_format.cmi +typing/ctype.cmo : typing/types.cmi typing/subst.cmi typing/path.cmi \ + utils/misc.cmi parsing/longident.cmi parsing/location.cmi \ + typing/ident.cmi typing/env.cmi utils/clflags.cmi typing/btype.cmi \ + parsing/asttypes.cmi typing/ctype.cmi +typing/ctype.cmx : typing/types.cmx typing/subst.cmx typing/path.cmx \ + utils/misc.cmx parsing/longident.cmx parsing/location.cmx \ + typing/ident.cmx typing/env.cmx utils/clflags.cmx typing/btype.cmx \ + parsing/asttypes.cmi typing/ctype.cmi +typing/datarepr.cmo : typing/types.cmi typing/predef.cmi typing/path.cmi \ + parsing/location.cmi typing/ident.cmi typing/btype.cmi \ + parsing/asttypes.cmi typing/datarepr.cmi +typing/datarepr.cmx : typing/types.cmx typing/predef.cmx typing/path.cmx \ + parsing/location.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 \ + typing/cmi_format.cmi utils/clflags.cmi typing/btype.cmi \ + parsing/asttypes.cmi typing/env.cmi +typing/env.cmx : utils/warnings.cmx typing/types.cmx utils/tbl.cmx \ + typing/subst.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \ + parsing/longident.cmx parsing/location.cmx typing/ident.cmx \ + typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \ + typing/cmi_format.cmx utils/clflags.cmx typing/btype.cmx \ + parsing/asttypes.cmi typing/env.cmi +typing/envaux.cmo : typing/types.cmi typing/subst.cmi typing/printtyp.cmi \ + typing/path.cmi typing/mtype.cmi utils/misc.cmi typing/env.cmi \ + parsing/asttypes.cmi typing/envaux.cmi +typing/envaux.cmx : typing/types.cmx typing/subst.cmx typing/printtyp.cmx \ + typing/path.cmx typing/mtype.cmx utils/misc.cmx typing/env.cmx \ + parsing/asttypes.cmi typing/envaux.cmi +typing/ident.cmo : typing/ident.cmi +typing/ident.cmx : typing/ident.cmi +typing/includeclass.cmo : typing/types.cmi typing/printtyp.cmi \ + typing/ctype.cmi typing/includeclass.cmi +typing/includeclass.cmx : typing/types.cmx typing/printtyp.cmx \ + typing/ctype.cmx typing/includeclass.cmi +typing/includecore.cmo : typing/types.cmi typing/typedtree.cmi \ + typing/predef.cmi typing/path.cmi utils/misc.cmi typing/ident.cmi \ + typing/env.cmi typing/ctype.cmi typing/btype.cmi parsing/asttypes.cmi \ + typing/includecore.cmi +typing/includecore.cmx : typing/types.cmx typing/typedtree.cmx \ + typing/predef.cmx typing/path.cmx utils/misc.cmx typing/ident.cmx \ + typing/env.cmx typing/ctype.cmx typing/btype.cmx parsing/asttypes.cmi \ + typing/includecore.cmi +typing/includemod.cmo : typing/types.cmi typing/typedtree.cmi utils/tbl.cmi \ + typing/subst.cmi typing/printtyp.cmi typing/path.cmi typing/mtype.cmi \ + utils/misc.cmi parsing/location.cmi typing/includecore.cmi \ + typing/includeclass.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ + utils/clflags.cmi typing/includemod.cmi +typing/includemod.cmx : typing/types.cmx typing/typedtree.cmx utils/tbl.cmx \ + typing/subst.cmx typing/printtyp.cmx typing/path.cmx typing/mtype.cmx \ + utils/misc.cmx parsing/location.cmx typing/includecore.cmx \ + typing/includeclass.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ + utils/clflags.cmx typing/includemod.cmi +typing/mtype.cmo : typing/types.cmi typing/subst.cmi typing/path.cmi \ + typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \ + typing/btype.cmi parsing/asttypes.cmi typing/mtype.cmi +typing/mtype.cmx : typing/types.cmx typing/subst.cmx typing/path.cmx \ + typing/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.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 \ + parsing/ast_helper.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 \ + parsing/ast_helper.cmx 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/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 \ + parsing/location.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + typing/printtyp.cmi +typing/printtyp.cmx : typing/types.cmx typing/primitive.cmx \ + typing/predef.cmx typing/path.cmx typing/outcometree.cmi \ + typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + typing/printtyp.cmi +typing/printtyped.cmo : typing/typedtree.cmi parsing/printast.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 parsing/printast.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 \ + parsing/location.cmx utils/clflags.cmx typing/annot.cmi typing/stypes.cmi +typing/subst.cmo : typing/types.cmi utils/tbl.cmi typing/path.cmi \ + utils/misc.cmi parsing/location.cmi typing/ident.cmi utils/clflags.cmi \ + typing/btype.cmi parsing/ast_mapper.cmi typing/subst.cmi +typing/subst.cmx : typing/types.cmx utils/tbl.cmx typing/path.cmx \ + utils/misc.cmx parsing/location.cmx typing/ident.cmx utils/clflags.cmx \ + typing/btype.cmx parsing/ast_mapper.cmx typing/subst.cmi +typing/typeclass.cmo : utils/warnings.cmi typing/typetexp.cmi \ + typing/types.cmi typing/typedtree.cmi typing/typedecl.cmi \ + typing/typecore.cmi typing/subst.cmi typing/stypes.cmi \ + typing/printtyp.cmi typing/predef.cmi typing/path.cmi \ + parsing/parsetree.cmi typing/parmatch.cmi utils/misc.cmi \ + parsing/longident.cmi parsing/location.cmi typing/includeclass.cmi \ + typing/ident.cmi typing/env.cmi typing/ctype.cmi typing/cmt_format.cmi \ + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + parsing/ast_helper.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 typing/cmt_format.cmx \ + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + parsing/ast_helper.cmx 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 \ + typing/cmt_format.cmi utils/clflags.cmi typing/btype.cmi \ + parsing/asttypes.cmi parsing/ast_helper.cmi typing/annot.cmi \ + typing/typecore.cmi +typing/typecore.cmx : utils/warnings.cmx typing/typetexp.cmx \ + typing/types.cmx typing/typedtree.cmx typing/subst.cmx typing/stypes.cmx \ + typing/printtyp.cmx typing/primitive.cmx typing/predef.cmx \ + typing/path.cmx parsing/parsetree.cmi typing/parmatch.cmx \ + typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ + typing/cmt_format.cmx utils/clflags.cmx typing/btype.cmx \ + parsing/asttypes.cmi parsing/ast_helper.cmx 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 \ + parsing/ast_helper.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 \ + parsing/ast_helper.cmx typing/typedecl.cmi +typing/typedtree.cmo : typing/types.cmi typing/primitive.cmi typing/path.cmi \ + parsing/parsetree.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 \ + parsing/parsetree.cmi utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx typing/ident.cmx typing/env.cmx parsing/asttypes.cmi \ + typing/typedtree.cmi +typing/typedtreeIter.cmo : typing/typedtree.cmi parsing/asttypes.cmi \ + typing/typedtreeIter.cmi +typing/typedtreeIter.cmx : typing/typedtree.cmx parsing/asttypes.cmi \ + typing/typedtreeIter.cmi +typing/typedtreeMap.cmo : typing/typedtree.cmi utils/misc.cmi \ + typing/typedtreeMap.cmi +typing/typedtreeMap.cmx : typing/typedtree.cmx utils/misc.cmx \ + typing/typedtreeMap.cmi +typing/typemod.cmo : utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \ + typing/typedtree.cmi typing/typedecl.cmi typing/typecore.cmi \ + typing/typeclass.cmi typing/subst.cmi typing/stypes.cmi \ + 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 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 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 \ + parsing/parsetree.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 \ + parsing/parsetree.cmi parsing/longident.cmx parsing/location.cmx \ + typing/ident.cmx parsing/asttypes.cmi typing/types.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 parsing/ast_helper.cmi \ + typing/typetexp.cmi +typing/typetexp.cmx : utils/warnings.cmx typing/types.cmx \ + typing/typedtree.cmx utils/tbl.cmx typing/printtyp.cmx typing/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 parsing/ast_helper.cmx \ + 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/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 : utils/misc.cmi typing/ident.cmi \ + bytecomp/cmo_format.cmi +bytecomp/translclass.cmi : typing/typedtree.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi +bytecomp/translcore.cmi : typing/typedtree.cmi typing/primitive.cmi \ + typing/path.cmi parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \ + parsing/asttypes.cmi +bytecomp/translmod.cmi : typing/typedtree.cmi typing/primitive.cmi \ + parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi +bytecomp/translobj.cmi : bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi +bytecomp/typeopt.cmi : typing/typedtree.cmi typing/path.cmi \ + bytecomp/lambda.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 \ + 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 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 typing/ident.cmi \ + bytecomp/dll.cmi utils/consistbl.cmi utils/config.cmi \ + bytecomp/cmo_format.cmi utils/clflags.cmi utils/ccomp.cmi \ + bytecomp/bytesections.cmi bytecomp/bytelink.cmi +bytecomp/bytelink.cmx : utils/warnings.cmx bytecomp/symtable.cmx \ + bytecomp/opcodes.cmx utils/misc.cmx parsing/location.cmx typing/ident.cmx \ + bytecomp/dll.cmx utils/consistbl.cmx utils/config.cmx \ + bytecomp/cmo_format.cmi utils/clflags.cmx utils/ccomp.cmx \ + bytecomp/bytesections.cmx bytecomp/bytelink.cmi +bytecomp/bytepackager.cmo : typing/typemod.cmi bytecomp/translmod.cmi \ + typing/subst.cmi typing/path.cmi utils/misc.cmi parsing/location.cmi \ + bytecomp/instruct.cmi typing/ident.cmi typing/env.cmi \ + 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/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 \ + 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 \ + 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 \ + 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 \ + 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/lambda.cmi bytecomp/instruct.cmi typing/ident.cmi \ + bytecomp/printinstr.cmi +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 \ + parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \ + parsing/asttypes.cmi bytecomp/printlambda.cmi +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 \ + 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 \ + 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 \ + typing/predef.cmi utils/misc.cmi bytecomp/meta.cmi parsing/location.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 \ + typing/predef.cmx utils/misc.cmx bytecomp/meta.cmx parsing/location.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 \ + typing/typedtree.cmi bytecomp/translobj.cmi bytecomp/translcore.cmi \ + typing/path.cmi bytecomp/matching.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi utils/clflags.cmi \ + typing/btype.cmi parsing/asttypes.cmi bytecomp/translclass.cmi +bytecomp/translclass.cmx : typing/types.cmx bytecomp/typeopt.cmx \ + typing/typedtree.cmx bytecomp/translobj.cmx bytecomp/translcore.cmx \ + typing/path.cmx bytecomp/matching.cmx parsing/location.cmx \ + bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/clflags.cmx \ + typing/btype.cmx parsing/asttypes.cmi bytecomp/translclass.cmi +bytecomp/translcore.cmo : utils/warnings.cmi typing/types.cmi \ + bytecomp/typeopt.cmi typing/typedtree.cmi bytecomp/translobj.cmi \ + typing/primitive.cmi typing/predef.cmi typing/path.cmi \ + typing/parmatch.cmi utils/misc.cmi bytecomp/matching.cmi \ + parsing/longident.cmi parsing/location.cmi bytecomp/lambda.cmi \ + typing/ident.cmi typing/env.cmi utils/config.cmi utils/clflags.cmi \ + typing/btype.cmi parsing/asttypes.cmi bytecomp/translcore.cmi +bytecomp/translcore.cmx : utils/warnings.cmx typing/types.cmx \ + bytecomp/typeopt.cmx typing/typedtree.cmx bytecomp/translobj.cmx \ + typing/primitive.cmx typing/predef.cmx typing/path.cmx \ + typing/parmatch.cmx utils/misc.cmx bytecomp/matching.cmx \ + parsing/longident.cmx parsing/location.cmx bytecomp/lambda.cmx \ + typing/ident.cmx typing/env.cmx utils/config.cmx utils/clflags.cmx \ + typing/btype.cmx parsing/asttypes.cmi bytecomp/translcore.cmi +bytecomp/translmod.cmo : typing/types.cmi typing/typedtree.cmi \ + bytecomp/translobj.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \ + typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \ + 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/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 \ + 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 \ + 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 \ + typing/predef.cmi typing/path.cmi bytecomp/lambda.cmi typing/ident.cmi \ + typing/env.cmi typing/ctype.cmi bytecomp/typeopt.cmi +bytecomp/typeopt.cmx : typing/types.cmx typing/typedtree.cmx \ + typing/predef.cmx typing/path.cmx bytecomp/lambda.cmx typing/ident.cmx \ + typing/env.cmx typing/ctype.cmx bytecomp/typeopt.cmi +asmcomp/asmgen.cmi : bytecomp/lambda.cmi asmcomp/cmm.cmi +asmcomp/asmlibrarian.cmi : +asmcomp/asmlink.cmi : asmcomp/cmx_format.cmi +asmcomp/asmpackager.cmi : +asmcomp/clambda.cmi : bytecomp/lambda.cmi typing/ident.cmi \ + asmcomp/debuginfo.cmi parsing/asttypes.cmi +asmcomp/closure.cmi : bytecomp/lambda.cmi asmcomp/clambda.cmi +asmcomp/cmm.cmi : typing/ident.cmi asmcomp/debuginfo.cmi +asmcomp/cmmgen.cmi : asmcomp/cmx_format.cmi asmcomp/cmm.cmi \ + asmcomp/clambda.cmi +asmcomp/cmx_format.cmi : asmcomp/clambda.cmi +asmcomp/codegen.cmi : asmcomp/cmm.cmi +asmcomp/coloring.cmi : +asmcomp/comballoc.cmi : asmcomp/mach.cmi +asmcomp/compilenv.cmi : bytecomp/lambda.cmi typing/ident.cmi \ + asmcomp/cmx_format.cmi asmcomp/clambda.cmi +asmcomp/debuginfo.cmi : parsing/location.cmi bytecomp/lambda.cmi +asmcomp/emit.cmi : asmcomp/linearize.cmi asmcomp/cmm.cmi +asmcomp/emitaux.cmi : asmcomp/debuginfo.cmi +asmcomp/interf.cmi : asmcomp/mach.cmi +asmcomp/linearize.cmi : asmcomp/reg.cmi asmcomp/mach.cmi \ + asmcomp/debuginfo.cmi +asmcomp/liveness.cmi : asmcomp/mach.cmi +asmcomp/mach.cmi : asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ + asmcomp/arch.cmo +asmcomp/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/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 asmcomp/printclambda.cmi \ + typing/primitive.cmi utils/misc.cmi asmcomp/mach.cmi parsing/location.cmi \ + asmcomp/liveness.cmi asmcomp/linearize.cmi asmcomp/interf.cmi \ + asmcomp/emitaux.cmi asmcomp/emit.cmi utils/config.cmi \ + asmcomp/compilenv.cmi asmcomp/comballoc.cmi asmcomp/coloring.cmi \ + asmcomp/cmmgen.cmi asmcomp/cmm.cmi asmcomp/closure.cmi utils/clflags.cmi \ + asmcomp/asmgen.cmi +asmcomp/asmgen.cmx : bytecomp/translmod.cmx asmcomp/split.cmx \ + asmcomp/spill.cmx asmcomp/selection.cmx asmcomp/scheduling.cmx \ + asmcomp/reload.cmx asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \ + asmcomp/printlinear.cmx asmcomp/printcmm.cmx asmcomp/printclambda.cmx \ + typing/primitive.cmx utils/misc.cmx asmcomp/mach.cmx parsing/location.cmx \ + asmcomp/liveness.cmx asmcomp/linearize.cmx asmcomp/interf.cmx \ + asmcomp/emitaux.cmx asmcomp/emit.cmx utils/config.cmx \ + asmcomp/compilenv.cmx asmcomp/comballoc.cmx asmcomp/coloring.cmx \ + asmcomp/cmmgen.cmx asmcomp/cmm.cmx asmcomp/closure.cmx utils/clflags.cmx \ + asmcomp/asmgen.cmi +asmcomp/asmlibrarian.cmo : utils/misc.cmi parsing/location.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 parsing/location.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 \ + 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 \ + 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 \ + utils/misc.cmi parsing/location.cmi typing/ident.cmi typing/env.cmi \ + utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmx_format.cmi \ + utils/clflags.cmi utils/ccomp.cmi asmcomp/asmlink.cmi asmcomp/asmgen.cmi \ + asmcomp/asmpackager.cmi +asmcomp/asmpackager.cmx : typing/typemod.cmx bytecomp/translmod.cmx \ + utils/misc.cmx parsing/location.cmx typing/ident.cmx typing/env.cmx \ + utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmx_format.cmi \ + utils/clflags.cmx utils/ccomp.cmx asmcomp/asmlink.cmx asmcomp/asmgen.cmx \ + asmcomp/asmpackager.cmi +asmcomp/clambda.cmo : bytecomp/lambda.cmi typing/ident.cmi \ + asmcomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/clambda.cmi +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 \ + 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/arch.cmo asmcomp/closure.cmi +asmcomp/closure.cmx : utils/tbl.cmx bytecomp/switch.cmx typing/primitive.cmx \ + utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx asmcomp/debuginfo.cmx \ + asmcomp/compilenv.cmx utils/clflags.cmx asmcomp/clambda.cmx \ + parsing/asttypes.cmi asmcomp/arch.cmx asmcomp/closure.cmi +asmcomp/cmm.cmo : typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/arch.cmo \ + asmcomp/cmm.cmi +asmcomp/cmm.cmx : typing/ident.cmx asmcomp/debuginfo.cmx asmcomp/arch.cmx \ + asmcomp/cmm.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 \ + 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/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/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/arch.cmo asmcomp/comballoc.cmi +asmcomp/comballoc.cmx : asmcomp/reg.cmx asmcomp/mach.cmx utils/config.cmx \ + asmcomp/arch.cmx asmcomp/comballoc.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.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/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/linearize.cmi asmcomp/debuginfo.cmi \ + utils/config.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/emitaux.cmi +asmcomp/emitaux.cmx : asmcomp/linearize.cmx asmcomp/debuginfo.cmx \ + utils/config.cmx utils/clflags.cmx asmcomp/arch.cmx asmcomp/emitaux.cmi +asmcomp/interf.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \ + asmcomp/interf.cmi +asmcomp/interf.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ + asmcomp/interf.cmi +asmcomp/linearize.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ + asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ + asmcomp/linearize.cmi +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/arch.cmo asmcomp/mach.cmi +asmcomp/mach.cmx : asmcomp/reg.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \ + asmcomp/arch.cmx asmcomp/mach.cmi +asmcomp/printclambda.cmo : bytecomp/printlambda.cmi bytecomp/lambda.cmi \ + typing/ident.cmi asmcomp/clambda.cmi parsing/asttypes.cmi \ + asmcomp/printclambda.cmi +asmcomp/printclambda.cmx : bytecomp/printlambda.cmx bytecomp/lambda.cmx \ + typing/ident.cmx asmcomp/clambda.cmx parsing/asttypes.cmi \ + asmcomp/printclambda.cmi +asmcomp/printcmm.cmo : typing/ident.cmi asmcomp/debuginfo.cmi \ + asmcomp/cmm.cmi asmcomp/printcmm.cmi +asmcomp/printcmm.cmx : typing/ident.cmx asmcomp/debuginfo.cmx \ + 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/linearize.cmx asmcomp/debuginfo.cmx asmcomp/printlinear.cmi +asmcomp/printmach.cmo : asmcomp/reg.cmi asmcomp/proc.cmi \ + asmcomp/printcmm.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi \ + asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/printmach.cmi +asmcomp/printmach.cmx : asmcomp/reg.cmx asmcomp/proc.cmx \ + asmcomp/printcmm.cmx asmcomp/mach.cmx asmcomp/debuginfo.cmx \ + asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/printmach.cmi +asmcomp/proc.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ + utils/config.cmi asmcomp/cmm.cmi utils/clflags.cmi utils/ccomp.cmi \ + asmcomp/arch.cmo asmcomp/proc.cmi +asmcomp/proc.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ + utils/config.cmx asmcomp/cmm.cmx utils/clflags.cmx utils/ccomp.cmx \ + asmcomp/arch.cmx asmcomp/proc.cmi +asmcomp/reg.cmo : asmcomp/cmm.cmi asmcomp/reg.cmi +asmcomp/reg.cmx : asmcomp/cmm.cmx asmcomp/reg.cmi +asmcomp/reload.cmo : asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ + asmcomp/cmm.cmi utils/clflags.cmi asmcomp/arch.cmo asmcomp/reload.cmi +asmcomp/reload.cmx : asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \ + asmcomp/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.cmi +asmcomp/reloadgen.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ + asmcomp/reloadgen.cmi +asmcomp/schedgen.cmo : asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/mach.cmi \ + asmcomp/linearize.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ + asmcomp/schedgen.cmi +asmcomp/schedgen.cmx : asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/mach.cmx \ + asmcomp/linearize.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ + asmcomp/schedgen.cmi +asmcomp/scheduling.cmo : asmcomp/schedgen.cmi asmcomp/scheduling.cmi +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/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/proc.cmi \ + utils/misc.cmi asmcomp/mach.cmi asmcomp/cmm.cmi utils/clflags.cmi \ + asmcomp/arch.cmo asmcomp/selection.cmi +asmcomp/selection.cmx : asmcomp/selectgen.cmx asmcomp/proc.cmx \ + utils/misc.cmx asmcomp/mach.cmx asmcomp/cmm.cmx utils/clflags.cmx \ + asmcomp/arch.cmx asmcomp/selection.cmi +asmcomp/spill.cmo : asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ + asmcomp/mach.cmi asmcomp/spill.cmi +asmcomp/spill.cmx : asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ + asmcomp/mach.cmx asmcomp/spill.cmi +asmcomp/split.cmo : asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ + asmcomp/split.cmi +asmcomp/split.cmx : asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ + asmcomp/split.cmi +driver/compenv.cmi : +driver/compile.cmi : +driver/compmisc.cmi : typing/env.cmi +driver/errors.cmi : +driver/main.cmi : +driver/main_args.cmi : +driver/optcompile.cmi : +driver/opterrors.cmi : +driver/optmain.cmi : +driver/pparse.cmi : parsing/parsetree.cmi +driver/compenv.cmo : utils/warnings.cmi utils/misc.cmi parsing/location.cmi \ + utils/config.cmi utils/clflags.cmi driver/compenv.cmi +driver/compenv.cmx : utils/warnings.cmx utils/misc.cmx parsing/location.cmx \ + utils/config.cmx utils/clflags.cmx driver/compenv.cmi +driver/compile.cmo : utils/warnings.cmi typing/typemod.cmi \ + typing/typedtree.cmi typing/typecore.cmi bytecomp/translmod.cmi \ + typing/stypes.cmi bytecomp/simplif.cmi typing/printtyped.cmi \ + typing/printtyp.cmi bytecomp/printlambda.cmi bytecomp/printinstr.cmi \ + parsing/printast.cmi parsing/pprintast.cmi driver/pparse.cmi \ + utils/misc.cmi parsing/location.cmi typing/includemod.cmi typing/env.cmi \ + bytecomp/emitcode.cmi driver/compmisc.cmi driver/compenv.cmi \ + utils/clflags.cmi utils/ccomp.cmi bytecomp/bytegen.cmi driver/compile.cmi +driver/compile.cmx : utils/warnings.cmx typing/typemod.cmx \ + typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \ + typing/stypes.cmx bytecomp/simplif.cmx typing/printtyped.cmx \ + typing/printtyp.cmx bytecomp/printlambda.cmx bytecomp/printinstr.cmx \ + parsing/printast.cmx parsing/pprintast.cmx driver/pparse.cmx \ + utils/misc.cmx parsing/location.cmx typing/includemod.cmx typing/env.cmx \ + bytecomp/emitcode.cmx driver/compmisc.cmx driver/compenv.cmx \ + utils/clflags.cmx utils/ccomp.cmx bytecomp/bytegen.cmx driver/compile.cmi +driver/compmisc.cmo : utils/misc.cmi typing/ident.cmi typing/env.cmi \ + utils/config.cmi driver/compenv.cmi utils/clflags.cmi driver/compmisc.cmi +driver/compmisc.cmx : utils/misc.cmx typing/ident.cmx typing/env.cmx \ + utils/config.cmx driver/compenv.cmx utils/clflags.cmx driver/compmisc.cmi +driver/errors.cmo : parsing/location.cmi driver/errors.cmi +driver/errors.cmx : parsing/location.cmx driver/errors.cmi +driver/main.cmo : utils/warnings.cmi utils/misc.cmi driver/main_args.cmi \ + parsing/location.cmi utils/config.cmi driver/compmisc.cmi \ + driver/compile.cmi driver/compenv.cmi utils/clflags.cmi \ + bytecomp/bytepackager.cmi bytecomp/bytelink.cmi \ + bytecomp/bytelibrarian.cmi driver/main.cmi +driver/main.cmx : utils/warnings.cmx utils/misc.cmx driver/main_args.cmx \ + parsing/location.cmx utils/config.cmx driver/compmisc.cmx \ + driver/compile.cmx driver/compenv.cmx utils/clflags.cmx \ + bytecomp/bytepackager.cmx bytecomp/bytelink.cmx \ + bytecomp/bytelibrarian.cmx driver/main.cmi +driver/main_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 typing/typecore.cmi bytecomp/translmod.cmi \ + typing/stypes.cmi bytecomp/simplif.cmi typing/printtyped.cmi \ + typing/printtyp.cmi bytecomp/printlambda.cmi parsing/printast.cmi \ + parsing/pprintast.cmi driver/pparse.cmi utils/misc.cmi \ + typing/includemod.cmi typing/env.cmi utils/config.cmi driver/compmisc.cmi \ + asmcomp/compilenv.cmi driver/compenv.cmi utils/clflags.cmi \ + utils/ccomp.cmi asmcomp/asmgen.cmi driver/optcompile.cmi +driver/optcompile.cmx : utils/warnings.cmx typing/typemod.cmx \ + typing/typedtree.cmx typing/typecore.cmx bytecomp/translmod.cmx \ + typing/stypes.cmx bytecomp/simplif.cmx typing/printtyped.cmx \ + typing/printtyp.cmx bytecomp/printlambda.cmx parsing/printast.cmx \ + parsing/pprintast.cmx driver/pparse.cmx utils/misc.cmx \ + typing/includemod.cmx typing/env.cmx utils/config.cmx driver/compmisc.cmx \ + asmcomp/compilenv.cmx driver/compenv.cmx utils/clflags.cmx \ + utils/ccomp.cmx asmcomp/asmgen.cmx driver/optcompile.cmi +driver/opterrors.cmo : parsing/location.cmi driver/opterrors.cmi +driver/opterrors.cmx : parsing/location.cmx driver/opterrors.cmi +driver/optmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \ + driver/optcompile.cmi utils/misc.cmi driver/main_args.cmi \ + parsing/location.cmi utils/config.cmi driver/compmisc.cmi \ + driver/compenv.cmi utils/clflags.cmi asmcomp/asmpackager.cmi \ + asmcomp/asmlink.cmi asmcomp/asmlibrarian.cmi asmcomp/arch.cmo \ + driver/optmain.cmi +driver/optmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \ + driver/optcompile.cmx utils/misc.cmx driver/main_args.cmx \ + parsing/location.cmx utils/config.cmx driver/compmisc.cmx \ + driver/compenv.cmx utils/clflags.cmx asmcomp/asmpackager.cmx \ + asmcomp/asmlink.cmx asmcomp/asmlibrarian.cmx asmcomp/arch.cmx \ + driver/optmain.cmi +driver/pparse.cmo : parsing/parse.cmi utils/misc.cmi parsing/location.cmi \ + utils/config.cmi utils/clflags.cmi utils/ccomp.cmi driver/pparse.cmi +driver/pparse.cmx : parsing/parse.cmx utils/misc.cmx parsing/location.cmx \ + utils/config.cmx utils/clflags.cmx utils/ccomp.cmx driver/pparse.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 \ + 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 \ + typing/env.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 \ + utils/misc.cmx typing/ident.cmx bytecomp/bytesections.cmx +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 \ + 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 \ + typing/printtyp.cmi toplevel/opttoploop.cmi utils/misc.cmi \ + parsing/longident.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \ + utils/config.cmi utils/clflags.cmi asmcomp/asmlink.cmi \ + toplevel/opttopdirs.cmi +toplevel/opttopdirs.cmx : utils/warnings.cmx typing/types.cmx \ + typing/printtyp.cmx toplevel/opttoploop.cmx utils/misc.cmx \ + parsing/longident.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ + utils/config.cmx utils/clflags.cmx asmcomp/asmlink.cmx \ + toplevel/opttopdirs.cmi +toplevel/opttoploop.cmo : utils/warnings.cmi typing/types.cmi \ + typing/typemod.cmi typing/typedtree.cmi typing/typecore.cmi \ + bytecomp/translmod.cmi bytecomp/simplif.cmi typing/printtyped.cmi \ + typing/printtyp.cmi bytecomp/printlambda.cmi parsing/printast.cmi \ + typing/predef.cmi parsing/pprintast.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/parse.cmi typing/outcometree.cmi \ + typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi parsing/lexer.cmi typing/ident.cmi \ + toplevel/genprintval.cmi typing/env.cmi utils/config.cmi \ + driver/compmisc.cmi asmcomp/compilenv.cmi utils/clflags.cmi \ + typing/btype.cmi asmcomp/asmlink.cmi asmcomp/asmgen.cmi \ + toplevel/opttoploop.cmi +toplevel/opttoploop.cmx : utils/warnings.cmx typing/types.cmx \ + typing/typemod.cmx typing/typedtree.cmx typing/typecore.cmx \ + bytecomp/translmod.cmx bytecomp/simplif.cmx typing/printtyped.cmx \ + typing/printtyp.cmx bytecomp/printlambda.cmx parsing/printast.cmx \ + typing/predef.cmx parsing/pprintast.cmx typing/path.cmx \ + parsing/parsetree.cmi parsing/parse.cmx typing/outcometree.cmi \ + typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx parsing/lexer.cmx typing/ident.cmx \ + toplevel/genprintval.cmx typing/env.cmx utils/config.cmx \ + driver/compmisc.cmx asmcomp/compilenv.cmx utils/clflags.cmx \ + typing/btype.cmx asmcomp/asmlink.cmx asmcomp/asmgen.cmx \ + toplevel/opttoploop.cmi +toplevel/opttopmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \ + toplevel/opttoploop.cmi toplevel/opttopdirs.cmi utils/misc.cmi \ + driver/main_args.cmi parsing/location.cmi utils/config.cmi \ + driver/compenv.cmi utils/clflags.cmi toplevel/opttopmain.cmi +toplevel/opttopmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \ + toplevel/opttoploop.cmx toplevel/opttopdirs.cmx utils/misc.cmx \ + driver/main_args.cmx parsing/location.cmx utils/config.cmx \ + driver/compenv.cmx utils/clflags.cmx toplevel/opttopmain.cmi +toplevel/opttopstart.cmo : toplevel/opttopmain.cmi +toplevel/opttopstart.cmx : toplevel/opttopmain.cmx +toplevel/topdirs.cmo : utils/warnings.cmi typing/types.cmi \ + 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 \ + 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/printtyped.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \ + bytecomp/printinstr.cmi parsing/printast.cmi typing/predef.cmi \ + parsing/pprintast.cmi driver/pparse.cmi typing/path.cmi \ + parsing/parsetree.cmi parsing/parse.cmi typing/outcometree.cmi \ + typing/oprint.cmi utils/misc.cmi bytecomp/meta.cmi parsing/longident.cmi \ + parsing/location.cmi parsing/lexer.cmi typing/includemod.cmi \ + typing/ident.cmi toplevel/genprintval.cmi typing/env.cmi \ + bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \ + utils/config.cmi driver/compmisc.cmi utils/clflags.cmi \ + bytecomp/bytegen.cmi typing/btype.cmi parsing/ast_helper.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/printtyped.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \ + bytecomp/printinstr.cmx parsing/printast.cmx typing/predef.cmx \ + parsing/pprintast.cmx driver/pparse.cmx typing/path.cmx \ + parsing/parsetree.cmi parsing/parse.cmx typing/outcometree.cmi \ + typing/oprint.cmx utils/misc.cmx bytecomp/meta.cmx parsing/longident.cmx \ + parsing/location.cmx parsing/lexer.cmx typing/includemod.cmx \ + typing/ident.cmx toplevel/genprintval.cmx typing/env.cmx \ + bytecomp/emitcode.cmx bytecomp/dll.cmx utils/consistbl.cmx \ + utils/config.cmx driver/compmisc.cmx utils/clflags.cmx \ + bytecomp/bytegen.cmx typing/btype.cmx parsing/ast_helper.cmx \ + toplevel/toploop.cmi +toplevel/topmain.cmo : utils/warnings.cmi toplevel/toploop.cmi \ + toplevel/topdirs.cmi utils/misc.cmi driver/main_args.cmi \ + parsing/location.cmi utils/config.cmi driver/compenv.cmi \ + utils/clflags.cmi toplevel/topmain.cmi +toplevel/topmain.cmx : utils/warnings.cmx toplevel/toploop.cmx \ + toplevel/topdirs.cmx utils/misc.cmx driver/main_args.cmx \ + parsing/location.cmx utils/config.cmx driver/compenv.cmx \ + utils/clflags.cmx toplevel/topmain.cmi +toplevel/topstart.cmo : toplevel/topmain.cmi +toplevel/topstart.cmx : toplevel/topmain.cmx +toplevel/trace.cmo : typing/types.cmi toplevel/toploop.cmi \ + typing/printtyp.cmi typing/predef.cmi typing/path.cmi utils/misc.cmi \ + bytecomp/meta.cmi parsing/longident.cmi typing/ctype.cmi \ + toplevel/trace.cmi +toplevel/trace.cmx : typing/types.cmx toplevel/toploop.cmx \ + typing/printtyp.cmx typing/predef.cmx typing/path.cmx utils/misc.cmx \ + bytecomp/meta.cmx parsing/longident.cmx typing/ctype.cmx \ + toplevel/trace.cmi diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..833c6d8 --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +_build/ +config.sh +myocamlbuild_config.ml +camlp4/boot/*.old +camlp4/META diff --git a/.ignore b/.ignore new file mode 100644 index 0000000..4bb83e4 --- /dev/null +++ b/.ignore @@ -0,0 +1,17 @@ +configure +ocamlc +ocamlc.opt +expunge +ocaml +ocamlopt +ocamlopt.opt +package-macosx +_boot_log1 +_boot_log2 +_build +_start +_buildtest +_log +myocamlbuild_config.ml +ocamlbuild-mixed-boot +ocamlnat diff --git a/.ocp-indent b/.ocp-indent new file mode 100644 index 0000000..324a382 --- /dev/null +++ b/.ocp-indent @@ -0,0 +1,2 @@ +match_clause=4 +strict_with=auto diff --git a/.travis-ci.sh b/.travis-ci.sh new file mode 100644 index 0000000..532221c --- /dev/null +++ b/.travis-ci.sh @@ -0,0 +1,26 @@ +case $XARCH in +i386) + uname -a + + git clone git://github.com/ocaml/ocaml -b trunk --depth 1 + cd ocaml + ./configure + make world.opt + sudo make install + cd .. + rm -rf ocaml + + git clone git://github.com/ocaml/ocamlbuild + cd ocamlbuild + make + sudo make install + cd .. + rm -rf ocamlbuild + + ./configure && make && sudo make install + ;; +*) + echo unknown arch + exit 1 + ;; +esac diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..3015c16 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,4 @@ +language: c +script: bash -ex .travis-ci.sh +env: + - XARCH=i386 diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 index 0000000..00d3f61 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,20 @@ +4.02.1+1 +-------- + +* map `functor () ->` to `functor * ->` like OCaml +* fix hanging problem in the toplevel + +4.02.0+2 +-------- + +* raise an error when passing "with type M.t := ..." to OCaml +* Make scripts insensitive to `CDPATH` +* fix build when ocamlopt is not available +* fix the default value of `PKGDIR` + +4.02.0+1 +-------- + +* support the `M()` syntax +* support for extensible types +* support the `match ... with exception ...` syntax diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..3791a2a --- /dev/null +++ b/LICENSE @@ -0,0 +1,501 @@ +Camlp4 is distributed under the terms of the GNU Library General +Public License version 2 (included below). + +As a special exception to the GNU Library General Public License, you +may link, statically or dynamically, a "work that uses the Library" +with a publicly distributed version of the Library to produce an +executable file containing portions of the Library, and distribute +that executable file under terms of your choice, without any of the +additional requirements listed in clause 6 of the GNU Library General +Public License. By "a publicly distributed version of the Library", +we mean either the unmodified Library as distributed by INRIA, or a +modified version of the Library that is distributed under the +conditions defined in clause 2 of the GNU Library General Public +License. This exception does not however invalidate any other reasons +why the executable file might be covered by the GNU Library General +Public License. + +---------------------------------------------------------------------- + + GNU LIBRARY GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1991 Free Software Foundation, Inc. + 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the library GPL. It is + numbered 2 because it goes with version 2 of the ordinary GPL.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Library General Public License, applies to some +specially designated Free Software Foundation software, and to any +other libraries whose authors decide to use it. You can use it for +your libraries, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if +you distribute copies of the library, or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link a program with the library, you must provide +complete object files to the recipients so that they can relink them +with the library, after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + Our method of protecting your rights has two steps: (1) copyright +the library, and (2) offer you this license which gives you legal +permission to copy, distribute and/or modify the library. + + Also, for each distributor's protection, we want to make certain +that everyone understands that there is no warranty for this free +library. If the library is modified by someone else and passed on, we +want its recipients to know that what they have is not the original +version, so that any problems introduced by others will not reflect on +the original authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that companies distributing free +software will individually obtain patent licenses, thus in effect +transforming the program into proprietary software. To prevent this, +we have made it clear that any patent must be licensed for everyone's +free use or not licensed at all. + + Most GNU software, including some libraries, is covered by the ordinary +GNU General Public License, which was designed for utility programs. This +license, the GNU Library General Public License, applies to certain +designated libraries. This license is quite different from the ordinary +one; be sure to read it in full, and don't assume that anything in it is +the same as in the ordinary license. + + The reason we have a separate public license for some libraries is that +they blur the distinction we usually make between modifying or adding to a +program and simply using it. Linking a program with a library, without +changing the library, is in some sense simply using the library, and is +analogous to running a utility program or application program. However, in +a textual and legal sense, the linked executable is a combined work, a +derivative of the original library, and the ordinary General Public License +treats it as such. + + Because of this blurred distinction, using the ordinary General +Public License for libraries did not effectively promote software +sharing, because most developers did not use the libraries. We +concluded that weaker conditions might promote sharing better. + + However, unrestricted linking of non-free programs would deprive the +users of those programs of all benefit from the free status of the +libraries themselves. This Library General Public License is intended to +permit developers of non-free programs to use free libraries, while +preserving your freedom as a user of such programs to change the free +libraries that are incorporated in them. (We have not seen how to achieve +this as regards changes in header files, but we have achieved it as regards +changes in the actual functions of the Library.) The hope is that this +will lead to faster development of free libraries. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, while the latter only +works together with the library. + + Note that it is possible for a library to be covered by the ordinary +General Public License rather than by this special one. + + GNU LIBRARY GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library which +contains a notice placed by the copyright holder or other authorized +party saying it may be distributed under the terms of this Library +General Public License (also called "this License"). Each licensee is +addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also compile or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + c) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + d) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the source code distributed need not include anything that is normally +distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Library General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, + MA 02111-1307, USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..b9225f6 --- /dev/null +++ b/Makefile @@ -0,0 +1,48 @@ +OB := ocamlbuild -classic-display -no-ocamlfind +DESTDIR= + +-include config.sh + +OB += $(OB_FLAGS) + +.PHONY: default +default: byte + +.PHONY: byte +byte: + $(OB) `sh ./build/camlp4-byte-only.sh` + +.PHONY: native +native: + $(OB) `sh ./build/camlp4-native-only.sh` + +.PHONY: all +all: byte native + +.PHONY: install +install: + env DESTDIR=$(DESTDIR) sh ./build/install.sh + +.PHONY: install-META +install-META: camlp4/META + mkdir -p $(DESTDIR)${PKGDIR}/camlp4/ + cp -f camlp4/META $(DESTDIR)${PKGDIR}/camlp4/ + +camlp4/META: camlp4/META.in + sed -e s/@@VERSION@@/${version}/g $? > $@ + +.PHONY: bootstrap +bootstrap: + sh ./build/camlp4-bootstrap.sh + +.PHONY: Camlp4Ast +Camlp4Ast: + sh ./build/camlp4-mkCamlp4Ast.sh + +.PHONY: clean +clean: + rm -rf _build + +.PHONY: distclean +distclean: + rm -rf _build myocamlbuild_config.ml Makefile.config diff --git a/README.md b/README.md new file mode 100644 index 0000000..a9dd22f --- /dev/null +++ b/README.md @@ -0,0 +1,30 @@ +camlp4 +====== + +Camlp4 was a software system for writing extensible parsers for +programming languages. Since 2017, Camlp4 is not actively maintained +anymore, and only receives occasional fixes for compatibility with new +OCaml versions. Maintainers of Camlp4-using projects are actively +encouraged to switch to other systems: + +- For new projects or actively-moving projects, we recommend adopting + ppx attributes and extensions, which is now the preferred way to + perform AST transformations on OCaml programs. + +- For slow-moving projects or users of other Camlp4 features + (extensible grammars), switching to the (maintained) + [Camlp5](https://github.com/camlp5/camlp5) variant of the + preprocessor should be easy. + +Unless you are interested in taking over maintainance of Camlp4, we +prefer not to receive request for new features or changes -- +contribution efforts should rather go to the ppx ecosystem or +Camlp5. Minor patches to improve compatibility with new OCaml versions +are welcome. + +Building from git +----------------- + +Camlp4 branches try to follow OCaml ones. To build with the trunk of +OCaml, you need to use the trunk branch of Camlp4. To build for a +specific version, for instance 4.02.1, use the 4.02 branch of Camlp4. diff --git a/_tags b/_tags new file mode 100644 index 0000000..e2124ea --- /dev/null +++ b/_tags @@ -0,0 +1,36 @@ +############################################################################ +# # +# OCaml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2007 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed under # +# the terms of the GNU Library General Public License, with the special # +# exception on linking described in LICENSE at the top of the Camlp4 # +# source tree. # +# # +############################################################################ + +# Ocamlbuild tags file + +# We want -g everywhere it's possible +true: debug + +# Enforce safe-string +true: safe_string + +: use_import +: use_dynlink +: use_ocamlcommon + +: use_unix +: -use_unix + +#<**/*.ml*>: warn_error(A-3) + +# The tag "camlp4boot" is for preprocessing using camlp4/boot/camlp4boot.byte +: camlp4boot, warn_Z +: -camlp4boot + or or "camlp4/Camlp4/Struct/Lexer.ml": -camlp4boot, -warn_Z, warn_a +: -debug diff --git a/build/camlp4-bootstrap-recipe.txt b/build/camlp4-bootstrap-recipe.txt new file mode 100644 index 0000000..8a7cb8f --- /dev/null +++ b/build/camlp4-bootstrap-recipe.txt @@ -0,0 +1,178 @@ +############################################################################ +# # +# OCaml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2010 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed under # +# the terms of the GNU Library General Public License, with the special # +# exception on linking described in LICENSE at the top of the Camlp4 # +# source tree. # +# # +############################################################################ + +=== Short version === + # Run the following command until you see three fixpoint: + make clean byte install bootstrap + +=== Install the bootstrapping camlp4 processor === + make install + +=== Build camlp4 === + make + +=== Bootstrap camlp4 === + # First "Build camlp4" + # Then "Install the bootstrapping camlp4 processor" + # Indeed the following bootstrapping script + # does use the installed version! + make bootstrap + # If the fixpoint not is reached yet + # Go to "Bootstrap camlp4" + # Otherwise + # Have a look at the changes in + # camlp4/boot it may be a good idea to commit them + +=== Generate Camlp4Ast.ml === + # First "Install the bootstrapping camlp4 processor" + # Indeed the following bootstrapping script + # does use the installed version! + make Camlp4Ast + +=== Case study "let open M in e" === + + Open the revised parser + Camlp4Parsers/Camlp4OCamlRevisedParser.ml + + Look for similar constructs, indeed rules + that start by the same prefix should in + the same entry. It is simpler to stick + them close to each other. + + [ "let"; r = opt_rec; ... + | "let"; "module"; m = a_UIDENT; ... + + So we naturally add something like + + | "let"; "open"; ... + + Then have a look to the "open" construct: + + | "open"; i = module_longident -> + + So we need a module_longident, it becomes: + + | "let"; "open"; i = module_longident; "in"; e = SELF -> + + Then we leave a dummy action but very close to what we want + in the end: + + | "let"; "open"; i = module_longident; "in"; e = SELF -> + <:expr< open_in $id:i$ $e$ >> + + Here it is just calling a (non-existing) function called open_in. + + Check that there is no other place where we have to duplicate this + rule (yuk!). In our case it is! The sequence entry have the "let" + rules again. + + Then go into Camlp4Parsers/Camlp4OCamlParser.ml and look for other + occurences. + + When copy/pasting the rule take care of SELF occurences, you may + have to replace it by expr and expr LEVEL ";" in our case. + + The return type of the production might be different from expr in + our case an action become <:str_item<...>> instead of <:expr<...> + + Watch the DELETE_RULE as well, in our case I'm searching for the + literal string "let" in the source: + + DELETE_RULE Gram expr: "let"; "open"; module_longident; "in"; SELF END; + + Then build and bootstrap. + + Then you can at last extend the AST, go in: + + Camlp4/Camlp4Ast.partial.ml + + And add the "open in" constructor (at the end). + + (* let open i in e *) + | ExOpI of loc and ident and expr + + Then "Generate Camlp4Ast.ml" and build. + + We get a single warning in Camlp4/Struct/Camlp4Ast2OCamlAst.ml but + don't fix it now. Notice that you may need to disable '-warn-error' + in order to be able to successfully compile, despite of the warning. + + Then I hacked the camlp4/boot/camlp4boot.ml to generate: + Ast.ExOpI(_loc, i, e) + instead of + Ast.ExApp(_loc .... "open_in" ... i ... e ...) + + Build. Bootstrap once and build again. + + Then change the parsers again and replace the + open_in $id:i$ $e$ + by + let open $i$ in $e$ + + Then change the Parsetree generation in + Camlp4/Struct/Camlp4Ast2OCamlAst.ml + + | <:expr@loc< let open $i$ in $e$ >> -> + mkexp loc (Pexp_open (long_uident i) (expr e)) + + Change the pretty-printers as well (drawing inspiration in + "let module" in this case): + + In Camlp4/Printers/OCaml.ml: + | <:expr< let open $i$ in $e$ >> -> + 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 $_$ >> + + Have a look in Camlp4/Printers/OCamlr.ml as well. + +=== Second case study "with t := ..." === + +1/ Change the revised parser first. +Add new parsing rules for := but keep the old actions for now. + +2/ Change Camlp4Ast.partial.ml, add: + (* type t := t *) + | WcTyS of loc and ctyp and ctyp + (* module i := i *) + | WcMoS of loc and ident and ident + +3/ "Generate Camlp4Ast.ml" and build. + +4/ Change the generated camlp4/boot/camlp4boot.ml: + Look for ":=" and change occurences of + WcMod by WcMoS and WcTyp by WcTyS + +5/ Build (DO NOT bootstrap) + "Install the bootstrapping camlp4 processor" + +6/ Change the required files: + Camlp4/Printers/OCaml.ml: + just copy/paste&adapt what is done for + "... with type t = u" and + "... with module M = N" + Camlp4/Struct/Camlp4Ast2OCamlAst.ml: + I've factored out a common part under + another function and then copy/pasted. + Camlp4Parsers/Camlp4OCamlRevisedParser.ml: + Change the <:with_constr< type $...$ = $...$ >> + we've introduced earlier by replacing the '=' + by ':='. + Camlp4Parsers/Camlp4OCamlParser.ml: + Copy paste what we have done in Camlp4OCamlRevisedParser + and but we need to call opt_private_ctyp instead of + ctyp (just like the "type =" construct). + +7/ Build & Bootstrap diff --git a/build/camlp4-bootstrap.sh b/build/camlp4-bootstrap.sh new file mode 100755 index 0000000..e160486 --- /dev/null +++ b/build/camlp4-bootstrap.sh @@ -0,0 +1,67 @@ +#!/bin/sh + +############################################################################ +# # +# OCaml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2007 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed under # +# the terms of the GNU Library General Public License, with the special # +# exception on linking described in LICENSE at the top of the Camlp4 # +# source tree. # +# # +############################################################################ + +# README: to bootstrap camlp4 have a look at build/camlp4-bootstrap-recipe.txt + +set -e +if [ ! -e camlp4/META.in ] ; then + echo "script $0 invoked from the wrong location" + exit 1 +fi + +. ./config.sh +export PATH=$BINDIR:$PATH + +TMPTARGETS="\ + camlp4/boot/Lexer.ml" + +TARGETS="\ + camlp4/boot/Camlp4Ast.ml \ + camlp4/boot/Camlp4.ml \ + camlp4/boot/camlp4boot.ml" + +for target in $TARGETS camlp4/boot/Camlp4Ast.ml; do + [ -f "$target" ] && mv "$target" "$target.old" + rm -f "_build/$target" +done + +cmd() { + echo $@ + $@ +} + +cmd camlp4o _build/camlp4/Camlp4/Struct/Lexer.ml -printer r -o camlp4/boot/Lexer.ml +cmd camlp4boot \ + -printer r \ + -filter map \ + -filter fold \ + -filter meta \ + -filter trash \ + -impl camlp4/Camlp4/Struct/Camlp4Ast.mlast \ + -o camlp4/boot/Camlp4Ast.ml +for t in Camlp4 camlp4boot; do + cmd camlp4boot -impl camlp4/boot/$t.ml4 -printer o -D OPT -o camlp4/boot/$t.ml +done +rm -f camlp4/boot/Lexer.ml + +for t in $TARGETS; do + echo promote $t + if cmp $t $t.old; then + echo "fixpoint for $t" + else + echo "$t is different, you should rebootstrap it by cleaning, building and call this script" + fi +done diff --git a/build/camlp4-byte-only.sh b/build/camlp4-byte-only.sh new file mode 100755 index 0000000..fcfc69d --- /dev/null +++ b/build/camlp4-byte-only.sh @@ -0,0 +1,27 @@ +#!/bin/sh + +############################################################################ +# # +# OCaml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2008 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed under # +# the terms of the GNU Library General Public License, with the special # +# exception on linking described in LICENSE at the top of the Camlp4 # +# source tree. # +# # +############################################################################ + +set -e +if [ ! -e camlp4/META.in ] ; then + echo "script $0 invoked from the wrong location" + exit 1 +fi + +. ./config.sh +. build/camlp4-targets.sh +set -x + +echo $CAMLP4_BYTE diff --git a/build/camlp4-mkCamlp4Ast.sh b/build/camlp4-mkCamlp4Ast.sh new file mode 100755 index 0000000..d71c311 --- /dev/null +++ b/build/camlp4-mkCamlp4Ast.sh @@ -0,0 +1,45 @@ +#!/bin/sh + +############################################################################ +# # +# OCaml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2010 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed under # +# the terms of the GNU Library General Public License, with the special # +# exception on linking described in LICENSE at the top of the Camlp4 # +# source tree. # +# # +############################################################################ + +set -e +if [ ! -e camlp4/META.in ] ; then + echo "script $0 invoked from the wrong location" + exit 1 +fi + +. ./config.sh +export PATH=$BINDIR:$PATH + +CAMLP4AST=camlp4/Camlp4/Struct/Camlp4Ast.ml +BOOTP4AST=camlp4/boot/Camlp4Ast.ml + +[ -f "$BOOTP4AST" ] && mv "$BOOTP4AST" "$BOOTP4AST.old" +rm -f "_build/$BOOTP4AST" +rm -f "_build/$CAMLP4AST" + +cmd() { + echo $@ + $@ +} + +cmd camlp4boot \ + -printer r \ + -filter map \ + -filter fold \ + -filter meta \ + -filter trash \ + -impl camlp4/Camlp4/Struct/Camlp4Ast.mlast \ + -o camlp4/boot/Camlp4Ast.ml diff --git a/build/camlp4-native-only.sh b/build/camlp4-native-only.sh new file mode 100755 index 0000000..1619837 --- /dev/null +++ b/build/camlp4-native-only.sh @@ -0,0 +1,27 @@ +#!/bin/sh + +############################################################################ +# # +# OCaml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2008 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed under # +# the terms of the GNU Library General Public License, with the special # +# exception on linking described in LICENSE at the top of the Camlp4 # +# source tree. # +# # +############################################################################ + +set -e +if [ ! -e camlp4/META.in ] ; then + echo "script $0 invoked from the wrong location" + exit 1 +fi + +. ./config.sh +. build/camlp4-targets.sh +set -x + +echo $CAMLP4_NATIVE diff --git a/build/camlp4-targets.sh b/build/camlp4-targets.sh new file mode 100755 index 0000000..a35b1ff --- /dev/null +++ b/build/camlp4-targets.sh @@ -0,0 +1,51 @@ +#!/bin/sh + +############################################################################ +# # +# OCaml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2007 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed under # +# the terms of the GNU Library General Public License, with the special # +# exception on linking described in LICENSE at the top of the Camlp4 # +# source tree. # +# # +############################################################################ + +CAMLP4_BYTE="\ + camlp4/Camlp4.cmo \ + camlp4/Camlp4Top.cmo \ + camlp4/camlp4prof.byte$EXE \ + camlp4/mkcamlp4.byte$EXE \ + camlp4/camlp4.byte$EXE \ + camlp4/camlp4fulllib.cma" +CAMLP4_NATIVE="\ + camlp4/Camlp4.cmx \ + camlp4/camlp4prof.native$EXE \ + camlp4/mkcamlp4.native$EXE \ + camlp4/camlp4.native$EXE \ + camlp4/camlp4fulllib.cmxa" + +if [ "$OCAMLNAT" = "true" ]; then + CAMLP4_NATIVE="$CAMLP4_NATIVE camlp4/Camlp4Top.cmx" +fi + +for i in camlp4boot camlp4r camlp4rf camlp4o camlp4of camlp4oof camlp4orf; do + CAMLP4_BYTE="$CAMLP4_BYTE camlp4/$i.byte$EXE camlp4/$i.cma" + CAMLP4_NATIVE="$CAMLP4_NATIVE camlp4/$i.native$EXE" + if [ "$OCAMLNAT" = "true" ]; then + CAMLP4_NATIVE="$CAMLP4_NATIVE camlp4/$i.cmxa" + fi +done + +cd ./camlp4 +for dir in Camlp4Parsers Camlp4Printers Camlp4Filters; do + for file in $dir/*.ml; do + base=camlp4/$dir/`basename $file .ml` + CAMLP4_BYTE="$CAMLP4_BYTE $base.cmo" + CAMLP4_NATIVE="$CAMLP4_NATIVE $base.cmx $base$O" + done +done +cd .. diff --git a/build/install.sh b/build/install.sh new file mode 100755 index 0000000..9a62e2d --- /dev/null +++ b/build/install.sh @@ -0,0 +1,166 @@ +#!/bin/sh + +############################################################################ +# # +# OCaml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2007 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed under # +# the terms of the GNU Library General Public License, with the special # +# exception on linking described in LICENSE at the top of the Camlp4 # +# source tree. # +# # +############################################################################ + +set -e +if [ ! -e camlp4/META.in ] ; then + echo "script $0 invoked from the wrong location" + exit 1 +fi + +# Save the following environment variables before sourcing config.sh +# since it will overwrite them and the user might have set them to +# emulate $(DESTDIR) which is unfortunately not supported. +SAVED_BINDIR="${BINDIR}" +SAVED_LIBDIR="${LIBDIR}" + +. ./config.sh + +BINDIR="$DESTDIR${SAVED_BINDIR:-${BINDIR}}" +LIBDIR="$DESTDIR${SAVED_LIBDIR:-${LIBDIR}}" + +not_installed=$PWD/_build/not_installed + +rm -f "$not_installed" +touch "$not_installed" + +wontinstall() { + echo "$1" >> "$not_installed" + echo " don't install $1" +} + +installbin() { + if [ -f "$1" ]; then + echo " install binary $2" + cp -f "$1" "$2" + [ -x "$2" ] || chmod +x "$2" + else + wontinstall "$1" + fi +} + +installbestbin() { + if [ -f "$1" ]; then + echo " install binary $3 (with `basename $1`)" + cp -f "$1" "$3" + else + if [ -f "$2" ]; then + echo " install binary $3 (with `basename $2`)" + cp -f "$2" "$3" + else + echo "None of $1, $2 exists" + exit 3 + fi + fi + [ -x "$3" ] || chmod +x "$3" +} + +installlib() { + if [ -f "$1" ]; then + dest="$2/`basename $1`" + echo " install library $dest" + cp -f "$1" "$2" + if [ "$ranlib" != "" ]; then + "$ranlib" "$dest" + fi + else + wontinstall "$1" + fi +} + +installdir() { + args="" + while [ $# -gt 1 ]; do + if [ -f "$1" ]; then + args="$args $1" + else + wontinstall "$1" + fi + shift + done + last="$1" + for file in $args; do + echo " install $last/`basename $file`" + cp -f "$file" "$last" + done +} + +installlibdir() { + args="" + while [ $# -gt 1 ]; do + args="$args $1" + shift + done + last="$1" + for file in $args; do + installlib "$file" "$last" + done +} + +mkdir -p $BINDIR +mkdir -p $LIBDIR/camlp4 + +cd ./_build + +echo "Installing camlp4..." +installbin camlp4/camlp4prof.byte$EXE $BINDIR/camlp4prof$EXE +installbin camlp4/mkcamlp4.byte$EXE $BINDIR/mkcamlp4$EXE +installbin camlp4/camlp4.byte$EXE $BINDIR/camlp4$EXE +installbin camlp4/camlp4boot.byte$EXE $BINDIR/camlp4boot$EXE +installbin camlp4/camlp4o.byte$EXE $BINDIR/camlp4o$EXE +installbin camlp4/camlp4of.byte$EXE $BINDIR/camlp4of$EXE +installbin camlp4/camlp4oof.byte$EXE $BINDIR/camlp4oof$EXE +installbin camlp4/camlp4orf.byte$EXE $BINDIR/camlp4orf$EXE +installbin camlp4/camlp4r.byte$EXE $BINDIR/camlp4r$EXE +installbin camlp4/camlp4rf.byte$EXE $BINDIR/camlp4rf$EXE +installbin camlp4/camlp4o.native$EXE $BINDIR/camlp4o.opt$EXE +installbin camlp4/camlp4of.native$EXE $BINDIR/camlp4of.opt$EXE +installbin camlp4/camlp4oof.native$EXE $BINDIR/camlp4oof.opt$EXE +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] \ + config/Camlp4_config.cmi camlp4prof.cm[iox] camlp4prof$O \ + $CAMLP4DIR +if [ "$OCAMLNAT" = "true" ]; then + installdir \ + camlp4o.cmxa camlp4of.cmxa camlp4oof.cmxa \ + camlp4orf.cmxa camlp4r.cmxa camlp4rf.cmxa \ + $CAMLP4DIR +fi +installlibdir camlp4lib$A camlp4fulllib$A $CAMLP4DIR +if [ "$OCAMLNAT" = "true" ]; then + installlibdir \ + camlp4o$A camlp4of$A camlp4oof$A \ + camlp4orf$A camlp4r$A camlp4rf$A \ + $CAMLP4DIR +fi +cd .. diff --git a/camlp4/.ignore b/camlp4/.ignore new file mode 100644 index 0000000..481c691 --- /dev/null +++ b/camlp4/.ignore @@ -0,0 +1,2 @@ +.cache-status +*.tmp.ml diff --git a/camlp4/CHANGES b/camlp4/CHANGES new file mode 100644 index 0000000..0251cd1 --- /dev/null +++ b/camlp4/CHANGES @@ -0,0 +1,898 @@ +- [...] + In the revised syntax of parsers the "?" is now a "??" like in the orignal + syntax to not conflict with optional labels. + +- [29 Jun 05] Add private row types. Make "private" a type constructor + "TyPrv" rather than a flag. (Jacques) + +- [09 Jun 04] Moved "-no_quot" option from pa_o to camlp4, enabling to + use it indepently fom pa_o.cmo. + +- [17 Nov 04] Renamed "loc" into "_loc", introducing an incompatibility + with existing code (3.08.x and before). Such code can generally run + unmodified using the -loc option (camlp4 -loc "loc"). + +Camlp4 Version 3.08.2 +------------------------ +- [07 Oct 04] Changes in the interfaces plexer.mli and pcaml.mli: + - plexer.mli: introduced a new lexer building function `make_lexer', + similar to `gmake', but returning a triple of references in addition + (holding respectively the character number of the beginning of the + current line, the current line number and the name of the file being + parsed). + - pcaml.mli: a new value `position'. A global reference to a triple like + the one mentioned above. +- [07 Sep 04] Camlp4 grammars `error recovery mode' now issues a warning + when used (but this warning is disabled by default). + +Camlp4 Version 3.08.[01] +------------------------ +- [05 Jul 04] creation of the `unmaintained' directory: + pa_format, pa_lefteval, pa_ocamllex, pa_olabl, pa_scheme and pa_sml + go there, each in its own subdir. Currently, they compile fine. +- [05 Jul 04] pa_ifdef, subsumed by pa_macro since 3.07, prints a warning + when loaded, encouraging use of pa_macro. +- [01 July 04] profiled versions of Camlp4 libs are *NOT* installed + by default (not even built). To build and install them, uncomment + the line PROFILING=prof in camlp4/config/Makefile.tpl, and then + make opt.opt && make install +- [22-23 June 04] `make install' now installs also pa_[or].cmx, pa_[or]p.cmx, + pa_[or]_fast.cmx, and odyl.cmx +- [12 may 04] Added to the camlp4 tools the -version option that prints + the version number, in the same way as the other ocaml tools. +- [12 may 04] Locations are now handled as in OCaml. The main benefit + is that line numbers are now correct in error messages. However, this + slightly changes the interface of a few Camlp4 modules (see ICHANGES). + ** Warning: Some contribs of the camlp4 distribution are broken because + of this change. In particular the scheme/lisp syntaxes. +- [20 nov 03] Illegal escape sequences in strings now issue a warning. + +Camlp4 Version 3.07 +___________________ + +- [29 Sep 03] Camlp4 code now licensed under the LGPL minus clause 6. +- [09 Sep 03] Added tokens LABEL and OPTLABEL in plexer, and use them in + both parsers (ocaml and revised). There was, afaik, no other way to fix + ambiguities (bugs) in parsing labels and type constraints. + +Camlp4 Version 3.07 beta1 +________________________ + +- [July 03] Updated the ocaml/camlp4 CVS tree with the camlp4 + "parallel" CVS tree, which becomes obsolete from now on. + Added support for recursive modules, private data constructors, and + new syntaxes for integers (int32, nativeint, ...). + +Camlp4 Version 3.06++ +----------------------- + +- [02 Dec 02] In AST predefined quotation, changed antiquotations for + "rec", "mutable": now all are with coercion "opt": $opt:...$ (instead + of "rec" and "mut"). Added antiquotation for "private". Cleaned up + the entries for "methods" and for labelled and optional parameters. +- [29 Nov 02] Removed all "extract_crc" stuff no more necessary with + the new interface of Dynlink. +- [26 Nov 02] Added ability to use "#use" directives in compiled files. +- [21 Nov 02] Changed Scheme syntax for directives: now, e.g. #load "file" + is written: # (load "file"). Added directives in "implem", "interf" and + "use" directive. +- [20 Nov 02] Added Grammar.glexer returning the lexer used by a + grammar. Also added a field in Token.glexer type to ask lexers to + record the locations of the comments. +- [04 Nov 02] Added option -no_quot with normal syntax (pa_o.cmo): + don't parse quotations (it allows to use e.g. <:> as a valid token). +- [31 Oct 02] Added pa_macro.cmo (to replace pa_ifdef.cmo which is + kept for compatibility, but deprecated). The extended statements + allow de definitions of macros and conditional compilation like + in C. +- [29 Oct 02] Changed pretty printers of the three main syntaxes: if + the locations of input are not correct, do no more raise End_of_file + when displaying the inter-phrases (return: the input found up to eof + if not empty, otherwise the value of the -sep parameter if not empty, + otherwise the string "\n"). +- [25 Oct 02] Added option -records in pa_sml.cmo: generates normal + OCaml records instead of objects (the user must be sure that there + are no names conflicts). +- [22 Oct 02] Added Plexer.specific_space_dot: when set to "true", the + next call to Plexer.gmake returns a lexer where the dot preceded by + spaces (space, tab, newline, etc.) return a different token than when + not preceded by spaces. +- [19 Oct 02] Added printer in Scheme syntax: pr_scheme.cmo and the + extension pr_schemep.cmo which rebuilts parsers. +- [15 Oct 02] Now, in case of syntax error, the real input file name is + displayed (can be different from the input file, because of the possibility + of line directives, typically generated by /lib/cpp). + Changed interface of Stdpp.line_of_loc: now return also a string: the name + of the real input file name. +- [14 Oct 02] Fixed bug in normal syntax (pa_o.cmo): the constructors + with currification of parameters (C x y) were accepted. +- [14 Oct 02] Fixed many problems of make under Windows (in particular if + installations directories contain spaces). +- [11 Oct 02] In ocaml syntax (pa_o.cmo), fixed 3 bugs (or incompatibilities + with the ocaml yacc version of the compiler): 1/ "ref new foo" was + interpreted as "ref;; new foo" instead of "ref (new foo)" 2/ unary + minuses did not work correctly (nor in quotation of syntax trees), in + particular "-0.0" 3/ "begin end" was a syntax error, instead of being "()". +- [Sep-Oct 02] Many changes and improvements in Scheme syntax. +- [07 Oct 02] Added definition of Pcaml.type_declaration which is + now visible in the interface, allowing to change the type declarations. +- [07 Oct 02] Added Pcaml.syntax_name to allow syntax extensions to test + it and take different decision. In revised syntax, its value is "Revised", + in normal syntax "OCaml" and in Scheme syntax "Scheme". +- [03 Oct 02] Added lexing of '\xHH' where HH is hexadecimal number. +- [01 Oct 02] In normal syntax (camlp4o), fixed problem of lexing + comment: (* bleble'''*) +- [23 Sep 02] Fixed bug: input "0x" raised Failure "int_of_string" + without location (syntaxes pa_o and pa_r). +- [14 Sep 02] Added functions Grammar.iter_entry and Grammar.fold_entry + to iterate a grammar entry and transitively all the entries it calls. +- [12 Sep 02] Added "Pcaml.rename_id", a hook to allow parsers to give + ability to rename their identifiers. Called in Scheme syntax (pa_scheme.ml) + when generating its identifiers. +- [09 Sep 02] Fixed bug under toplevel, the command: + !Toploop.parse_toplevel_phrase (Lexing.from_buff "1;;");; + failed "End_of_file". +- [06 Sep 02] Added "Pcaml.string_of". Combined with Pcaml.pr_expr, + Pcaml.pr_patt, and so on, allow to pretty print syntax trees in string. + E.g. in the toplevel: + # #load "pr_o.cmo"; + # Pcaml.string_of Pcaml.pr_expr <:expr< let x = 3 in x + 2 >>;; + - : string = "let x = 3 in x + 2" + +Camlp4 Version 3.06 +-------------------- + +- [24 Jul 02] Added Scheme syntax: pa_scheme.ml, camlp4sch.cma (toplevel), + camlp4sch (command). + +Camlp4 Version 3.05 +----------------------- + +- [12 Jul 02] Better treatment of comments in option -cip (add comments + in phrases) for both printers pr_o.cmo (normal syntax) and pr_r.cmo + (revised syntax); added comments before let binding and class + structure items; treat comments inside sum and record type definitions; + the option -tc is now deprecated and equivalent to -cip. +- [13 Jun 02] Added pa_lefteval.cmo: add let..in expressions to guarantee + left evaluation of functions parameters, t-uples, and so on (instead of + the default non-specified-but-in-fact-right-to-left evaluation). +- [06 Jun 02] Changed revised syntax (pa_r) of variants types definition; + (Jacques Garrigue's idea): + old syntax new syntax + [| ... |] [ = ... ] + [| < ... |] [ < ... ] + [| > ... |] [ > ... ] + This applies also in predefined quotations of syntax tree for types + <:ctyp< ... >> +- [05 Jun 02] Added option -ss in pr_o.cmo: print with double semicolons; + and the option -no_ss is now by default. +- [30 May 02] Improved SML syntax (pa_sml). +- [30 May 02] Changed the AST for the "with module" construct (was with + type "module_type"; changed into type "module_expr"). +- [26 May 02] Added missing abstract module types. +- [21 Apr 02] Added polymorphic types for polymorphic methods: + revised syntax (example): ! 'a 'b . type + ctyp quotation: <:ctyp< ! $list:pl$ . $t$ >> +- [17 Apr 02] Fixed bug: in normal syntax (pa_o.cmo) made a parse error on + the "dot" on (in interface file file): + class c : a * B.c -> object val x : int end +- [03 Apr 02] Fixed bug: (* "(*" *) resulted in "comment not terminated". +- [03 Apr 02] Fixed incompatibility with ocaml: ''' and '"' must be + displayed as '\'' and '\"' in normal syntax printer (pr_o.cmo). +- [03 Apr 02] When there are several tokens parsed together (locally LL(n)), + the location error now highlights all tokens, resulting in a more clear + error message (e.g. "for i let" would display "illegal begin of expr" + and highlight the 3 tokens, not just "for"). +- [30 Mar 02] Added pa_extfold.cmo extending pa_extend.cmo by grammar + symbols FOLD0 and FOLD1. Work like LIST0 and LIST1 but have two initial + parameters: a function of type 'a -> 'b -> 'b doing the fold and an + initial value of type 'b. Actually, LIST0 now is like + FOLD0 (fun x y -> x :: y) [] + with an reverse of the resulting list. +- [20 Mar 02] Fixed problem: when running a toplevel linked with camlp4 + as a script, the camlp4 welcome message was displayed. +- [14 Mar 02] The configure shell and the program now test the consistency + of OCaml and Camlp4. Therefore 1/ if trying to compile this version with + an incompatible OCaml version or 2/ trying to run an installed Camlp4 with + a incompatible OCaml version: in both cases, camlp4 fails. +- [14 Mar 02] When make opt.opt is done, the very fast version is made for + the normal syntax ("compiled" version). The installed camlp4o.opt is that + version. +- [05 Mar 02] Changed the conversion to OCaml syntax tree for <:expr< x.val >> + and <:expr< x.val := e >> which generates now the tree of !x and x := e, + no more x.contents and x.contents <- e. This change was necessary because + of a problem if a record has been defined with a field named "contents". + +- [16 Feb 02] Changed interface of grammars: the token type is now + customizable, using a new lexer type Token.glexer, parametrized by + the token type, and a new functor GMake. This was accompanied by + some cleanup. Become deprecated: the type Token.lexer (use Token.glexer), + Grammar.create (use Grammar.gcreate), Unsafe.reinit_gram (use + Unsafe.gram_reinit), the functor Grammar.Make (use Grammar.GMake). + Deprecated means that they are kept during some versions and removed + afterwards. +- [06 Feb 02] Added missing infix "%" in pa_o (normal syntax). +- [06 Feb 02] Added Grammar.print_entry printing any kind of (obj) entry + and having the Format.formatter as first parameter (Grammar.Entry.print + and its equivalent in functorial interface call it). +- [05 Feb 02] Added a flag Plexer.no_quotations. When set to True, the + quotations are no more lexed in all lexers built by Plexer.make () +- [05 Feb 02] Changed the printing of options so that the option -help + aligns correctly their documentation. One can use now Pcaml.add_option + without having to calculate that. +- [05 Feb 02] pr_r.cmo: now the option -ncip (no comments in phrases) is + by default, because its behaviour is not 100% sure. An option -cip has + been added to set it. +- [03 Feb 02] Added function Stdpp.line_of_loc returning the line and + columns positions from a character location and a file. +- [01 Feb 02] Fixed bug in token.ml: the location function provided by + lexer_func_of_parser, lexer_func_of_ocamllex and make_stream_and_location + could raise Invalid_argument "Array.make" for big files if the number + of read tokens overflows the maximum arrays size (Sys.max_array_length). + The bug is not really fixed: in case of this overflow, the returned + location is (0, 0) (but the program does not fail). +- [28 Jan 02] Fixed bug in pa_o when parsing class_types. A horrible hack + had to be programmed to be able to treat them correctly. +- [28 Jan 02] Fixed bug in OCaml toplevel when loading camlp4: the directives + were not applied in the good order. +- [26 Jan 02] The printer pr_extend.cmo try now also to rebuild GEXTEND + statements (before it tried only the EXTEND). +- [23 Jan 02] The empty functional stream "fstream [: :]" is now of type + 'a Fstream.t thanks to the new implementation of lazies allowing to + create polymorphic lazy values. +- [11 Jan 02] Added a test in grammars using Plexer that a keyword is not + used also as parameter of a LIDENT or a UIDENT. +- [04 Jan 02] Fixed bug in pa_sml (SML syntax): the function definitions + with several currified parameters did not work. It works now, but the + previous code was supposed to treat let ("fun" in SML syntax) definitions + of infix operators, what does not work any more now. +- [04 Jan 02] Alain Frisch's contribution: + Added pa_ocamllex.cma, syntax for ocamllex files. The command: + camlp4 pa_ocamllex.cmo pr_o.cmo -ocamllex -impl foo.mll > foo.ml + does the same thing as: + ocamllex foo.mll + Allow to compile directly mll files. Without option -ocamllex, allow + to insert lex rules in a ml file. +- [29 Dec 01] Added variable "inter_phrases" in Pcaml, of type ref (option + string) to specify the string to print between phrases in pretty printers. + The default is None, meaning to copy the inter phrases from the source + file. + +Camlp4 Version 3.04 +------------------- + +- [07 Dec 01] Added Pcaml.parse_interf and Pcaml.parse_implem, hooks to + specify the parsers tof use, i.e. now can use other parsing technics + than the Camlp4 grammar system. +- [27 Nov 01] Fixed functions Token.eval_char and Token.eval_string which + returned bad values, resulting lexing of backslash sequences incompatible + with OCaml (e.g. "\1" returned "\001" (one character) but OCaml returns + the string of the two characters \ and 1). +- [15 Nov 01] In revised syntax, in let binding in sequences, the "in" + can be replaced by a semicolon; the revised syntax printer pr_r.cmo + now rather prints a semicolon there. +- [07 Nov 01] Added the ability to use $ as token: was impossible so far, + because of AST quotation uses it for its antiquotation. The fix is just + a little (invisible) change in Plexer. +- [05 Nov 01] Added option -tc (types comment) when using pr_o or pr_r + try to print comments inside sum and record types like they are in + the source (not by default, because may work incorrectly). +- [05 Nov 01] Added option -ca (comment after) when using pr_o or pr_r: + print ocamldoc comments after the declarations, when they are before. +- [04 Nov 01] Added locations for variants and labels declarations in AST + (file MLast.mli). +- [03 Nov 01] In pretty printers pr_o and pr_r, skip to next begin of line + when displaying the sources between phrase, to prevent e.g. the displaying + of the possible last comment of a sum type declaration (the other comment + being not displayed anyway). +- [24 Oct 01] Fixed incorrect locations in sequences. +- [24 Oct 01] Was erroneously compiled by the OCaml boot compiler instead + of the generated ocamlc. Fixed. +- [15 Oct 01] Fixed some parsing differences between pa_o and ocamlyacc: + in parsers, in labels. +- [12 Oct 01] Added missing bigarray syntax a.{b} (and Cie) in standard + syntax (pa_o). + +Camlp4 Version 3.03 +------------------- + +- [09 Oct 01] Fixed bug: the token !$ did not work. Fixed and completed + some syntaxes of labels patterns. Added missing case in exception + declaration (exception rebinding). +- [05 Oct 01] Fixed bug in normal syntax: when defining a constructor + named "True" of "False" (capitalized, i.e. not like the booleans), it + did not work. +- [04 Oct 01] Fixed some revised and quotation syntaxes in objects classes + and types (cleaner). Cleaned up also several parts of the parsers. +- [02 Oct 01] In revised syntax, the warning for using old syntax for + sequences is now by default. To remove it, the option -no-warn-seq + of camlp4r has been added. Option -warn-seq has been removed. +- [07 Sep 01] Included Camlp4 in OCaml distribution. +- [06 Sep 01] Added missing pattern construction #t +- [05 Sep 01] Fixed bug in pa_o: {A.B.c = d} was refused. +- [26 Aug 01] Fixed bug: in normal and revised syntaxes, refused -1.0 + (minus float) as pattern. +- [24 Aug 01] Fixed bug: (a : b :> c) and ((a : b) :> c) were parsed + identically. +- [20 Aug 01] Fixed configure script for Windows configuration. +- [10 Aug 01] Fixed bug: <:expr< 'a' >> did not work because of a typing + problem. +- [10 Aug 01] Fixed bug in compilation process under Windows: the use of + the extension .exe was missing in several parts in Makefiles and shell + scripts. +- [09 Aug 01] Changed message error in grammar: in the case when the rule + is: ....; tok1; tok2; .. tokn; ... (n terminal tokens following each other), + where the grammar is locally LL(n), it displays now: + tok1 tok2 .. tokn expected + instead of just + tok1 expected + because "tok1" can be correct in the input, and in this case, the message + underscored the tok1 and said "tok1 expected". +- [07 Aug 01] When camlp4r.cma is loaded in the toplevel, the results are + now displayed in revised syntax. +- [04 Aug 01] Added syntax "declare..end" in quotations class_str_item and + class_sig_item to be able to generate several items from one only item + (like in str_item and sig_item). + +Camlp4 Version 3.02 +------------------- + +- [21 Jul 01] Fixed bug: <:expr< { l = x } >> was badly built and resulted + in a typing error. +- [13 Jul 01] Fixed bug: did not accept floats in patterns. +- [11 Jul 01] Added function Pcaml.top_printer to be able to use the + printers Pcaml.pr_expr, Pcaml.pr_patt, and so on for the #install_printer + of OCaml toplevel. Ex: + let f = Pcaml.top_printer Pcaml.pr_expr;; + #install_printer f;; + #load "pr_o.cmo";; +- [24 Jun 01] In grammars, added symbol ANY, returning the current token, + whichever it is. +- [24 Jun 01] In grammars, a rule list of the form [ s1 | s2 | .. | sn ] + is interpreted as [ x = s1 -> x | x = s2 -> x | .. x = sn -> x ] + instead of [ _ = s1 -> () | _ = s2 -> () .. ] +- [24 Jun 01] Moved the functions [Plexer.char_of_char_token] and + [Plexer.string_of_string_token] into module [Token] with names + [Token.eval_char] and [Token.eval_string]. +- [22 Jun 01] Added warning when using old syntax for sequences, while + and do (do..return, do..done) in predefined quotation expr. +- [22 Jun 01] Changed message for unbound quotations (more clear). + +Camlp4 Version 3.01.6: +---------------------- + +- [22 Jun 01] Changed the module Pretty into Spretty. +- [21 Jun 01] Camlp4 can now be compiled even if OCaml is not installed: + in the directory "config", the file "configure_batch" is a possibility + to configure the compilation (alternative of "configure" of the top + directory) and has a parameter "-ocaml-top" to specify the OCaml top + directory (relative to the camlp4/config directory). +- [21 Jun 01] The interactive "configure" now tests if the native-code + compilers ocamlc.opt and ocamlopt.opt are accessible and tell the + Makefile to preferably use them if they are. +- [16 Jun 01] The syntax tree for strings and characters now represent their + exact input representation (the node for characters is now of type string, + no more char). For example, the string "a\098c" remains "a\098c" and is + *not* converted into (the equivalent) "abc" in the syntax tree. The + convertion takes place when converting into OCaml tree representation. + This has the advantage that the pretty print now display them as they + are in the input file. To convert from input to real representation + (if needed), two functions have been added: Plexer.string_of_string_token + and Plexer.char_of_char_token. +- [10 Jun 01] In revised syntax, added ability to write {foo x = y} as short + form for {foo = fun x -> y}. +- [08 Jun 01] Completed missing cases in pa_extfun.cmo for variants. +- [06 Jun 01] Completed missing cases in abstract syntax tree and in normal + syntax parser pa_o.ml (about classes). +- [06 Jun 01] Fixed bug in pa_o.cmo (parser of normal syntax): (~~) did not + work, and actually all prefix operators between parentheses. + +Camlp4 Version 3.01.5: +---------------------- + +- [04 Jun 01] Fixed bug: when using "include" in a structure item the rest + of the structure was lost. +- [31 May 01] Added ability to user #load and #directory inside ml or mli + files to specify a cmo file to be loaded (for syntax extension) or the + directory path (like option -I). Same semantics than in toplevel. +- [29 May 01] The name of the location variable used in grammars (action + parts of the rules) and in the predefined quotations for OCaml syntax + trees is now configurable in Stdpp.loc_name (string reference). Added also + option -loc to set this variable. Default: loc. +- [26 May 01] Added functional streams: a library module Fstream and a syntax + kit: pa_fstream.cmo. Syntax: + streams: fstream [: ... :] + parsers: fparser [ [: ... :] -> ... | ... ] +- [25 May 01] Added function Token.lexer_func_of a little bit more general + than Token.lexer_func_of_parser. + +Camlp4 Version 3.01.4: +---------------------- + +- [20 May 01] Fixed bug: pr_rp and pr_op could generate bound variables + resulting incorrect program: + (e.g. fun s -> parser [: `_; x :] -> s x was printed: + fun s -> parser [: `_; s :] -> s s) +- [19 May 01] Small improvement in pretty.ml resulting a faster print (no + more stacked HOVboxes which printers pr_r and pr_o usually generate in + expr, patt, ctyp, etc.) +- [18 May 01] Added [lexer_func_of_parser] and [lexer_func_of_ocamllex] + in module [Token] to create lexers functions from char stream parsers + or from [ocamllex] lexers. +- [16 May 01] Pretty printing with pr_r.cmo (revised syntax) now keep + comments inside phrases. +- [15 May 01] Changed pretty printing system, using now new extensible + functions of Camlp4. +- [15 May 01] Added library module Extfun for extensible functions, + syntax pa_extfun, and a printer pr_extfun. +- [12 May 01] Fixed bug: missing cases in pr_o and pr_r for in cases of + "for", "while", and some other expressions, when between parentheses. + +Camlp4 Version 3.01.3: +---------------------- + +- [04 May 01] Put back the syntax "do ... return ..." in predefined + quotation "expr", to be able to compile previous programs. Work + only if the quotation is in position of expression, not in pattern. +- [04 May 01] Added lisp syntax pa_lisp.cmo (not terminated). +- [01 May 01] Fixed bug: in toplevel, in case of syntax error in #use, + the display was incorrect: it displayed the input, instead of the + file location. + +Camlp4 Version 3.01.2: +---------------------- + +- [27 Apr 01] Added variable Grammar.error_verbose and option -verbose of + command camlp4 to display more information in case of parsing error. +- [27 Apr 01] Fixed bug: the locations in sequences was not what expected + by OCaml, resulting on bad locations displaying in case of typing error. +- [27 Apr 01] Fixed bug: in normal syntax, the sequence was parsed + of left associative instead of right associative, resulting bad pretty + printing. + +Camlp4 Version 3.01.1: +---------------------- + +- [19 Apr 01] Added missing new feature "include" (structure item). +- [17 Apr 01] Changed revised syntax of sequences. Now: + do { expr1; expr2 ..... ; exprn } + for patt = expr to/downto expr do { expr1; expr2 ..... ; exprn } + while expr do { expr1; expr2 ..... ; exprn } + * If holding a "let ... in", the scope applies up to the end of the sequence. + * The old syntax "do .... return ..." is still accepted. + * In expr quotation, it is *not* accepted. To ensure backward + compatibility, use ifdef NEWSEQ, which answers True from this version. + * The printer pr_r.cmo by default prints with this new syntax. + * To print with old syntax, use option -old_seq. + * To get a warning when using old syntax, use option -warn_seq. + +Camlp4 Version 3.01: +-------------------- + +- [5 Mar 01] In pa_o.ml fixed problem, did not parse: + class ['a, 'b] cl a b : ['a, 'b] classtype +- [9 Oct 00] Raise now Stream.Error when parsing with an empty entry (meaning + that the user probably forgot to initialize it). +- [21 Jul 00] Fixed (pr_o.cmo) pb of bad printing of + let (f : unit -> int) = fun () -> 1 +- [10 Jun, 21 Jul 00] Added Pcaml.sync to synchronize after syntax error in + toplevel. +- [24 May 00] Changed the "make opt", returning to what was done in the + previous releases, i.e. just the compilation of the library (6 files). + The native code compilation of "camlp4o" and "camlp4r" are not absolutely + necessary and can create problems in some systems because of too long code. + The drawbacks are more important than the advantages. +- [19 May 00] Changed option -split_gext (when pa_extend.cmo is loaded) into + -split_ext: it applies now also for non functorial grammars (extended by + EXTEND instead of GEXTEND). +- [12 May 00] Fixed problem in pr_rp.cmo and pr_op.cmo: the pretty printing + of the construction "match x with parser" did not work (because of the + type constraint "Stream.t _" added some versions ago). + +Camlp4 Version 3.00: +-------------------- + +- [Apr 19, 00] Added "pa_olabl" for labels with old Olabl syntax. +- [Apr 18, 00] Make opt now builds camlp4o.opt and camlp4r.opt +- [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: + ( operator ) + ( expr ) + with the problem of "( - )" as: + "("; "-"; ")" + "("; operator; ")" + "("; expr; ")" + after factorization of the "(", the rule "-"; ")" is locally LL(2): it + works for this reason. In the previous implementation, a hack had to be + added for this case. + + To allow this, the interface of "Token" changed. The field "tparse" is + now of type "pattern -> option (Stream.t t -> string)" instead of + "pattern -> Stream.t t -> string". Set it to "None" for standard pattern + parsing (or if you don't know). + +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. + +Camlp4 Version 2.03: +-------------------- + +* pr_depend: + - [Jun 25, 99] Added missing case in "pr_depend.cmo": pattern A.B.C. + - [Jun 5, 99] Fixed in "pr_depend.ml" case expression "Foo.Bar" displaying a + bad dependency with file "bar.ml" if existed. And changed "pa_r.ml" + (revised syntax parsing) to generate a more logical ast for case + "var.Mod.lab". + - [Apr 29, 99] Added missing cases in "pr_o.cmo" and in "pr_depend.cmo". + - [Mar 11, 99] Added missing cases in "pr_depend.cmo". + - [Mar 9, 99] Added missing case in pr_depend.ml. + +* Other: + - [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. + - [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 + - [May 10, 99] Added shell script "configure_batch" in directory "config". + - [May 10, 99] Changed LICENSE to BSD. + - [Apr 29, 99] Added "ifdef" for mli files. + - [Apr 11, 99] Changed option "-no_cp" into "-sep" in pr_r.cmo and pr_o.cmo. + - [Apr 11, 99] Fixed (old) bug: too long strings where bad pretty printed. + - [Mar 24, 99] Added missing stream type constraint for parsers. + - [Mar 17, 99] Changed template Makefile to use ocamlc.opt and ocamlopt.opt + by default, instead of ocamlc and ocamlopt. + - [Mar 9, 99] Added ifndef in pa_ifdef.ml. + - [Mar 7, 99] Completed and fixed some cases in pr_extend.ml. + +Camlp4 Version 2.02: +-------------------- + +* Parsing: + - [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 + +* Printing: + - [Mar 4, 99] Added pr_depend.cmo for printing file dependencies. + - [Dec 28, 98] Fixed pretty printing of long strings starting with spaces; + used to display "\\n..." instead of "\\n...". + +* Camlp4: + - [Feb 19, 99] Sort command line argument list in reverse order to + avoid argument names conflicts when adding arguments. + +* Olabl: + - [Feb 26, 99] Started extensions for Olabl: directory "lablp4" and some + changes in MLast. Olabl programs can be preprocessed by: + camlp4 pa_labl.cma pr_ldump.cmo + +* Internal: + - Use of pr_depend.cmo instead of ocamldep for dependencies. + +Camlp4 Version 2.01: +-------------------- + +Token interface +* Big change: the type for tokens and tokens patterns is now (string * string) + the first string being the constructor name and the second its possible + parameters. No change in EXTEND statements using Plexer. But lexers + have: + - a supplementary parameter "tparse" to specify how to parse token + from token patterns. + - fields "using" and "removing" replacing "add_keyword" and + "remove_keyword". + See the file README-2.01 for how to update your programs and the interface + of Token. + +Grammar interface +* The function "keywords" have been replaced by "tokens". The equivalent + of the old statement: + Grammar.keywords g + is now: + Grammar.tokens g "" + +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 + +Compilation +* Added "make scratch" +* Changed Makefile. No more "make T=../", working bad in some systems. +* Some changes to make compilation in Windows 95/98 working better (thanks + to Patricia Peratto). + +Classes and objects +* Added quotations for classes and objects (q_MLast.ml) +* Added accessible entries in module Pcaml (class_type, class_expr, etc.) +* Changed classes and objects types in definition (module MLast) + +Miscelleneous +* Some adds in pa_sml.cmo. Thanks to Franklin Chen. +* Added option "-no_cp" when "pr_o.cmo" or "pr_r.cmo" is loaded: do + not print comments between phrases. +* Added option "-split_gext" when "pa_extend.cmo" is loaded: split GEXTEND + by functions to turn around a PowerPC problem. + +Bug fixes +* Fixed pa_r.cmo, pa_o.cmo to parse, and pr_r.cmo, pr_o.cmo to print "(x:#M.c)" +* Fixed printing pr_o.cmo of "(a.b <- 1)::1" +* Extended options with parameters worked only when the parameter was sticked. + Ex: + camlp4o pr_o.cmo -l120 foo.ml + worked, but not: + camlp4o pr_o.cmo -l 120 foo.ml + +Camlp4 Version 2.00: +-------------------- + +* Designation "righteous" has been renamed "revised". +* 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. + +Camlp4 Version 2.00--1: +----------------------- + +* 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. +* No objects and classes in this version. + +* Added "let module" parsing and printing. +* Added arrays patterns parsing and printing. +* Added records with "with" "{... with ...}" parsing and printing + +* Added # num "string" in plexer (was missing). +* Fixed bug in pr_o.cmo: module A = B (C);; was printed module A = B C;; +* Added "pa_sml.cmo", SML syntax + "lib.sml" +* Fixed bug in pa_r.ml and pa_o.ml: forgot to clear let_binding +* Changed Plexer: unknown keywords do not raise error but return Tterm +* q_MLast.cmo: suppressed <:expr< [$list:el$] >> (cannot work) +* Added option "-no_ss" (no ;;) when "pr_o.cmo" loaded +* Many changes and bug fixing in pretty printing pr_o.cmo and pr_r.cmo +* Command ocpp works now without having to explicitely load + "/usr/local/lib/ocaml/stdlib.cma" and + "/usr/local/lib/camlp4/gramlib.cma" + +* Fixed problem of pretty print "&" and "or" in normal and righteous syntaxes +* 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. +* Same change in righteous syntax, by symmetry. + +Camlp4 Version 1.07.2: +---------------------- + +Errors and missings in normal and righteous syntaxes. + +* Added forgotten syntax (righteous): type constraints in class type fields. +* 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 in Windows NT/95: problem in backslash before newlines in strings + +Grammars, EXTEND, DELETE_RULE + +* Added functorial version for grammars (started in version 1.07.1, + completed in this version). +* Added statements GEXTEND and GDELETE_RULE in pa_extend.cmo for functorial + version. +* EXTEND statement is added AFTER "top" instead of LEVEL "top" (because + of problems parsing "a; EXTEND...") +* Added ability to have expressions (in antiquotation form) of type string in + EXTEND after keywords "LIDENT", "UIDENT", "IDENT", "ANTIQUOT", "INT" as + in others constructions inside EXTEND. +* A grammar rule hidden by another is not deleted but just masked. DELETE_RULE + will restore the old version. +* DELETE_RULE now raises Not_found if no rule matched. +* Fixed bug: DELETE_RULE did not work when deleting a rule which is a prefix of + another rule. +* Some functions for "system use" in [Grammar] become "official": + [Entry.obj], [extend], [delete_rule]. + +Command line, man page + +* Added option -o: output on file instead of standard output, necessary + to allow compilation in Windows NT/95 (in fact, this option exists since + 1.07.1 but forgotten in its "changes" list). +* Command line option -help more complete. +* Updated man page: camlp4 options are better explained. +* Fixed bug: "camlp4 [other-options] foo.ml" worked but not + "camlp4 foo.ml [other-options]". +* Fixed bug: "camlp4 foo" did not display a understandable error message. + +Camlp4's compilation + +* Changes in compilation process in order to try to make it work better for + Windows NT under Cygnus. + +Miscellaneous + +* Added [Pcaml.add_option] for adding command line options. + +Camlp4 Version 1.07.1: +---------------------- + +* Added forgotten syntax in pr_o: type x = y = A | B +* Fixed bug negative floats parsing in pa_o => error while pretty printing +* Added assert statement and option -noassert. +* 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 +* 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 + +Camlp4 Version 1.07: +-------------------- + +* Changed version number + configuration script +* 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). +* 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) +* 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) +* Modified odyl implementation; works better +* Added ability to extend command line specification +* Added "let_binding" as predefined (accessible) entry in Pcaml. +* Added construction FUNCTION in EXTEND statement to call another function. +* Added some ISO-8859-1 characters in lexer identifiers. +* Fixed bug "value x = {val = 1};" (righteous syntax) +* Fixed bug "open A.B.C" was interpreted as "open B.A.C" +* Modified behavior of "DELETE_RULE": the complete rule must be provided +* Completed quotations MLast ("expr", "patt", etc) to accept whole language +* Renamed "LIKE" into "LEVEL" in grammar EXTEND +* Added "NEXT" as grammar symbol in grammar EXTEND +* Added command "mkcamlp4" to make camlp4 executables linked with C code +* Added "pr_extend.cmo" to reconstitute EXTEND instructions + +Camlp4 Version 0.6: +------------------- + +--- Installing + +* To compile camlp4, it is no more necessary to have the sources of the + Objective Caml compiler available. It can be compiled like any other + Objective Caml program. + +--- Options of "camlp4" + +* Added option -where: "camlp4 -where" prints the name of the standard + library directory of Camlp4 and exit. So, the ocaml toplevel and the + compiler can use the option: + -I `camlp4 -where` + +* Added option -nolib to not search for objects files in the installed + library directory of Camlp4. + +--- Interface of grammar library modules + +* The function Grammar.keywords returns now a list of pairs. The pair is + composed of a keyword and the number of times it is used in entries. + +* Changed interface of Token and Grammar for lexers, so user lexers have + to be changed. + +--- New features in grammars + +* New instruction "DELETE_RULE" provided by pa_extend.cmo to delete rules. + Ex: + DELETE_RULE Pcaml.expr: "if" END; + deletes the "if" instruction of the language. + +* Added the ability to parse some specific integer in grammars: a possible + parameter to INT, like the ones for LIDENT and UIDENT. + +* In instruction EXTEND, ability to omit "-> action", default is "-> ()" + +* Ability to add antiquotation (between $'s) as symbol rule, of type string, + interpreted as a keyword, in instruction EXTEND. + +* Ability to put entries with qualified names (Foo.bar) in instruction EXTEND. + +--- Quotations + +* The module Ast has been renamed MLast. The quotation expander "q_ast.cmo" + has been renamed "q_MLast.cmo". + +* Quotation expanders are now of two kinds: + - The "classical" type for expanders returning a string. These expanders + have now a supplementary parameter: a boolean value set to "True" + when the quotation is in a context of an expression an to "False" + 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). + - 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 + extensions used. + +* The predefined quotation expanders "ctyp_", "patt_" and "expr_" has + been deleted; one can use "ctyp", "patt", and "expr" in position of + pattern or expression. + +--- 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 + level. + +--- Grammars behavior + +* While extending entries: default position is now "extension of the + first level", instead of "adding a new level at the end". + +* Another Change: in each precedence level, terminals are inserted before + other symbols (non terminals, lists, options, etc), LIDENT "foo" before + LIDENT (alone) and UIDENT "foo" before UIDENT (alone). New rules not + factorizable are now inserted before the other rules. + +* Changed algorithm of entries parsing: each precedence level is tested + against the stream *before* its next precedences levels (instead of + *after*): + EXTEND e: [[ LIDENT "a" -> "xxx" ] | [ i = LIDENT -> i ]]; END; + Now, parsing the entry e with the string "a" returns "xxx" instead of "a" + +* Less keywords in instruction EXTEND (LEFTA, LIDENT, etc), which can be + used now as normal identifiers. + +* When inserting a new rule, a warning appears if a rule with the + same production already existed (it is deleted). + +* Parse error messages (Gstream.Error) are formatted => spaces trigger + Format.print_space and newlines trigger Format.force_newline. + + +Camlp4 Version 0.5: +------------------- + +* Possible creation of native code library (make opt) + +* OCaml and Righteous Syntax more complete + +* Added pa_ru.cmo for compiling sequences of type unit (Righteous) + +* Quotations AST + - No more quotation long_id + - Antiquotations for identifiers more simple + +* Lot of small changes + + +Camlp4 Version 0.4: +------------------- + +* First distributed version diff --git a/camlp4/Camlp4.mlpack b/camlp4/Camlp4.mlpack new file mode 100644 index 0000000..7ccb28f --- /dev/null +++ b/camlp4/Camlp4.mlpack @@ -0,0 +1,10 @@ +Debug +ErrorHandler +OCamlInitSyntax +Options +PreCast +Printers +Register +Sig +Struct +Utils diff --git a/camlp4/Camlp4/Camlp4Ast.partial.ml b/camlp4/Camlp4/Camlp4Ast.partial.ml new file mode 100644 index 0000000..c22026f --- /dev/null +++ b/camlp4/Camlp4/Camlp4Ast.partial.ml @@ -0,0 +1,428 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Note: when you modify these types you must increment + ast magic numbers defined in Camlp4_config.ml. *) + + type loc = Loc.t + and meta_bool = + [ BTrue + | BFalse + | BAnt of string ] + and rec_flag = + [ ReRecursive + | ReNonrecursive + | ReNil + | ReAnt of string ] + and direction_flag = + [ DiTo + | DiDownto + | DiAnt of string ] + and mutable_flag = + [ MuMutable + | MuNil + | MuAnt of string ] + and private_flag = + [ PrPrivate + | PrNil + | PrAnt of string ] + and virtual_flag = + [ ViVirtual + | ViNil + | ViAnt of string ] + and override_flag = + [ OvOverride + | OvNil + | OvAnt of string ] + and row_var_flag = + [ RvRowVar + | RvNil + | RvAnt of string ] + and meta_option 'a = + [ ONone + | OSome of 'a + | OAnt of string ] + and meta_list 'a = + [ LNil + | LCons of 'a and meta_list 'a + | LAnt of string ] + and ident = + [ IdAcc of loc and ident and ident (* i . i *) + | IdApp of loc and ident and ident (* i i *) + | IdLid of loc and string (* foo *) + | IdUid of loc and string (* Bar *) + | IdAnt of loc and string (* $s$ *) ] + and ctyp = + [ TyNil of loc + | TyAli of loc and ctyp and ctyp (* t as t *) (* list 'a as 'a *) + | TyAny of loc (* _ *) + | TyApp of loc and ctyp and ctyp (* t t *) (* list 'a *) + | TyArr of loc and ctyp and ctyp (* t -> t *) (* int -> string *) + | TyCls of loc and ident (* #i *) (* #point *) + | TyLab of loc and string and ctyp (* ~s:t *) + | TyId of loc and ident (* i *) (* Lazy.t *) + | TyMan of loc and ctyp and ctyp (* t == t *) (* type t = [ A | B ] == Foo.t *) + (* type t 'a 'b 'c = t constraint t = t constraint t = t *) + | TyDcl of loc and string and list ctyp and ctyp and list (ctyp * ctyp) + (* type t 'a 'b 'c += A *) + | TyExt of loc and ident and list ctyp and ctyp + (* < (t)? (..)? > *) (* < move : int -> 'a .. > as 'a *) + | TyObj of loc and ctyp and row_var_flag + | TyOlb of loc and string and ctyp (* ?s:t *) + | TyPol of loc and ctyp and ctyp (* ! t . t *) (* ! 'a . list 'a -> 'a *) + | TyTypePol of loc and ctyp and ctyp (* type t . t *) (* type a . list a -> a *) + | TyQuo of loc and string (* 's *) + | TyQuP of loc and string (* +'s *) + | TyQuM of loc and string (* -'s *) + | TyAnP of loc (* +_ *) + | TyAnM of loc (* -_ *) + | TyVrn of loc and string (* `s *) + | TyRec of loc and ctyp (* { t } *) (* { foo : int ; bar : mutable string } *) + | TyCol of loc and ctyp and ctyp (* t : t *) + | TySem of loc and ctyp and ctyp (* t; t *) + | TyCom of loc and ctyp and ctyp (* t, t *) + | TySum of loc and ctyp (* [ t ] *) (* [ A of int and string | B ] *) + | TyOf of loc and ctyp and ctyp (* t of t *) (* A of int *) + | TyAnd of loc and ctyp and ctyp (* t and t *) + | TyOr of loc and ctyp and ctyp (* t | t *) + | TyPrv of loc and ctyp (* private t *) + | TyMut of loc and ctyp (* mutable t *) + | TyTup of loc and ctyp (* ( t ) *) (* (int * string) *) + | TySta of loc and ctyp and ctyp (* t * t *) + | TyVrnEq of loc and ctyp (* [ = t ] *) + | TyVrnSup of loc and ctyp (* [ > t ] *) + | TyVrnInf of loc and ctyp (* [ < t ] *) + | TyVrnInfSup of loc and ctyp and ctyp (* [ < t > t ] *) + | TyAmp of loc and ctyp and ctyp (* t & t *) + | TyOfAmp of loc and ctyp and ctyp (* t of & t *) + | TyPkg of loc and module_type (* (module S) *) + | TyOpn of loc (* .. *) + | TyAtt of loc and string and str_item and ctyp (* .. [@attr] *) + | TyAnt of loc and string (* $s$ *) + ] + and patt = + [ PaNil of loc + | PaId of loc and ident (* i *) + | PaAli of loc and patt and patt (* p as p *) (* (Node x y as n) *) + | PaAnt of loc and string (* $s$ *) + | PaAny of loc (* _ *) + | PaApp of loc and patt and patt (* p p *) (* fun x y -> *) + | PaArr of loc and patt (* [| p |] *) + | PaCom of loc and patt and patt (* p, p *) + | PaSem of loc and patt and patt (* p; p *) + | PaChr of loc and string (* c *) (* 'x' *) + | PaInt of loc and string + | PaInt32 of loc and string + | PaInt64 of loc and string + | PaNativeInt of loc and string + | PaFlo of loc and string + | PaLab of loc and string and patt (* ~s or ~s:(p) *) + (* ?s or ?s:(p) *) + | PaOlb of loc and string and patt + (* ?s:(p = e) or ?(p = e) *) + | PaOlbi of loc and string and patt and expr + | PaOrp of loc and patt and patt (* p | p *) + | PaRng of loc and patt and patt (* p .. p *) + | PaRec of loc and patt (* { p } *) + | PaEq of loc and ident and patt (* i = p *) + | PaStr of loc and string (* s *) + | PaTup of loc and patt (* ( p ) *) + | PaTyc of loc and patt and ctyp (* (p : t) *) + | PaTyp of loc and ident (* #i *) + | PaVrn of loc and string (* `s *) + | PaLaz of loc and patt (* lazy p *) + | PaAtt of loc and string and str_item and patt (* .. [@attr] *) + | PaMod of loc and string (* (module M) *) + | PaExc of loc and patt (* exception p *) ] + and expr = + [ ExNil of loc + | ExId of loc and ident (* i *) + | ExAcc of loc and expr and expr (* e.e *) + | ExAnt of loc and string (* $s$ *) + | ExApp of loc and expr and expr (* e e *) + | ExAre of loc and expr and expr (* e.(e) *) + | ExArr of loc and expr (* [| e |] *) + | ExSem of loc and expr and expr (* e; e *) + | ExAsf of loc (* assert False *) + | ExAsr of loc and expr (* assert e *) + | ExAss of loc and expr and expr (* e := e *) + | ExChr of loc and string (* 'c' *) + | ExCoe of loc and expr and ctyp and ctyp (* (e : t) or (e : t :> t) *) + | ExFlo of loc and string (* 3.14 *) + (* for s = e to/downto e do { e } *) + | ExFor of loc and patt and expr and expr and direction_flag and expr + | ExFun of loc and match_case (* fun [ mc ] *) + | ExIfe of loc and expr and expr and expr (* if e then e else e *) + | ExInt of loc and string (* 42 *) + | ExInt32 of loc and string + | ExInt64 of loc and string + | ExNativeInt of loc and string + | ExLab of loc and string and expr (* ~s or ~s:e *) + | ExLaz of loc and expr (* lazy e *) + (* let b in e or let rec b in e *) + | ExLet of loc and rec_flag and binding and expr + (* let module s = me in e *) + | ExLmd of loc and string and module_expr and expr + (* match e with [ mc ] *) + | ExMat of loc and expr and match_case + (* new i *) + | ExNew of loc and ident + (* object ((p))? (cst)? end *) + | ExObj of loc and patt and class_str_item + (* ?s or ?s:e *) + | ExOlb of loc and string and expr + (* {< rb >} *) + | ExOvr of loc and rec_binding + (* { rb } or { (e) with rb } *) + | ExRec of loc and rec_binding and expr + (* do { e } *) + | ExSeq of loc and expr + (* e#s *) + | ExSnd of loc and expr and string + (* e.[e] *) + | ExSte of loc and expr and expr + (* s *) (* "foo" *) + | ExStr of loc and string + (* try e with [ mc ] *) + | ExTry of loc and expr and match_case + (* (e) *) + | ExTup of loc and expr + (* e, e *) + | ExCom of loc and expr and expr + (* (e : t) *) + | ExTyc of loc and expr and ctyp + (* `s *) + | ExVrn of loc and string + (* while e do { e } *) + | ExWhi of loc and expr and expr + (* let open i in e *) + | ExOpI of loc and ident and override_flag and expr + (* fun (type t) -> e *) + (* let f x (type t) y z = e *) + | ExFUN of loc and string and expr + (* (module ME : S) which is represented as (module (ME : S)) *) + | ExPkg of loc and module_expr + (* e [@attr] *) + | ExAtt of loc and string and str_item and expr + ] + and module_type = + [ MtNil of loc + (* i *) (* A.B.C *) + | MtId of loc and ident + (* (module ident) *) + | MtAlias of loc and ident + (* functor (s : mt) -> mt *) + | MtFun of loc and string and module_type and module_type + (* 's *) + | MtQuo of loc and string + (* sig sg end *) + | MtSig of loc and sig_item + (* mt with wc *) + | MtWit of loc and module_type and with_constr + (* module type of m *) + | MtOf of loc and module_expr + | MtAtt of loc and string and str_item and module_type (* .. [@attr] *) + | MtAnt of loc and string (* $s$ *) ] + and sig_item = + [ SgNil of loc + (* class cict *) + | SgCls of loc and class_type + (* class type cict *) + | SgClt of loc and class_type + (* sg ; sg *) + | SgSem of loc and sig_item and sig_item + (* # s or # s e *) + | SgDir of loc and string and expr + (* exception t *) + | SgExc of loc and ctyp + (* external s : t = s ... s *) + | SgExt of loc and string and ctyp and meta_list string + (* include mt *) + | SgInc of loc and module_type + (* module s : mt *) + | SgMod of loc and string and module_type + (* module rec mb *) + | SgRecMod of loc and module_binding + (* module type s = mt *) + | SgMty of loc and string and module_type + (* open i *) + | SgOpn of loc and override_flag and ident + (* type t *) + | SgTyp of loc and rec_flag and ctyp + (* value s : t *) + | SgVal of loc and string and ctyp + | SgAnt of loc and string (* $s$ *) ] + and with_constr = + [ WcNil of loc + (* type t = t *) + | WcTyp of loc and ctyp and ctyp + (* module i = i *) + | WcMod of loc and ident and ident + (* type t := t *) + | WcTyS of loc and ctyp and ctyp + (* module i := i *) + | WcMoS of loc and ident and ident + (* wc and wc *) + | WcAnd of loc and with_constr and with_constr + | WcAnt of loc and string (* $s$ *) ] + and binding = + [ BiNil of loc + (* bi and bi *) (* let a = 42 and c = 43 *) + | BiAnd of loc and binding and binding + (* p = e *) (* let patt = expr *) + | BiEq of loc and patt and expr + | BiAnt of loc and string (* $s$ *) ] + and rec_binding = + [ RbNil of loc + (* rb ; rb *) + | RbSem of loc and rec_binding and rec_binding + (* i = e *) + | RbEq of loc and ident and expr + | RbAnt of loc and string (* $s$ *) ] + and module_binding = + [ MbNil of loc + (* mb and mb *) (* module rec (s : mt) = me and (s : mt) = me *) + | MbAnd of loc and module_binding and module_binding + (* s : mt = me *) + | MbColEq of loc and string and module_type and module_expr + (* s : mt *) + | MbCol of loc and string and module_type + | MbAnt of loc and string (* $s$ *) ] + and match_case = + [ McNil of loc + (* a | a *) + | McOr of loc and match_case and match_case + (* p (when e)? -> e *) + | McArr of loc and patt and expr and expr + | McAnt of loc and string (* $s$ *) ] + and module_expr = + [ MeNil of loc + (* i *) + | MeId of loc and ident + (* me me *) + | MeApp of loc and module_expr and module_expr + (* functor (s : mt) -> me *) + | MeFun of loc and string and module_type and module_expr + (* struct st end *) + | MeStr of loc and str_item + (* (me : mt) *) + | MeTyc of loc and module_expr and module_type + (* (value e) *) + (* (value e : S) which is represented as (value (e : S)) *) + | MePkg of loc and expr + | MeAtt of loc and string and str_item and module_expr (* .. [@attr] *) + | MeAnt of loc and string (* $s$ *) ] + and str_item = + [ StNil of loc + (* class cice *) + | StCls of loc and class_expr + (* class type cict *) + | StClt of loc and class_type + (* st ; st *) + | StSem of loc and str_item and str_item + (* # s or # s e *) + | StDir of loc and string and expr + (* exception t or exception t = i *) + | StExc of loc and ctyp and meta_option(*FIXME*) ident + (* e *) + | StExp of loc and expr + (* external s : t = s ... s *) + | StExt of loc and string and ctyp and meta_list string + (* include me *) + | StInc of loc and module_expr + (* module s = me *) + | StMod of loc and string and module_expr + (* module rec mb *) + | StRecMod of loc and module_binding + (* module type s = mt *) + | StMty of loc and string and module_type + (* open i *) + | StOpn of loc and override_flag and ident + (* type t *) + | StTyp of loc and rec_flag and ctyp + (* value (rec)? bi *) + | StVal of loc and rec_flag and binding + | StAnt of loc and string (* $s$ *) ] + and class_type = + [ CtNil of loc + (* (virtual)? i ([ t ])? *) + | CtCon of loc and virtual_flag and ident and ctyp + (* [t] -> ct *) + | CtFun of loc and ctyp and class_type + (* object ((t))? (csg)? end *) + | CtSig of loc and ctyp and class_sig_item + (* ct and ct *) + | CtAnd of loc and class_type and class_type + (* ct : ct *) + | CtCol of loc and class_type and class_type + (* ct = ct *) + | CtEq of loc and class_type and class_type + (* $s$ *) + | CtAtt of loc and string and str_item and class_type (* .. [@attr] *) + | CtAnt of loc and string ] + and class_sig_item = + [ CgNil of loc + (* type t = t *) + | CgCtr of loc and ctyp and ctyp + (* csg ; csg *) + | CgSem of loc and class_sig_item and class_sig_item + (* inherit ct *) + | CgInh of loc and class_type + (* method s : t or method private s : t *) + | CgMth of loc and string and private_flag and ctyp + (* value (virtual)? (mutable)? s : t *) + | CgVal of loc and string and mutable_flag and virtual_flag and ctyp + (* method virtual (private)? s : t *) + | CgVir of loc and string and private_flag and ctyp + | CgAnt of loc and string (* $s$ *) ] + and class_expr = + [ CeNil of loc + (* ce e *) + | CeApp of loc and class_expr and expr + (* (virtual)? i ([ t ])? *) + | CeCon of loc and virtual_flag and ident and ctyp + (* fun p -> ce *) + | CeFun of loc and patt and class_expr + (* let (rec)? bi in ce *) + | CeLet of loc and rec_flag and binding and class_expr + (* object ((p))? (cst)? end *) + | CeStr of loc and patt and class_str_item + (* ce : ct *) + | CeTyc of loc and class_expr and class_type + (* ce and ce *) + | CeAnd of loc and class_expr and class_expr + (* ce = ce *) + | CeEq of loc and class_expr and class_expr + (* $s$ *) + | CeAtt of loc and string and str_item and class_expr (* .. [@attr] *) + | CeAnt of loc and string ] + and class_str_item = + [ CrNil of loc + (* cst ; cst *) + | CrSem of loc and class_str_item and class_str_item + (* type t = t *) + | CrCtr of loc and ctyp and ctyp + (* inherit(!)? ce (as s)? *) + | CrInh of loc and override_flag and class_expr and string + (* initializer e *) + | CrIni of loc and expr + (* method(!)? (private)? s : t = e or method(!)? (private)? s = e *) + | CrMth of loc and string and override_flag and private_flag and expr and ctyp + (* value(!)? (mutable)? s = e *) + | CrVal of loc and string and override_flag and mutable_flag and expr + (* method virtual (private)? s : t *) + | CrVir of loc and string and private_flag and ctyp + (* value virtual (mutable)? s : t *) + | CrVvr of loc and string and mutable_flag and ctyp + | CrAnt of loc and string (* $s$ *) ]; diff --git a/camlp4/Camlp4/Debug.ml b/camlp4/Camlp4/Debug.ml new file mode 100644 index 0000000..3a00cfd --- /dev/null +++ b/camlp4/Camlp4/Debug.ml @@ -0,0 +1,64 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) +(* camlp4r *) +open Format; + +module Debug = struct value mode _ = False; end; + +type section = string; + +value out_channel = + try + let f = Sys.getenv "CAMLP4_DEBUG_FILE" in + open_out_gen [Open_wronly; Open_creat; Open_append; Open_text] + 0o666 f + with + [ Not_found -> Pervasives.stderr ]; + +module StringSet = Set.Make String; + +value mode = + try + let str = Sys.getenv "CAMLP4_DEBUG" in + let rec loop acc i = + try + let pos = String.index_from str i ':' in + loop (StringSet.add (String.sub str i (pos - i)) acc) (pos + 1) + with + [ Not_found -> + StringSet.add (String.sub str i (String.length str - i)) acc ] in + let sections = loop StringSet.empty 0 in + if StringSet.mem "*" sections then fun _ -> True + else fun x -> StringSet.mem x sections + with [ Not_found -> fun _ -> False ]; + +value formatter = + let header = "camlp4-debug: " in + let at_bol = ref True in + (make_formatter + (fun buf pos len -> + for i = pos to pos + len - 1 do + if at_bol.val then output_string out_channel header else (); + let ch = buf.[i]; + output_char out_channel ch; + at_bol.val := ch = '\n'; + done) + (fun () -> flush out_channel)); + +value printf section fmt = fprintf formatter ("%s: " ^^ fmt) section; diff --git a/camlp4/Camlp4/Debug.mli b/camlp4/Camlp4/Debug.mli new file mode 100644 index 0000000..66990d3 --- /dev/null +++ b/camlp4/Camlp4/Debug.mli @@ -0,0 +1,22 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) +(* camlp4r *) +type section = string; +value mode : section -> bool; +value printf : section -> format 'a Format.formatter unit -> 'a; diff --git a/camlp4/Camlp4/ErrorHandler.ml b/camlp4/Camlp4/ErrorHandler.ml new file mode 100644 index 0000000..562dcb7 --- /dev/null +++ b/camlp4/Camlp4/ErrorHandler.ml @@ -0,0 +1,170 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) +(* camlp4r *) + +open Format; + +module ObjTools = struct + + value desc obj = + if Obj.is_block obj then + "tag = " ^ string_of_int (Obj.tag obj) + else "int_val = " ^ string_of_int (Obj.obj obj); + + (*Imported from the extlib*) + value rec to_string r = + if Obj.is_int r then + let i = (Obj.magic r : int) + in string_of_int i ^ " | CstTag" ^ string_of_int (i + 1) + else (* Block. *) + let rec get_fields acc = + fun + [ 0 -> acc + | n -> let n = n-1 in get_fields [Obj.field r n :: acc] n ] + in + let rec is_list r = + if Obj.is_int r then + r = Obj.repr 0 (* [] *) + else + let s = Obj.size r and t = Obj.tag r in + t = 0 && s = 2 && is_list (Obj.field r 1) (* h :: t *) + in + let rec get_list r = + if Obj.is_int r then [] + else let h = Obj.field r 0 and t = get_list (Obj.field r 1) in [h :: t] + in + let opaque name = + (* XXX In future, print the address of value 'r'. Not possible in + * pure OCaml at the moment. + *) + "<" ^ name ^ ">" + in + let s = Obj.size r and t = Obj.tag r in + (* From the tag, determine the type of block. *) + match t with + [ _ when is_list r -> + let fields = get_list r in + "[" ^ String.concat "; " (List.map to_string fields) ^ "]" + | 0 -> + let fields = get_fields [] s in + "(" ^ String.concat ", " (List.map to_string fields) ^ ")" + | x when x = Obj.lazy_tag -> + (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not + * clear if very large constructed values could have the same + * tag. XXX *) + opaque "lazy" + | x when x = Obj.closure_tag -> + opaque "closure" + | x when x = Obj.object_tag -> + let fields = get_fields [] s in + let (_class, id, slots) = + match fields with + [ [h; h'::t] -> (h, h', t) + | _ -> assert False ] + in + (* No information on decoding the class (first field). So just print + * out the ID and the slots. *) + "Object #" ^ to_string id ^ " (" ^ String.concat ", " (List.map to_string slots) ^ ")" + | x when x = Obj.infix_tag -> + opaque "infix" + | x when x = Obj.forward_tag -> + opaque "forward" + | x when x < Obj.no_scan_tag -> + let fields = get_fields [] s in + "Tag" ^ string_of_int t ^ + " (" ^ String.concat ", " (List.map to_string fields) ^ ")" + | x when x = Obj.string_tag -> + "\"" ^ String.escaped (Obj.magic r : string) ^ "\"" + | x when x = Obj.double_tag -> + Utils.float_repres (Obj.magic r : float) + | x when x = Obj.abstract_tag -> + opaque "abstract" + | x when x = Obj.custom_tag -> + opaque "custom" + | _ -> + failwith ("ObjTools.to_string: unknown tag (" ^ string_of_int t ^ ")") ]; + + value print ppf x = fprintf ppf "%s" (to_string x); + value print_desc ppf x = fprintf ppf "%s" (desc x); + +end; + +value default_handler ppf x = do { + let x = Obj.repr x; + if Obj.tag x <> 0 then + fprintf ppf "Camlp4: Uncaught exception: %s" + (Obj.obj (Obj.field x 0) : string) + else do { + fprintf ppf "Camlp4: Uncaught exception: %s" + (Obj.obj (Obj.field (Obj.field x 0) 0) : string); + if Obj.size x > 1 then do { + pp_print_string ppf " ("; + for i = 1 to Obj.size x - 1 do + if i > 1 then pp_print_string ppf ", " else (); + ObjTools.print ppf (Obj.field x i); + done; + pp_print_char ppf ')' + } + else (); + }; + fprintf ppf "@." +}; + +value handler = ref (fun ppf default_handler exn -> default_handler ppf exn); + +value register f = + let current_handler = handler.val in + handler.val := + fun ppf default_handler exn -> + try f ppf exn with exn -> current_handler ppf default_handler exn; + +module Register (Error : Sig.Error) = struct + let current_handler = handler.val in + handler.val := + fun ppf default_handler -> + fun [ Error.E x -> Error.print ppf x + | x -> current_handler ppf default_handler x ]; +end; + + +value gen_print ppf default_handler = + fun + [ Out_of_memory -> fprintf ppf "Out of memory" + | Assert_failure (file, line, char) -> + fprintf ppf "Assertion failed, file %S, line %d, char %d" + file line char + | Match_failure (file, line, char) -> + fprintf ppf "Pattern matching failed, file %S, line %d, char %d" + file line char + | Failure str -> fprintf ppf "Failure: %S" str + | Invalid_argument str -> fprintf ppf "Invalid argument: %S" str + | Sys_error str -> fprintf ppf "I/O error: %S" str + | Stream.Failure -> fprintf ppf "Parse failure" + | Stream.Error str -> fprintf ppf "Parse error: %s" str + | x -> handler.val ppf default_handler x ]; + +value print ppf = gen_print ppf default_handler; + +value try_print ppf = gen_print ppf (fun _ -> raise); + +value to_string exn = + Format.asprintf "%a" print exn; + +value try_to_string exn = + Format.asprintf "%a" try_print exn; diff --git a/camlp4/Camlp4/ErrorHandler.mli b/camlp4/Camlp4/ErrorHandler.mli new file mode 100644 index 0000000..d8fed08 --- /dev/null +++ b/camlp4/Camlp4/ErrorHandler.mli @@ -0,0 +1,36 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) +value print : Format.formatter -> exn -> unit; + +value try_print : Format.formatter -> exn -> unit; + +value to_string : exn -> string; + +value try_to_string : exn -> string; + +value register : (Format.formatter -> exn -> unit) -> unit; + +module Register (Error : Sig.Error) : sig end; + +module ObjTools : sig + value print : Format.formatter -> Obj.t -> unit; + value print_desc : Format.formatter -> Obj.t -> unit; + (*Imported from the extlib*) + value to_string : Obj.t -> string; + value desc : Obj.t -> string; +end; diff --git a/camlp4/Camlp4/OCamlInitSyntax.ml b/camlp4/Camlp4/OCamlInitSyntax.ml new file mode 100644 index 0000000..ae5b900 --- /dev/null +++ b/camlp4/Camlp4/OCamlInitSyntax.ml @@ -0,0 +1,266 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +module Make (Ast : Sig.Camlp4Ast) + (Gram : Sig.Grammar.Static with module Loc = Ast.Loc + with type Token.t = Sig.camlp4_token) + (Quotation : Sig.Quotation with module Ast = Sig.Camlp4AstToAst Ast) +: Sig.Camlp4Syntax with module Loc = Ast.Loc + and module Ast = Ast + and module Token = Gram.Token + and module Gram = Gram + and module Quotation = Quotation += struct + + module Loc = Ast.Loc; + module Ast = Ast; + module Gram = Gram; + module Token = Gram.Token; + open Sig; + + (* Warnings *) + type warning = Loc.t -> string -> unit; + value default_warning loc txt = Format.eprintf " %a: %s@." Loc.print loc txt; + value current_warning = ref default_warning; + value print_warning loc txt = current_warning.val loc txt; + + value a_CHAR = Gram.Entry.mk "a_CHAR"; + value a_FLOAT = Gram.Entry.mk "a_FLOAT"; + value a_INT = Gram.Entry.mk "a_INT"; + value a_INT32 = Gram.Entry.mk "a_INT32"; + value a_INT64 = Gram.Entry.mk "a_INT64"; + value a_LABEL = Gram.Entry.mk "a_LABEL"; + value a_LIDENT = Gram.Entry.mk "a_LIDENT"; + value a_NATIVEINT = Gram.Entry.mk "a_NATIVEINT"; + value a_OPTLABEL = Gram.Entry.mk "a_OPTLABEL"; + value a_STRING = Gram.Entry.mk "a_STRING"; + value a_UIDENT = Gram.Entry.mk "a_UIDENT"; + value a_ident = Gram.Entry.mk "a_ident"; + value amp_ctyp = Gram.Entry.mk "amp_ctyp"; + value and_ctyp = Gram.Entry.mk "and_ctyp"; + value match_case = Gram.Entry.mk "match_case"; + value match_case0 = Gram.Entry.mk "match_case0"; + value binding = Gram.Entry.mk "binding"; + value class_declaration = Gram.Entry.mk "class_declaration"; + value class_description = Gram.Entry.mk "class_description"; + value class_expr = Gram.Entry.mk "class_expr"; + value class_fun_binding = Gram.Entry.mk "class_fun_binding"; + value class_fun_def = Gram.Entry.mk "class_fun_def"; + value class_info_for_class_expr = Gram.Entry.mk "class_info_for_class_expr"; + value class_info_for_class_type = Gram.Entry.mk "class_info_for_class_type"; + value class_longident = Gram.Entry.mk "class_longident"; + value class_longident_and_param = Gram.Entry.mk "class_longident_and_param"; + value class_name_and_param = Gram.Entry.mk "class_name_and_param"; + value class_sig_item = Gram.Entry.mk "class_sig_item"; + value class_signature = Gram.Entry.mk "class_signature"; + value class_str_item = Gram.Entry.mk "class_str_item"; + value class_structure = Gram.Entry.mk "class_structure"; + value class_type = Gram.Entry.mk "class_type"; + value class_type_declaration = Gram.Entry.mk "class_type_declaration"; + value class_type_longident = Gram.Entry.mk "class_type_longident"; + value class_type_longident_and_param = Gram.Entry.mk "class_type_longident_and_param"; + value class_type_plus = Gram.Entry.mk "class_type_plus"; + value comma_ctyp = Gram.Entry.mk "comma_ctyp"; + value comma_expr = Gram.Entry.mk "comma_expr"; + value comma_ipatt = Gram.Entry.mk "comma_ipatt"; + value comma_patt = Gram.Entry.mk "comma_patt"; + value comma_type_parameter = Gram.Entry.mk "comma_type_parameter"; + value constrain = Gram.Entry.mk "constrain"; + value constructor_arg_list = Gram.Entry.mk "constructor_arg_list"; + value constructor_declaration = Gram.Entry.mk "constructor_declaration"; + value constructor_declarations = Gram.Entry.mk "constructor_declarations"; + value ctyp = Gram.Entry.mk "ctyp"; + value cvalue_binding = Gram.Entry.mk "cvalue_binding"; + value direction_flag = Gram.Entry.mk "direction_flag"; + value direction_flag_quot = Gram.Entry.mk "direction_flag_quot"; + value dummy = Gram.Entry.mk "dummy"; + value entry_eoi = Gram.Entry.mk "entry_eoi"; + value eq_expr = Gram.Entry.mk "eq_expr"; + value expr = Gram.Entry.mk "expr"; + value expr_eoi = Gram.Entry.mk "expr_eoi"; + value field_expr = Gram.Entry.mk "field_expr"; + value field_expr_list = Gram.Entry.mk "field_expr_list"; + value fun_binding = Gram.Entry.mk "fun_binding"; + value fun_def = Gram.Entry.mk "fun_def"; + value ident = Gram.Entry.mk "ident"; + value implem = Gram.Entry.mk "implem"; + value interf = Gram.Entry.mk "interf"; + value ipatt = Gram.Entry.mk "ipatt"; + value ipatt_tcon = Gram.Entry.mk "ipatt_tcon"; + value label = Gram.Entry.mk "label"; + value label_declaration = Gram.Entry.mk "label_declaration"; + value label_declaration_list = Gram.Entry.mk "label_declaration_list"; + value label_expr = Gram.Entry.mk "label_expr"; + value label_expr_list = Gram.Entry.mk "label_expr_list"; + value label_ipatt = Gram.Entry.mk "label_ipatt"; + value label_ipatt_list = Gram.Entry.mk "label_ipatt_list"; + value label_longident = Gram.Entry.mk "label_longident"; + value label_patt = Gram.Entry.mk "label_patt"; + value label_patt_list = Gram.Entry.mk "label_patt_list"; + value labeled_ipatt = Gram.Entry.mk "labeled_ipatt"; + value let_binding = Gram.Entry.mk "let_binding"; + value meth_list = Gram.Entry.mk "meth_list"; + value meth_decl = Gram.Entry.mk "meth_decl"; + value module_binding = Gram.Entry.mk "module_binding"; + value module_binding0 = Gram.Entry.mk "module_binding0"; + value module_declaration = Gram.Entry.mk "module_declaration"; + value module_expr = Gram.Entry.mk "module_expr"; + value module_longident = Gram.Entry.mk "module_longident"; + value module_longident_with_app = Gram.Entry.mk "module_longident_with_app"; + value module_rec_declaration = Gram.Entry.mk "module_rec_declaration"; + value module_type = Gram.Entry.mk "module_type"; + value package_type = Gram.Entry.mk "package_type"; + value more_ctyp = Gram.Entry.mk "more_ctyp"; + value name_tags = Gram.Entry.mk "name_tags"; + value opt_as_lident = Gram.Entry.mk "opt_as_lident"; + value opt_class_self_patt = Gram.Entry.mk "opt_class_self_patt"; + value opt_class_self_type = Gram.Entry.mk "opt_class_self_type"; + value opt_class_signature = Gram.Entry.mk "opt_class_signature"; + value opt_class_structure = Gram.Entry.mk "opt_class_structure"; + value opt_comma_ctyp = Gram.Entry.mk "opt_comma_ctyp"; + value opt_dot_dot = Gram.Entry.mk "opt_dot_dot"; + value row_var_flag_quot = Gram.Entry.mk "row_var_flag_quot"; + value opt_eq_ctyp = Gram.Entry.mk "opt_eq_ctyp"; + value opt_expr = Gram.Entry.mk "opt_expr"; + value opt_meth_list = Gram.Entry.mk "opt_meth_list"; + value opt_mutable = Gram.Entry.mk "opt_mutable"; + value mutable_flag_quot = Gram.Entry.mk "mutable_flag_quot"; + value opt_polyt = Gram.Entry.mk "opt_polyt"; + value opt_private = Gram.Entry.mk "opt_private"; + value private_flag_quot = Gram.Entry.mk "private_flag_quot"; + value opt_rec = Gram.Entry.mk "opt_rec"; + value opt_nonrec = Gram.Entry.mk "opt_nonrec"; + value rec_flag_quot = Gram.Entry.mk "rec_flag_quot"; + value opt_sig_items = Gram.Entry.mk "opt_sig_items"; + value opt_str_items = Gram.Entry.mk "opt_str_items"; + value opt_virtual = Gram.Entry.mk "opt_virtual"; + value virtual_flag_quot = Gram.Entry.mk "virtual_flag_quot"; + value opt_override = Gram.Entry.mk "opt_override"; + value override_flag_quot = Gram.Entry.mk "override_flag_quot"; + value opt_when_expr = Gram.Entry.mk "opt_when_expr"; + value patt = Gram.Entry.mk "patt"; + value patt_as_patt_opt = Gram.Entry.mk "patt_as_patt_opt"; + value patt_eoi = Gram.Entry.mk "patt_eoi"; + value patt_tcon = Gram.Entry.mk "patt_tcon"; + value phrase = Gram.Entry.mk "phrase"; + value poly_type = Gram.Entry.mk "poly_type"; + value row_field = Gram.Entry.mk "row_field"; + value sem_expr = Gram.Entry.mk "sem_expr"; + value sem_expr_for_list = Gram.Entry.mk "sem_expr_for_list"; + value sem_patt = Gram.Entry.mk "sem_patt"; + value sem_patt_for_list = Gram.Entry.mk "sem_patt_for_list"; + value semi = Gram.Entry.mk "semi"; + value sequence = Gram.Entry.mk "sequence"; + value do_sequence = Gram.Entry.mk "do_sequence"; + value sig_item = Gram.Entry.mk "sig_item"; + value sig_items = Gram.Entry.mk "sig_items"; + value star_ctyp = Gram.Entry.mk "star_ctyp"; + value str_item = Gram.Entry.mk "str_item"; + value str_items = Gram.Entry.mk "str_items"; + value top_phrase = Gram.Entry.mk "top_phrase"; + value type_constraint = Gram.Entry.mk "type_constraint"; + value type_declaration = Gram.Entry.mk "type_declaration"; + value type_ident_and_parameters = Gram.Entry.mk "type_ident_and_parameters"; + value type_kind = Gram.Entry.mk "type_kind"; + value type_longident = Gram.Entry.mk "type_longident"; + value type_longident_and_parameters = Gram.Entry.mk "type_longident_and_parameters"; + value type_parameter = Gram.Entry.mk "type_parameter"; + value type_parameters = Gram.Entry.mk "type_parameters"; + value typevars = Gram.Entry.mk "typevars"; + value use_file = Gram.Entry.mk "use_file"; + value val_longident = Gram.Entry.mk "val_longident"; + value value_let = Gram.Entry.mk "value_let"; + value value_val = Gram.Entry.mk "value_val"; + value with_constr = Gram.Entry.mk "with_constr"; + value expr_quot = Gram.Entry.mk "quotation of expression"; + value patt_quot = Gram.Entry.mk "quotation of pattern"; + value ctyp_quot = Gram.Entry.mk "quotation of type"; + value str_item_quot = Gram.Entry.mk "quotation of structure item"; + value sig_item_quot = Gram.Entry.mk "quotation of signature item"; + value class_str_item_quot = Gram.Entry.mk "quotation of class structure item"; + value class_sig_item_quot = Gram.Entry.mk "quotation of class signature item"; + value module_expr_quot = Gram.Entry.mk "quotation of module expression"; + value module_type_quot = Gram.Entry.mk "quotation of module type"; + value class_type_quot = Gram.Entry.mk "quotation of class type"; + value class_expr_quot = Gram.Entry.mk "quotation of class expression"; + value with_constr_quot = Gram.Entry.mk "quotation of with constraint"; + value binding_quot = Gram.Entry.mk "quotation of binding"; + value rec_binding_quot = Gram.Entry.mk "quotation of record binding"; + value match_case_quot = Gram.Entry.mk "quotation of match_case (try/match/function case)"; + value module_binding_quot = Gram.Entry.mk "quotation of module rec binding"; + value ident_quot = Gram.Entry.mk "quotation of identifier"; + value prefixop = Gram.Entry.mk "prefix operator (start with '!', '?', '~')"; + value infixop0 = Gram.Entry.mk "infix operator (level 0) (comparison operators, and some others)"; + value infixop1 = Gram.Entry.mk "infix operator (level 1) (start with '^', '@')"; + value infixop2 = Gram.Entry.mk "infix operator (level 2) (start with '+', '-')"; + value infixop3 = Gram.Entry.mk "infix operator (level 3) (start with '*', '/', '%')"; + value infixop4 = Gram.Entry.mk "infix operator (level 4) (start with \"**\") (right assoc)"; + + EXTEND Gram + top_phrase: + [ [ `EOI -> None ] ] + ; + END; + + module AntiquotSyntax = struct + module Loc = Ast.Loc; + module Ast = Sig.Camlp4AstToAst Ast; + module Gram = Gram; + value antiquot_expr = Gram.Entry.mk "antiquot_expr"; + value antiquot_patt = Gram.Entry.mk "antiquot_patt"; + EXTEND Gram + antiquot_expr: + [ [ x = expr; `EOI -> x ] ] + ; + antiquot_patt: + [ [ x = patt; `EOI -> x ] ] + ; + END; + value parse_expr loc str = Gram.parse_string antiquot_expr loc str; + value parse_patt loc str = Gram.parse_string antiquot_patt loc str; + end; + + module Quotation = Quotation; + + value wrap directive_handler pa init_loc cs = + let rec loop loc = + let (pl, stopped_at_directive) = pa loc cs in + match stopped_at_directive with + [ Some new_loc -> + let pl = + match List.rev pl with + [ [] -> assert False + | [x :: xs] -> + match directive_handler x with + [ None -> xs + | Some x -> [x :: xs] ] ] + in (List.rev pl) @ (loop new_loc) + | None -> pl ] + in loop init_loc; + + value parse_implem ?(directive_handler = fun _ -> None) _loc cs = + let l = wrap directive_handler (Gram.parse implem) _loc cs in + <:str_item< $list:l$ >>; + + value parse_interf ?(directive_handler = fun _ -> None) _loc cs = + let l = wrap directive_handler (Gram.parse interf) _loc cs in + <:sig_item< $list:l$ >>; + + value print_interf ?input_file:(_) ?output_file:(_) _ = failwith "No interface printer"; + value print_implem ?input_file:(_) ?output_file:(_) _ = failwith "No implementation printer"; +end; diff --git a/camlp4/Camlp4/Options.ml b/camlp4/Camlp4/Options.ml new file mode 100644 index 0000000..2d08920 --- /dev/null +++ b/camlp4/Camlp4/Options.ml @@ -0,0 +1,191 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) +type spec_list = list (string * Arg.spec * string); +open Format; + +value rec action_arg s sl = + fun + [ Arg.Unit f -> if s = "" then do { f (); Some sl } else None + | Arg.Bool f -> + if s = "" then + match sl with + [ [s :: sl] -> + try do { f (bool_of_string s); Some sl } with + [ Invalid_argument _ -> None ] + | [] -> None ] + else + try do { f (bool_of_string s); Some sl } with + [ Invalid_argument _ -> None ] + | Arg.Set r -> if s = "" then do { r.val := True; Some sl } else None + | Arg.Clear r -> if s = "" then do { r.val := False; Some sl } else None + | Arg.Rest f -> do { List.iter f [s :: sl]; Some [] } + | Arg.String f -> + if s = "" then + match sl with + [ [s :: sl] -> do { f s; Some sl } + | [] -> None ] + else do { f s; Some sl } + | Arg.Set_string r -> + if s = "" then + match sl with + [ [s :: sl] -> do { r.val := s; Some sl } + | [] -> None ] + else do { r.val := s; Some sl } + | Arg.Int f -> + if s = "" then + match sl with + [ [s :: sl] -> + try do { f (int_of_string s); Some sl } with + [ Failure _ -> None ] + | [] -> None ] + else + try do { f (int_of_string s); Some sl } with + [ Failure _ -> None ] + | Arg.Set_int r -> + if s = "" then + match sl with + [ [s :: sl] -> + try do { r.val := (int_of_string s); Some sl } with + [ Failure _ -> None ] + | [] -> None ] + else + try do { r.val := (int_of_string s); Some sl } with + [ Failure _ -> None ] + | Arg.Float f -> + if s = "" then + match sl with + [ [s :: sl] -> do { f (float_of_string s); Some sl } + | [] -> None ] + else do { f (float_of_string s); Some sl } + | Arg.Set_float r -> + if s = "" then + match sl with + [ [s :: sl] -> do { r.val := (float_of_string s); Some sl } + | [] -> None ] + else do { r.val := (float_of_string s); Some sl } + | Arg.Tuple specs -> + let rec action_args s sl = + fun + [ [] -> Some sl + | [spec :: spec_list] -> + match action_arg s sl spec with + [ None -> action_args "" [] spec_list + | Some [s :: sl] -> action_args s sl spec_list + | Some sl -> action_args "" sl spec_list + ] + ] in + action_args s sl specs + | Arg.Symbol syms f -> + match (if s = "" then sl else [s :: sl]) with + [ [s :: sl] when List.mem s syms -> do { f s; Some sl } + | _ -> None ] + ]; + +value common_start s1 s2 = + loop 0 where rec loop i = + if i == String.length s1 || i == String.length s2 then i + else if s1.[i] == s2.[i] then loop (i + 1) + else i; + +value parse_arg fold s sl = + fold + (fun (name, action, _) acu -> + let i = common_start s name in + if i == String.length name then + try action_arg (String.sub s i (String.length s - i)) sl action with + [ Arg.Bad _ -> acu ] + else acu) None; + +value rec parse_aux fold anon_fun = + fun + [ [] -> [] + | [s :: sl] -> + if String.length s > 1 && s.[0] = '-' then + match parse_arg fold s sl with + [ Some sl -> parse_aux fold anon_fun sl + | None -> [s :: parse_aux fold anon_fun sl] ] + else do { (anon_fun s : unit); parse_aux fold anon_fun sl } ]; + +value align_doc key s = + let s = + loop 0 where rec loop i = + if i = String.length s then "" + else if s.[i] = ' ' then loop (i + 1) + else String.sub s i (String.length s - i) + in + let (p, s) = + if String.length s > 0 then + if s.[0] = '<' then + loop 0 where rec loop i = + if i = String.length s then ("", s) + else if s.[i] <> '>' then loop (i + 1) + else + let p = String.sub s 0 (i + 1) in + loop (i + 1) where rec loop i = + if i >= String.length s then (p, "") + else if s.[i] = ' ' then loop (i + 1) + else (p, String.sub s i (String.length s - i)) + else ("", s) + else ("", "") + in + let tab = + String.make (max 1 (16 - String.length key - String.length p)) ' ' + in + p ^ tab ^ s; + +value make_symlist l = + match l with + [ [] -> "" + | [h::t] -> (List.fold_left (fun x y -> x ^ "|" ^ y) ("{" ^ h) t) ^ "}" ]; + +value print_usage_list l = + List.iter + (fun (key, spec, doc) -> + match spec with + [ Arg.Symbol symbs _ -> + let s = make_symlist symbs in + let synt = key ^ " " ^ s in + eprintf " %s %s\n" synt (align_doc synt doc) + | _ -> eprintf " %s %s\n" key (align_doc key doc) ] ) + l; + +value remaining_args argv = + let rec loop l i = + if i == Array.length argv then l else loop [argv.(i) :: l] (i + 1) + in + List.rev (loop [] (Arg.current.val + 1)); + +value init_spec_list = ref []; +value ext_spec_list = ref []; + +value init spec_list = init_spec_list.val := spec_list; + +value add name spec descr = + ext_spec_list.val := [(name, spec, descr) :: ext_spec_list.val]; + +value fold f init = + let spec_list = init_spec_list.val @ ext_spec_list.val in + let specs = List.sort (fun (k1, _, _) (k2, _, _) -> String.compare k2 k1) spec_list in + List.fold_right f specs init; + +value parse anon_fun argv = + let remaining_args = remaining_args argv in + parse_aux fold anon_fun remaining_args; + +value ext_spec_list () = ext_spec_list.val; diff --git a/camlp4/Camlp4/Options.mli b/camlp4/Camlp4/Options.mli new file mode 100644 index 0000000..c2d9753 --- /dev/null +++ b/camlp4/Camlp4/Options.mli @@ -0,0 +1,26 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +type spec_list = list (string * Arg.spec * string); +value init : spec_list -> unit; +value add : string -> Arg.spec -> string -> unit; + (** Add an option to the command line options. *) +value print_usage_list : spec_list -> unit; +value ext_spec_list : unit -> spec_list; +value parse : (string -> unit) -> array string -> list string; diff --git a/camlp4/Camlp4/PreCast.ml b/camlp4/Camlp4/PreCast.ml new file mode 100644 index 0000000..361ffa4 --- /dev/null +++ b/camlp4/Camlp4/PreCast.ml @@ -0,0 +1,67 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Id = struct + value name = "Camlp4.PreCast"; + value version = Sys.ocaml_version; +end; + +type camlp4_token = Sig.camlp4_token == + [ KEYWORD of string + | SYMBOL of string + | LIDENT of string + | UIDENT of string + | ESCAPED_IDENT of string + | INT of int and string + | INT32 of int32 and string + | INT64 of int64 and string + | NATIVEINT of nativeint and string + | FLOAT of float and string + | CHAR of char and string + | STRING of string and string + | LABEL of string + | OPTLABEL of string + | QUOTATION of Sig.quotation + | ANTIQUOT of string and string + | COMMENT of string + | BLANKS of string + | NEWLINE + | LINE_DIRECTIVE of int and option string + | EOI ]; + +module Loc = Struct.Loc; +module Ast = Struct.Camlp4Ast.Make Loc; +module Token = Struct.Token.Make Loc; +module Lexer = Struct.Lexer.Make Token; +module Gram = Struct.Grammar.Static.Make Lexer; +module DynLoader = Struct.DynLoader; +module Quotation = Struct.Quotation.Make Ast; +module MakeSyntax (U : sig end) = OCamlInitSyntax.Make Ast Gram Quotation; +module Syntax = MakeSyntax (struct end); +module AstFilters = Struct.AstFilters.Make Ast; +module MakeGram = Struct.Grammar.Static.Make; + +module Printers = struct + module OCaml = Printers.OCaml.Make Syntax; + module OCamlr = Printers.OCamlr.Make Syntax; + (* module OCamlrr = Printers.OCamlrr.Make Syntax; *) + module DumpOCamlAst = Printers.DumpOCamlAst.Make Syntax; + module DumpCamlp4Ast = Printers.DumpCamlp4Ast.Make Syntax; + module Null = Printers.Null.Make Syntax; +end; diff --git a/camlp4/Camlp4/PreCast.mli b/camlp4/Camlp4/PreCast.mli new file mode 100644 index 0000000..ae58264 --- /dev/null +++ b/camlp4/Camlp4/PreCast.mli @@ -0,0 +1,76 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +type camlp4_token = Sig.camlp4_token == + [ KEYWORD of string + | SYMBOL of string + | LIDENT of string + | UIDENT of string + | ESCAPED_IDENT of string + | INT of int and string + | INT32 of int32 and string + | INT64 of int64 and string + | NATIVEINT of nativeint and string + | FLOAT of float and string + | CHAR of char and string + | STRING of string and string + | LABEL of string + | OPTLABEL of string + | QUOTATION of Sig.quotation + | ANTIQUOT of string and string + | COMMENT of string + | BLANKS of string + | NEWLINE + | LINE_DIRECTIVE of int and option string + | EOI ]; + +module Id : Sig.Id; +module Loc : Sig.Loc; +module Ast : Sig.Camlp4Ast with module Loc = Loc; +module Token : Sig.Token + with module Loc = Loc + and type t = camlp4_token; +module Lexer : Sig.Lexer + with module Loc = Loc + and module Token = Token; +module Gram : Sig.Grammar.Static + with module Loc = Loc + and module Token = Token; +module Quotation : Sig.Quotation with module Ast = Sig.Camlp4AstToAst Ast; +module DynLoader : Sig.DynLoader; +module AstFilters : Sig.AstFilters with module Ast = Ast; +module Syntax : Sig.Camlp4Syntax + with module Loc = Loc + and module Token = Token + and module Ast = Ast + and module Gram = Gram + and module Quotation = Quotation; + +module Printers : sig + module OCaml : (Sig.Printer Ast).S; + module OCamlr : (Sig.Printer Ast).S; + module DumpOCamlAst : (Sig.Printer Ast).S; + module DumpCamlp4Ast : (Sig.Printer Ast).S; + module Null : (Sig.Printer Ast).S; +end; + +module MakeGram (Lexer : Sig.Lexer with module Loc = Loc) + : Sig.Grammar.Static with module Loc = Loc and module Token = Lexer.Token; + +module MakeSyntax (U : sig end) : Sig.Syntax; diff --git a/camlp4/Camlp4/Printers.mlpack b/camlp4/Camlp4/Printers.mlpack new file mode 100644 index 0000000..9e593a7 --- /dev/null +++ b/camlp4/Camlp4/Printers.mlpack @@ -0,0 +1,5 @@ +DumpCamlp4Ast +DumpOCamlAst +Null +OCaml +OCamlr diff --git a/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml b/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml new file mode 100644 index 0000000..92bcb7c --- /dev/null +++ b/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml @@ -0,0 +1,51 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Id = struct + value name = "Camlp4Printers.DumpCamlp4Ast"; + value version = Sys.ocaml_version; +end; + +module Make (Syntax : Sig.Syntax) +: (Sig.Printer Syntax.Ast).S += struct + include Syntax; + + value with_open_out_file x f = + match x with + [ Some file -> do { let oc = open_out_bin file; + f oc; + flush oc; + close_out oc } + | None -> do { set_binary_mode_out stdout True; f stdout; flush stdout } ]; + + value dump_ast magic ast oc = do { + output_string oc magic; + output_value oc ast; + }; + + value print_interf ?input_file:(_) ?output_file ast = + with_open_out_file output_file + (dump_ast Camlp4_config.camlp4_ast_intf_magic_number ast); + + value print_implem ?input_file:(_) ?output_file ast = + with_open_out_file output_file + (dump_ast Camlp4_config.camlp4_ast_impl_magic_number ast); + +end; diff --git a/camlp4/Camlp4/Printers/DumpCamlp4Ast.mli b/camlp4/Camlp4/Printers/DumpCamlp4Ast.mli new file mode 100644 index 0000000..40e8563 --- /dev/null +++ b/camlp4/Camlp4/Printers/DumpCamlp4Ast.mli @@ -0,0 +1,21 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +module Id : Sig.Id; + +module Make (Syntax : Sig.Syntax) : (Sig.Printer Syntax.Ast).S; diff --git a/camlp4/Camlp4/Printers/DumpOCamlAst.ml b/camlp4/Camlp4/Printers/DumpOCamlAst.ml new file mode 100644 index 0000000..881d786 --- /dev/null +++ b/camlp4/Camlp4/Printers/DumpOCamlAst.ml @@ -0,0 +1,53 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Id : Sig.Id = struct + value name = "Camlp4Printers.DumpOCamlAst"; + value version = Sys.ocaml_version; +end; + +module Make (Syntax : Sig.Camlp4Syntax) +: (Sig.Printer Syntax.Ast).S += struct + include Syntax; + module Ast2pt = Struct.Camlp4Ast2OCamlAst.Make Ast; + + value with_open_out_file x f = + match x with + [ Some file -> do { let oc = open_out_bin file; + f oc; + flush oc; + close_out oc } + | None -> do { set_binary_mode_out stdout True; f stdout; flush stdout } ]; + + value dump_pt magic fname pt oc = do { + output_string oc magic; + output_value oc (if fname = "-" then "" else fname); + output_value oc pt; + }; + + value print_interf ?(input_file = "-") ?output_file ast = + let pt = Ast2pt.sig_item ast in + with_open_out_file output_file (dump_pt Camlp4_config.ocaml_ast_intf_magic_number input_file pt); + + value print_implem ?(input_file = "-") ?output_file ast = + let pt = Ast2pt.str_item ast in + with_open_out_file output_file (dump_pt Camlp4_config.ocaml_ast_impl_magic_number input_file pt); + +end; diff --git a/camlp4/Camlp4/Printers/DumpOCamlAst.mli b/camlp4/Camlp4/Printers/DumpOCamlAst.mli new file mode 100644 index 0000000..1b36c97 --- /dev/null +++ b/camlp4/Camlp4/Printers/DumpOCamlAst.mli @@ -0,0 +1,21 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +module Id : Sig.Id; + +module Make (Syntax : Sig.Camlp4Syntax) : (Sig.Printer Syntax.Ast).S; diff --git a/camlp4/Camlp4/Printers/Null.ml b/camlp4/Camlp4/Printers/Null.ml new file mode 100644 index 0000000..9338ce5 --- /dev/null +++ b/camlp4/Camlp4/Printers/Null.ml @@ -0,0 +1,30 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Id = struct + value name = "Camlp4.Printers.Null"; + value version = Sys.ocaml_version; +end; + +module Make (Syntax : Sig.Syntax) = struct + include Syntax; + + value print_interf ?input_file:(_) ?output_file:(_) _ = (); + value print_implem ?input_file:(_) ?output_file:(_) _ = (); +end; diff --git a/camlp4/Camlp4/Printers/Null.mli b/camlp4/Camlp4/Printers/Null.mli new file mode 100644 index 0000000..bf69819 --- /dev/null +++ b/camlp4/Camlp4/Printers/Null.mli @@ -0,0 +1,22 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Id : Sig.Id; + +module Make (Syntax : Sig.Syntax) : (Sig.Printer Syntax.Ast).S; diff --git a/camlp4/Camlp4/Printers/OCaml.ml b/camlp4/Camlp4/Printers/OCaml.ml new file mode 100644 index 0000000..3449347 --- /dev/null +++ b/camlp4/Camlp4/Printers/OCaml.ml @@ -0,0 +1,1209 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +open Format; + +module Id = struct + value name = "Camlp4.Printers.OCaml"; + value version = Sys.ocaml_version; +end; + +module Make (Syntax : Sig.Camlp4Syntax) = struct + include Syntax; + + type sep = format unit formatter unit; + type fun_binding = [= `patt of Ast.patt | `newtype of string ]; + + value pp = fprintf; + value cut f = fprintf f "@ "; + + value list' elt sep sep' f = + let rec loop = + fun + [ [] -> () + | [x::xs] -> do { pp f sep ; elt f x; pp f sep'; loop xs } ] in + fun + [ [] -> () + | [x] -> do { elt f x; pp f sep' } + | [x::xs] -> do { elt f x; pp f sep'; loop xs } ]; + + value list elt sep f = + let rec loop = + fun + [ [] -> () + | [x::xs] -> do { pp f sep ; elt f x; loop xs } ] in + fun + [ [] -> () + | [x] -> elt f x + | [x::xs] -> do { elt f x; loop xs } ]; + + value rec list_of_meta_list = + fun + [ Ast.LNil -> [] + | Ast.LCons x xs -> [x :: list_of_meta_list xs] + | Ast.LAnt _ -> assert False ]; + + value meta_list elt sep f mxs = + let xs = list_of_meta_list mxs in + list elt sep f xs; + + module CommentFilter = Struct.CommentFilter.Make Token; + value comment_filter = CommentFilter.mk (); + CommentFilter.define (Gram.get_filter ()) comment_filter; + + module StringSet = Set.Make String; + + value infix_lidents = ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"]; + + value is_infix = + let first_chars = ['='; '<'; '>'; '|'; '&'; '$'; '@'; '^'; '+'; '-'; '*'; '/'; '%'; '\\'] + and infixes = + List.fold_right StringSet.add infix_lidents StringSet.empty + in fun s -> (StringSet.mem s infixes + || (s <> "" && List.mem s.[0] first_chars)); + + value is_keyword = + let keywords = (* without infix_lidents *) + List.fold_right StringSet.add + ["and"; "as"; "assert"; "begin"; "class"; "constraint"; "do"; + "done"; "downto"; "else"; "end"; "exception"; "external"; "false"; + "for"; "fun"; "function"; "functor"; "if"; "in"; "include"; + "inherit"; "initializer"; "lazy"; "let"; "match"; "method"; "module"; + "mutable"; "new"; "object"; "of"; "open"; "parser"; "private"; "rec"; "sig"; + "struct"; "then"; "to"; "true"; "try"; "type"; "val"; "virtual"; + "when"; "while"; "with"] StringSet.empty + in fun s -> StringSet.mem s keywords; + + module Lexer = Struct.Lexer.Make Token; + let module M = ErrorHandler.Register Lexer.Error in (); + open Sig; + value lexer s = + Lexer.from_string ~quotations:Camlp4_config.quotations.val Loc.ghost s; + value lex_string str = + try match lexer str with parser + [: `(tok, _); `(EOI, _) :] -> tok + with + [ Stream.Failure | Stream.Error _ -> + failwith (sprintf + "Cannot print %S this string contains more than one token" str) + | Lexer.Error.E exn -> + failwith (sprintf + "Cannot print %S this identifier does not respect OCaml lexing rules (%s)" + str (Lexer.Error.to_string exn)) ]; + + (* 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 + [ <:expr< $a1$ $a2$ >> -> get_expr_args a1 [a2 :: al] + | _ -> (a, al) ]; + + value rec get_patt_args a al = + match a with + [ <:patt< $a1$ $a2$ >> -> get_patt_args a1 [a2 :: al] + | _ -> (a, al) ]; + + value rec get_ctyp_args a al = + match a with + [ <:ctyp< $a1$ $a2$ >> -> get_ctyp_args a1 [a2 :: al] + | _ -> (a, al) ]; + + value is_irrefut_patt = Ast.is_irrefut_patt; + + value rec expr_fun_args = + fun + [ <:expr< fun $p$ -> $e$ >> as ge -> + if is_irrefut_patt p then + let (pl, e) = expr_fun_args e in + ([`patt p :: pl], e) + else ([], ge) + | <:expr< fun (type $i$) -> $e$ >> -> + let (pl, e) = expr_fun_args e in + ([`newtype i :: pl], e) + | ge -> ([], ge) ]; + + value rec class_expr_fun_args = + fun + [ <:class_expr< fun $p$ -> $ce$ >> as ge -> + if is_irrefut_patt p then + let (pl, ce) = class_expr_fun_args ce in + ([p :: pl], ce) + else ([], ge) + | ge -> ([], ge) ]; + + value rec do_print_comments_before loc f = + parser + [ [: ` (comm, comm_loc) when Loc.strictly_before comm_loc loc; s :] -> + let () = f comm comm_loc in + do_print_comments_before loc f s + | [: :] -> () ]; + + class printer ?curry_constr:(init_curry_constr = False) ?(comments = True) () = + object (o) + + (** pipe means we are under a match case (try, function) *) + value pipe = False; + value semi = False; + + method under_pipe = {< pipe = True >}; + method under_semi = {< semi = True >}; + method reset_semi = {< semi = False >}; + method reset = {< pipe = False; semi = False >}; + + value semisep : sep = ";;"; + value no_semisep : sep = ""; (* used to mark where ";;" should not occur *) + value mode = if comments then `comments else `no_comments; + value curry_constr = init_curry_constr; + value var_conversion = False; + + method andsep : sep = "@]@ @[<2>and@ "; + method value_val = "val"; + method value_let = "let"; + + method semisep = semisep; + method set_semisep s = {< semisep = s >}; + method set_comments b = {< mode = if b then `comments else `no_comments >}; + method set_loc_and_comments = {< mode = `loc_and_comments >}; + method set_curry_constr b = {< curry_constr = b >}; + + method print_comments_before loc f = + match mode with + [ `comments -> + do_print_comments_before loc (fun c _ -> pp f "%s@ " c) + (CommentFilter.take_stream comment_filter) + | `loc_and_comments -> + let () = pp f "(*loc: %a*)@ " Loc.dump loc in + do_print_comments_before loc + (fun s -> pp f "%s(*comm_loc: %a*)@ " s Loc.dump) + (CommentFilter.take_stream comment_filter) + | _ -> () ]; + + method var f = + fun + [ "" -> pp f "$lid:\"\"$" + | "[]" -> pp f "[]" + | "()" -> pp f "()" + | " True" -> pp f "True" + | " False" -> pp f "False" + | v -> + match (var_conversion, v) with + [ (True, "val") -> pp f "contents" + | (True, "True") -> pp f "true" + | (True, "False") -> pp f "false" + | _ -> + match lex_string v with + [ (LIDENT s | UIDENT s | ESCAPED_IDENT s) when is_keyword s -> + pp f "%s__" s + | (LIDENT s | ESCAPED_IDENT s) when List.mem s infix_lidents -> + pp f "( %s )" s + | SYMBOL s -> + pp f "( %s )" s + | LIDENT s | UIDENT s | ESCAPED_IDENT s -> + pp_print_string f s + | tok -> failwith (sprintf + "Bad token used as an identifier: %s" + (Token.to_string tok)) ] ] ]; + + method type_params f = + fun + [ [] -> () + | [x] -> pp f "%a@ " o#ctyp x + | l -> pp f "@[<1>(%a)@]@ " (list o#ctyp ",@ ") l ]; + + method class_params f = + fun + [ <:ctyp< $t1$, $t2$ >> -> + pp f "@[<1>%a,@ %a@]" o#class_params t1 o#class_params t2 + | x -> o#ctyp f x ]; + + method override_flag f = + fun + [ Ast.OvOverride -> pp f "!" + | Ast.OvNil -> () + | Ast.OvAnt s -> o#anti f s ]; + + method mutable_flag f = fun + [ Ast.MuMutable -> pp f "mutable@ " + | Ast.MuNil -> () + | Ast.MuAnt s -> o#anti f s ]; + + method rec_flag f = fun + [ Ast.ReRecursive -> pp f "rec@ " + | Ast.ReNonrecursive + | Ast.ReNil -> () + | Ast.ReAnt s -> o#anti f s ]; + + method nonrec_flag f = fun + [ Ast.ReNonrecursive -> pp f "nonrec@ " + | Ast.ReRecursive + | Ast.ReNil -> () + | Ast.ReAnt s -> o#anti f s ]; + + method virtual_flag f = fun + [ Ast.ViVirtual -> pp f "virtual@ " + | Ast.ViNil -> () + | Ast.ViAnt s -> o#anti f s ]; + + method private_flag f = fun + [ Ast.PrPrivate -> pp f "private@ " + | Ast.PrNil -> () + | Ast.PrAnt s -> o#anti f s ]; + + method anti f s = pp f "$%s$" s; + + method seq f = + fun + [ <:expr< $e1$; $e2$ >> -> + pp f "%a;@ %a" o#under_semi#seq e1 o#seq e2 + | <:expr< do { $e$ } >> -> + o#seq f e + | e -> o#expr f e ]; + + (* FIXME when the Format module will fixed. + pp_print_if_newline f (); + pp_print_string f "| "; *) + method match_case f = + fun + [ <:match_case@_loc<>> -> + pp f "@[<2>@ _ ->@ %a@]" o#raise_match_failure _loc + | a -> o#match_case_aux f a ]; + + method match_case_aux f = + fun + [ <:match_case<>> -> () + | <:match_case< $anti:s$ >> -> o#anti f s + | <:match_case< $a1$ | $a2$ >> -> + pp f "%a%a" o#match_case_aux a1 o#match_case_aux a2 + | <:match_case< $p$ -> $e$ >> -> + pp f "@ | @[<2>%a@ ->@ %a@]" o#patt p o#under_pipe#expr e + | <:match_case< $p$ when $w$ -> $e$ >> -> + pp f "@ | @[<2>%a@ when@ %a@ ->@ %a@]" + o#patt p o#under_pipe#expr w o#under_pipe#expr e ]; + + method fun_binding f = + fun + [ `patt p -> o#simple_patt f p + | `newtype i -> pp f "(type %s)" i ]; + + method binding f bi = + let () = o#node f bi Ast.loc_of_binding in + match bi with + [ <:binding<>> -> () + | <:binding< $b1$ and $b2$ >> -> + do { o#binding f b1; pp f o#andsep; o#binding f b2 } + | <:binding< $p$ = $e$ >> -> + let (pl, e') = + match p with + [ <:patt< ($_$ : $_$) >> -> ([], e) + | _ -> expr_fun_args e ] in + 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' + | (<: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 = + let () = o#node f bi Ast.loc_of_rec_binding in + match bi with + [ <:rec_binding<>> -> () + | <:rec_binding< $i$ = $e$ >> -> + pp f "@ @[<2>%a =@ %a@];" o#var_ident i o#expr e + | <:rec_binding< $b1$ ; $b2$ >> -> + do { o#under_semi#record_binding f b1; + o#under_semi#record_binding f b2 } + | <:rec_binding< $anti:s$ >> -> o#anti f s ]; + + method mk_patt_list = + fun + [ <:patt< [$p1$ :: $p2$] >> -> + let (pl, c) = o#mk_patt_list p2 in + ([p1 :: pl], c) + | <:patt< [] >> -> ([], None) + | p -> ([], Some p) ]; + + method mk_expr_list = + fun + [ <:expr< [$e1$ :: $e2$] >> -> + let (el, c) = o#mk_expr_list e2 in + ([e1 :: el], c) + | <:expr< [] >> -> ([], None) + | e -> ([], Some e) ]; + + method expr_list f = + fun + [ [] -> pp f "[]" + | [e] -> pp f "[ %a ]" o#under_semi#expr e + | el -> pp f "@[<2>[ %a@] ]" (list o#under_semi#expr ";@ ") el ]; + + method expr_list_cons simple f e = + let (el, c) = o#mk_expr_list e in + match c with + [ None -> o#expr_list f el + | Some x -> + (if simple then pp f "@[<2>(%a)@]" else pp f "@[<2>%a@]") + (list o#under_semi#dot_expr " ::@ ") (el @ [x]) ]; + + method patt_expr_fun_args f (p, e) = + let (pl, e) = expr_fun_args e + in pp f "%a@ ->@ %a" (list o#fun_binding "@ ") [p::pl] o#expr e; + + method patt_class_expr_fun_args f (p, ce) = + let (pl, ce) = class_expr_fun_args ce + in pp f "%a =@]@ %a" (list o#simple_patt "@ ") [p::pl] o#class_expr ce; + + method constrain f (t1, t2) = + pp f "@[<2>constraint@ %a =@ %a@]" o#ctyp t1 o#ctyp t2; + + method sum_type f t = + match Ast.list_of_ctyp t [] with + [ [] -> () + | ts -> + pp f "@[| %a@]" (list o#constructor_declaration "@ | ") ts ]; + + method private constructor_declaration f t = + match t with + [ <:ctyp< $t1$ : $t2$ -> $t3$ >> -> pp f "@[<2>%a :@ @[<2>%a@ ->@ %a@]@]" o#ctyp t1 o#constructor_type t2 o#ctyp t3 + | t -> o#ctyp f t ]; + + method string f = pp f "%s"; + method quoted_string f = pp f "%S"; + + method numeric f num suff = + if num.[0] = '-' then pp f "(%s%s)" num suff else pp f "%s%s" num suff; + + method module_expr_get_functor_args accu = + fun + [ <:module_expr< functor ($s$ : $mt$) -> $me$ >> -> + o#module_expr_get_functor_args [(s, mt)::accu] me + | <:module_expr< ($me$ : $mt$) >> -> (List.rev accu, me, Some mt) + | me -> (List.rev accu, me, None) ]; + + method functor_args f = list o#functor_arg "@ " f; + + method functor_arg f (s, mt) = + match mt with + [ Ast.MtNil _ -> + o#functor_arg_var f s + | _ -> + pp f "@[<2>(%a :@ %a)@]" o#functor_arg_var s o#module_type mt ]; + + method functor_arg_var f v = + match v with + [ "*" -> pp f "()" + | v -> o#var f v ]; + + method module_rec_binding f = + fun + [ <:module_binding<>> -> () + | <:module_binding< $s$ : $mt$ = $me$ >> -> + pp f "@[<2>%a :@ %a =@ %a@]" + o#var s o#module_type mt o#module_expr me + | <:module_binding< $s$ : $mt$ >> -> + pp f "@[<2>%a :@ %a@]" o#var s o#module_type mt + | <:module_binding< $mb1$ and $mb2$ >> -> + do { o#module_rec_binding f mb1; + pp f o#andsep; + o#module_rec_binding f mb2 } + | <:module_binding< $anti:s$ >> -> o#anti f s ]; + + method class_declaration f = + fun + [ <:class_expr< ( $ce$ : $ct$ ) >> -> + pp f "%a :@ %a" o#class_expr ce o#class_type ct + | ce -> o#class_expr f ce ]; + + method raise_match_failure f _loc = + let n = Loc.file_name _loc in + let l = Loc.start_line _loc in + let c = Loc.start_off _loc - Loc.start_bol _loc in + o#expr f <:expr< raise (Match_failure $`str:n$ $`int:l$ $`int:c$) >>; + + method node : ! 'a . formatter -> 'a -> ('a -> Loc.t) -> unit = + fun f node loc_of_node -> + o#print_comments_before (loc_of_node node) f; + + method ident f i = + let () = o#node f i Ast.loc_of_ident in + match i with + [ <:ident< $i1$.$i2$ >> -> pp f "%a.@,%a" o#ident i1 o#ident i2 + | <:ident< $i1$ $i2$ >> -> pp f "%a@,(%a)" o#ident i1 o#ident i2 + | <:ident< $anti:s$ >> -> o#anti f s + | <:ident< $lid:s$ >> | <:ident< $uid:s$ >> -> o#var f s ]; + + method private var_ident = {< var_conversion = True >}#ident; + + method expr f e = + let () = o#node f e Ast.loc_of_expr in + match e with + [ ((<:expr< let $rec:_$ $_$ in $_$ >> | + <:expr< let module $_$ = $_$ in $_$ >>) as e) when semi -> + pp f "(%a)" o#reset#expr e + | ((<:expr< match $_$ with [ $_$ ] >> | + <:expr< try $_$ with [ $_$ ] >> | + <:expr< fun [ $_$ ] >>) as e) when pipe || semi -> + pp f "(%a)" o#reset#expr e + + | <:expr< - $x$ >> -> + (* If you want to remove the space take care of - !r *) + pp f "@[<2>-@ %a@]" o#dot_expr x + | <:expr< -. $x$ >> -> + pp f "@[<2>-.@ %a@]" o#dot_expr x (* same note as above *) + | <:expr< [$_$ :: $_$] >> -> o#expr_list_cons False f e + | <:expr@_loc< $lid:n$ $x$ $y$ >> when is_infix n -> + pp f "@[<2>%a@ %s@ %a@]" o#apply_expr x n o#apply_expr y + | <:expr< $x$ $y$ >> -> + let (a, al) = get_expr_args x [y] in + if (not curry_constr) && Ast.is_expr_constructor a then + match al with + [ [ <:expr< ($tup:_$) >> ] -> + pp f "@[<2>%a@ (%a)@]" o#apply_expr x o#expr y + | [_] -> pp f "@[<2>%a@ %a@]" o#apply_expr x o#apply_expr y + | al -> + pp f "@[<2>%a@ (%a)@]" o#apply_expr a + (* The #apply_expr below may put too much parens. + However using #expr would be wrong: PR#5056. *) + (list o#under_pipe#apply_expr ",@ ") al ] + else pp f "@[<2>%a@]" (list o#apply_expr "@ ") [a::al] + | <:expr< $e1$.val := $e2$ >> -> + pp f "@[<2>%a :=@ %a@]" o#dot_expr e1 o#expr e2 + | <:expr< $e1$ := $e2$ >> -> + pp f "@[<2>%a@ <-@ %a@]" o#dot_expr e1 o#expr e2 + | <:expr@loc< fun [] >> -> + pp f "@[<2>fun@ _@ ->@ %a@]" o#raise_match_failure loc + | <:expr< fun $p$ -> $e$ >> when is_irrefut_patt p -> + pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (`patt p, e) + | <:expr< fun (type $i$) -> $e$ >> -> + pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (`newtype i, e) + | <:expr< fun [ $a$ ] >> -> + pp f "@[function%a@]" o#match_case a + | <:expr< if $e1$ then $e2$ else $e3$ >> -> + pp f "@[@[<2>if@ %a@]@ @[<2>then@ %a@]@ @[<2>else@ %a@]@]" + o#expr e1 o#under_semi#expr e2 o#under_semi#expr e3 + | <:expr< lazy $e$ >> -> pp f "@[<2>lazy@ %a@]" o#simple_expr e + | <:expr< let $rec:r$ $bi$ in $e$ >> -> + match e with + [ <:expr< let $rec:_$ $_$ in $_$ >> -> + pp f "@[<0>@[<2>let %a%a in@]@ %a@]" + o#rec_flag r o#binding bi o#reset_semi#expr e + | _ -> + pp f "@[@[<2>let %a%a@]@ @[in@ %a@]@]" + o#rec_flag r o#binding bi o#reset_semi#expr e ] + | Ast.ExOpI _loc i ov e -> + (* | <:expr< let open $i$ in $e$ >> -> *) + pp f "@[<2>let open%a %a@]@ @[<2>in@ %a@]" + o#override_flag ov o#ident i o#reset_semi#expr e + | <:expr< match $e$ with [ $a$ ] >> -> + pp f "@[@[@[<2>match %a@]@ with@]%a@]" + o#expr e o#match_case a + | <:expr< try $e$ with [ $a$ ] >> -> + pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" + o#expr e o#match_case a + | <:expr< assert False >> -> pp f "@[<2>assert@ false@]" + | <:expr< assert $e$ >> -> pp f "@[<2>assert@ %a@]" o#dot_expr e + | <:expr< let module $s$ = $me$ in $e$ >> -> + pp f "@[<2>let module %a =@ %a@]@ @[<2>in@ %a@]" o#var s o#module_expr me o#reset_semi#expr e + | <:expr< object $cst$ end >> -> + pp f "@[@[object@ %a@]@ end@]" o#class_str_item cst + | <:expr< object ($p$ : $t$) $cst$ end >> -> + pp f "@[@[object @[<1>(%a :@ %a)@]@ %a@]@ end@]" + o#patt p o#ctyp t o#class_str_item cst + | <:expr< object ($p$) $cst$ end >> -> + pp f "@[@[object @[<2>(%a)@]@ %a@]@ end@]" + o#patt p o#class_str_item cst + | e -> o#apply_expr f e ]; + + method apply_expr f e = + let () = o#node f e Ast.loc_of_expr in + match e with + [ <:expr< new $i$ >> -> pp f "@[<2>new@ %a@]" o#ident i + | e -> o#dot_expr f e ]; + + method dot_expr f e = + let () = o#node f e Ast.loc_of_expr in + match e with + [ <:expr< $e$.val >> -> pp f "@[<2>!@,%a@]" o#simple_expr e + | <:expr< $e1$ . $e2$ >> -> pp f "@[<2>%a.@,%a@]" o#dot_expr e1 o#dot_expr e2 + | <:expr< $e1$ .( $e2$ ) >> -> + pp f "@[<2>%a.@,(%a)@]" o#dot_expr e1 o#expr e2 + | <:expr< $e1$ .[ $e2$ ] >> -> + pp f "%a.@[<1>[@,%a@]@,]" o#dot_expr e1 o#expr e2 + | <:expr< $e$ # $s$ >> -> pp f "@[<2>%a#@,%s@]" o#dot_expr e s + | e -> o#simple_expr f e ]; + + method simple_expr f e = + let () = o#node f e Ast.loc_of_expr in + match e with + [ <:expr<>> -> () + | <:expr< do { $e$ } >> -> + pp f "@[(%a)@]" o#seq e + | <:expr< [$_$ :: $_$] >> -> o#expr_list_cons True f e + | <:expr< ( $tup:e$ ) >> -> + pp f "@[<1>(%a)@]" o#expr e + | <:expr< [| $e$ |] >> -> + pp f "@[<0>@[<2>[|@ %a@]@ |]@]" o#under_semi#expr e + | <:expr< ($e$ :> $t$) >> -> + pp f "@[<2>(%a :>@ %a)@]" o#expr e o#ctyp t + | <:expr< ($e$ : $t1$ :> $t2$) >> -> + pp f "@[<2>(%a :@ %a :>@ %a)@]" o#expr e o#ctyp t1 o#ctyp t2 + | <:expr< ($e$ : $t$) >> -> + pp f "@[<2>(%a :@ %a)@]" o#expr e o#ctyp t + | <:expr< $anti:s$ >> -> o#anti f s + | <:expr< for $p$ = $e1$ $to:df$ $e2$ do { $e3$ } >> -> + pp f "@[@[@[<2>for %a =@ %a@ %a@ %a@ do@]@ %a@]@ done@]" + o#patt p o#expr e1 o#direction_flag df o#expr e2 o#seq e3 + | <:expr< $int:s$ >> -> o#numeric f s "" + | <:expr< $nativeint:s$ >> -> o#numeric f s "n" + | <:expr< $int64:s$ >> -> o#numeric f s "L" + | <:expr< $int32:s$ >> -> o#numeric f s "l" + | <:expr< $flo:s$ >> -> o#numeric f s "" + | <:expr< $chr:s$ >> -> pp f "'%s'" (ocaml_char s) + | <:expr< $id:i$ >> -> o#var_ident f i + | <:expr< { $b$ } >> -> + pp f "@[@[{%a@]@ }@]" o#record_binding b + | <:expr< { ($e$) with $b$ } >> -> + pp f "@[@[{@ (%a)@ with%a@]@ }@]" + o#expr e o#record_binding b + | <:expr< $str:s$ >> -> pp f "\"%s\"" s + | <:expr< while $e1$ do { $e2$ } >> -> + pp f "@[<2>while@ %a@ do@ %a@ done@]" o#expr e1 o#seq e2 + | <:expr< ~ $s$ >> -> pp f "~%s" s + | <:expr< ~ $s$ : $e$ >> -> pp f "@[<2>~%s:@ %a@]" s o#dot_expr e + | <:expr< ? $s$ >> -> pp f "?%s" s + | <:expr< ? $s$ : $e$ >> -> pp f "@[<2>?%s:@ %a@]" s o#dot_expr e + | <:expr< ` $lid:s$ >> -> pp f "`%a" o#var s + | <:expr< {< $b$ >} >> -> + pp f "@[@[{<%a@]@ >}@]" o#record_binding b + | <:expr< $e1$, $e2$ >> -> + pp f "%a,@ %a" o#simple_expr e1 o#simple_expr e2 + | <:expr< $e1$; $e2$ >> -> + pp f "%a;@ %a" o#under_semi#expr e1 o#expr e2 + | <:expr< (module $me$ : $mt$) >> -> + pp f "@[@[(module %a : %a@])@]" + o#module_expr me o#module_type mt + | <:expr< (module $me$) >> -> + pp f "@[@[(module %a@])@]" o#module_expr me + | Ast.ExAtt _loc s str e -> + pp f "((%a)[@@%s %a])" o#expr e s o#str_item str + | <:expr< $_$ $_$ >> | <:expr< $_$ . $_$ >> | <:expr< $_$ . ( $_$ ) >> | + <:expr< $_$ . [ $_$ ] >> | <:expr< $_$ := $_$ >> | + <:expr< $_$ # $_$ >> | + <:expr< fun [ $_$ ] >> | <:expr< fun (type $_$) -> $_$ >> | <:expr< match $_$ with [ $_$ ] >> | + <:expr< try $_$ with [ $_$ ] >> | + <:expr< if $_$ then $_$ else $_$ >> | + <:expr< let $rec:_$ $_$ in $_$ >> | + <:expr< let module $_$ = $_$ in $_$ >> | + (* <:expr< let open $_$ in $_$ >> *)Ast.ExOpI _ _ _ _ | + <:expr< assert $_$ >> | <:expr< assert False >> | + <:expr< lazy $_$ >> | <:expr< new $_$ >> | + <:expr< object ($_$) $_$ end >> -> + pp f "(%a)" o#reset#expr e ]; + + method direction_flag f b = + match b with + [ Ast.DiTo -> pp_print_string f "to" + | Ast.DiDownto -> pp_print_string f "downto" + | Ast.DiAnt s -> o#anti f s ]; + + method patt f p = + let () = o#node f p Ast.loc_of_patt in match p with + [ <:patt< ( $p1$ as $p2$ ) >> -> pp f "@[<1>(%a@ as@ %a)@]" o#patt p1 o#patt p2 + | <:patt< $i$ = $p$ >> -> pp f "@[<2>%a =@ %a@]" o#var_ident i o#patt p + | <:patt< $p1$; $p2$ >> -> pp f "%a;@ %a" o#patt p1 o#patt p2 + | p -> o#patt1 f p ]; + + method patt1 f = fun + [ <:patt< $p1$ | $p2$ >> -> pp f "@[<2>%a@ |@ %a@]" o#patt1 p1 o#patt2 p2 + | p -> o#patt2 f p ]; + + method patt2 f = fun + [ (* <:patt< ( $tup:p$ ) >> -> pp f "@[<1>(%a)@]" o#patt3 p + | *) p -> o#patt3 f p ]; + + method patt3 f = fun + [ <:patt< $p1$ .. $p2$ >> -> pp f "@[<2>%a@ ..@ %a@]" o#patt3 p1 o#patt4 p2 + | <:patt< $p1$, $p2$ >> -> pp f "%a,@ %a" o#patt3 p1 o#patt3 p2 + | p -> o#patt4 f p ]; + + method patt4 f = fun + [ <:patt< [$_$ :: $_$] >> as p -> + let (pl, c) = o#mk_patt_list p in + match c with + [ None -> pp f "@[<2>[@ %a@]@ ]" (list o#patt ";@ ") pl + | Some x -> pp f "@[<2>%a@]" (list o#patt5 " ::@ ") (pl @ [x]) ] + | p -> o#patt5 f p ]; + + method patt5 f = fun + [ <:patt< [$_$ :: $_$] >> as p -> o#simple_patt f p + | <:patt< lazy $p$ >> -> + pp f "@[<2>lazy %a@]" o#simple_patt p + | Ast.PaExc _ p -> + pp f "@[<2>exception %a@]" o#simple_patt p + | <:patt< $x$ $y$ >> -> + let (a, al) = get_patt_args x [y] in + if not (Ast.is_patt_constructor a) then + Format.eprintf "WARNING: strange pattern application of a non constructor@." + else if curry_constr then + pp f "@[<2>%a@]" (list o#simple_patt "@ ") [a::al] + else + match al with + [ [ <:patt< ($tup:_$) >> ] -> + pp f "@[<2>%a@ (%a)@]" o#simple_patt x o#patt y + | [_] -> pp f "@[<2>%a@ %a@]" o#patt5 x o#simple_patt y + | al -> pp f "@[<2>%a@ (%a)@]" o#patt5 a + (list o#simple_patt ",@ ") al ] + | p -> o#simple_patt f p ]; + + method simple_patt f p = + let () = o#node f p Ast.loc_of_patt in + match p with + [ <:patt<>> -> () + | <:patt< $id:i$ >> -> o#var_ident f i + | <:patt< $anti:s$ >> -> o#anti f s + | <:patt< _ >> -> pp f "_" + | <:patt< ( module $m$ ) >> -> pp f "(module %s)" m + | <:patt< ( $tup:p$ ) >> -> pp f "@[<1>(%a)@]" o#patt3 p + | <:patt< { $p$ } >> -> pp f "@[{@ %a@]@ }" o#patt p + | <:patt< $str:s$ >> -> pp f "\"%s\"" s + | <:patt< ( $p$ : $t$ ) >> -> pp f "@[<1>(%a :@ %a)@]" o#patt p o#ctyp t + | <:patt< $nativeint:s$ >> -> o#numeric f s "n" + | <:patt< $int64:s$ >> -> o#numeric f s "L" + | <:patt< $int32:s$ >> -> o#numeric f s "l" + | <:patt< $int:s$ >> -> o#numeric f s "" + | <:patt< $flo:s$ >> -> o#numeric f s "" + | <:patt< $chr:s$ >> -> pp f "'%s'" (ocaml_char s) + | <:patt< ~ $s$ >> -> pp f "~%s" s + | <:patt< ` $uid:s$ >> -> pp f "`%a" o#var s + | <:patt< # $i$ >> -> pp f "@[<2>#%a@]" o#ident i + | <:patt< [| $p$ |] >> -> pp f "@[<2>[|@ %a@]@ |]" o#patt p + | <:patt< ~ $s$ : ($p$) >> -> pp f "@[<2>~%s:@ (%a)@]" s o#patt p + | <:patt< ? $s$ >> -> pp f "?%s" s + | <:patt< ?($p$) >> -> + pp f "@[<2>?(%a)@]" o#patt_tycon p + | <:patt< ? $s$ : ($p$) >> -> + pp f "@[<2>?%s:@,@[<1>(%a)@]@]" s o#patt_tycon p + | <:patt< ?($p$ = $e$) >> -> + pp f "@[<2>?(%a =@ %a)@]" o#patt_tycon p o#expr e + | <:patt< ? $s$ : ($p$ = $e$) >> -> + pp f "@[<2>?%s:@,@[<1>(%a =@ %a)@]@]" s o#patt_tycon p o#expr e + | <:patt< $_$ $_$ >> | <:patt< ($_$ as $_$) >> | <:patt< $_$ | $_$ >> | + <:patt< $_$ .. $_$ >> | <:patt< $_$, $_$ >> | + <:patt< $_$; $_$ >> | <:patt< $_$ = $_$ >> | <:patt< lazy $_$ >> | + Ast.PaExc _ _ as p -> + pp f "@[<1>(%a)@]" o#patt p + | Ast.PaAtt _loc s str e -> + pp f "((%a)[@@%s %a])" o#patt e s o#str_item str + ]; + + method patt_tycon f = + fun + [ <:patt< ( $p$ : $t$ ) >> -> pp f "%a :@ %a" o#patt p o#ctyp t + | p -> o#patt f p ]; + + method simple_ctyp f t = + let () = o#node f t Ast.loc_of_ctyp in + match t with + [ <:ctyp< $id:i$ >> -> o#ident f i + | <:ctyp< $anti:s$ >> -> o#anti f s + | <:ctyp< _ >> -> pp f "_" + | Ast.TyOpn _ -> pp f ".." + | Ast.TyAnP _ -> pp f "+_" + | Ast.TyAnM _ -> pp f "-_" + | <:ctyp< ~ $s$ : $t$ >> -> pp f "@[<2>%s:@ %a@]" s o#simple_ctyp t + | <:ctyp< ? $s$ : $t$ >> -> pp f "@[<2>?%s:@ %a@]" s o#simple_ctyp t + | <:ctyp< < > >> -> pp f "< >" + | <:ctyp< < .. > >> -> pp f "< .. >" + | <:ctyp< < $t$ .. > >> -> pp f "@[<0>@[<2><@ %a;@ ..@]@ >@]" o#ctyp t + | <:ctyp< < $t$ > >> -> pp f "@[<0>@[<2><@ %a@]@ >@]" o#ctyp t + | <:ctyp< '$s$ >> -> pp f "'%a" o#var s + | <:ctyp< { $t$ } >> -> pp f "@[<2>{@ %a@]@ }" o#ctyp t + | <:ctyp< [ $t$ ] >> -> pp f "@[<0>%a@]" o#sum_type t + | <:ctyp< ( $tup:t$ ) >> -> pp f "@[<1>(%a)@]" o#ctyp t + | <:ctyp< (module $mt$) >> -> pp f "@[<2>(module@ %a@])" o#module_type mt + | <:ctyp< [ = $t$ ] >> -> pp f "@[<2>[@ %a@]@ ]" o#sum_type t + | <:ctyp< [ < $t$ ] >> -> pp f "@[<2>[<@ %a@]@,]" o#sum_type t + | <:ctyp< [ < $t1$ > $t2$ ] >> -> + let (a, al) = get_ctyp_args t2 [] in + pp f "@[<2>[<@ %a@ >@ %a@]@ ]" o#sum_type t1 + (list o#simple_ctyp "@ ") [a::al] + | <:ctyp< [ > $t$ ] >> -> pp f "@[<2>[>@ %a@]@,]" o#sum_type t + | <:ctyp< # $i$ >> -> pp f "@[<2>#%a@]" o#ident i + | <:ctyp< `$s$ >> -> pp f "`%a" o#var s + | <:ctyp< $t1$ * $t2$ >> -> pp f "%a *@ %a" o#simple_ctyp t1 o#simple_ctyp t2 + | Ast.TyAtt _loc s str e -> + pp f "((%a)[@@%s %a])" o#ctyp e s o#str_item str + | <:ctyp<>> -> assert False + | t -> pp f "@[<1>(%a)@]" o#ctyp t ]; + + method ctyp f t = + let () = o#node f t Ast.loc_of_ctyp in + match t with + [ <:ctyp< $t1$ as $t2$ >> -> pp f "@[<2>%a@ as@ %a@]" o#simple_ctyp t1 o#simple_ctyp t2 + | <:ctyp< $t1$ -> $t2$ >> -> pp f "@[<2>%a@ ->@ %a@]" o#ctyp1 t1 o#ctyp t2 + | <:ctyp< +'$s$ >> -> pp f "+'%a" o#var s + | <:ctyp< -'$s$ >> -> pp f "-'%a" o#var s + | <:ctyp< $t1$ | $t2$ >> -> pp f "%a@ | %a" o#ctyp t1 o#ctyp t2 + | <:ctyp< $t1$ : mutable $t2$ >> -> + pp f "@[mutable@ %a :@ %a@]" o#ctyp t1 o#ctyp t2 + | <:ctyp< $t1$ : $t2$ >> -> pp f "@[<2>%a :@ %a@]" o#ctyp t1 o#ctyp t2 + | <:ctyp< $t1$; $t2$ >> -> pp f "%a;@ %a" o#ctyp t1 o#ctyp t2 + | <:ctyp< $t$ of $<:ctyp<>>$ >> -> o#ctyp f t + | <:ctyp< $t1$ of $t2$ >> -> + pp f "@[%a@ @[<3>of@ %a@]@]" o#ctyp t1 o#constructor_type t2 + | <:ctyp< $t1$ of & $t2$ >> -> + pp f "@[%a@ @[<3>of &@ %a@]@]" o#ctyp t1 o#constructor_type t2 + | <:ctyp< $t1$ and $t2$ >> -> pp f "%a@ and %a" o#ctyp t1 o#ctyp t2 + | <:ctyp< mutable $t$ >> -> pp f "@[<2>mutable@ %a@]" o#ctyp t + | <:ctyp< $t1$ & $t2$ >> -> pp f "%a@ &@ %a" o#ctyp t1 o#ctyp t2 + | <:ctyp< $t1$ == $t2$ >> -> + pp f "@[<2>%a =@ %a@]" o#simple_ctyp t1 o#ctyp t2 + | Ast.TyDcl _ tn tp te cl -> do { + pp f "@[<2>%a%a@]" o#type_params tp o#var tn; + match te with + [ <:ctyp<>> -> () + | _ -> pp f " =@ %a" o#ctyp te ]; + if cl <> [] then pp f "@ %a" (list o#constrain "@ ") cl else (); + } + | Ast.TyExt _ tn tp te -> + pp f "@[<2>%a%a@] =@ %a" o#type_params tp o#ident tn o#ctyp te + | Ast.TyCom (loc, _, _) -> + Loc.raise loc (Failure "this construction is not allowed here") + | t -> o#ctyp1 f t ]; + + method ctyp1 f = fun + [ <:ctyp< $t1$ $t2$ >> -> + match get_ctyp_args t1 [t2] with + [ (_, [_]) -> pp f "@[<2>%a@ %a@]" o#simple_ctyp t2 o#simple_ctyp t1 + | (a, al) -> pp f "@[<2>(%a)@ %a@]" (list o#ctyp ",@ ") al o#simple_ctyp a ] + | <:ctyp< ! $t1$ . $t2$ >> -> + let (a, al) = get_ctyp_args t1 [] in + pp f "@[<2>%a.@ %a@]" (list o#ctyp "@ ") [a::al] o#ctyp t2 + | Ast.TyTypePol (_,t1,t2) -> + let (a, al) = get_ctyp_args t1 [] in + pp f "@[<2>type %a.@ %a@]" (list o#ctyp "@ ") [a::al] o#ctyp t2 + | <:ctyp< private $t$ >> -> pp f "@[private@ %a@]" o#simple_ctyp t + | t -> o#simple_ctyp f t ]; + + method constructor_type f t = + match t with + [ <:ctyp@loc< $t1$ and $t2$ >> -> + let () = o#node f t (fun _ -> loc) in + pp f "%a@ * %a" o#constructor_type t1 o#constructor_type t2 + | <:ctyp< $_$ -> $_$ >> -> pp f "(%a)" o#ctyp t + | t -> o#ctyp f t ]; + + + method sig_item f sg = + let () = o#node f sg Ast.loc_of_sig_item in + match sg with + [ <:sig_item<>> -> () + | <:sig_item< $sg$; $<:sig_item<>>$ >> | + <:sig_item< $<:sig_item<>>$; $sg$ >> -> + o#sig_item f sg + | <:sig_item< $sg1$; $sg2$ >> -> + do { o#sig_item f sg1; cut f; o#sig_item f sg2 } + | <:sig_item< exception $t$ >> -> + pp f "@[<2>exception@ %a%(%)@]" o#ctyp t semisep + | <:sig_item< external $s$ : $t$ = $sl$ >> -> + pp f "@[<2>external@ %a :@ %a =@ %a%(%)@]" + o#var s o#ctyp t (meta_list o#quoted_string "@ ") sl semisep + | Ast.SgMod(_, name, Ast.MtAlias(_, id)) -> + pp f "@[<2>module %a@ =@ %a@]" + o#var name o#ident id + | <:sig_item< module $s1$ ($s2$ : $mt1$) : $mt2$ >> -> + let rec loop accu = + fun + [ <:module_type< functor ($s$ : $mt1$) -> $mt2$ >> -> + loop [(s, mt1)::accu] mt2 + | mt -> (List.rev accu, mt) ] in + let (al, mt) = loop [(s2, mt1)] mt2 in + pp f "@[<2>module %a@ @[<0>%a@] :@ %a%(%)@]" + o#var s1 o#functor_args al o#module_type mt semisep + | <:sig_item< module $s$ : $mt$ >> -> + pp f "@[<2>module %a :@ %a%(%)@]" + o#var s o#module_type mt semisep + | <:sig_item< module type $s$ = $ <:module_type<>> $ >> -> + pp f "@[<2>module type %a%(%)@]" o#var s semisep + | <:sig_item< module type $s$ = $mt$ >> -> + pp f "@[<2>module type %a =@ %a%(%)@]" + o#var s o#module_type mt semisep + | Ast.SgOpn _loc ov sl -> + pp f "@[<2>open%a@ %a%(%)@]" + o#override_flag ov + o#ident sl semisep + | Ast.SgTyp(_, rf, t) -> + pp f "@[@[type%a %a@]%(%)@]" o#nonrec_flag rf o#ctyp t semisep + | <:sig_item< value $s$ : $t$ >> -> + pp f "@[<2>%s %a :@ %a%(%)@]" + o#value_val o#var s o#ctyp t semisep + | <:sig_item< include $mt$ >> -> + pp f "@[<2>include@ %a%(%)@]" o#module_type mt semisep + | <:sig_item< class type $ct$ >> -> + pp f "@[<2>class type %a%(%)@]" o#class_type ct semisep + | <:sig_item< class $ce$ >> -> + pp f "@[<2>class %a%(%)@]" o#class_type ce semisep + | <:sig_item< module rec $mb$ >> -> + pp f "@[<2>module rec %a%(%)@]" + o#module_rec_binding mb semisep + | Ast.SgDir _ _ _ -> () + | <:sig_item< $anti:s$ >> -> + pp f "%a%(%)" o#anti s semisep ]; + + method str_item f st = + let () = o#node f st Ast.loc_of_str_item in + match st with + [ <:str_item<>> -> () + | <:str_item< $st$; $<:str_item<>>$ >> | + <:str_item< $<:str_item<>>$; $st$ >> -> + o#str_item f st + | <:str_item< $st1$; $st2$ >> -> + do { o#str_item f st1; cut f; o#str_item f st2 } + | <:str_item< exception $t$ >> -> + pp f "@[<2>exception@ %a%(%)@]" o#ctyp t semisep + | <:str_item< exception $t$ = $sl$ >> -> + pp f "@[<2>exception@ %a =@ %a%(%)@]" o#ctyp t o#ident sl semisep + | <:str_item< external $s$ : $t$ = $sl$ >> -> + pp f "@[<2>external@ %a :@ %a =@ %a%(%)@]" + o#var s o#ctyp t (meta_list o#quoted_string "@ ") sl semisep + | <:str_item< module $s1$ ($s2$ : $mt1$) = $me$ >> -> + match o#module_expr_get_functor_args [(s2, mt1)] me with + [ (al, me, Some mt2) -> + pp f "@[<2>module %a@ @[<0>%a@] :@ %a =@ %a%(%)@]" + o#var s1 o#functor_args al o#module_type mt2 + o#module_expr me semisep + | (al, me, _) -> + pp f "@[<2>module %a@ @[<0>%a@] =@ %a%(%)@]" + o#var s1 o#functor_args al o#module_expr me semisep ] + | <:str_item< module $s$ : $mt$ = $me$ >> -> + pp f "@[<2>module %a :@ %a =@ %a%(%)@]" + o#var s o#module_type mt o#module_expr me semisep + | <:str_item< module $s$ = $me$ >> -> + pp f "@[<2>module %a =@ %a%(%)@]" o#var s o#module_expr me semisep + | <:str_item< module type $s$ = $mt$ >> -> + pp f "@[<2>module type %a =@ %a%(%)@]" + o#var s o#module_type mt semisep + | Ast.StOpn _loc ov sl -> + (* | <:str_item< open $sl$ >> -> *) + pp f "@[<2>open%a@ %a%(%)@]" + o#override_flag ov + o#ident sl semisep + | Ast.StTyp(_, rf, t) -> + pp f "@[@[type%a %a@]%(%)@]" o#nonrec_flag rf o#ctyp t semisep + | <:str_item< value $rec:r$ $bi$ >> -> + pp f "@[<2>%s %a%a%(%)@]" o#value_let o#rec_flag r o#binding bi semisep + | <:str_item< $exp:e$ >> -> + pp f "@[<2>let _ =@ %a%(%)@]" o#expr e semisep + | <:str_item< include $me$ >> -> + pp f "@[<2>include@ %a%(%)@]" o#simple_module_expr me semisep + | <:str_item< class type $ct$ >> -> + pp f "@[<2>class type %a%(%)@]" o#class_type ct semisep + | <:str_item< class $ce$ >> -> + pp f "@[class %a%(%)@]" o#class_declaration ce semisep + | <:str_item< module rec $mb$ >> -> + pp f "@[<2>module rec %a%(%)@]" o#module_rec_binding mb semisep + | Ast.StDir _ _ _ -> () + | <:str_item< $anti:s$ >> -> pp f "%a%(%)" o#anti s semisep + | Ast.StExc _ _ (Ast.OAnt _) -> assert False ]; + + method module_type f mt = + let () = o#node f mt Ast.loc_of_module_type in + match mt with + [ <:module_type<>> -> assert False + | <:module_type< module type of $me$ >> -> + pp f "@[<2>module type of@ %a@]" o#module_expr me + | <:module_type< $id:i$ >> -> o#ident f i + | <:module_type< $anti:s$ >> -> o#anti f s + | Ast.MtFun(_, "*", Ast.MtNil _, mt) -> + pp f "@[<2>functor@ ()@ ->@ %a@]" o#module_type mt + | <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >> -> + pp f "@[<2>functor@ @[<1>(%a :@ %a)@]@ ->@ %a@]" + o#var s o#module_type mt1 o#module_type mt2 + | <:module_type< '$s$ >> -> pp f "'%a" o#var s + | <:module_type< sig $sg$ end >> -> + pp f "@[@[sig@ %a@]@ end@]" o#sig_item sg + | Ast.MtAtt _loc s str e -> + pp f "((%a)[@@%s %a])" o#module_type e s o#str_item str + | <:module_type< $mt$ with $wc$ >> -> + pp f "@[<2>%a@ with@ %a@]" o#module_type mt o#with_constraint wc + | Ast.MtAlias(_, id) -> + pp f "@[<2>(module@ %a@])" o#ident id ]; + + method with_constraint f wc = + let () = o#node f wc Ast.loc_of_with_constr in + match wc with + [ <:with_constr<>> -> () + | <:with_constr< type $t1$ = $t2$ >> -> + pp f "@[<2>type@ %a =@ %a@]" o#ctyp t1 o#ctyp t2 + | <:with_constr< module $i1$ = $i2$ >> -> + pp f "@[<2>module@ %a =@ %a@]" o#ident i1 o#ident i2 + | <:with_constr< type $t1$ := $t2$ >> -> + pp f "@[<2>type@ %a :=@ %a@]" o#ctyp t1 o#ctyp t2 + | <:with_constr< module $i1$ := $i2$ >> -> + pp f "@[<2>module@ %a :=@ %a@]" o#ident i1 o#ident i2 + | <:with_constr< $wc1$ and $wc2$ >> -> + do { o#with_constraint f wc1; pp f o#andsep; o#with_constraint f wc2 } + | <:with_constr< $anti:s$ >> -> o#anti f s ]; + + method module_expr f me = + let () = o#node f me Ast.loc_of_module_expr in + match me with + [ <:module_expr<>> -> assert False + | <:module_expr< ( struct $st$ end : sig $sg$ end ) >> -> + pp f "@[<2>@[struct@ %a@]@ end :@ @[sig@ %a@]@ end@]" + o#str_item st o#sig_item sg + | _ -> o#simple_module_expr f me ]; + + method simple_module_expr f me = + let () = o#node f me Ast.loc_of_module_expr in + match me with + [ <:module_expr<>> -> assert False + | <:module_expr< $id:i$ >> -> o#ident f i + | <:module_expr< $anti:s$ >> -> o#anti f s + | <:module_expr< $me1$ $me2$ >> -> + pp f "@[<2>%a@,(%a)@]" o#module_expr me1 o#module_expr me2 + | Ast.MeFun(_, "*", Ast.MtNil _, me) -> + pp f "@[<2>functor@ ()@ ->@ %a@]" o#module_expr me + | <:module_expr< functor ( $s$ : $mt$ ) -> $me$ >> -> + pp f "@[<2>functor@ @[<1>(%a :@ %a)@]@ ->@ %a@]" o#var s o#module_type mt o#module_expr me + | <:module_expr< struct $st$ end >> -> + pp f "@[@[struct@ %a@]@ end@]" o#str_item st + | <:module_expr< ( $me$ : $mt$ ) >> -> + pp f "@[<1>(%a :@ %a)@]" o#module_expr me o#module_type mt + | <:module_expr< (value $e$ : $mt$ ) >> -> + pp f "@[<1>(%s %a :@ %a)@]" o#value_val o#expr e o#module_type mt + | <:module_expr< (value $e$ ) >> -> + pp f "@[<1>(%s %a)@]" o#value_val o#expr e + | Ast.MeAtt _loc s str e -> + pp f "((%a)[@@%s %a])" o#module_expr e s o#str_item str + ]; + + method class_expr f ce = + let () = o#node f ce Ast.loc_of_class_expr in + match ce with + [ <:class_expr< $ce$ $e$ >> -> + pp f "@[<2>%a@ %a@]" o#class_expr ce o#apply_expr e + | <:class_expr< $id:i$ >> -> + pp f "@[<2>%a@]" o#ident i + | <:class_expr< $id:i$ [ $t$ ] >> -> + pp f "@[<2>@[<1>[%a]@]@ %a@]" o#class_params t o#ident i + | <:class_expr< virtual $lid:i$ >> -> + pp f "@[<2>virtual@ %a@]" o#var i + | <:class_expr< virtual $lid:i$ [ $t$ ] >> -> + pp f "@[<2>virtual@ @[<1>[%a]@]@ %a@]" o#class_params t o#var i + | <:class_expr< fun $p$ -> $ce$ >> -> + pp f "@[<2>fun@ %a@ ->@ %a@]" o#simple_patt p o#class_expr ce + | <:class_expr< let $rec:r$ $bi$ in $ce$ >> -> + pp f "@[<2>let %a%a@]@ @[<2>in@ %a@]" + o#rec_flag r o#binding bi o#class_expr ce + | <:class_expr< object $cst$ end >> -> + pp f "@[@[object %a@]@ end@]" o#class_str_item cst + | <:class_expr< object ($p$) $cst$ end >> -> + pp f "@[@[object @[<1>(%a)@]@ %a@]@ end@]" + o#patt p o#class_str_item cst + | <:class_expr< ( $ce$ : $ct$ ) >> -> + pp f "@[<1>(%a :@ %a)@]" o#class_expr ce o#class_type ct + | <:class_expr< $anti:s$ >> -> o#anti f s + | <:class_expr< $ce1$ and $ce2$ >> -> + do { o#class_expr f ce1; pp f o#andsep; o#class_expr f ce2 } + | <:class_expr< $ce1$ = fun $p$ -> $ce2$ >> when is_irrefut_patt p -> + pp f "@[<2>%a@ %a" o#class_expr ce1 + o#patt_class_expr_fun_args (p, ce2) + | <:class_expr< $ce1$ = $ce2$ >> -> + pp f "@[<2>%a =@]@ %a" o#class_expr ce1 o#class_expr ce2 + | Ast.CeAtt _loc s str e -> + pp f "((%a)[@@%s %a])" o#class_expr e s o#str_item str + | _ -> assert False ]; + + method class_type f ct = + let () = o#node f ct Ast.loc_of_class_type in + match ct with + [ <:class_type< $id:i$ >> -> + pp f "@[<2>%a@]" o#ident i + | <:class_type< $id:i$ [ $t$ ] >> -> + pp f "@[<2>[@,%a@]@,]@ %a" o#class_params t o#ident i + | <:class_type< virtual $lid:i$ >> -> + pp f "@[<2>virtual@ %a@]" o#var i + | <:class_type< virtual $lid:i$ [ $t$ ] >> -> + pp f "@[<2>virtual@ [@,%a@]@,]@ %a" o#class_params t o#var i + | <:class_type< [ $t$ ] -> $ct$ >> -> + pp f "@[<2>%a@ ->@ %a@]" o#simple_ctyp t o#class_type ct + | <:class_type< object $csg$ end >> -> + pp f "@[@[object@ %a@]@ end@]" o#class_sig_item csg + | <:class_type< object ($t$) $csg$ end >> -> + pp f "@[@[object @[<1>(%a)@]@ %a@]@ end@]" + o#ctyp t o#class_sig_item csg + | <:class_type< $anti:s$ >> -> o#anti f s + | <:class_type< $ct1$ and $ct2$ >> -> + do { o#class_type f ct1; pp f o#andsep; o#class_type f ct2 } + | <:class_type< $ct1$ : $ct2$ >> -> + pp f "%a :@ %a" o#class_type ct1 o#class_type ct2 + | <:class_type< $ct1$ = $ct2$ >> -> + pp f "%a =@ %a" o#class_type ct1 o#class_type ct2 + | Ast.CtAtt _loc s str e -> + pp f "((%a)[@@%s %a])" o#class_type e s o#str_item str + | _ -> assert False ]; + + method class_sig_item f csg = + let () = o#node f csg Ast.loc_of_class_sig_item in + match csg with + [ <:class_sig_item<>> -> () + | <:class_sig_item< $csg$; $<:class_sig_item<>>$ >> | + <:class_sig_item< $<:class_sig_item<>>$; $csg$ >> -> + o#class_sig_item f csg + | <:class_sig_item< $csg1$; $csg2$ >> -> + do { o#class_sig_item f csg1; cut f; o#class_sig_item f csg2 } + | <:class_sig_item< constraint $t1$ = $t2$ >> -> + pp f "@[<2>constraint@ %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 no_semisep + | <:class_sig_item< inherit $ct$ >> -> + pp f "@[<2>inherit@ %a%(%)@]" o#class_type ct no_semisep + | <:class_sig_item< method $private:pr$ $s$ : $t$ >> -> + pp f "@[<2>method %a%a :@ %a%(%)@]" o#private_flag pr o#var s + o#ctyp t no_semisep + | <:class_sig_item< method virtual $private:pr$ $s$ : $t$ >> -> + pp f "@[<2>method virtual %a%a :@ %a%(%)@]" + o#private_flag pr o#var s o#ctyp t no_semisep + | <:class_sig_item< value $mutable:mu$ $virtual:vi$ $s$ : $t$ >> -> + pp f "@[<2>%s %a%a%a :@ %a%(%)@]" + o#value_val o#mutable_flag mu o#virtual_flag vi o#var s o#ctyp t + no_semisep + | <:class_sig_item< $anti:s$ >> -> + pp f "%a%(%)" o#anti s no_semisep ]; + + method class_str_item f cst = + let () = o#node f cst Ast.loc_of_class_str_item in + match cst with + [ <:class_str_item<>> -> () + | <:class_str_item< $cst$; $<:class_str_item<>>$ >> | + <:class_str_item< $<:class_str_item<>>$; $cst$ >> -> + o#class_str_item f cst + | <:class_str_item< $cst1$; $cst2$ >> -> + do { o#class_str_item f cst1; cut f; o#class_str_item f cst2 } + | <:class_str_item< constraint $t1$ = $t2$ >> -> + pp f "@[<2>constraint %a =@ %a%(%)@]" o#ctyp t1 o#ctyp t2 no_semisep + | <:class_str_item< inherit $override:ov$ $ce$ >> -> + pp f "@[<2>inherit%a@ %a%(%)@]" o#override_flag ov o#class_expr ce no_semisep + | <:class_str_item< inherit $override:ov$ $ce$ as $lid:s$ >> -> + pp f "@[<2>inherit%a@ %a as@ %a%(%)@]" o#override_flag ov o#class_expr ce o#var s no_semisep + | <:class_str_item< initializer $e$ >> -> + pp f "@[<2>initializer@ %a%(%)@]" o#expr e no_semisep + | <:class_str_item< method $override:ov$ $private:pr$ $s$ = $e$ >> -> + pp f "@[<2>method%a %a%a =@ %a%(%)@]" + o#override_flag ov o#private_flag pr o#var s o#expr e no_semisep + | <:class_str_item< method $override:ov$ $private:pr$ $s$ : $t$ = $e$ >> -> + pp f "@[<2>method%a %a%a :@ %a =@ %a%(%)@]" + o#override_flag ov o#private_flag pr o#var s o#ctyp t o#expr e no_semisep + | <:class_str_item< method virtual $private:pr$ $s$ : $t$ >> -> + pp f "@[<2>method virtual@ %a%a :@ %a%(%)@]" + o#private_flag pr o#var s o#ctyp t no_semisep + | <:class_str_item< value virtual $mutable:mu$ $s$ : $t$ >> -> + pp f "@[<2>%s virtual %a%a :@ %a%(%)@]" + o#value_val o#mutable_flag mu o#var s o#ctyp t no_semisep + | <:class_str_item< value $override:ov$ $mutable:mu$ $s$ = $e$ >> -> + pp f "@[<2>%s%a %a%a =@ %a%(%)@]" + o#value_val o#override_flag ov o#mutable_flag mu o#var s o#expr e no_semisep + | <:class_str_item< $anti:s$ >> -> + pp f "%a%(%)" o#anti s no_semisep ]; + + method implem f st = + match st with + [ <:str_item< $exp:e$ >> -> pp f "@[<0>%a%(%)@]@." o#expr e semisep + | st -> pp f "@[%a@]@." o#str_item st ]; + + method interf f sg = pp f "@[%a@]@." o#sig_item sg; + end; + + value with_outfile output_file fct arg = + let call close f = do { + try fct f arg with [ exn -> do { close (); raise exn } ]; + close () + } in + match output_file with + [ None -> call (fun () -> ()) std_formatter + | Some s -> + let oc = open_out s in + let f = formatter_of_out_channel oc in + call (fun () -> close_out oc) f ]; + + value print output_file fct = + let o = new printer () in + with_outfile output_file (fct o); + + value print_interf ?input_file:(_) ?output_file sg = + print output_file (fun o -> o#interf) sg; + + value print_implem ?input_file:(_) ?output_file st = + print output_file (fun o -> o#implem) st; + +end; + +module MakeMore (Syntax : Sig.Camlp4Syntax) +: (Sig.Printer Syntax.Ast).S += struct + + include Make Syntax; + + value semisep : ref sep = ref ("@\n" : sep); + value margin = ref 78; + value comments = ref True; + value locations = ref False; + value curry_constr = ref False; + + value print output_file fct = + let o = new printer ~comments:comments.val + ~curry_constr:curry_constr.val () in + let o = o#set_semisep semisep.val in + let o = if locations.val then o#set_loc_and_comments else o in + with_outfile output_file + (fun f -> + let () = Format.pp_set_margin f margin.val in + Format.fprintf f "@[%a@]@." (fct o)); + + value print_interf ?input_file:(_) ?output_file sg = + print output_file (fun o -> o#interf) sg; + + value print_implem ?input_file:(_) ?output_file st = + print output_file (fun o -> o#implem) st; + + value check_sep s = + if String.contains s '%' then failwith "-sep Format error, % found in string" + else (Obj.magic (Struct.Token.Eval.string s : string) : sep); + + Options.add "-l" (Arg.Int (fun i -> margin.val := i)) + " line length for pretty printing."; + + Options.add "-ss" (Arg.Unit (fun () -> semisep.val := ";;")) + " Print double semicolons."; + + Options.add "-no_ss" (Arg.Unit (fun () -> semisep.val := "")) + " Do not print double semicolons (default)."; + + Options.add "-sep" (Arg.String (fun s -> semisep.val := check_sep s)) + " Use this string between phrases."; + + Options.add "-curry-constr" (Arg.Set curry_constr) "Use currified constructors."; + + Options.add "-no_comments" (Arg.Clear comments) "Do not add comments."; + + Options.add "-add_locations" (Arg.Set locations) "Add locations as comment."; + +end; diff --git a/camlp4/Camlp4/Printers/OCaml.mli b/camlp4/Camlp4/Printers/OCaml.mli new file mode 100644 index 0000000..fbb8fc1 --- /dev/null +++ b/camlp4/Camlp4/Printers/OCaml.mli @@ -0,0 +1,169 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +module Id : Sig.Id; + +module Make (Syntax : Sig.Camlp4Syntax) : sig + open Format; + include Sig.Camlp4Syntax + with module Loc = Syntax.Loc + and module Token = Syntax.Token + and module Ast = Syntax.Ast + and module Gram = Syntax.Gram; + + type sep = format unit formatter unit; + type fun_binding = [= `patt of Ast.patt | `newtype of string ]; + + value list' : + (formatter -> 'a -> unit) -> + format 'b formatter unit -> + format unit formatter unit -> + formatter -> list 'a -> unit; + + value list : + (formatter -> 'a -> unit) -> + format 'b formatter unit -> + formatter -> list 'a -> unit; + + value lex_string : string -> Token.t; + value is_infix : string -> bool; + value is_keyword : string -> bool; + value ocaml_char : string -> string; + value get_expr_args : + Ast.expr -> list Ast.expr -> (Ast.expr * list Ast.expr); + value get_patt_args : + Ast.patt -> list Ast.patt -> (Ast.patt * list Ast.patt); + value get_ctyp_args : + Ast.ctyp -> list Ast.ctyp -> (Ast.ctyp * list Ast.ctyp); + value expr_fun_args : Ast.expr -> (list fun_binding * Ast.expr); + + (** + [new printer ~curry_constr:True ~comments:False] + Default values: curry_constr = False + comments = True + *) + class printer : + [?curry_constr: bool] -> [?comments: bool] -> [unit] -> + object ('a) + method interf : formatter -> Ast.sig_item -> unit; + method implem : formatter -> Ast.str_item -> unit; + method sig_item : formatter -> Ast.sig_item -> unit; + method str_item : formatter -> Ast.str_item -> unit; + + value pipe : bool; + value semi : bool; + value semisep : sep; + value no_semisep : sep; + method value_val : string; + method value_let : string; + method andsep : sep; + method anti : formatter -> string -> unit; + method class_declaration : + formatter -> Ast.class_expr -> unit; + method class_expr : formatter -> Ast.class_expr -> unit; + method class_sig_item : + formatter -> Ast.class_sig_item -> unit; + method class_str_item : + formatter -> Ast.class_str_item -> unit; + method class_type : formatter -> Ast.class_type -> unit; + method constrain : + formatter -> (Ast.ctyp * Ast.ctyp) -> unit; + method ctyp : formatter -> Ast.ctyp -> unit; + method ctyp1 : formatter -> Ast.ctyp -> unit; + method constructor_type : formatter -> Ast.ctyp -> unit; + method dot_expr : formatter -> Ast.expr -> unit; + method apply_expr : formatter -> Ast.expr -> unit; + method expr : formatter -> Ast.expr -> unit; + method expr_list : formatter -> list Ast.expr -> unit; + method expr_list_cons : bool -> formatter -> Ast.expr -> unit; + method fun_binding : formatter -> fun_binding -> unit; + method functor_arg_var : formatter -> string -> unit; + method functor_arg : + formatter -> (string * Ast.module_type) -> unit; + method functor_args : + formatter -> + list (string * Ast.module_type) -> unit; + method ident : formatter -> Ast.ident -> unit; + method numeric : formatter -> string -> string -> unit; + method binding : formatter -> Ast.binding -> unit; + method record_binding : formatter -> Ast.rec_binding -> unit; + method match_case : formatter -> Ast.match_case -> unit; + method match_case_aux : formatter -> Ast.match_case -> unit; + method mk_expr_list : Ast.expr -> (list Ast.expr * option Ast.expr); + method mk_patt_list : Ast.patt -> (list Ast.patt * option Ast.patt); + method simple_module_expr : formatter -> Ast.module_expr -> unit; + method module_expr : formatter -> Ast.module_expr -> unit; + method module_expr_get_functor_args : + list (string * Ast.module_type) -> + Ast.module_expr -> + (list (string * Ast.module_type) * + Ast.module_expr * + option Ast.module_type); + method module_rec_binding : formatter -> Ast.module_binding -> unit; + method module_type : formatter -> Ast.module_type -> unit; + method override_flag : formatter -> Ast.override_flag -> unit; + method mutable_flag : formatter -> Ast.mutable_flag -> unit; + method direction_flag : formatter -> Ast.direction_flag -> unit; + method rec_flag : formatter -> Ast.rec_flag -> unit; + method nonrec_flag : formatter -> Ast.rec_flag -> unit; + method node : formatter -> 'b -> ('b -> Loc.t) -> unit; + method patt : formatter -> Ast.patt -> unit; + method patt1 : formatter -> Ast.patt -> unit; + method patt2 : formatter -> Ast.patt -> unit; + method patt3 : formatter -> Ast.patt -> unit; + method patt4 : formatter -> Ast.patt -> unit; + method patt5 : formatter -> Ast.patt -> unit; + method patt_tycon : formatter -> Ast.patt -> unit; + method patt_expr_fun_args : + formatter -> (fun_binding * Ast.expr) -> unit; + method patt_class_expr_fun_args : + formatter -> (Ast.patt * Ast.class_expr) -> unit; + method print_comments_before : Loc.t -> formatter -> unit; + method private_flag : formatter -> Ast.private_flag -> unit; + method virtual_flag : formatter -> Ast.virtual_flag -> unit; + method quoted_string : formatter -> string -> unit; + method raise_match_failure : formatter -> Loc.t -> unit; + method reset : 'a; + method reset_semi : 'a; + method semisep : sep; + method set_comments : bool -> 'a; + method set_curry_constr : bool -> 'a; + method set_loc_and_comments : 'a; + method set_semisep : sep -> 'a; + method simple_ctyp : formatter -> Ast.ctyp -> unit; + method simple_expr : formatter -> Ast.expr -> unit; + method simple_patt : formatter -> Ast.patt -> unit; + method seq : formatter -> Ast.expr -> unit; + method string : formatter -> string -> unit; + method sum_type : formatter -> Ast.ctyp -> unit; + method type_params : formatter -> list Ast.ctyp -> unit; + method class_params : formatter -> Ast.ctyp -> unit; + method under_pipe : 'a; + method under_semi : 'a; + method var : formatter -> string -> unit; + method with_constraint : formatter -> Ast.with_constr -> unit; + end; + + value with_outfile : + option string -> (formatter -> 'a -> unit) -> 'a -> unit; + + value print : + option string -> (printer -> formatter -> 'a -> unit) -> 'a -> unit; +end; + +module MakeMore (Syntax : Sig.Camlp4Syntax) : (Sig.Printer Syntax.Ast).S; diff --git a/camlp4/Camlp4/Printers/OCamlr.ml b/camlp4/Camlp4/Printers/OCamlr.ml new file mode 100644 index 0000000..d22efcd --- /dev/null +++ b/camlp4/Camlp4/Printers/OCamlr.ml @@ -0,0 +1,324 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +open Format; + +module Id = struct + value name = "Camlp4.Printers.OCamlr"; + value version = Sys.ocaml_version; +end; + +module Make (Syntax : Sig.Camlp4Syntax) = struct + include Syntax; + open Sig; + + module PP_o = OCaml.Make Syntax; + + open PP_o; + + value pp = fprintf; + + value is_keyword = + let keywords = ["where"] + and not_keywords = ["false"; "function"; "true"; "val"] + in fun s -> not (List.mem s not_keywords) + && (is_keyword s || List.mem s keywords); + + class printer ?curry_constr:(init_curry_constr = True) ?(comments = True) () = + object (o) + inherit PP_o.printer ~curry_constr:init_curry_constr ~comments () as super; + + value! semisep : sep = ";"; + value! no_semisep : sep = ";"; + value mode = if comments then `comments else `no_comments; + value curry_constr = init_curry_constr; + value first_match_case = True; + + method andsep : sep = "@]@ @[<2>and@ "; + method value_val = "value"; + method value_let = "value"; + method under_pipe = o; + method under_semi = o; + method reset_semi = o; + method reset = o; + method private unset_first_match_case = {< first_match_case = False >}; + method private set_first_match_case = {< first_match_case = True >}; + + method seq f e = + let rec self right f e = + let go_right = self right and go_left = self False in + match e with + [ <:expr< let $rec:r$ $bi$ in $e1$ >> -> + if right then + pp f "@[<2>let %a%a@];@ %a" + o#rec_flag r o#binding bi go_right e1 + else + pp f "(%a)" o#expr e + | <:expr< do { $e$ } >> -> go_right f e + | <:expr< $e1$; $e2$ >> -> do { + pp f "%a;@ " go_left e1; + match (right, e2) with + [ (True, <:expr< let $rec:r$ $bi$ in $e3$ >>) -> + pp f "@[<2>let %a%a@];@ %a" + o#rec_flag r o#binding bi go_right e3 + | _ -> go_right f e2 ] } + | e -> o#expr f e ] + in self True f e; + + method var f = + fun + [ "" -> pp f "$lid:\"\"$" + | "[]" -> pp f "[]" + | "()" -> pp f "()" + | " True" -> pp f "True" + | " False" -> pp f "False" + | v -> + match lex_string v with + [ (LIDENT s | UIDENT s | ESCAPED_IDENT s) when is_keyword s -> + pp f "%s__" s + | SYMBOL s -> + pp f "( %s )" s + | LIDENT s | UIDENT s | ESCAPED_IDENT s -> + pp_print_string f s + | tok -> failwith (sprintf + "Bad token used as an identifier: %s" + (Token.to_string tok)) ] ]; + + method type_params f = + fun + [ [] -> () + | [x] -> pp f "@ %a" o#ctyp x + | l -> pp f "@ @[<1>%a@]" (list o#ctyp "@ ") l ]; + + method match_case f = + fun + [ <:match_case<>> -> pp f "@ []" + | m -> pp f "@ [ %a ]" o#set_first_match_case#match_case_aux m ]; + + method match_case_aux f = + fun + [ <:match_case<>> -> () + | <:match_case< $anti:s$ >> -> o#anti f s + | <:match_case< $a1$ | $a2$ >> -> + pp f "%a%a" o#match_case_aux a1 o#unset_first_match_case#match_case_aux a2 + | <:match_case< $p$ -> $e$ >> -> + let () = if first_match_case then () else pp f "@ | " in + pp f "@[<2>%a@ ->@ %a@]" o#patt p o#under_pipe#expr e + | <:match_case< $p$ when $w$ -> $e$ >> -> + let () = if first_match_case then () else pp f "@ | " in + pp f "@[<2>%a@ when@ %a@ ->@ %a@]" + o#patt p o#under_pipe#expr w o#under_pipe#expr e ]; + + method sum_type f = + fun + [ <:ctyp<>> -> pp f "[]" + | t -> pp f "@[[ %a ]@]" o#ctyp t + ]; + + method ident f i = + let () = o#node f i Ast.loc_of_ident in + match i with + [ <:ident< $i1$ $i2$ >> -> pp f "%a@ %a" o#dot_ident i1 o#dot_ident i2 + | i -> o#dot_ident f i ]; + + method private dot_ident f i = + let () = o#node f i Ast.loc_of_ident in + match i with + [ <:ident< $i1$.$i2$ >> -> pp f "%a.@,%a" o#dot_ident i1 o#dot_ident i2 + | <:ident< $anti:s$ >> -> o#anti f s + | <:ident< $lid:s$ >> | <:ident< $uid:s$ >> -> o#var f s + | i -> pp f "(%a)" o#ident i ]; + + method patt4 f = fun + [ <:patt< [$_$ :: $_$] >> as p -> + let (pl, c) = o#mk_patt_list p in + match c with + [ None -> pp f "@[<2>[@ %a@]@ ]" (list o#patt ";@ ") pl + | Some x -> pp f "@[<2>[ %a ::@ %a ]@]" (list o#patt ";@ ") pl o#patt x ] + | p -> super#patt4 f p ]; + + method expr_list_cons _ f e = + let (el, c) = o#mk_expr_list e in + match c with + [ None -> o#expr_list f el + | Some x -> pp f "@[<2>[ %a ::@ %a ]@]" (list o#expr ";@ ") el o#expr x ]; + + method expr f e = + let () = o#node f e Ast.loc_of_expr in + match e with + [ <:expr< $e1$ := $e2$ >> -> + pp f "@[<2>%a@ :=@ %a@]" o#dot_expr e1 o#expr e2 + | <:expr< fun $p$ -> $e$ >> when Ast.is_irrefut_patt p -> + pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (`patt p, e) + | <:expr< fun (type $i$) -> $e$ >> -> + pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (`newtype i, e) + | <:expr< fun [ $a$ ] >> -> + pp f "@[fun%a@]" o#match_case a + | <:expr< assert False >> -> pp f "@[<2>assert@ False@]" + | e -> super#expr f e ]; + + method dot_expr f e = + let () = o#node f e Ast.loc_of_expr in + match e with + [ <:expr< $e$.val >> -> pp f "@[<2>%a.@,val@]" o#simple_expr e + | e -> super#dot_expr f e ]; + + method ctyp f t = + let () = o#node f t Ast.loc_of_ctyp in + match t with + [ Ast.TyDcl _ tn tp te cl -> do { + pp f "@[<2>%a%a@]" o#var tn o#type_params tp; + match te with + [ <:ctyp<>> -> () + | _ -> pp f " =@ %a" o#ctyp te ]; + if cl <> [] then pp f "@ %a" (list o#constrain "@ ") cl else (); + } + | <: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 = + let () = o#node f t Ast.loc_of_ctyp in + match t with + [ <:ctyp< [ = $t$ ] >> -> pp f "@[<2>[ =@ %a@]@ ]" o#ctyp t + | <:ctyp< [ < $t$ ] >> -> pp f "@[<2>[ <@ %a@]@,]" o#ctyp t + | <:ctyp< [ < $t1$ > $t2$ ] >> -> + pp f "@[<2>[ <@ %a@ >@ %a@]@ ]" o#ctyp t1 o#ctyp t2 + | <:ctyp< [ > $t$ ] >> -> pp f "@[<2>[ >@ %a@]@,]" o#ctyp t + | <:ctyp< $t1$ == $t2$ >> -> + pp f "@[<2>%a@ ==@ %a@]" o#simple_ctyp t1 o#simple_ctyp t2 + | <:ctyp< ~ $s$ : $t$ >> -> pp f "@[<2>~%s:@ %a@]" s o#simple_ctyp t + | t -> super#simple_ctyp f t ]; + + method ctyp1 f = fun + [ <:ctyp< $t1$ $t2$ >> -> + match get_ctyp_args t1 [t2] with + [ (_, [_]) -> pp f "@[<2>%a@ %a@]" o#simple_ctyp t1 o#simple_ctyp t2 + | (a, al) -> pp f "@[<2>%a@]" (list o#simple_ctyp "@ ") [a::al] ] + | <:ctyp< ! $t1$ . $t2$ >> -> + let (a, al) = get_ctyp_args t1 [] in + pp f "@[<2>! %a.@ %a@]" (list o#ctyp "@ ") [a::al] o#ctyp t2 + | t -> super#ctyp1 f t ]; + + method constructor_type f t = + match t with + [ <:ctyp@loc< $t1$ and $t2$ >> -> + let () = o#node f t (fun _ -> loc) in + pp f "%a@ and %a" o#constructor_type t1 o#constructor_type t2 + | t -> o#ctyp f t ]; + + method str_item f st = + match st with + [ <:str_item< $exp:e$ >> -> pp f "@[<2>%a%(%)@]" o#expr e semisep + | st -> super#str_item f st ]; + + method module_expr f me = + let () = o#node f me Ast.loc_of_module_expr in + match me with + [ <:module_expr< $me1$ $me2$ >> -> + pp f "@[<2>%a@ %a@]" o#module_expr me1 o#simple_module_expr me2 + | me -> super#module_expr f me ]; + + method simple_module_expr f me = + let () = o#node f me Ast.loc_of_module_expr in + match me with + [ <:module_expr< $_$ $_$ >> -> + pp f "(%a)" o#module_expr me + | _ -> super#simple_module_expr f me ]; + + method implem f st = pp f "@[%a@]@." o#str_item st; + + method class_type f ct = + let () = o#node f ct Ast.loc_of_class_type in + match ct with + [ <:class_type< [ $t$ ] -> $ct$ >> -> + pp f "@[<2>[ %a ] ->@ %a@]" o#simple_ctyp t o#class_type ct + | <:class_type< $id:i$ >> -> + pp f "@[<2>%a@]" o#ident i + | <:class_type< $id:i$ [ $t$ ] >> -> + pp f "@[<2>%a [@,%a@]@,]" o#ident i o#class_params t + | <:class_type< virtual $lid:i$ >> -> + pp f "@[<2>virtual@ %a@]" o#var i + | <:class_type< virtual $lid:i$ [ $t$ ] >> -> + pp f "@[<2>virtual@ %a@ [@,%a@]@,]" o#var i o#class_params t + | ct -> super#class_type f ct ]; + + method class_expr f ce = + let () = o#node f ce Ast.loc_of_class_expr in + match ce with + [ <:class_expr< $id:i$ >> -> + pp f "@[<2>%a@]" o#ident i + | <:class_expr< $id:i$ [ $t$ ] >> -> + pp f "@[<2>%a@ @[<1>[%a]@]@]" o#ident i o#class_params t + | <:class_expr< virtual $lid:i$ >> -> + pp f "@[<2>virtual@ %a@]" o#var i + | <:class_expr< virtual $lid:i$ [ $t$ ] >> -> + pp f "@[<2>virtual@ %a@ @[<1>[%a]@]@]" o#var i o#class_params t + | ce -> super#class_expr f ce ]; + end; + + value with_outfile = with_outfile; + + value print output_file fct = + let o = new printer () in + with_outfile output_file (fct o); + + value print_interf ?input_file:(_) ?output_file sg = + print output_file (fun o -> o#interf) sg; + + value print_implem ?input_file:(_) ?output_file st = + print output_file (fun o -> o#implem) st; + +end; + +module MakeMore (Syntax : Sig.Camlp4Syntax) +: (Sig.Printer Syntax.Ast).S += struct + + include Make Syntax; + + value margin = ref 78; + value comments = ref True; + value locations = ref False; + value curry_constr = ref True; + + value print output_file fct = + let o = new printer ~comments:comments.val + ~curry_constr:curry_constr.val () in + let o = if locations.val then o#set_loc_and_comments else o in + with_outfile output_file + (fun f -> + let () = Format.pp_set_margin f margin.val in + Format.fprintf f "@[%a@]@." (fct o)); + + value print_interf ?input_file:(_) ?output_file sg = + print output_file (fun o -> o#interf) sg; + + value print_implem ?input_file:(_) ?output_file st = + print output_file (fun o -> o#implem) st; + + Options.add "-l" (Arg.Int (fun i -> margin.val := i)) + " line length for pretty printing."; + + Options.add "-no_comments" (Arg.Clear comments) "Do not add comments."; + + Options.add "-add_locations" (Arg.Set locations) "Add locations as comment."; + +end; diff --git a/camlp4/Camlp4/Printers/OCamlr.mli b/camlp4/Camlp4/Printers/OCamlr.mli new file mode 100644 index 0000000..b155d65 --- /dev/null +++ b/camlp4/Camlp4/Printers/OCamlr.mli @@ -0,0 +1,47 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +module Id : Sig.Id; + +module Make (Syntax : Sig.Camlp4Syntax) : sig + open Format; + include Sig.Camlp4Syntax + with module Loc = Syntax.Loc + and module Token = Syntax.Token + and module Ast = Syntax.Ast + and module Gram = Syntax.Gram; + + (** + [new printer ~curry_constr:c ~comments:False] + Default values: curry_constr = True + comments = True + *) + class printer : + [?curry_constr: bool] -> [?comments: bool] -> [unit] -> + object ('a) + inherit (OCaml.Make Syntax).printer; + end; + + value with_outfile : + option string -> (formatter -> 'a -> unit) -> 'a -> unit; + + value print : + option string -> (printer -> formatter -> 'a -> unit) -> 'a -> unit; +end; + +module MakeMore (Syntax : Sig.Camlp4Syntax) : (Sig.Printer Syntax.Ast).S; diff --git a/camlp4/Camlp4/Register.ml b/camlp4/Camlp4/Register.ml new file mode 100644 index 0000000..5cac6bd --- /dev/null +++ b/camlp4/Camlp4/Register.ml @@ -0,0 +1,171 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module PP = Printers; +open PreCast; + +type parser_fun 'a = + ?directive_handler:('a -> option 'a) -> PreCast.Loc.t -> Stream.t char -> 'a; + +type printer_fun 'a = + ?input_file:string -> ?output_file:string -> 'a -> unit; + +value sig_item_parser = ref (fun ?directive_handler:(_) _ _ -> failwith "No interface parser"); +value str_item_parser = ref (fun ?directive_handler:(_) _ _ -> failwith "No implementation parser"); + +value sig_item_printer = ref (fun ?input_file:(_) ?output_file:(_) _ -> failwith "No interface printer"); +value str_item_printer = ref (fun ?input_file:(_) ?output_file:(_) _ -> failwith "No implementation printer"); + +value callbacks = Queue.create (); + +value loaded_modules = ref []; + +value iter_and_take_callbacks f = + let rec loop () = loop (f (Queue.take callbacks)) in + try loop () with [ Queue.Empty -> () ]; + +value declare_dyn_module m f = + begin + (* let () = Format.eprintf "declare_dyn_module: %s@." m in *) + loaded_modules.val := [ m :: loaded_modules.val ]; + Queue.add (m, f) callbacks; + end; + +value register_str_item_parser f = str_item_parser.val := f; +value register_sig_item_parser f = sig_item_parser.val := f; +value register_parser f g = + do { str_item_parser.val := f; sig_item_parser.val := g }; +value current_parser () = (str_item_parser.val, sig_item_parser.val); + +value register_str_item_printer f = str_item_printer.val := f; +value register_sig_item_printer f = sig_item_printer.val := f; +value register_printer f g = + do { str_item_printer.val := f; sig_item_printer.val := g }; +value current_printer () = (str_item_printer.val, sig_item_printer.val); + +module Plugin (Id : Sig.Id) (Maker : functor (Unit : sig end) -> sig end) = struct + declare_dyn_module Id.name (fun _ -> let module M = Maker (struct end) in ()); +end; + +module SyntaxExtension (Id : Sig.Id) (Maker : Sig.SyntaxExtension) = struct + declare_dyn_module Id.name (fun _ -> let module M = Maker Syntax in ()); +end; + +module OCamlSyntaxExtension + (Id : Sig.Id) (Maker : functor (Syn : Sig.Camlp4Syntax) -> Sig.Camlp4Syntax) = +struct + declare_dyn_module Id.name (fun _ -> let module M = Maker Syntax in ()); +end; + +module SyntaxPlugin (Id : Sig.Id) (Maker : functor (Syn : Sig.Syntax) -> sig end) = struct + declare_dyn_module Id.name (fun _ -> let module M = Maker Syntax in ()); +end; + +module Printer + (Id : Sig.Id) (Maker : functor (Syn : Sig.Syntax) + -> (Sig.Printer Syn.Ast).S) = +struct + declare_dyn_module Id.name (fun _ -> + let module M = Maker Syntax in + register_printer M.print_implem M.print_interf); +end; + +module OCamlPrinter + (Id : Sig.Id) (Maker : functor (Syn : Sig.Camlp4Syntax) + -> (Sig.Printer Syn.Ast).S) = +struct + declare_dyn_module Id.name (fun _ -> + let module M = Maker Syntax in + register_printer M.print_implem M.print_interf); +end; + +module OCamlPreCastPrinter + (Id : Sig.Id) (P : (Sig.Printer PreCast.Ast).S) = +struct + declare_dyn_module Id.name (fun _ -> + register_printer P.print_implem P.print_interf); +end; + +module Parser + (Id : Sig.Id) (Maker : functor (Ast : Sig.Ast) + -> (Sig.Parser Ast).S) = +struct + declare_dyn_module Id.name (fun _ -> + let module M = Maker PreCast.Ast in + register_parser M.parse_implem M.parse_interf); +end; + +module OCamlParser + (Id : Sig.Id) (Maker : functor (Ast : Sig.Camlp4Ast) + -> (Sig.Parser Ast).S) = +struct + declare_dyn_module Id.name (fun _ -> + let module M = Maker PreCast.Ast in + register_parser M.parse_implem M.parse_interf); +end; + +module OCamlPreCastParser + (Id : Sig.Id) (P : (Sig.Parser PreCast.Ast).S) = +struct + declare_dyn_module Id.name (fun _ -> + register_parser P.parse_implem P.parse_interf); +end; + +module AstFilter + (Id : Sig.Id) (Maker : functor (F : Sig.AstFilters) -> sig end) = +struct + declare_dyn_module Id.name (fun _ -> let module M = Maker AstFilters in ()); +end; + +sig_item_parser.val := Syntax.parse_interf; +str_item_parser.val := Syntax.parse_implem; + +module CurrentParser = struct + module Ast = Ast; + value parse_interf ?directive_handler loc strm = + sig_item_parser.val ?directive_handler loc strm; + value parse_implem ?directive_handler loc strm = + str_item_parser.val ?directive_handler loc strm; +end; + +module CurrentPrinter = struct + module Ast = Ast; + value print_interf ?input_file ?output_file ast = + sig_item_printer.val ?input_file ?output_file ast; + value print_implem ?input_file ?output_file ast = + str_item_printer.val ?input_file ?output_file ast; +end; + +value enable_ocaml_printer () = + let module M = OCamlPrinter PP.OCaml.Id PP.OCaml.MakeMore in (); + +value enable_ocamlr_printer () = + let module M = OCamlPrinter PP.OCamlr.Id PP.OCamlr.MakeMore in (); + +(* value enable_ocamlrr_printer () = + let module M = OCamlPrinter PP.OCamlrr.Id PP.OCamlrr.MakeMore in (); *) + +value enable_dump_ocaml_ast_printer () = + let module M = OCamlPrinter PP.DumpOCamlAst.Id PP.DumpOCamlAst.Make in (); + +value enable_dump_camlp4_ast_printer () = + let module M = Printer PP.DumpCamlp4Ast.Id PP.DumpCamlp4Ast.Make in (); + +value enable_null_printer () = + let module M = Printer PP.Null.Id PP.Null.Make in (); diff --git a/camlp4/Camlp4/Register.mli b/camlp4/Camlp4/Register.mli new file mode 100644 index 0000000..371d526 --- /dev/null +++ b/camlp4/Camlp4/Register.mli @@ -0,0 +1,95 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Plugin + (Id : Sig.Id) (Plugin : functor (Unit : sig end) -> sig end) : sig end; + +module SyntaxPlugin + (Id : Sig.Id) (SyntaxPlugin : functor (Syn : Sig.Syntax) -> sig end) : + sig end; + +module SyntaxExtension + (Id : Sig.Id) (SyntaxExtension : Sig.SyntaxExtension) : sig end; + +module OCamlSyntaxExtension + (Id : Sig.Id) + (SyntaxExtension : functor (Syntax : Sig.Camlp4Syntax) -> Sig.Camlp4Syntax) + : sig end; + +(** {6 Registering Parsers} *) + +type parser_fun 'a = + ?directive_handler:('a -> option 'a) -> PreCast.Loc.t -> Stream.t char -> 'a; + +value register_str_item_parser : parser_fun PreCast.Ast.str_item -> unit; +value register_sig_item_parser : parser_fun PreCast.Ast.sig_item -> unit; +value register_parser : parser_fun PreCast.Ast.str_item -> parser_fun PreCast.Ast.sig_item -> unit; +value current_parser : unit -> (parser_fun PreCast.Ast.str_item * parser_fun PreCast.Ast.sig_item); + +module Parser + (Id : Sig.Id) (Maker : functor (Ast : Sig.Ast) -> (Sig.Parser Ast).S) : sig end; + +module OCamlParser + (Id : Sig.Id) (Maker : functor (Ast : Sig.Camlp4Ast) -> (Sig.Parser Ast).S) : sig end; + +module OCamlPreCastParser + (Id : Sig.Id) (Parser : (Sig.Parser PreCast.Ast).S) : sig end; + +(** {6 Registering Printers} *) + +type printer_fun 'a = + ?input_file:string -> ?output_file:string -> 'a -> unit; + +value register_str_item_printer : printer_fun PreCast.Ast.str_item -> unit; +value register_sig_item_printer : printer_fun PreCast.Ast.sig_item -> unit; +value register_printer : printer_fun PreCast.Ast.str_item -> printer_fun PreCast.Ast.sig_item -> unit; +value current_printer : unit -> (printer_fun PreCast.Ast.str_item * printer_fun PreCast.Ast.sig_item); + +module Printer + (Id : Sig.Id) + (Maker : functor (Syn : Sig.Syntax) -> (Sig.Printer Syn.Ast).S) : + sig end; + +module OCamlPrinter + (Id : Sig.Id) + (Maker : functor (Syn : Sig.Camlp4Syntax) -> (Sig.Printer Syn.Ast).S) : + sig end; + +module OCamlPreCastPrinter + (Id : Sig.Id) (Printer : (Sig.Printer PreCast.Ast).S) : + sig end; + +(** {6 Registering Filters} *) + +module AstFilter + (Id : Sig.Id) (Maker : functor (F : Sig.AstFilters) -> sig end) : sig end; + +value declare_dyn_module : string -> (unit -> unit) -> unit; +value iter_and_take_callbacks : ((string * (unit -> unit)) -> unit) -> unit; +value loaded_modules : ref (list string); + +module CurrentParser : (Sig.Parser PreCast.Ast).S; +module CurrentPrinter : (Sig.Printer PreCast.Ast).S; + +value enable_ocaml_printer : unit -> unit; +value enable_ocamlr_printer : unit -> unit; +(* value enable_ocamlrr_printer : unit -> unit; *) +value enable_null_printer : unit -> unit; +value enable_dump_ocaml_ast_printer : unit -> unit; +value enable_dump_camlp4_ast_printer : unit -> unit; diff --git a/camlp4/Camlp4/Sig.ml b/camlp4/Camlp4/Sig.ml new file mode 100644 index 0000000..89d7807 --- /dev/null +++ b/camlp4/Camlp4/Sig.ml @@ -0,0 +1,1446 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + + + +(** Camlp4 signature repository *) + +(** {6 Basic signatures} *) + +(** Signature with just a type. *) +module type Type = sig + type t; +end; + +(** Signature for errors modules, an Error modules can be registred with + the {!ErrorHandler.Register} functor in order to be well printed. *) +module type Error = sig + type t; + exception E of t; + value to_string : t -> string; + value print : Format.formatter -> t -> unit; +end; + +(** A signature for extensions identifiers. *) +module type Id = sig + + (** The name of the extension, typically the module name. *) + value name : string; + + (** The version of the extension, typically $ Id$ with a versionning system. *) + value version : string; + +end; + +(** A signature for warnings abstract from locations. *) +module Warning (Loc : Type) = struct + module type S = sig + type warning = Loc.t -> string -> unit; + value default_warning : warning; + value current_warning : ref warning; + value print_warning : warning; + end; +end; + +(** {6 Advanced signatures} *) + +(** 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. + This location starts at the begining of the file. *) + value mk : string -> t; + + (** The [ghost] location can be used when no location + information is available. *) + value ghost : t; + + (** {6 Conversion functions} *) + + (** Return a location where both positions are set the given position. *) + value of_lexing_position : Lexing.position -> t; + + (** Return an OCaml location. *) + value to_ocaml_location : t -> Location.t; + + (** Return a location from an OCaml location. *) + value of_ocaml_location : Location.t -> t; + + (** Return a location from ocamllex buffer. *) + value of_lexbuf : Lexing.lexbuf -> t; + + (** Return a location from [(file_name, start_line, start_bol, start_off, + stop_line, stop_bol, stop_off, ghost)]. *) + value of_tuple : (string * int * int * int * int * int * int * bool) -> t; + + (** Return [(file_name, start_line, start_bol, start_off, + 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]. *) + value merge : t -> t -> t; + + (** The stop pos becomes equal to the start pos. *) + value join : t -> t; + + (** [move selector n loc] + Return the location where positions are moved. + Affected positions are chosen with [selector]. + Returned positions have their character offset plus [n]. *) + value move : [= `start | `stop | `both ] -> int -> t -> t; + + (** [shift n loc] Return the location where the new start position is the old + stop position, and where the new stop position character offset is the + old one plus [n]. *) + value shift : int -> t -> t; + + (** [move_line n loc] Return the location with the old line count plus [n]. + The "begin of line" of both positions become the current offset. *) + value move_line : int -> t -> t; + + (** {6 Accessors} *) + + (** Return the file name *) + value file_name : t -> string; + + (** Return the line number of the begining of this location. *) + value start_line : t -> int; + + (** 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 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 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 stream + of the begining of this location. *) + value start_off : t -> int; + + (** Return the number of characters from the begining of the stream + of the ending of this location. *) + value stop_off : t -> int; + + (** Return the start position as a Lexing.position. *) + value start_pos : t -> Lexing.position; + + (** Return the stop position as a Lexing.position. *) + value stop_pos : t -> Lexing.position; + + (** Generally, return true if this location does not come + from an input stream. *) + value is_ghost : t -> bool; + + (** Return the associated ghost location. *) + value ghostify : t -> t; + + (** Return the location with the give file name *) + value set_file_name : string -> t -> t; + + (** [strictly_before loc1 loc2] True if the stop position of [loc1] is + strictly_before the start position of [loc2]. *) + value strictly_before : t -> t -> bool; + + (** Return the location with an absolute file name. *) + value make_absolute : t -> t; + + (** Print the location into the formatter in a format suitable for error + reporting. *) + value print : Format.formatter -> t -> unit; + + (** Print the location in a short format useful for debugging. *) + value dump : Format.formatter -> t -> unit; + + (** Same as {!print} but return a string instead of printting it. *) + value to_string : t -> string; + + (** [Exc_located loc e] is an encapsulation of the exception [e] with + the input location [loc]. To be used in quotation expanders + and in grammars to specify some input location for an error. + Do not raise this exception directly: rather use the following + function [Loc.raise]. *) + exception Exc_located of t and exn; + + (** [raise loc e], if [e] is already an [Exc_located] exception, + re-raise it, else raise the exception [Exc_located loc e]. *) + value raise : t -> exn -> 'a; + + (** The name of the location variable used in grammars and in + the predefined quotations for OCaml syntax trees. Default: [_loc]. *) + value name : ref string; + +end; + +(** Abstract syntax tree minimal signature. + Types of this signature are abstract. + See the {!Camlp4Ast} signature for a concrete definition. *) +module type Ast = sig + + (** {6 Syntactic categories as abstract types} *) + + type loc; + type meta_bool; + type meta_option 'a; + type meta_list 'a; + type ctyp; + type patt; + type expr; + type module_type; + type sig_item; + type with_constr; + type module_expr; + type str_item; + type class_type; + type class_sig_item; + type class_expr; + type class_str_item; + type match_case; + type ident; + type binding; + type rec_binding; + type module_binding; + type rec_flag; + type direction_flag; + type mutable_flag; + type private_flag; + type virtual_flag; + type row_var_flag; + type override_flag; + + (** {6 Location accessors} *) + + value loc_of_ctyp : ctyp -> loc; + value loc_of_patt : patt -> loc; + value loc_of_expr : expr -> loc; + value loc_of_module_type : module_type -> loc; + value loc_of_module_expr : module_expr -> loc; + value loc_of_sig_item : sig_item -> loc; + value loc_of_str_item : str_item -> loc; + value loc_of_class_type : class_type -> loc; + value loc_of_class_sig_item : class_sig_item -> loc; + value loc_of_class_expr : class_expr -> loc; + value loc_of_class_str_item : class_str_item -> loc; + value loc_of_with_constr : with_constr -> loc; + value loc_of_binding : binding -> loc; + value loc_of_rec_binding : rec_binding -> loc; + value loc_of_module_binding : module_binding -> loc; + value loc_of_match_case : match_case -> loc; + value loc_of_ident : ident -> loc; + + (** {6 Traversals} *) + + (** This class is the base class for map traversal on the Ast. + To make a custom traversal class one just extend it like that: + + This example swap pairs expression contents: + open Camlp4.PreCast; + [class swap = object + inherit Ast.map as super; + method expr e = + match super#expr e with + \[ <:expr\@_loc< ($e1$, $e2$) >> -> <:expr< ($e2$, $e1$) >> + | e -> e \]; + end; + value _loc = Loc.ghost; + value map = (new swap)#expr; + assert (map <:expr< fun x -> (x, 42) >> = <:expr< fun x -> (42, x) >>);] + *) + class map : object ('self_type) + method string : string -> string; + method list : ! 'a 'b . ('self_type -> 'a -> 'b) -> list 'a -> list 'b; + method meta_bool : meta_bool -> meta_bool; + method meta_option : ! 'a 'b . ('self_type -> 'a -> 'b) -> meta_option 'a -> meta_option 'b; + method meta_list : ! 'a 'b . ('self_type -> 'a -> 'b) -> meta_list 'a -> meta_list 'b; + method loc : loc -> loc; + method expr : expr -> expr; + method patt : patt -> patt; + method ctyp : ctyp -> ctyp; + method str_item : str_item -> str_item; + method sig_item : sig_item -> sig_item; + + method module_expr : module_expr -> module_expr; + method module_type : module_type -> module_type; + method class_expr : class_expr -> class_expr; + method class_type : class_type -> class_type; + method class_sig_item : class_sig_item -> class_sig_item; + method class_str_item : class_str_item -> class_str_item; + method with_constr : with_constr -> with_constr; + method binding : binding -> binding; + method rec_binding : rec_binding -> rec_binding; + method module_binding : module_binding -> module_binding; + method match_case : match_case -> match_case; + method ident : ident -> ident; + method override_flag : override_flag -> override_flag; + method mutable_flag : mutable_flag -> mutable_flag; + method private_flag : private_flag -> private_flag; + method virtual_flag : virtual_flag -> virtual_flag; + method direction_flag : direction_flag -> direction_flag; + method rec_flag : rec_flag -> rec_flag; + method row_var_flag : row_var_flag -> row_var_flag; + + method unknown : ! 'a. 'a -> 'a; + end; + + (** Fold style traversal *) + class fold : object ('self_type) + method string : string -> 'self_type; + method list : ! 'a . ('self_type -> 'a -> 'self_type) -> list 'a -> 'self_type; + method meta_bool : meta_bool -> 'self_type; + method meta_option : ! 'a . ('self_type -> 'a -> 'self_type) -> meta_option 'a -> 'self_type; + method meta_list : ! 'a . ('self_type -> 'a -> 'self_type) -> meta_list 'a -> 'self_type; + method loc : loc -> 'self_type; + method expr : expr -> 'self_type; + method patt : patt -> 'self_type; + method ctyp : ctyp -> 'self_type; + method str_item : str_item -> 'self_type; + method sig_item : sig_item -> 'self_type; + method module_expr : module_expr -> 'self_type; + method module_type : module_type -> 'self_type; + method class_expr : class_expr -> 'self_type; + method class_type : class_type -> 'self_type; + method class_sig_item : class_sig_item -> 'self_type; + method class_str_item : class_str_item -> 'self_type; + method with_constr : with_constr -> 'self_type; + method binding : binding -> 'self_type; + method rec_binding : rec_binding -> 'self_type; + method module_binding : module_binding -> 'self_type; + method match_case : match_case -> 'self_type; + method ident : ident -> 'self_type; + method rec_flag : rec_flag -> 'self_type; + method direction_flag : direction_flag -> 'self_type; + method mutable_flag : mutable_flag -> 'self_type; + method private_flag : private_flag -> 'self_type; + method virtual_flag : virtual_flag -> 'self_type; + method row_var_flag : row_var_flag -> 'self_type; + method override_flag : override_flag -> 'self_type; + + method unknown : ! 'a. 'a -> 'self_type; + end; + +end; + + +(** Signature for OCaml syntax trees. *) (* + This signature is an extension of {!Ast} + It provides: + - Types for all kinds of structure. + - Map: A base class for map traversals. + - Map classes and functions for common kinds. + + == Core language == + ctyp :: Representaion of types + patt :: The type of patterns + expr :: The type of expressions + match_case :: The type of cases for match/function/try constructions + ident :: The type of identifiers (including path like Foo(X).Bar.y) + binding :: The type of let bindings + rec_binding :: The type of record definitions + + == Modules == + module_type :: The type of module types + sig_item :: The type of signature items + str_item :: The type of structure items + module_expr :: The type of module expressions + module_binding :: The type of recursive module definitions + with_constr :: The type of `with' constraints + + == Classes == + class_type :: The type of class types + class_sig_item :: The type of class signature items + class_expr :: The type of class expressions + class_str_item :: The type of class structure items + *) +module type Camlp4Ast = sig + + (** The inner module for locations *) + module Loc : Loc; + + INCLUDE "camlp4/Camlp4/Camlp4Ast.partial.ml"; + + value loc_of_ctyp : ctyp -> loc; + value loc_of_patt : patt -> loc; + value loc_of_expr : expr -> loc; + value loc_of_module_type : module_type -> loc; + value loc_of_module_expr : module_expr -> loc; + value loc_of_sig_item : sig_item -> loc; + value loc_of_str_item : str_item -> loc; + value loc_of_class_type : class_type -> loc; + value loc_of_class_sig_item : class_sig_item -> loc; + value loc_of_class_expr : class_expr -> loc; + value loc_of_class_str_item : class_str_item -> loc; + value loc_of_with_constr : with_constr -> loc; + value loc_of_binding : binding -> loc; + value loc_of_rec_binding : rec_binding -> loc; + value loc_of_module_binding : module_binding -> loc; + value loc_of_match_case : match_case -> loc; + value loc_of_ident : ident -> loc; + + module Meta : sig + module type META_LOC = sig + (* The first location is where to put the returned pattern. + Generally it's _loc to match with <:patt< ... >> quotations. + The second location is the one to treat. *) + value meta_loc_patt : loc -> loc -> patt; + (* The first location is where to put the returned expression. + Generally it's _loc to match with <:expr< ... >> quotations. + The second location is the one to treat. *) + value meta_loc_expr : loc -> loc -> expr; + end; + module MetaLoc : sig + value meta_loc_patt : loc -> loc -> patt; + value meta_loc_expr : loc -> loc -> expr; + end; + module MetaGhostLoc : sig + value meta_loc_patt : loc -> 'a -> patt; + value meta_loc_expr : loc -> 'a -> expr; + end; + module MetaLocVar : sig + value meta_loc_patt : loc -> 'a -> patt; + value meta_loc_expr : loc -> 'a -> expr; + end; + module Make (MetaLoc : META_LOC) : sig + module Expr : sig + value meta_string : loc -> string -> expr; + value meta_int : loc -> string -> expr; + value meta_float : loc -> string -> expr; + value meta_char : loc -> string -> expr; + value meta_bool : loc -> bool -> expr; + value meta_list : (loc -> 'a -> expr) -> loc -> list 'a -> expr; + value meta_binding : loc -> binding -> expr; + value meta_rec_binding : loc -> rec_binding -> expr; + value meta_class_expr : loc -> class_expr -> expr; + value meta_class_sig_item : loc -> class_sig_item -> expr; + value meta_class_str_item : loc -> class_str_item -> expr; + value meta_class_type : loc -> class_type -> expr; + value meta_ctyp : loc -> ctyp -> expr; + value meta_expr : loc -> expr -> expr; + value meta_ident : loc -> ident -> expr; + value meta_match_case : loc -> match_case -> expr; + value meta_module_binding : loc -> module_binding -> expr; + value meta_module_expr : loc -> module_expr -> expr; + value meta_module_type : loc -> module_type -> expr; + value meta_patt : loc -> patt -> expr; + value meta_sig_item : loc -> sig_item -> expr; + value meta_str_item : loc -> str_item -> expr; + value meta_with_constr : loc -> with_constr -> expr; + value meta_rec_flag : loc -> rec_flag -> expr; + value meta_mutable_flag : loc -> mutable_flag -> expr; + value meta_virtual_flag : loc -> virtual_flag -> expr; + value meta_private_flag : loc -> private_flag -> expr; + value meta_row_var_flag : loc -> row_var_flag -> expr; + value meta_override_flag : loc -> override_flag -> expr; + value meta_direction_flag : loc -> direction_flag -> expr; + end; + module Patt : sig + value meta_string : loc -> string -> patt; + value meta_int : loc -> string -> patt; + value meta_float : loc -> string -> patt; + value meta_char : loc -> string -> patt; + value meta_bool : loc -> bool -> patt; + value meta_list : (loc -> 'a -> patt) -> loc -> list 'a -> patt; + value meta_binding : loc -> binding -> patt; + value meta_rec_binding : loc -> rec_binding -> patt; + value meta_class_expr : loc -> class_expr -> patt; + value meta_class_sig_item : loc -> class_sig_item -> patt; + value meta_class_str_item : loc -> class_str_item -> patt; + value meta_class_type : loc -> class_type -> patt; + value meta_ctyp : loc -> ctyp -> patt; + value meta_expr : loc -> expr -> patt; + value meta_ident : loc -> ident -> patt; + value meta_match_case : loc -> match_case -> patt; + value meta_module_binding : loc -> module_binding -> patt; + value meta_module_expr : loc -> module_expr -> patt; + value meta_module_type : loc -> module_type -> patt; + value meta_patt : loc -> patt -> patt; + value meta_sig_item : loc -> sig_item -> patt; + value meta_str_item : loc -> str_item -> patt; + value meta_with_constr : loc -> with_constr -> patt; + value meta_rec_flag : loc -> rec_flag -> patt; + value meta_mutable_flag : loc -> mutable_flag -> patt; + value meta_virtual_flag : loc -> virtual_flag -> patt; + value meta_private_flag : loc -> private_flag -> patt; + value meta_row_var_flag : loc -> row_var_flag -> patt; + value meta_override_flag : loc -> override_flag -> patt; + value meta_direction_flag : loc -> direction_flag -> patt; + end; + end; + end; + + (** See {!Ast.map}. *) + class map : object ('self_type) + method string : string -> string; + method list : ! 'a 'b . ('self_type -> 'a -> 'b) -> list 'a -> list 'b; + method meta_bool : meta_bool -> meta_bool; + method meta_option : ! 'a 'b . ('self_type -> 'a -> 'b) -> meta_option 'a -> meta_option 'b; + method meta_list : ! 'a 'b . ('self_type -> 'a -> 'b) -> meta_list 'a -> meta_list 'b; + method loc : loc -> loc; + method expr : expr -> expr; + method patt : patt -> patt; + method ctyp : ctyp -> ctyp; + method str_item : str_item -> str_item; + method sig_item : sig_item -> sig_item; + + method module_expr : module_expr -> module_expr; + method module_type : module_type -> module_type; + method class_expr : class_expr -> class_expr; + method class_type : class_type -> class_type; + method class_sig_item : class_sig_item -> class_sig_item; + method class_str_item : class_str_item -> class_str_item; + method with_constr : with_constr -> with_constr; + method binding : binding -> binding; + method rec_binding : rec_binding -> rec_binding; + method module_binding : module_binding -> module_binding; + method match_case : match_case -> match_case; + method ident : ident -> ident; + method mutable_flag : mutable_flag -> mutable_flag; + method private_flag : private_flag -> private_flag; + method virtual_flag : virtual_flag -> virtual_flag; + method direction_flag : direction_flag -> direction_flag; + method rec_flag : rec_flag -> rec_flag; + method row_var_flag : row_var_flag -> row_var_flag; + method override_flag : override_flag -> override_flag; + + method unknown : ! 'a. 'a -> 'a; + end; + + (** See {!Ast.fold}. *) + class fold : object ('self_type) + method string : string -> 'self_type; + method list : ! 'a . ('self_type -> 'a -> 'self_type) -> list 'a -> 'self_type; + method meta_bool : meta_bool -> 'self_type; + method meta_option : ! 'a . ('self_type -> 'a -> 'self_type) -> meta_option 'a -> 'self_type; + method meta_list : ! 'a . ('self_type -> 'a -> 'self_type) -> meta_list 'a -> 'self_type; + method loc : loc -> 'self_type; + method expr : expr -> 'self_type; + method patt : patt -> 'self_type; + method ctyp : ctyp -> 'self_type; + method str_item : str_item -> 'self_type; + method sig_item : sig_item -> 'self_type; + method module_expr : module_expr -> 'self_type; + method module_type : module_type -> 'self_type; + method class_expr : class_expr -> 'self_type; + method class_type : class_type -> 'self_type; + method class_sig_item : class_sig_item -> 'self_type; + method class_str_item : class_str_item -> 'self_type; + method with_constr : with_constr -> 'self_type; + method binding : binding -> 'self_type; + method rec_binding : rec_binding -> 'self_type; + method module_binding : module_binding -> 'self_type; + method match_case : match_case -> 'self_type; + method ident : ident -> 'self_type; + method rec_flag : rec_flag -> 'self_type; + method direction_flag : direction_flag -> 'self_type; + method mutable_flag : mutable_flag -> 'self_type; + method private_flag : private_flag -> 'self_type; + method virtual_flag : virtual_flag -> 'self_type; + method row_var_flag : row_var_flag -> 'self_type; + method override_flag : override_flag -> 'self_type; + + method unknown : ! 'a. 'a -> 'self_type; + end; + + value map_expr : (expr -> expr) -> map; + value map_patt : (patt -> patt) -> map; + value map_ctyp : (ctyp -> ctyp) -> map; + value map_str_item : (str_item -> str_item) -> map; + value map_sig_item : (sig_item -> sig_item) -> map; + value map_loc : (loc -> loc) -> map; + + value ident_of_expr : expr -> ident; + value ident_of_patt : patt -> ident; + value ident_of_ctyp : ctyp -> ident; + + value biAnd_of_list : list binding -> binding; + value rbSem_of_list : list rec_binding -> rec_binding; + value paSem_of_list : list patt -> patt; + value paCom_of_list : list patt -> patt; + value tyOr_of_list : list ctyp -> ctyp; + value tyAnd_of_list : list ctyp -> ctyp; + value tyAmp_of_list : list ctyp -> ctyp; + value tySem_of_list : list ctyp -> ctyp; + value tyCom_of_list : list ctyp -> ctyp; + value tySta_of_list : list ctyp -> ctyp; + value stSem_of_list : list str_item -> str_item; + value sgSem_of_list : list sig_item -> sig_item; + value crSem_of_list : list class_str_item -> class_str_item; + value cgSem_of_list : list class_sig_item -> class_sig_item; + value ctAnd_of_list : list class_type -> class_type; + value ceAnd_of_list : list class_expr -> class_expr; + value wcAnd_of_list : list with_constr -> with_constr; + value meApp_of_list : list module_expr -> module_expr; + value mbAnd_of_list : list module_binding -> module_binding; + value mcOr_of_list : list match_case -> match_case; + value idAcc_of_list : list ident -> ident; + value idApp_of_list : list ident -> ident; + value exSem_of_list : list expr -> expr; + value exCom_of_list : list expr -> expr; + + value list_of_ctyp : ctyp -> list ctyp -> list ctyp; + value list_of_binding : binding -> list binding -> list binding; + value list_of_rec_binding : rec_binding -> list rec_binding -> list rec_binding; + value list_of_with_constr : with_constr -> list with_constr -> list with_constr; + value list_of_patt : patt -> list patt -> list patt; + value list_of_expr : expr -> list expr -> list expr; + value list_of_str_item : str_item -> list str_item -> list str_item; + value list_of_sig_item : sig_item -> list sig_item -> list sig_item; + value list_of_class_sig_item : class_sig_item -> list class_sig_item -> list class_sig_item; + value list_of_class_str_item : class_str_item -> list class_str_item -> list class_str_item; + value list_of_class_type : class_type -> list class_type -> list class_type; + value list_of_class_expr : class_expr -> list class_expr -> list class_expr; + value list_of_module_expr : module_expr -> list module_expr -> list module_expr; + value list_of_module_binding : module_binding -> list module_binding -> list module_binding; + value list_of_match_case : match_case -> list match_case -> list match_case; + value list_of_ident : ident -> list ident -> list ident; + + (** Like [String.escape] but takes care to not + escape antiquotations strings. *) + value safe_string_escaped : string -> string; + + (** Returns True if the given pattern is irrefutable. *) + value is_irrefut_patt : patt -> bool; + + value is_constructor : ident -> bool; + value is_patt_constructor : patt -> bool; + value is_expr_constructor : expr -> bool; + + value ty_of_stl : (Loc.t * string * list ctyp) -> ctyp; + value ty_of_sbt : (Loc.t * string * bool * ctyp) -> ctyp; + value bi_of_pe : (patt * expr) -> binding; + value pel_of_binding : binding -> list (patt * expr); + value binding_of_pel : list (patt * expr) -> binding; + value sum_type_of_list : list (Loc.t * string * list ctyp) -> ctyp; + value record_type_of_list : list (Loc.t * string * bool * ctyp) -> ctyp; +end; + +(** This functor is a restriction functor. + It takes a Camlp4Ast module and gives the Ast one. + Typical use is for [with] constraints. + Example: ... with module Ast = Camlp4.Sig.Camlp4AstToAst Camlp4Ast *) +module Camlp4AstToAst (M : Camlp4Ast) : Ast + with type loc = M.loc + and type meta_bool = M.meta_bool + and type meta_option 'a = M.meta_option 'a + and type meta_list 'a = M.meta_list 'a + and type ctyp = M.ctyp + and type patt = M.patt + and type expr = M.expr + and type module_type = M.module_type + and type sig_item = M.sig_item + and type with_constr = M.with_constr + and type module_expr = M.module_expr + and type str_item = M.str_item + and type class_type = M.class_type + and type class_sig_item = M.class_sig_item + and type class_expr = M.class_expr + and type class_str_item = M.class_str_item + and type binding = M.binding + and type rec_binding = M.rec_binding + and type module_binding = M.module_binding + and type match_case = M.match_case + and type ident = M.ident + and type rec_flag = M.rec_flag + and type direction_flag = M.direction_flag + and type mutable_flag = M.mutable_flag + and type private_flag = M.private_flag + and type virtual_flag = M.virtual_flag + and type row_var_flag = M.row_var_flag + and type override_flag = M.override_flag += M; + +(** Concrete definition of Camlp4 ASTs abstracted from locations. + Since the Ast contains locations, this functor produces Ast types + for a given location type. *) +module MakeCamlp4Ast (Loc : Type) = struct + + INCLUDE "camlp4/Camlp4/Camlp4Ast.partial.ml"; + +end; + +(** {6 Filters} *) + +(** A type for stream filters. *) +type stream_filter 'a 'loc = Stream.t ('a * 'loc) -> Stream.t ('a * 'loc); + +(** Registerinng and folding of Ast filters. + Two kinds of filters must be handled: + - Implementation filters: str_item -> str_item. + - Interface filters: sig_item -> sig_item. *) +module type AstFilters = sig + + module Ast : Camlp4Ast; + + type filter 'a = 'a -> 'a; + + value register_sig_item_filter : (filter Ast.sig_item) -> unit; + value register_str_item_filter : (filter Ast.str_item) -> unit; + value register_topphrase_filter : (filter Ast.str_item) -> unit; + + value fold_interf_filters : ('a -> filter Ast.sig_item -> 'a) -> 'a -> 'a; + value fold_implem_filters : ('a -> filter Ast.str_item -> 'a) -> 'a -> 'a; + value fold_topphrase_filters : ('a -> filter Ast.str_item -> 'a) -> 'a -> 'a; + +end; + +(** ASTs as one single dynamic type *) +module type DynAst = sig + module Ast : Ast; + type tag 'a; + + value ctyp_tag : tag Ast.ctyp; + value patt_tag : tag Ast.patt; + value expr_tag : tag Ast.expr; + value module_type_tag : tag Ast.module_type; + value sig_item_tag : tag Ast.sig_item; + value with_constr_tag : tag Ast.with_constr; + value module_expr_tag : tag Ast.module_expr; + value str_item_tag : tag Ast.str_item; + value class_type_tag : tag Ast.class_type; + value class_sig_item_tag : tag Ast.class_sig_item; + value class_expr_tag : tag Ast.class_expr; + value class_str_item_tag : tag Ast.class_str_item; + value match_case_tag : tag Ast.match_case; + value ident_tag : tag Ast.ident; + value binding_tag : tag Ast.binding; + value rec_binding_tag : tag Ast.rec_binding; + value module_binding_tag : tag Ast.module_binding; + + value string_of_tag : tag 'a -> string; + + module Pack (X : sig type t 'a; end) : sig + type pack; + value pack : tag 'a -> X.t 'a -> pack; + value unpack : tag 'a -> pack -> X.t 'a; + value print_tag : Format.formatter -> pack -> unit; + end; +end; + + +(** {6 Quotation operations} *) + +(** The generic quotation type. + To see how fields are used here is an example: + <:q_name@q_loc> + The last one, q_shift is equal to the length of "<:q_name@q_loc<". *) +type quotation = + { q_name : string ; + q_loc : string ; + q_shift : int ; + q_contents : string }; + +(** The signature for a quotation expander registery. *) +module type Quotation = sig + module Ast : Ast; + module DynAst : DynAst with module Ast = Ast; + open Ast; + + (** The [loc] is the initial location. The option string is the optional name + for the location variable. The string is the quotation contents. *) + type expand_fun 'a = loc -> option string -> string -> 'a; + + (** [add name exp] adds the quotation [name] associated with the + expander [exp]. *) + value add : string -> DynAst.tag 'a -> expand_fun 'a -> unit; + + (** [find name] returns the expander of the given quotation name. *) + value find : string -> DynAst.tag 'a -> expand_fun 'a; + + (** [default] holds the default quotation name. *) + value default : ref string; + + (** [parse_quotation_result parse_function loc position_tag quotation quotation_result] + It's a parser wrapper, this function handles the error reporting for you. *) + value parse_quotation_result : + (loc -> string -> 'a) -> loc -> quotation -> string -> string -> 'a; + + (** function translating quotation names; default = identity *) + value translate : ref (string -> string); + + value expand : loc -> quotation -> DynAst.tag 'a -> 'a; + + (** [dump_file] optionally tells Camlp4 to dump the + result of an expander if this result is syntactically incorrect. + If [None] (default), this result is not dumped. If [Some fname], the + result is dumped in the file [fname]. *) + value dump_file : ref (option string); + + module Error : Error; + +end; + +(** {6 Tokens} *) + +(** A signature for tokens. *) +module type Token = sig + + module Loc : Loc; + + type t; + + value to_string : t -> string; + + value print : Format.formatter -> t -> unit; + + value match_keyword : string -> t -> bool; + + value extract_string : t -> string; + + module Filter : sig + + type token_filter = stream_filter t Loc.t; + + (** The type for this filter chain. + A basic implementation just store the [is_keyword] function given + by [mk] and use it in the [filter] function. *) + type t; + + (** The given predicate function returns true if the given string + is a keyword. This function can be used in filters to translate + identifier tokens to keyword tokens. *) + value mk : (string -> bool) -> t; + + (** This function allows to register a new filter to the token filter chain. + You can choose to not support these and raise an exception. *) + value define_filter : t -> (token_filter -> token_filter) -> unit; + + (** This function filter the given stream and return a filtered stream. + A basic implementation just match identifiers against the [is_keyword] + function to produce token keywords instead. *) + value filter : t -> token_filter; + + (** Called by the grammar system when a keyword is used. + The boolean argument is True when it's the first time that keyword + is used. If you do not care about this information just return [()]. *) + value keyword_added : t -> string -> bool -> unit; + + (** Called by the grammar system when a keyword is no longer used. + If you do not care about this information just return [()]. *) + value keyword_removed : t -> string -> unit; + end; + + module Error : Error; +end; + +(** This signature describes tokens for the OCaml and the Revised + syntax lexing rules. For some tokens the data constructor holds two + representations with the evaluated one and the source one. For example + the INT data constructor holds an integer and a string, this string can + contains more information that's needed for a good pretty-printing + ("42", "4_2", "0000042", "0b0101010"...). + + The meaning of the tokens are: +- [KEYWORD s] is the keyword [s]. +- [LIDENT s] is the ident [s] starting with a lowercase letter. +- [UIDENT s] is the ident [s] starting with an uppercase letter. +- [INT i s] (resp. [INT32 i s], [INT64 i s] and [NATIVEINT i s]) + the integer constant [i] whose string source is [s]. +- [FLOAT f s] is the float constant [f] whose string source is [s]. +- [STRING s s'] is the string constant [s] whose string source is [s']. +- [CHAR c s] is the character constant [c] whose string source is [s]. +- [QUOTATION q] is a quotation [q], see {!Quotation.t} for more information. +- [ANTIQUOT n s] is an antiquotation [n] holding the string [s]. +- [EOI] is the end of input. + + Warning: the second string associated with the constructor [STRING] is + the string found in the source without any interpretation. In particular, + the backslashes are not interpreted. For example, if the input is ["\n"] + the string is *not* a string with one element containing the character + "return", but a string of two elements: the backslash and the character + ["n"]. To interpret a string use the first string of the [STRING] + constructor (or if you need to compute it use the module + {!Camlp4.Struct.Token.Eval}. Same thing for the constructor [CHAR]. *) +type camlp4_token = + [ KEYWORD of string + | SYMBOL of string + | LIDENT of string + | UIDENT of string + | ESCAPED_IDENT of string + | INT of int and string + | INT32 of int32 and string + | INT64 of int64 and string + | NATIVEINT of nativeint and string + | FLOAT of float and string + | CHAR of char and string + | STRING of string and string + | LABEL of string + | OPTLABEL of string + | QUOTATION of quotation + | ANTIQUOT of string and string + | COMMENT of string + | BLANKS of string + | NEWLINE + | LINE_DIRECTIVE of int and option string + | EOI ]; + +(** A signature for specialized tokens. *) +module type Camlp4Token = Token with type t = camlp4_token; + +(** {6 Dynamic loaders} *) + +(** A signature for dynamic loaders. *) +module type DynLoader = sig + type t; + exception Error of string and string; + + (** [mk ?ocaml_stdlib ?camlp4_stdlib] + The stdlib flag is true by default. + To disable it use: [mk ~ocaml_stdlib:False] *) + value mk : ?ocaml_stdlib: bool -> ?camlp4_stdlib: bool -> unit -> t; + + (** Fold over the current load path list. *) + value fold_load_path : t -> (string -> 'a -> 'a) -> 'a -> 'a; + + (** [load f] Load the file [f]. If [f] is not an absolute path name, + the load path list used to find the directory of [f]. *) + value load : t -> string -> unit; + + (** [include_dir d] Add the directory [d] in the current load path + list (like the common -I option). *) + value include_dir : t -> string -> unit; + + (** [find_in_path f] Returns the full path of the file [f] if + [f] is in the current load path, raises [Not_found] otherwise. *) + value find_in_path : t -> string -> string; + + (** [is_native] [True] if we are in native code, [False] for bytecode. *) + value is_native : bool; +end; + +(** A signature for grammars. *) +module Grammar = struct + + (** Internal signature for sematantic actions of grammars, + not for the casual user. These functions are unsafe. *) + module type Action = sig + type t ; + + value mk : 'a -> t; + value get : t -> 'a; + value getf : t -> ('a -> 'b); + value getf2 : t -> ('a -> 'b -> 'c); + end; + + type assoc = + [ NonA + | RightA + | LeftA ]; + + type position = + [ First + | Last + | Before of string + | After of string + | Level of string ]; + + (** Common signature for {!Sig.Grammar.Static} and {!Sig.Grammar.Dynamic}. *) + module type Structure = sig + module Loc : Loc; + module Action : Action; + module Token : Token with module Loc = Loc; + + type gram; + type internal_entry; + type tree; + + type token_pattern = ((Token.t -> bool) * string); + type token_info; + type token_stream = Stream.t (Token.t * token_info); + + value token_location : token_info -> Loc.t; + + type symbol = + [ Smeta of string and list symbol and Action.t + | Snterm of internal_entry + | Snterml of internal_entry and string + | Slist0 of symbol + | Slist0sep of symbol and symbol + | Slist1 of symbol + | Slist1sep of symbol and symbol + | Sopt of symbol + | Stry of symbol + | Sself + | Snext + | Stoken of token_pattern + | Skeyword of string + | Stree of tree ]; + + type production_rule = (list symbol * Action.t); + type single_extend_statment = + (option string * option assoc * list production_rule); + type extend_statment = + (option position * list single_extend_statment); + type delete_statment = list symbol; + + type fold 'a 'b 'c = + internal_entry -> list symbol -> + (Stream.t 'a -> 'b) -> Stream.t 'a -> 'c; + + type foldsep 'a 'b 'c = + internal_entry -> list symbol -> + (Stream.t 'a -> 'b) -> (Stream.t 'a -> unit) -> Stream.t 'a -> 'c; + + end; + + (** Signature for Camlp4 grammars. Here the dynamic means that you can produce as + many grammar values as needed with a single grammar module. + If you do not need many grammar values it's preferable to use a static one. *) + module type Dynamic = sig + include Structure; + + (** Make a new grammar. *) + value mk : unit -> gram; + + module Entry : sig + (** The abstract type of grammar entries. The type parameter is the type + of the semantic actions that are associated with this entry. *) + type t 'a; + + (** Make a new entry from the given name. *) + value mk : gram -> string -> t 'a; + + (** Make a new entry from a name and an hand made token parser. *) + value of_parser : + gram -> string -> (token_stream -> 'a) -> t 'a; + + (** Clear the entry and setup this parser instead. *) + value setup_parser : + t 'a -> (token_stream -> 'a) -> unit; + + (** Get the entry name. *) + value name : t 'a -> string; + + (** Print the given entry into the given formatter. *) + value print : Format.formatter -> t 'a -> unit; + + (** Same as {!print} but show the left-factorization. *) + value dump : Format.formatter -> t 'a -> unit; + + (**/**) + value obj : t 'a -> internal_entry; + value clear : t 'a -> unit; + (**/**) + end; + + (** [get_filter g] Get the {!Token.Filter} associated to the [g]. *) + value get_filter : gram -> Token.Filter.t; + + type not_filtered 'a; + + (** This function is called by the EXTEND ... END syntax. *) + value extend : Entry.t 'a -> extend_statment -> unit; + + (** The delete rule. *) + value delete_rule : Entry.t 'a -> delete_statment -> unit; + + value srules : Entry.t 'a -> list (list symbol * Action.t) -> symbol; + value sfold0 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; + value sfold1 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; + value sfold0sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; + (* value sfold1sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; *) + + (** Use the lexer to produce a non filtered token stream from a char stream. *) + value lex : gram -> Loc.t -> Stream.t char -> not_filtered (Stream.t (Token.t * Loc.t)); + + (** Token stream from string. *) + value lex_string : gram -> Loc.t -> string -> not_filtered (Stream.t (Token.t * Loc.t)); + + (** Filter a token stream using the {!Token.Filter} module *) + value filter : gram -> not_filtered (Stream.t (Token.t * Loc.t)) -> token_stream; + + (** Lex, filter and parse a stream of character. *) + value parse : Entry.t 'a -> Loc.t -> Stream.t char -> 'a; + + (** Same as {!parse} but from a string. *) + value parse_string : Entry.t 'a -> Loc.t -> string -> 'a; + + (** Parse a token stream that is not filtered yet. *) + value parse_tokens_before_filter : + Entry.t 'a -> not_filtered (Stream.t (Token.t * Loc.t)) -> 'a; + + (** Parse a token stream that is already filtered. *) + value parse_tokens_after_filter : + Entry.t 'a -> token_stream -> 'a; + + end; + + (** Signature for Camlp4 grammars. Here the static means that there is only + one grammar value by grammar module. If you do not need to store the grammar + value it's preferable to use a static one. *) + module type Static = sig + include Structure; + + module Entry : sig + (** The abstract type of grammar entries. The type parameter is the type + of the semantic actions that are associated with this entry. *) + type t 'a; + + (** Make a new entry from the given name. *) + value mk : string -> t 'a; + + (** Make a new entry from a name and an hand made token parser. *) + value of_parser : + string -> (token_stream -> 'a) -> t 'a; + + (** Clear the entry and setup this parser instead. *) + value setup_parser : + t 'a -> (token_stream -> 'a) -> unit; + + (** Get the entry name. *) + value name : t 'a -> string; + + (** Print the given entry into the given formatter. *) + value print : Format.formatter -> t 'a -> unit; + + (** Same as {!print} but show the left-factorization. *) + value dump : Format.formatter -> t 'a -> unit; + + (**/**) + value obj : t 'a -> internal_entry; + value clear : t 'a -> unit; + (**/**) + end; + + (** Get the {!Token.Filter} associated to the grammar module. *) + value get_filter : unit -> Token.Filter.t; + + type not_filtered 'a; + + (** This function is called by the EXTEND ... END syntax. *) + value extend : Entry.t 'a -> extend_statment -> unit; + + (** The delete rule. *) + value delete_rule : Entry.t 'a -> delete_statment -> unit; + value srules : Entry.t 'a -> list (list symbol * Action.t) -> symbol; + value sfold0 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; + value sfold1 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; + value sfold0sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; + (* value sfold1sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; *) + + (** Use the lexer to produce a non filtered token stream from a char stream. *) + value lex : Loc.t -> Stream.t char -> not_filtered (Stream.t (Token.t * Loc.t)); + + (** Token stream from string. *) + value lex_string : Loc.t -> string -> not_filtered (Stream.t (Token.t * Loc.t)); + + (** Filter a token stream using the {!Token.Filter} module *) + value filter : not_filtered (Stream.t (Token.t * Loc.t)) -> token_stream; + + (** Lex, filter and parse a stream of character. *) + value parse : Entry.t 'a -> Loc.t -> Stream.t char -> 'a; + + (** Same as {!parse} but from a string. *) + value parse_string : Entry.t 'a -> Loc.t -> string -> 'a; + + (** Parse a token stream that is not filtered yet. *) + value parse_tokens_before_filter : + Entry.t 'a -> not_filtered (Stream.t (Token.t * Loc.t)) -> 'a; + + (** Parse a token stream that is already filtered. *) + value parse_tokens_after_filter : + Entry.t 'a -> token_stream -> 'a; + + end; + +end; + +(** A signature for lexers. *) +module type Lexer = sig + module Loc : Loc; + module Token : Token with module Loc = Loc; + module Error : Error; + + (** The constructor for a lexing function. The character stream is the input + stream to be lexed. The result is a stream of pairs of a token and + a location. + The lexer do not use global (mutable) variables: instantiations + of [Lexer.mk ()] do not perturb each other. *) + value mk : unit -> (Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t)); +end; + + +(** A signature for parsers abstract from ASTs. *) +module Parser (Ast : Ast) = struct + module type SIMPLE = sig + (** The parse function for expressions. + The underlying expression grammar entry is generally "expr; EOI". *) + value parse_expr : Ast.loc -> string -> Ast.expr; + + (** The parse function for patterns. + The underlying pattern grammar entry is generally "patt; EOI". *) + value parse_patt : Ast.loc -> string -> Ast.patt; + end; + + module type S = sig + + (** Called when parsing an implementation (ml file) to build the syntax + tree; the returned list contains the phrases (structure items) as a + single "declare" node (a list of structure items); if the parser + encounter a directive it stops (since the directive may change the + syntax), the given [directive_handler] function evaluates it and + the parsing starts again. *) + value parse_implem : ?directive_handler:(Ast.str_item -> option Ast.str_item) -> + Ast.loc -> Stream.t char -> Ast.str_item; + + (** Same as {!parse_implem} but for interface (mli file). *) + value parse_interf : ?directive_handler:(Ast.sig_item -> option Ast.sig_item) -> + Ast.loc -> Stream.t char -> Ast.sig_item; + end; +end; + +(** A signature for printers abstract from ASTs. *) +module Printer (Ast : Ast) = struct + module type S = sig + + value print_interf : ?input_file:string -> ?output_file:string -> + Ast.sig_item -> unit; + value print_implem : ?input_file:string -> ?output_file:string -> + Ast.str_item -> unit; + + end; +end; + +(** A syntax module is a sort of constistent bunch of modules and values. + In such a module you have a parser, a printer, and also modules for + locations, syntax trees, tokens, grammars, quotations, anti-quotations. + There is also the main grammar entries. *) +module type Syntax = sig + module Loc : Loc; + module Ast : Ast with type loc = Loc.t; + module Token : Token with module Loc = Loc; + module Gram : Grammar.Static with module Loc = Loc and module Token = Token; + module Quotation : Quotation with module Ast = Ast; + + module AntiquotSyntax : (Parser Ast).SIMPLE; + + include (Warning Loc).S; + include (Parser Ast).S; + include (Printer Ast).S; +end; + +(** A syntax module is a sort of constistent bunch of modules and values. + In such a module you have a parser, a printer, and also modules for + locations, syntax trees, tokens, grammars, quotations, anti-quotations. + There is also the main grammar entries. *) +module type Camlp4Syntax = sig + module Loc : Loc; + + module Ast : Camlp4Ast with module Loc = Loc; + module Token : Camlp4Token with module Loc = Loc; + + module Gram : Grammar.Static with module Loc = Loc and module Token = Token; + module Quotation : Quotation with module Ast = Camlp4AstToAst Ast; + + module AntiquotSyntax : (Parser Ast).SIMPLE; + + include (Warning Loc).S; + include (Parser Ast).S; + include (Printer Ast).S; + + value interf : Gram.Entry.t (list Ast.sig_item * option Loc.t); + value implem : Gram.Entry.t (list Ast.str_item * option Loc.t); + value top_phrase : Gram.Entry.t (option Ast.str_item); + value use_file : Gram.Entry.t (list Ast.str_item * option Loc.t); + value a_CHAR : Gram.Entry.t string; + value a_FLOAT : Gram.Entry.t string; + value a_INT : Gram.Entry.t string; + value a_INT32 : Gram.Entry.t string; + value a_INT64 : Gram.Entry.t string; + value a_LABEL : Gram.Entry.t string; + value a_LIDENT : Gram.Entry.t string; + value a_NATIVEINT : Gram.Entry.t string; + value a_OPTLABEL : Gram.Entry.t string; + value a_STRING : Gram.Entry.t string; + value a_UIDENT : Gram.Entry.t string; + value a_ident : Gram.Entry.t string; + value amp_ctyp : Gram.Entry.t Ast.ctyp; + value and_ctyp : Gram.Entry.t Ast.ctyp; + value match_case : Gram.Entry.t Ast.match_case; + value match_case0 : Gram.Entry.t Ast.match_case; + value match_case_quot : Gram.Entry.t Ast.match_case; + value binding : Gram.Entry.t Ast.binding; + value binding_quot : Gram.Entry.t Ast.binding; + value rec_binding_quot : Gram.Entry.t Ast.rec_binding; + value class_declaration : Gram.Entry.t Ast.class_expr; + value class_description : Gram.Entry.t Ast.class_type; + value class_expr : Gram.Entry.t Ast.class_expr; + value class_expr_quot : Gram.Entry.t Ast.class_expr; + value class_fun_binding : Gram.Entry.t Ast.class_expr; + value class_fun_def : Gram.Entry.t Ast.class_expr; + value class_info_for_class_expr : Gram.Entry.t Ast.class_expr; + value class_info_for_class_type : Gram.Entry.t Ast.class_type; + value class_longident : Gram.Entry.t Ast.ident; + value class_longident_and_param : Gram.Entry.t Ast.class_expr; + value class_name_and_param : Gram.Entry.t (string * Ast.ctyp); + value class_sig_item : Gram.Entry.t Ast.class_sig_item; + value class_sig_item_quot : Gram.Entry.t Ast.class_sig_item; + value class_signature : Gram.Entry.t Ast.class_sig_item; + value class_str_item : Gram.Entry.t Ast.class_str_item; + value class_str_item_quot : Gram.Entry.t Ast.class_str_item; + value class_structure : Gram.Entry.t Ast.class_str_item; + value class_type : Gram.Entry.t Ast.class_type; + value class_type_declaration : Gram.Entry.t Ast.class_type; + value class_type_longident : Gram.Entry.t Ast.ident; + value class_type_longident_and_param : Gram.Entry.t Ast.class_type; + value class_type_plus : Gram.Entry.t Ast.class_type; + value class_type_quot : Gram.Entry.t Ast.class_type; + value comma_ctyp : Gram.Entry.t Ast.ctyp; + value comma_expr : Gram.Entry.t Ast.expr; + value comma_ipatt : Gram.Entry.t Ast.patt; + value comma_patt : Gram.Entry.t Ast.patt; + value comma_type_parameter : Gram.Entry.t Ast.ctyp; + value constrain : Gram.Entry.t (Ast.ctyp * Ast.ctyp); + value constructor_arg_list : Gram.Entry.t Ast.ctyp; + value constructor_declaration : Gram.Entry.t Ast.ctyp; + value constructor_declarations : Gram.Entry.t Ast.ctyp; + value ctyp : Gram.Entry.t Ast.ctyp; + value ctyp_quot : Gram.Entry.t Ast.ctyp; + value cvalue_binding : Gram.Entry.t Ast.expr; + value direction_flag : Gram.Entry.t Ast.direction_flag; + value direction_flag_quot : Gram.Entry.t Ast.direction_flag; + value dummy : Gram.Entry.t unit; + value eq_expr : Gram.Entry.t (string -> Ast.patt -> Ast.patt); + value expr : Gram.Entry.t Ast.expr; + value expr_eoi : Gram.Entry.t Ast.expr; + value expr_quot : Gram.Entry.t Ast.expr; + value field_expr : Gram.Entry.t Ast.rec_binding; + value field_expr_list : Gram.Entry.t Ast.rec_binding; + value fun_binding : Gram.Entry.t Ast.expr; + value fun_def : Gram.Entry.t Ast.expr; + value ident : Gram.Entry.t Ast.ident; + value ident_quot : Gram.Entry.t Ast.ident; + value ipatt : Gram.Entry.t Ast.patt; + value ipatt_tcon : Gram.Entry.t Ast.patt; + value label : Gram.Entry.t string; + value label_declaration : Gram.Entry.t Ast.ctyp; + value label_declaration_list : Gram.Entry.t Ast.ctyp; + value label_expr : Gram.Entry.t Ast.rec_binding; + value label_expr_list : Gram.Entry.t Ast.rec_binding; + value label_ipatt : Gram.Entry.t Ast.patt; + value label_ipatt_list : Gram.Entry.t Ast.patt; + value label_longident : Gram.Entry.t Ast.ident; + value label_patt : Gram.Entry.t Ast.patt; + value label_patt_list : Gram.Entry.t Ast.patt; + value labeled_ipatt : Gram.Entry.t Ast.patt; + value let_binding : Gram.Entry.t Ast.binding; + value meth_list : Gram.Entry.t (Ast.ctyp * Ast.row_var_flag); + value meth_decl : Gram.Entry.t Ast.ctyp; + value module_binding : Gram.Entry.t Ast.module_binding; + value module_binding0 : Gram.Entry.t Ast.module_expr; + value module_binding_quot : Gram.Entry.t Ast.module_binding; + value module_declaration : Gram.Entry.t Ast.module_type; + value module_expr : Gram.Entry.t Ast.module_expr; + value module_expr_quot : Gram.Entry.t Ast.module_expr; + value module_longident : Gram.Entry.t Ast.ident; + value module_longident_with_app : Gram.Entry.t Ast.ident; + value module_rec_declaration : Gram.Entry.t Ast.module_binding; + value module_type : Gram.Entry.t Ast.module_type; + value package_type : Gram.Entry.t Ast.module_type; + value module_type_quot : Gram.Entry.t Ast.module_type; + value more_ctyp : Gram.Entry.t Ast.ctyp; + value name_tags : Gram.Entry.t Ast.ctyp; + value opt_as_lident : Gram.Entry.t string; + value opt_class_self_patt : Gram.Entry.t Ast.patt; + value opt_class_self_type : Gram.Entry.t Ast.ctyp; + value opt_comma_ctyp : Gram.Entry.t Ast.ctyp; + value opt_dot_dot : Gram.Entry.t Ast.row_var_flag; + value row_var_flag_quot : Gram.Entry.t Ast.row_var_flag; + value opt_eq_ctyp : Gram.Entry.t Ast.ctyp; + value opt_expr : Gram.Entry.t Ast.expr; + value opt_meth_list : Gram.Entry.t Ast.ctyp; + value opt_mutable : Gram.Entry.t Ast.mutable_flag; + value mutable_flag_quot : Gram.Entry.t Ast.mutable_flag; + value opt_override : Gram.Entry.t Ast.override_flag; + value override_flag_quot : Gram.Entry.t Ast.override_flag; + value opt_polyt : Gram.Entry.t Ast.ctyp; + value opt_private : Gram.Entry.t Ast.private_flag; + value private_flag_quot : Gram.Entry.t Ast.private_flag; + value opt_rec : Gram.Entry.t Ast.rec_flag; + value opt_nonrec : Gram.Entry.t Ast.rec_flag; + value rec_flag_quot : Gram.Entry.t Ast.rec_flag; + value opt_virtual : Gram.Entry.t Ast.virtual_flag; + value virtual_flag_quot : Gram.Entry.t Ast.virtual_flag; + value opt_when_expr : Gram.Entry.t Ast.expr; + value patt : Gram.Entry.t Ast.patt; + value patt_as_patt_opt : Gram.Entry.t Ast.patt; + value patt_eoi : Gram.Entry.t Ast.patt; + value patt_quot : Gram.Entry.t Ast.patt; + value patt_tcon : Gram.Entry.t Ast.patt; + value phrase : Gram.Entry.t Ast.str_item; + value poly_type : Gram.Entry.t Ast.ctyp; + value row_field : Gram.Entry.t Ast.ctyp; + value sem_expr : Gram.Entry.t Ast.expr; + value sem_expr_for_list : Gram.Entry.t (Ast.expr -> Ast.expr); + value sem_patt : Gram.Entry.t Ast.patt; + value sem_patt_for_list : Gram.Entry.t (Ast.patt -> Ast.patt); + value semi : Gram.Entry.t unit; + value sequence : Gram.Entry.t Ast.expr; + value do_sequence : Gram.Entry.t Ast.expr; + value sig_item : Gram.Entry.t Ast.sig_item; + value sig_item_quot : Gram.Entry.t Ast.sig_item; + value sig_items : Gram.Entry.t Ast.sig_item; + value star_ctyp : Gram.Entry.t Ast.ctyp; + value str_item : Gram.Entry.t Ast.str_item; + value str_item_quot : Gram.Entry.t Ast.str_item; + value str_items : Gram.Entry.t Ast.str_item; + value type_constraint : Gram.Entry.t unit; + value type_declaration : Gram.Entry.t Ast.ctyp; + value type_ident_and_parameters : Gram.Entry.t (Ast.ident * list Ast.ctyp); + value type_kind : Gram.Entry.t Ast.ctyp; + value type_longident : Gram.Entry.t Ast.ident; + value type_longident_and_parameters : Gram.Entry.t Ast.ctyp; + value type_parameter : Gram.Entry.t Ast.ctyp; + value type_parameters : Gram.Entry.t (Ast.ctyp -> Ast.ctyp); + value typevars : Gram.Entry.t Ast.ctyp; + value val_longident : Gram.Entry.t Ast.ident; + value value_let : Gram.Entry.t unit; + value value_val : Gram.Entry.t unit; + value with_constr : Gram.Entry.t Ast.with_constr; + value with_constr_quot : Gram.Entry.t Ast.with_constr; + value prefixop : Gram.Entry.t Ast.expr; + value infixop0 : Gram.Entry.t Ast.expr; + value infixop1 : Gram.Entry.t Ast.expr; + value infixop2 : Gram.Entry.t Ast.expr; + value infixop3 : Gram.Entry.t Ast.expr; + value infixop4 : Gram.Entry.t Ast.expr; +end; + +(** A signature for syntax extension (syntax -> syntax functors). *) +module type SyntaxExtension = functor (Syn : Syntax) + -> (Syntax with module Loc = Syn.Loc + and module Ast = Syn.Ast + and module Token = Syn.Token + and module Gram = Syn.Gram + and module Quotation = Syn.Quotation); diff --git a/camlp4/Camlp4/Struct.mlpack b/camlp4/Camlp4/Struct.mlpack new file mode 100644 index 0000000..a939fe7 --- /dev/null +++ b/camlp4/Camlp4/Struct.mlpack @@ -0,0 +1,15 @@ +AstFilters +Camlp4Ast +Camlp4Ast2OCamlAst +CleanAst +CommentFilter +DynLoader +EmptyError +EmptyPrinter +FreeVars +Lexer +Loc +Quotation +Token +Grammar +DynAst diff --git a/camlp4/Camlp4/Struct/.ignore b/camlp4/Camlp4/Struct/.ignore new file mode 100644 index 0000000..262784d --- /dev/null +++ b/camlp4/Camlp4/Struct/.ignore @@ -0,0 +1,2 @@ +Lexer.ml +Camlp4Ast.tmp.ml diff --git a/camlp4/Camlp4/Struct/AstFilters.ml b/camlp4/Camlp4/Struct/AstFilters.ml new file mode 100644 index 0000000..f3ac1be --- /dev/null +++ b/camlp4/Camlp4/Struct/AstFilters.ml @@ -0,0 +1,37 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) +module Make (Ast : Sig.Camlp4Ast) +: Sig.AstFilters with module Ast = Ast += struct + + module Ast = Ast; + + type filter 'a = 'a -> 'a; + + value interf_filters = Queue.create (); + value fold_interf_filters f i = Queue.fold f i interf_filters; + value implem_filters = Queue.create (); + value fold_implem_filters f i = Queue.fold f i implem_filters; + value topphrase_filters = Queue.create (); + value fold_topphrase_filters f i = Queue.fold f i topphrase_filters; + + value register_sig_item_filter f = Queue.add f interf_filters; + value register_str_item_filter f = Queue.add f implem_filters; + value register_topphrase_filter f = Queue.add f topphrase_filters; +end; diff --git a/camlp4/Camlp4/Struct/Camlp4Ast.mlast b/camlp4/Camlp4/Struct/Camlp4Ast.mlast new file mode 100644 index 0000000..1b4a5ef --- /dev/null +++ b/camlp4/Camlp4/Struct/Camlp4Ast.mlast @@ -0,0 +1,546 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Make (Loc : Sig.Loc) +: Sig.Camlp4Ast with module Loc = Loc += struct + module Loc = Loc; + + module Ast = struct + include Sig.MakeCamlp4Ast Loc; + + value safe_string_escaped s = + if String.length s > 2 && s.[0] = '\\' && s.[1] = '$' then s + else String.escaped s; + end; + + include Ast; + + external loc_of_ctyp : ctyp -> Loc.t = "%field0"; + external loc_of_patt : patt -> Loc.t = "%field0"; + external loc_of_expr : expr -> Loc.t = "%field0"; + external loc_of_module_type : module_type -> Loc.t = "%field0"; + external loc_of_module_expr : module_expr -> Loc.t = "%field0"; + external loc_of_sig_item : sig_item -> Loc.t = "%field0"; + external loc_of_str_item : str_item -> Loc.t = "%field0"; + external loc_of_class_type : class_type -> Loc.t = "%field0"; + external loc_of_class_sig_item : class_sig_item -> Loc.t = "%field0"; + external loc_of_class_expr : class_expr -> Loc.t = "%field0"; + external loc_of_class_str_item : class_str_item -> Loc.t = "%field0"; + external loc_of_with_constr : with_constr -> Loc.t = "%field0"; + external loc_of_binding : binding -> Loc.t = "%field0"; + external loc_of_rec_binding : rec_binding -> Loc.t = "%field0"; + external loc_of_module_binding : module_binding -> Loc.t = "%field0"; + external loc_of_match_case : match_case -> Loc.t = "%field0"; + external loc_of_ident : ident -> Loc.t = "%field0"; + + value ghost = Loc.ghost; + + value rec is_module_longident = + fun + [ <:ident< $_$.$i$ >> -> is_module_longident i + | <:ident< $i1$ $i2$ >> -> + is_module_longident i1 && is_module_longident i2 + | <:ident< $uid:_$ >> -> True + | _ -> False ]; + + value ident_of_expr = + let error () = + invalid_arg "ident_of_expr: this expression is not an identifier" in + let rec self = + fun + [ <:expr@_loc< $e1$ $e2$ >> -> <:ident< $self e1$ $self e2$ >> + | <:expr@_loc< $e1$.$e2$ >> -> <:ident< $self e1$.$self e2$ >> + | <:expr< $lid:_$ >> -> error () + | <:expr< $id:i$ >> -> if is_module_longident i then i else error () + | _ -> error () ] in + fun + [ <:expr< $id:i$ >> -> i + | <:expr< $_$ $_$ >> -> error () + | t -> self t ]; + + value ident_of_ctyp = + let error () = + invalid_arg "ident_of_ctyp: this type is not an identifier" in + let rec self = + fun + [ <:ctyp@_loc< $t1$ $t2$ >> -> <:ident< $self t1$ $self t2$ >> + | <:ctyp< $lid:_$ >> -> error () + | <:ctyp< $id:i$ >> -> if is_module_longident i then i else error () + | _ -> error () ] in + fun + [ <:ctyp< $id:i$ >> -> i + | t -> self t ]; + + value ident_of_patt = + let error () = + invalid_arg "ident_of_patt: this pattern is not an identifier" in + let rec self = + fun + [ <:patt@_loc< $p1$ $p2$ >> -> <:ident< $self p1$ $self p2$ >> + | <:patt< $lid:_$ >> -> error () + | <:patt< $id:i$ >> -> if is_module_longident i then i else error () + | _ -> error () ] in + fun + [ <:patt< $id:i$ >> -> i + | p -> self p ]; + + value rec is_irrefut_patt = + fun + [ <:patt< $lid:_$ >> -> True + | <:patt< () >> -> True + | <:patt< _ >> -> True + | <:patt<>> -> True (* why not *) + | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y + | <:patt< { $p$ } >> -> is_irrefut_patt p + | <:patt< $_$ = $p$ >> -> is_irrefut_patt p + | <:patt< $p1$; $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 + | <:patt< $p1$, $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 + | <:patt< $p1$ | $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 (* could be more fine grained *) + | <:patt< $p1$ $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 + | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p + | <:patt< ($tup:pl$) >> -> is_irrefut_patt pl + | <:patt< ? $_$ >> -> True + | <:patt< ? $_$ : ($p$) >> -> is_irrefut_patt p + | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p + | <:patt< ~ $_$ >> -> True + | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p + | <:patt< lazy $p$ >> -> is_irrefut_patt p + | Ast.PaAtt _loc _s _str p -> is_irrefut_patt p + | <:patt< $id:_$ >> -> False (* here one need to know the arity of constructors *) + | <:patt< (module $_$) >> -> True + | Ast.PaExc _loc p -> is_irrefut_patt p + | <:patt< `$_$ >> | <:patt< $str:_$ >> | <:patt< $_$ .. $_$ >> | + <:patt< $flo:_$ >> | <:patt< $nativeint:_$ >> | <:patt< $int64:_$ >> | + <:patt< $int32:_$ >> | <:patt< $int:_$ >> | <:patt< $chr:_$ >> | + <:patt< #$_$ >> | <:patt< [| $_$ |] >> | <:patt< $anti:_$ >> -> False + ]; + + value rec is_constructor = + fun + [ <:ident< $_$.$i$ >> -> is_constructor i + | <:ident< $uid:_$ >> -> True + | <:ident< $lid:_$ >> | <:ident< $_$ $_$ >> -> False + | <:ident< $anti:_$ >> -> assert False ]; + + value is_patt_constructor = + fun + [ <:patt< $id:i$ >> -> is_constructor i + | <:patt< `$_$ >> -> True + | _ -> False ]; + + value rec is_expr_constructor = + fun + [ <:expr< $id:i$ >> -> is_constructor i + | <:expr< $e1$.$e2$ >> -> is_expr_constructor e1 && is_expr_constructor e2 + | <:expr< `$_$ >> -> True + | _ -> False ]; + + value rec tyOr_of_list = + fun + [ [] -> <:ctyp@ghost<>> + | [t] -> t + | [t::ts] -> + let _loc = loc_of_ctyp t in <:ctyp< $t$ | $tyOr_of_list ts$ >> ]; + + value rec tyAnd_of_list = + fun + [ [] -> <:ctyp@ghost<>> + | [t] -> t + | [t::ts] -> + let _loc = loc_of_ctyp t in <:ctyp< $t$ and $tyAnd_of_list ts$ >> ]; + + value rec tySem_of_list = + fun + [ [] -> <:ctyp@ghost<>> + | [t] -> t + | [t::ts] -> + let _loc = loc_of_ctyp t in <:ctyp< $t$ ; $tySem_of_list ts$ >> ]; + + value rec tyCom_of_list = + fun + [ [] -> <:ctyp@ghost<>> + | [t] -> t + | [t::ts] -> + let _loc = loc_of_ctyp t in <:ctyp< $t$, $tyCom_of_list ts$ >> ]; + + value rec tyAmp_of_list = + fun + [ [] -> <:ctyp@ghost<>> + | [t] -> t + | [t::ts] -> + let _loc = loc_of_ctyp t in <:ctyp< $t$ & $tyAmp_of_list ts$ >> ]; + + value rec tySta_of_list = + fun + [ [] -> <:ctyp@ghost<>> + | [t] -> t + | [t::ts] -> + let _loc = loc_of_ctyp t in <:ctyp< $t$ * $tySta_of_list ts$ >> ]; + + value rec stSem_of_list = + fun + [ [] -> <:str_item@ghost<>> + | [t] -> t + | [t::ts] -> + let _loc = loc_of_str_item t in <:str_item< $t$ ; $stSem_of_list ts$ >> ]; + + value rec sgSem_of_list = + fun + [ [] -> <:sig_item@ghost<>> + | [t] -> t + | [t::ts] -> + let _loc = loc_of_sig_item t in <:sig_item< $t$ ; $sgSem_of_list ts$ >> ]; + + value rec biAnd_of_list = + fun + [ [] -> <:binding@ghost<>> + | [b] -> b + | [b::bs] -> + let _loc = loc_of_binding b in <:binding< $b$ and $biAnd_of_list bs$ >> ]; + + value rec rbSem_of_list = + fun + [ [] -> <:rec_binding@ghost<>> + | [b] -> b + | [b::bs] -> + let _loc = loc_of_rec_binding b in + <:rec_binding< $b$; $rbSem_of_list bs$ >> ]; + + value rec wcAnd_of_list = + fun + [ [] -> <:with_constr@ghost<>> + | [w] -> w + | [w::ws] -> + let _loc = loc_of_with_constr w in + <:with_constr< $w$ and $wcAnd_of_list ws$ >> ]; + + value rec idAcc_of_list = + fun + [ [] -> assert False + | [i] -> i + | [i::is] -> + let _loc = loc_of_ident i in + <:ident< $i$ . $idAcc_of_list is$ >> ]; + + value rec idApp_of_list = + fun + [ [] -> assert False + | [i] -> i + | [i::is] -> + let _loc = loc_of_ident i in + <:ident< $i$ $idApp_of_list is$ >> ]; + + value rec mcOr_of_list = + fun + [ [] -> <:match_case@ghost<>> + | [x] -> x + | [x::xs] -> + let _loc = loc_of_match_case x in + <:match_case< $x$ | $mcOr_of_list xs$ >> ]; + + value rec mbAnd_of_list = + fun + [ [] -> <:module_binding@ghost<>> + | [x] -> x + | [x::xs] -> + let _loc = loc_of_module_binding x in + <:module_binding< $x$ and $mbAnd_of_list xs$ >> ]; + + value rec meApp_of_list = + fun + [ [] -> assert False + | [x] -> x + | [x::xs] -> + let _loc = loc_of_module_expr x in + <:module_expr< $x$ $meApp_of_list xs$ >> ]; + + value rec ceAnd_of_list = + fun + [ [] -> <:class_expr@ghost<>> + | [x] -> x + | [x::xs] -> + let _loc = loc_of_class_expr x in + <:class_expr< $x$ and $ceAnd_of_list xs$ >> ]; + + value rec ctAnd_of_list = + fun + [ [] -> <:class_type@ghost<>> + | [x] -> x + | [x::xs] -> + let _loc = loc_of_class_type x in + <:class_type< $x$ and $ctAnd_of_list xs$ >> ]; + + value rec cgSem_of_list = + fun + [ [] -> <:class_sig_item@ghost<>> + | [x] -> x + | [x::xs] -> + let _loc = loc_of_class_sig_item x in + <:class_sig_item< $x$; $cgSem_of_list xs$ >> ]; + + value rec crSem_of_list = + fun + [ [] -> <:class_str_item@ghost<>> + | [x] -> x + | [x::xs] -> + let _loc = loc_of_class_str_item x in + <:class_str_item< $x$; $crSem_of_list xs$ >> ]; + + value rec paSem_of_list = + fun + [ [] -> <:patt@ghost<>> + | [x] -> x + | [x::xs] -> + let _loc = loc_of_patt x in + <:patt< $x$; $paSem_of_list xs$ >> ]; + + value rec paCom_of_list = + fun + [ [] -> <:patt@ghost<>> + | [x] -> x + | [x::xs] -> + let _loc = loc_of_patt x in + <:patt< $x$, $paCom_of_list xs$ >> ]; + + value rec exSem_of_list = + fun + [ [] -> <:expr@ghost<>> + | [x] -> x + | [x::xs] -> + let _loc = loc_of_expr x in + <:expr< $x$; $exSem_of_list xs$ >> ]; + + value rec exCom_of_list = + fun + [ [] -> <:expr@ghost<>> + | [x] -> x + | [x::xs] -> + let _loc = loc_of_expr x in + <:expr< $x$, $exCom_of_list xs$ >> ]; + + value ty_of_stl = + fun + [ (_loc, s, []) -> <:ctyp< $uid:s$ >> + | (_loc, s, tl) -> <:ctyp< $uid:s$ of $tyAnd_of_list tl$ >> ]; + + value ty_of_sbt = + fun + [ (_loc, s, True, t) -> <:ctyp< $lid:s$ : mutable $t$ >> + | (_loc, s, False, t) -> <:ctyp< $lid:s$ : $t$ >> ]; + + value bi_of_pe (p, e) = let _loc = loc_of_patt p in <:binding< $p$ = $e$ >>; + value sum_type_of_list l = tyOr_of_list (List.map ty_of_stl l); + value record_type_of_list l = tySem_of_list (List.map ty_of_sbt l); + value binding_of_pel l = biAnd_of_list (List.map bi_of_pe l); + + value rec pel_of_binding = + fun + [ <:binding< $b1$ and $b2$ >> -> pel_of_binding b1 @ pel_of_binding b2 + | <:binding< $p$ = $e$ >> -> [(p, e)] + | _ -> assert False ]; + + value rec list_of_binding x acc = + match x with + [ <:binding< $b1$ and $b2$ >> -> + list_of_binding b1 (list_of_binding b2 acc) + | t -> [t :: acc] ]; + + value rec list_of_rec_binding x acc = + match x with + [ <:rec_binding< $b1$; $b2$ >> -> + list_of_rec_binding b1 (list_of_rec_binding b2 acc) + | t -> [t :: acc] ]; + + value rec list_of_with_constr x acc = + match x with + [ <:with_constr< $w1$ and $w2$ >> -> + list_of_with_constr w1 (list_of_with_constr w2 acc) + | t -> [t :: acc] ]; + + value rec list_of_ctyp x acc = + match x with + [ <:ctyp<>> -> acc + | <:ctyp< $x$ & $y$ >> | <:ctyp< $x$, $y$ >> | + <:ctyp< $x$ * $y$ >> | <:ctyp< $x$; $y$ >> | + <:ctyp< $x$ and $y$ >> | <:ctyp< $x$ | $y$ >> -> + list_of_ctyp x (list_of_ctyp y acc) + | x -> [x :: acc] ]; + + value rec list_of_patt x acc = + match x with + [ <:patt<>> -> acc + | <:patt< $x$, $y$ >> | <:patt< $x$; $y$ >> -> + list_of_patt x (list_of_patt y acc) + | x -> [x :: acc] ]; + + value rec list_of_expr x acc = + match x with + [ <:expr<>> -> acc + | <:expr< $x$, $y$ >> | <:expr< $x$; $y$ >> -> + list_of_expr x (list_of_expr y acc) + | x -> [x :: acc] ]; + + value rec list_of_str_item x acc = + match x with + [ <:str_item<>> -> acc + | <:str_item< $x$; $y$ >> -> + list_of_str_item x (list_of_str_item y acc) + | x -> [x :: acc] ]; + + value rec list_of_sig_item x acc = + match x with + [ <:sig_item<>> -> acc + | <:sig_item< $x$; $y$ >> -> + list_of_sig_item x (list_of_sig_item y acc) + | x -> [x :: acc] ]; + + value rec list_of_class_sig_item x acc = + match x with + [ <:class_sig_item<>> -> acc + | <:class_sig_item< $x$; $y$ >> -> + list_of_class_sig_item x (list_of_class_sig_item y acc) + | x -> [x :: acc] ]; + + value rec list_of_class_str_item x acc = + match x with + [ <:class_str_item<>> -> acc + | <:class_str_item< $x$; $y$ >> -> + list_of_class_str_item x (list_of_class_str_item y acc) + | x -> [x :: acc] ]; + + value rec list_of_class_type x acc = + match x with + [ <:class_type< $x$ and $y$ >> -> + list_of_class_type x (list_of_class_type y acc) + | x -> [x :: acc] ]; + + value rec list_of_class_expr x acc = + match x with + [ <:class_expr< $x$ and $y$ >> -> + list_of_class_expr x (list_of_class_expr y acc) + | x -> [x :: acc] ]; + + value rec list_of_module_expr x acc = + match x with + [ <:module_expr< $x$ $y$ >> -> + list_of_module_expr x (list_of_module_expr y acc) + | x -> [x :: acc] ]; + + value rec list_of_match_case x acc = + match x with + [ <:match_case<>> -> acc + | <:match_case< $x$ | $y$ >> -> + list_of_match_case x (list_of_match_case y acc) + | x -> [x :: acc] ]; + + value rec list_of_ident x acc = + match x with + [ <:ident< $x$ . $y$ >> | <:ident< $x$ $y$ >> -> + list_of_ident x (list_of_ident y acc) + | x -> [x :: acc] ]; + + value rec list_of_module_binding x acc = + match x with + [ <:module_binding< $x$ and $y$ >> -> + list_of_module_binding x (list_of_module_binding y acc) + | x -> [x :: acc] ]; + + module Camlp4Trash = struct + INCLUDE "camlp4/Camlp4/Camlp4Ast.partial.ml"; + end; + + module Meta = struct + + module type META_LOC = sig + (** The first location is where to put the returned pattern. + Generally it's _loc to match with <:patt< ... >> quotations. + The second location is the one to treat. *) + value meta_loc_patt : Loc.t -> Loc.t -> Ast.patt; + (** The first location is where to put the returned expression. + Generally it's _loc to match with <:expr< ... >> quotations. + The second location is the one to treat. *) + value meta_loc_expr : Loc.t -> Loc.t -> Ast.expr; + end; + + module MetaLoc = struct + value meta_loc_patt _loc location = + let (a, b, c, d, e, f, g, h) = Loc.to_tuple location in + <:patt< Loc.of_tuple + ($`str:a$, $`int:b$, $`int:c$, $`int:d$, + $`int:e$, $`int:f$, $`int:g$, + $if h then <:patt< True >> else <:patt< False >> $) >>; + value meta_loc_expr _loc location = + let (a, b, c, d, e, f, g, h) = Loc.to_tuple location in + <:expr< Loc.of_tuple + ($`str:a$, $`int:b$, $`int:c$, $`int:d$, + $`int:e$, $`int:f$, $`int:g$, + $if h then <:expr< True >> else <:expr< False >> $) >>; + end; + + module MetaGhostLoc = struct + value meta_loc_patt _loc _ = <:patt< Loc.ghost >>; + value meta_loc_expr _loc _ = <:expr< Loc.ghost >>; + end; + + module MetaLocVar = struct + value meta_loc_patt _loc _ = <:patt< $lid:Loc.name.val$ >>; + value meta_loc_expr _loc _ = <:expr< $lid:Loc.name.val$ >>; + end; + + module Make (MetaLoc : META_LOC) = struct + open MetaLoc; + + value meta_loc = meta_loc_expr; + module Expr = Camlp4Filters.MetaGeneratorExpr Ast; + value meta_loc = meta_loc_patt; + module Patt = Camlp4Filters.MetaGeneratorPatt Ast; + end; + + end; + + class map = Camlp4MapGenerator.generated; + + class fold = Camlp4FoldGenerator.generated; + + value map_expr f = object + inherit map as super; + method expr x = f (super#expr x); + end; + value map_patt f = object + inherit map as super; + method patt x = f (super#patt x); + end; + value map_ctyp f = object + inherit map as super; + method ctyp x = f (super#ctyp x); + end; + value map_str_item f = object + inherit map as super; + method str_item x = f (super#str_item x); + end; + value map_sig_item f = object + inherit map as super; + method sig_item x = f (super#sig_item x); + end; + value map_loc f = object + inherit map as super; + method loc x = f (super#loc x); + end; +end; diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml new file mode 100644 index 0000000..cf2cc61 --- /dev/null +++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml @@ -0,0 +1,1465 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2002-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +(* We copy the implementation of a few functions from OCaml to avoid depending on its + implementation. *) + +module Location = struct + type t = Location.t == { + loc_start: Lexing.position; + loc_end: Lexing.position; + loc_ghost: bool; + }; + + type loc 'a = Location.loc 'a == { + txt : 'a; + loc : t; + }; + + value none = + let loc = { + Lexing. + pos_fname = "_none_"; + pos_lnum = 1; + pos_bol = 0; + pos_cnum = -1; + } in + { loc_start = loc; loc_end = loc; loc_ghost = True }; + + value mkloc txt loc = { txt; loc }; +end; + +module Longident = struct + type t = Longident.t == + [ Lident of string + | Ldot of t and string + | Lapply of t and t ]; + + value last = fun + [ Lident s -> s + | Ldot _ s -> s + | Lapply _ _ -> failwith "Longident.last" ]; +end; + +module Make (Ast : Sig.Camlp4Ast) = struct + open Format; + open Parsetree; + open Longident; + open Asttypes; + open Ast; + + value error loc str = Loc.raise loc (Failure str); + + value char_of_char_token loc s = + try Token.Eval.char s with [ Failure _ as exn -> Loc.raise loc exn ] + ; + + value string_of_string_token loc s = + try Token.Eval.string s + with [ Failure _ as exn -> Loc.raise loc exn ] + ; + + value remove_underscores s = + let s = Bytes.of_string s in + let l = Bytes.length s in + let rec remove src dst = + if src >= l then + if dst >= l then s else Bytes.sub s 0 dst + else + match Bytes.get s src with + [ '_' -> remove (src + 1) dst + | c -> do { Bytes.set s dst c; remove (src + 1) (dst + 1) } ] + in Bytes.to_string (remove 0 0) + ; + + value mkloc = Loc.to_ocaml_location; + value mkghloc loc = Loc.to_ocaml_location (Loc.ghostify loc); + + value with_loc txt loc = Location.mkloc txt (mkloc loc); + + value mktyp loc d = {ptyp_desc = d; ptyp_loc = mkloc loc; ptyp_attributes = []}; + value mkpat loc d = {ppat_desc = d; ppat_loc = mkloc loc; ppat_attributes = []}; + value mkghpat loc d = {ppat_desc = d; ppat_loc = mkghloc loc; ppat_attributes = []}; + value mkexp loc d = {pexp_desc = d; pexp_loc = mkloc loc; pexp_attributes = []}; + value mkmty loc d = {pmty_desc = d; pmty_loc = mkloc loc; pmty_attributes = []}; + value mksig loc d = {psig_desc = d; psig_loc = mkloc loc}; + value mkmod loc d = {pmod_desc = d; pmod_loc = mkloc loc; pmod_attributes = []}; + value mkstr loc d = {pstr_desc = d; pstr_loc = mkloc loc}; + value mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc; pcty_attributes = []}; + value mkcl loc d = {pcl_desc = d; pcl_loc = mkloc loc; pcl_attributes = []}; + value mkcf loc d = { pcf_desc = d; pcf_loc = mkloc loc; pcf_attributes = []}; + value mkctf loc d = { pctf_desc = d; pctf_loc = mkloc loc; pctf_attributes = []}; + + value mkpolytype t = + match t.ptyp_desc with + [ Ptyp_poly _ _ -> t + | _ -> { (t) with ptyp_desc = Ptyp_poly [] t } ] + ; + + value mkvirtual = fun + [ <:virtual_flag< virtual >> -> Virtual + | <:virtual_flag<>> -> Concrete + | _ -> assert False ]; + + value mkdirection = fun + [ <:direction_flag< to >> -> Upto + | <:direction_flag< downto >> -> Downto + | _ -> 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; + + value conv_con = + let t = Hashtbl.create 73 in + do { + List.iter (fun (s, s') -> Hashtbl.add t s s') + [("True", "true"); ("False", "false"); (" True", "True"); + (" False", "False")]; + fun s -> try Hashtbl.find t s with [ Not_found -> s ] + } + ; + + value conv_lab = + let t = Hashtbl.create 73 in + do { + List.iter (fun (s, s') -> Hashtbl.add t s s') [("val", "contents")]; + fun s -> try Hashtbl.find t s with [ Not_found -> s ] + } + ; + + 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 + [ Ast.ReRecursive -> Recursive + | Ast.ReNonrecursive | Ast.ReNil -> Nonrecursive + | _ -> assert False ]; + value mknrf = + fun + [ Ast.ReNonrecursive -> Nonrecursive + | Ast.ReRecursive | Ast.ReNil -> Recursive + | _ -> assert False ]; + + value mkli sloc s list = with_loc (loop lident list) sloc + where rec loop f = + fun + [ [i :: il] -> loop (ldot (f i)) il + | [] -> f s ] + ; + + value rec ctyp_fa al = + fun + [ TyApp _ f a -> ctyp_fa [a :: al] f + | f -> (f, al) ] + ; + + value ident_tag ?(conv_lid = fun x -> x) i = + + let rec self i acc = + match i with + [ <:ident< $i1$.$i2$ >> -> + self i2 (Some (self i1 acc)) + | <:ident< $i1$ $i2$ >> -> + let i' = Lapply (fst (self i1 None)) (fst (self i2 None)) in + let x = + match acc with + [ None -> i' + | _ -> error (loc_of_ident i) "invalid long identifier" ] + in (x, `app) + | <:ident< $uid:s$ >> -> + let x = + match acc with + [ None -> lident s + | Some (acc, `uident | `app) -> ldot acc s + | _ -> error (loc_of_ident i) "invalid long identifier" ] + in (x, `uident) + | <:ident< $lid:s$ >> -> + let x = + match acc with + [ None -> lident (conv_lid s) + | Some (acc, `uident | `app) -> ldot acc (conv_lid s) + | _ -> error (loc_of_ident i) "invalid long identifier" ] + in (x, `lident) + | _ -> error (loc_of_ident i) "invalid long identifier" ] + in self i None; + + 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 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_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" ] + ; + + 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_noloc i + | <:ctyp< $m1$ $m2$ >> -> + let li1 = ctyp_long_id_prefix m1 in + let li2 = ctyp_long_id_prefix m2 in + Lapply li1 li2 + | t -> error (loc_of_ctyp t) "invalid module expression" ] + ; + + value ctyp_long_id t = + match t with + [ <:ctyp< $id:i$ >> -> + (False, long_type_ident i) + | TyApp loc _ _ -> + error loc "invalid type name" + | TyCls _ i -> (True, ident i) + | t -> error (loc_of_ctyp t) "invalid type" ] + ; + + value rec ty_var_list_of_ctyp = + fun + [ <:ctyp< $t1$ $t2$ >> -> ty_var_list_of_ctyp t1 @ ty_var_list_of_ctyp t2 + | <:ctyp@loc< '$s$ >> -> [with_loc s loc] + | _ -> assert False ]; + + value attribute_fwd = ref (fun _ _ _ -> assert False); + + value attribute loc s str = + !attribute_fwd loc s str; + + value rec ctyp = + fun + [ TyId loc i -> + let li = long_type_ident i in + mktyp loc (Ptyp_constr li []) + | TyAli loc t1 t2 -> + let (t, i) = + match (t1, t2) with + [ (t, TyQuo _ s) -> (t, s) + | (TyQuo _ s, t) -> (t, s) + | _ -> error loc "invalid alias type" ] + in + mktyp loc (Ptyp_alias (ctyp t) i) + | TyAny loc -> mktyp loc Ptyp_any + | TyApp loc _ _ as f -> + let (f, al) = ctyp_fa [] f in + let (is_cls, li) = ctyp_long_id f in + if is_cls then mktyp loc (Ptyp_class li (List.map ctyp al)) + else mktyp loc (Ptyp_constr li (List.map ctyp al)) + | TyArr loc (TyLab _ lab t1) t2 -> + mktyp loc (Ptyp_arrow (Labelled lab) (ctyp t1) (ctyp t2)) + | TyArr loc (TyOlb _ lab t1) t2 -> + mktyp loc (Ptyp_arrow (Optional lab) (ctyp t1) (ctyp t2)) + | TyArr loc t1 t2 -> mktyp loc (Ptyp_arrow Nolabel (ctyp t1) (ctyp t2)) + | <:ctyp@loc< < $fl$ > >> -> mktyp loc (Ptyp_object (meth_list fl []) Closed) + | <:ctyp@loc< < $fl$ .. > >> -> + mktyp loc (Ptyp_object (meth_list fl []) Open) + | TyCls loc id -> + mktyp loc (Ptyp_class (ident id) []) + | <:ctyp@loc< (module $pt$) >> -> + let (i, cs) = package_type pt in + mktyp loc (Ptyp_package i cs) + | TyAtt loc s str e -> + let e = ctyp e in + {(e) with ptyp_attributes = e.ptyp_attributes @ [attribute loc s str]} + | TyLab loc _ _ -> error loc "labelled type not allowed here" + | TyMan loc _ _ -> error loc "manifest type not allowed here" + | TyOlb loc _ _ -> error loc "labelled type not allowed here" + | TyPol loc t1 t2 -> mktyp loc (Ptyp_poly (ty_var_list_of_ctyp t1) (ctyp t2)) + | TyQuo loc s -> mktyp loc (Ptyp_var s) + | TyRec loc _ -> error loc "record type not allowed here" + | TySum loc _ -> error loc "sum type not allowed here" + | TyPrv loc _ -> error loc "private type not allowed here" + | TyMut loc _ -> error loc "mutable type not allowed here" + | TyOr loc _ _ -> error loc "type1 | type2 not allowed here" + | TyAnd loc _ _ -> error loc "type1 and type2 not allowed here" + | TyOf loc _ _ -> error loc "type1 of type2 not allowed here" + | TyCol loc _ _ -> error loc "type1 : type2 not allowed here" + | TySem loc _ _ -> error loc "type1 ; type2 not allowed here" + | TyTypePol loc _ _ -> error loc "locally abstract type not allowed here" + | <:ctyp@loc< ($t1$ * $t2$) >> -> + mktyp loc (Ptyp_tuple (List.map ctyp (list_of_ctyp t1 (list_of_ctyp t2 [])))) + | <:ctyp@loc< [ = $t$ ] >> -> mktyp loc (Ptyp_variant (row_field t) Closed None) + | <:ctyp@loc< [ > $t$ ] >> -> mktyp loc (Ptyp_variant (row_field t) Open None) + | <:ctyp@loc< [ < $t$ ] >> -> mktyp loc (Ptyp_variant (row_field t) Closed (Some [])) + | <:ctyp@loc< [ < $t$ > $t'$ ] >> -> + mktyp loc (Ptyp_variant (row_field t) Closed (Some (name_tags t'))) + | TyAnt loc _ -> error loc "antiquotation not allowed here" + | TyOfAmp loc _ _ + | TyAmp loc _ _ + | TySta loc _ _ + | TyCom loc _ _ + | TyVrn loc _ + | TyQuM loc _ + | TyQuP loc _ + | TyDcl loc _ _ _ _ + | TyExt loc _ _ _ + | TyAnP loc + | TyAnM loc + | TyObj loc _ (RvAnt _) + | TyNil loc + | TyOpn loc + | TyTup loc _ -> error loc "this construction is not allowed here" ] + and row_field = fun + [ <:ctyp<>> -> [] + | <:ctyp@loc< `$i$ >> -> + [Rtag (with_loc (conv_con i) loc) [] True []] + | <:ctyp@loc< `$i$ of & $t$ >> -> + [Rtag (with_loc (conv_con i) loc) [] True (List.map ctyp (list_of_ctyp t []))] + | <:ctyp@loc< `$i$ of $t$ >> -> + [Rtag (with_loc (conv_con i) loc) [] False (List.map ctyp (list_of_ctyp t []))] + | <:ctyp< $t1$ | $t2$ >> -> row_field t1 @ row_field t2 + | t -> [Rinherit (ctyp t)] ] + and name_tags = fun + [ <:ctyp< $t1$ $t2$ >> -> name_tags t1 @ name_tags t2 + | <:ctyp< `$s$ >> -> [s] + | _ -> assert False ] + and meth_list fl acc = + match fl with + [ <:ctyp<>> -> acc + | <:ctyp< $t1$; $t2$ >> -> meth_list t1 (meth_list t2 acc) + | <:ctyp@loc< $lid:lab$ : $t$ >> -> + [Otag (with_loc lab loc) [] (mkpolytype (ctyp t)) :: acc] + | _ -> assert False ] + + and package_type_constraints wc acc = + match wc with + [ <:with_constr<>> -> acc + | <:with_constr< type $id:id$ = $ct$ >> -> + [(ident id, ctyp ct) :: acc] + | <:with_constr< $wc1$ and $wc2$ >> -> + package_type_constraints wc1 (package_type_constraints wc2 acc) + | _ -> error (loc_of_with_constr wc) "unexpected `with constraint' for a package type" ] + + and package_type : module_type -> package_type = + fun + [ <:module_type< $id:i$ with $wc$ >> -> + (long_uident i, package_type_constraints wc []) + | <:module_type< $id:i$ >> -> (long_uident i, []) + | mt -> error (loc_of_module_type mt) "unexpected package type" ] + ; + + value mktype loc name tl cl tk tp tm = + {ptype_name = name; + ptype_params = tl; ptype_cstrs = cl; ptype_kind = tk; + ptype_private = tp; ptype_manifest = tm; ptype_loc = mkloc loc; + ptype_attributes = []} + ; + value mktypext path tl tc tp = + {ptyext_path = path; + ptyext_params = tl; + ptyext_constructors = tc; + ptyext_private = tp; + ptyext_attributes = []} + ; + value mkprivate' m = if m then Private else Public; + value mkprivate = fun + [ <:private_flag< private >> -> Private + | <:private_flag<>> -> Public + | _ -> assert False ]; + value mktrecord = + fun + [ <:ctyp@loc< $id:(<:ident@sloc< $lid:s$ >>)$ : mutable $t$ >> -> + {pld_name=with_loc s sloc; + pld_mutable=Mutable; + pld_type=mkpolytype (ctyp t); + pld_loc=mkloc loc; + pld_attributes=[]; + } + | <:ctyp@loc< $id:(<:ident@sloc< $lid:s$ >>)$ : $t$ >> -> + {pld_name=with_loc s sloc; + pld_mutable=Immutable; + pld_type=mkpolytype (ctyp t); + pld_loc=mkloc loc; + pld_attributes=[]; + } + | _ -> assert False (*FIXME*) ]; + value mkvariant = + fun + [ <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ >> -> + { pcd_name = with_loc (conv_con s) sloc + ; pcd_args = Pcstr_tuple [] + ; pcd_res = None + ; pcd_loc = mkloc loc + ; pcd_attributes = [] + } + | <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ of $t$ >> -> + { pcd_name = with_loc (conv_con s) sloc + ; pcd_args = Pcstr_tuple (List.map ctyp (list_of_ctyp t [])) + ; pcd_res = None + ; pcd_loc = mkloc loc + ; pcd_attributes = [] + } + | <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ : ($t$ -> $u$) >> -> + { pcd_name = with_loc (conv_con s) sloc + ; pcd_args = Pcstr_tuple (List.map ctyp (list_of_ctyp t [])) + ; pcd_res = Some (ctyp u) + ; pcd_loc = mkloc loc + ; pcd_attributes = [] + } + | <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ : $t$ >> -> + { pcd_name = with_loc (conv_con s) sloc + ; pcd_args = Pcstr_tuple [] + ; pcd_res = Some (ctyp t) + ; pcd_loc = mkloc loc + ; pcd_attributes = [] + } + | _ -> assert False (*FIXME*) ]; + value mkextension_constructor = + fun + [ <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ >> -> + {pext_name = with_loc (conv_con s) sloc; + pext_kind = Pext_decl (Pcstr_tuple []) None; + pext_loc = mkloc loc; + pext_attributes = []} + | <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ of $t$ >> -> + {pext_name = with_loc (conv_con s) sloc; + pext_kind = Pext_decl (Pcstr_tuple (List.map ctyp (list_of_ctyp t []))) None; + pext_loc = mkloc loc; + pext_attributes = []} + | <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ : ($t$ -> $u$) >> -> + {pext_name = with_loc (conv_con s) sloc; + pext_kind = Pext_decl (Pcstr_tuple (List.map ctyp (list_of_ctyp t []))) (Some (ctyp u)); + pext_loc = mkloc loc; + pext_attributes = []} + | <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ : $t$ >> -> + {pext_name = with_loc (conv_con s) sloc; + pext_kind = Pext_decl (Pcstr_tuple []) (Some (ctyp t)); + pext_loc = mkloc loc; + pext_attributes = []} + | <:ctyp@loc< $id:(<:ident@sloc< $uid:s$ >>)$ == $id:r$ >> -> + {pext_name = with_loc (conv_con s) sloc; + pext_kind = Pext_rebind (long_uident r); + pext_loc = mkloc loc; + pext_attributes = []} + | _ -> assert False (*FIXME*) ]; + value rec type_decl name tl cl loc m pflag = + fun + [ <:ctyp< $t1$ == $t2$ >> -> + type_decl name tl cl loc (Some (ctyp t1)) pflag t2 + | <:ctyp@_loc< private $t$ >> -> + if pflag then + error _loc "multiple private keyword used, use only one instead" + else + type_decl name tl cl loc m True t + | <:ctyp< { $t$ } >> -> + mktype loc name tl cl + (Ptype_record (List.map mktrecord (list_of_ctyp t []))) (mkprivate' pflag) m + | <:ctyp< [ $t$ ] >> -> + mktype loc name tl cl + (Ptype_variant (List.map mkvariant (list_of_ctyp t []))) (mkprivate' pflag) m + | TyOpn loc -> + mktype loc name tl cl Ptype_open (mkprivate' pflag) m + | t -> + if m <> None then + error loc "only one manifest type allowed by definition" else + let m = + match t with + [ <:ctyp<>> -> None + | _ -> Some (ctyp t) ] + in + mktype loc name tl cl Ptype_abstract (mkprivate' pflag) m ] + ; + value rec type_ext path tl loc pflag = + fun + [ <:ctyp@_loc< $_$ == $_$ >> -> + error _loc "manifest type not allowed for extensions" + | <:ctyp@_loc< private $t$ >> -> + if pflag then + error _loc "multiple private keyword used, use only one instead" + else + type_ext path tl loc True t + | <:ctyp< [ $t$ ] >> -> + mktypext path tl + (List.map mkextension_constructor (list_of_ctyp t [])) + (mkprivate' pflag) + | _ -> + error loc "invalid type extension" ] + ; + + value type_decl name tl cl t loc = type_decl name tl cl loc None False t; + value type_ext path tl t loc = type_ext path tl loc False t; + + value mkvalue_desc loc name t p = {pval_name = name; pval_type = ctyp t; pval_prim = p; pval_loc = mkloc loc; pval_attributes = []}; + + value rec list_of_meta_list = + fun + [ Ast.LNil -> [] + | Ast.LCons x xs -> [x :: list_of_meta_list xs] + | Ast.LAnt _ -> assert False ]; + + value mkmutable = fun + [ <:mutable_flag< mutable >> -> Mutable + | <:mutable_flag<>> -> Immutable + | _ -> assert False ]; + + value paolab lab p = + match (lab, p) with + [ ("", <:patt< $lid:i$ >> | <:patt< ($lid:i$ : $_$) >>) -> i + | ("", p) -> error (loc_of_patt p) "bad ast in label" + | _ -> lab ] + ; + + value opt_private_ctyp = + fun + [ <:ctyp< private $t$ >> -> (Ptype_abstract, Private, ctyp t) + | t -> (Ptype_abstract, Public, ctyp t) ]; + + value rec type_parameters t acc = + match t with + [ <:ctyp< $t1$ $t2$ >> -> type_parameters t1 (type_parameters t2 acc) + | <:ctyp< +'$s$ >> -> [(s, Covariant) :: acc] + | <:ctyp< -'$s$ >> -> [(s, Contravariant) :: acc] + | <:ctyp< '$s$ >> -> [(s, Invariant) :: acc] + | _ -> assert False ]; + + value core_type loc ty = + { ptyp_desc = ty + ; ptyp_loc = mkloc loc + ; ptyp_attributes = [] + }; + + value ptyp_var loc s = core_type loc (Ptyp_var s); + value ptyp_any loc = core_type loc Ptyp_any; + + value rec optional_type_parameters t acc = + match t with + [ <:ctyp< $t1$ $t2$ >> -> optional_type_parameters t1 (optional_type_parameters t2 acc) + | <:ctyp@loc< +'$s$ >> -> [(ptyp_var loc s, Covariant) :: acc] + | Ast.TyAnP loc -> [(ptyp_any loc, Covariant) :: acc] + | <:ctyp@loc< -'$s$ >> -> [(ptyp_var loc s, Contravariant) :: acc] + | Ast.TyAnM loc -> [(ptyp_any loc, Contravariant) :: acc] + | <:ctyp@loc< '$s$ >> -> [(ptyp_var loc s, Invariant) :: acc] + | Ast.TyAny loc -> [(ptyp_any loc, Invariant) :: acc] + | _ -> assert False ]; + + value rec class_parameters t acc = + match t with + [ <:ctyp< $t1$, $t2$ >> -> class_parameters t1 (class_parameters t2 acc) + | <:ctyp@loc< +'$s$ >> -> [(ptyp_var loc s, Covariant) :: acc] + | <:ctyp@loc< -'$s$ >> -> [(ptyp_var loc s, Contravariant) :: acc] + | <:ctyp@loc< '$s$ >> -> [(ptyp_var loc s, Invariant) :: acc] + | _ -> assert False ]; + + value rec type_parameters_and_type_name t acc = + match t with + [ <:ctyp< $t1$ $t2$ >> -> + type_parameters_and_type_name t1 + (optional_type_parameters t2 acc) + | <:ctyp< $id:i$ >> -> (ident i, acc) + | _ -> assert False ]; + + value mkwithtyp pwith_type loc id_tpl ct = + let (id, tpl) = type_parameters_and_type_name id_tpl [] in + let (kind, priv, ct) = opt_private_ctyp ct in + pwith_type id + { ptype_name = Location.mkloc (Longident.last id.txt) id.loc; + ptype_params = tpl; ptype_cstrs = []; + ptype_kind = kind; + ptype_private = priv; + ptype_manifest = Some ct; + ptype_loc = mkloc loc; + ptype_attributes = []; + }; + + value rec mkwithc wc acc = + match wc with + [ <:with_constr<>> -> acc + | <:with_constr@loc< type $id_tpl$ = $ct$ >> -> + [mkwithtyp (fun lid x -> Pwith_type lid x) loc id_tpl ct :: acc] + | <:with_constr< module $i1$ = $i2$ >> -> + [(Pwith_module (long_uident i1) (long_uident i2)) :: acc] + | <:with_constr@loc< type $id_tpl$ := $ct$ >> -> + [mkwithtyp (fun lid x -> Pwith_typesubst lid x) loc id_tpl ct :: acc] + | <:with_constr< module $i1$ := $i2$ >> (*WcMoS _ i1 i2*) -> + [(Pwith_modsubst (long_uident i1) (long_uident i2)) :: acc] + | <:with_constr< $wc1$ and $wc2$ >> -> mkwithc wc1 (mkwithc wc2 acc) + | <:with_constr@loc< $anti:_$ >> -> + error loc "bad with constraint (antiquotation)" ]; + + value rec patt_fa al = + fun + [ PaApp _ f a -> patt_fa [a :: al] f + | f -> (f, al) ] + ; + + value rec deep_mkrangepat loc c1 c2 = + if c1 = c2 then mkghpat loc (Ppat_constant (Pconst_char c1)) + else + mkghpat loc + (Ppat_or (mkghpat loc (Ppat_constant (Pconst_char c1))) + (deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2)) + ; + + value rec mkrangepat loc c1 c2 = + if c1 > c2 then mkrangepat loc c2 c1 + else if c1 = c2 then mkpat loc (Ppat_constant (Pconst_char c1)) + else + mkpat loc + (Ppat_or (mkghpat loc (Ppat_constant (Pconst_char c1))) + (deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2)) + ; + + value rec patt = + fun + [ <: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 + in mkpat loc p + | PaAli loc p1 p2 -> + let (p, i) = + match (p1, p2) with + [ (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< $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))) + | PaApp loc _ _ as f -> + let (f, al) = patt_fa [] f in + let al = List.map patt al in + match (patt f).ppat_desc with + [ Ppat_construct li None -> + let a = + match al with + [ [a] -> a + | _ -> mkpat loc (Ppat_tuple al) ] + in + mkpat loc (Ppat_construct li (Some a)) + | Ppat_variant s None -> + let a = + match al with + [ [a] -> a + | _ -> mkpat loc (Ppat_tuple al) ] + in mkpat loc (Ppat_variant s (Some a)) + | _ -> + error (loc_of_patt f) + "this is not a constructor, it cannot be applied in a pattern" ] + | PaArr loc p -> mkpat loc (Ppat_array (List.map patt (list_of_patt p []))) + | PaChr loc s -> + mkpat loc (Ppat_constant (Pconst_char (char_of_char_token loc s))) + | PaInt loc s -> mkpat loc (Ppat_constant (Pconst_integer (s, None))) + | PaInt32 loc s -> mkpat loc (Ppat_constant (Pconst_integer (s, Some 'l'))) + | PaInt64 loc s -> mkpat loc (Ppat_constant (Pconst_integer (s, Some 'L'))) + | PaNativeInt loc s -> mkpat loc (Ppat_constant (Pconst_integer (s, Some 'n'))) + | PaFlo loc s -> mkpat loc (Ppat_constant (Pconst_float (remove_underscores s, None))) + | PaLab loc _ _ -> error loc "labeled pattern not allowed here" + | PaOlb loc _ _ | PaOlbi loc _ _ _ -> error loc "labeled pattern not allowed here" + | PaOrp loc p1 p2 -> mkpat loc (Ppat_or (patt p1) (patt p2)) + | PaRng loc p1 p2 -> + match (p1, p2) with + [ (PaChr loc1 c1, PaChr loc2 c2) -> + let c1 = char_of_char_token loc1 c1 in + let c2 = char_of_char_token loc2 c2 in + mkrangepat loc c1 c2 + | _ -> error loc "range pattern allowed only for characters" ] + | PaRec loc p -> + let ps = list_of_patt p [] in + let is_wildcard = fun [ <:patt< _ >> -> True | _ -> False ] in + let (wildcards,ps) = List.partition is_wildcard ps in + let is_closed = if wildcards = [] then Closed else Open in + mkpat loc (Ppat_record (List.map mklabpat ps, is_closed)) + | PaStr loc s -> + mkpat loc (Ppat_constant (Pconst_string (string_of_string_token loc s) None)) + | <:patt@loc< ($p1$, $p2$) >> -> + mkpat loc (Ppat_tuple + (List.map patt (list_of_patt p1 (list_of_patt p2 [])))) + | <: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 (conv_con s) None) + | PaLaz loc p -> mkpat loc (Ppat_lazy (patt p)) + | PaMod loc m -> mkpat loc (Ppat_unpack (with_loc m loc)) + | PaExc loc p -> mkpat loc (Ppat_exception (patt p)) + | PaAtt loc s str e -> + let e = patt e in + {(e) with ppat_attributes = e.ppat_attributes @ [attribute loc s str]} + | PaEq _ _ _ | PaSem _ _ _ | PaCom _ _ _ | PaNil _ as p -> + error (loc_of_patt p) "invalid pattern" ] + and mklabpat = + fun + [ <:patt< $i$ = $p$ >> -> (ident ~conv_lid:conv_lab i, patt p) + | p -> error (loc_of_patt p) "invalid pattern" ]; + + value rec expr_fa al = + fun + [ ExApp _ f a -> expr_fa [a :: al] f + | f -> (f, al) ] + ; + + value rec class_expr_fa al = + fun + [ CeApp _ ce a -> class_expr_fa [a :: al] ce + | ce -> (ce, al) ] + ; + + + value rec sep_expr_acc l = + fun + [ ExAcc _ e1 e2 -> sep_expr_acc (sep_expr_acc l e2) e1 + | <:expr@loc< $uid:s$ >> as e -> + match l with + [ [] -> [(loc, [], e)] + | [(loc', sl, e) :: l] -> [(Loc.merge loc loc', [s :: sl], e) :: l] ] + | <:expr< $id:(<:ident< $_$.$_$ >> as i)$ >> -> + let rec normalize_acc = + fun + [ <:ident@_loc< $i1$.$i2$ >> -> + <:expr< $normalize_acc i1$.$normalize_acc i2$ >> + | <:ident@_loc< $i1$ $i2$ >> -> + <:expr< $normalize_acc i1$ $normalize_acc i2$ >> + | <:ident@_loc< $anti:_$ >> | <:ident@_loc< $uid:_$ >> | + <:ident@_loc< $lid:_$ >> as i -> <:expr< $id:i$ >> ] + in sep_expr_acc l (normalize_acc i) + | e -> [(loc_of_expr e, [], e) :: l] ] + ; + + value override_flag loc = + fun [ <:override_flag< ! >> -> Override + | <:override_flag<>> -> Fresh + | _ -> error loc "antiquotation not allowed here" + ]; + + value list_of_opt_ctyp ot acc = + match ot with + [ <:ctyp<>> -> acc + | t -> list_of_ctyp t acc ]; + +value varify_constructors var_names = + let rec loop t = + let desc = + match t.ptyp_desc with + [ + Ptyp_any -> Ptyp_any + | Ptyp_var x -> Ptyp_var x + | Ptyp_arrow label core_type core_type' -> + Ptyp_arrow label (loop core_type) (loop core_type') + | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) + | Ptyp_constr ({ txt = Lident s }) [] + when List.exists (fun x -> s = x.txt) var_names -> + Ptyp_var ("&" ^ s) + | Ptyp_constr longident lst -> + Ptyp_constr longident (List.map loop lst) + | Ptyp_object (lst, o) -> + Ptyp_object (List.map loop_object_field lst, o) + | Ptyp_class longident lst -> + Ptyp_class (longident, List.map loop lst) + | Ptyp_alias core_type string -> + Ptyp_alias(loop core_type, string) + | Ptyp_variant row_field_list flag lbl_lst_option -> + Ptyp_variant(List.map loop_row_field row_field_list, flag, lbl_lst_option) + | Ptyp_poly string_lst core_type -> + Ptyp_poly(string_lst, loop core_type) + | Ptyp_package longident lst -> + Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) + | Ptyp_extension x -> + Ptyp_extension x +] + in + {(t) with ptyp_desc = desc} + and loop_object_field x = + match x with + [ Otag s a t -> Otag s a (loop t) + | Oinherit t -> Oinherit (loop t) ] + and loop_row_field x = + match x with + [ Rtag(label,attrs,flag,lst) -> + Rtag(label,attrs,flag,List.map loop lst) + | Rinherit t -> + Rinherit (loop t) ] + in + loop; + + + + value rec expr = + fun + [ <:expr@loc< $x$.val >> -> + mkexp loc + (Pexp_apply (mkexp loc (Pexp_ident (lident_with_loc "!" loc))) + [(Nolabel, 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] -> + (mkexp loc (Pexp_construct (mkli loc (conv_con s) ml) None), l) + | [(loc, ml, <:expr< $lid:s$ >>) :: l] -> + (mkexp loc (Pexp_ident (mkli loc 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 + [ <:expr@sloc< $lid:s$ >> -> + let loc = Loc.merge loc_bp loc_ep + 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 + e + | ExAnt loc _ -> error loc "antiquotation not allowed here" + | ExApp loc _ _ as f -> + let (f, al) = expr_fa [] f in + let al = List.map label_expr al in + match (expr f).pexp_desc with + [ Pexp_construct li None -> + let al = List.map snd al in + let a = + match al with + [ [a] -> a + | _ -> mkexp loc (Pexp_tuple al) ] + in + mkexp loc (Pexp_construct li (Some a)) + | Pexp_variant s None -> + let al = List.map snd al in + let a = + match al with + [ [a] -> a + | _ -> mkexp loc (Pexp_tuple al) ] + in mkexp loc (Pexp_variant s (Some a)) + | _ -> mkexp loc (Pexp_apply (expr f) al) ] + | ExAre loc e1 e2 -> + mkexp loc + (Pexp_apply (mkexp loc (Pexp_ident (array_function loc "Array" "get"))) + [(Nolabel, expr e1); (Nolabel, expr e2)]) + | ExArr loc e -> mkexp loc (Pexp_array (List.map expr (list_of_expr e []))) + | ExAsf loc -> + mkexp loc (Pexp_assert (mkexp loc (Pexp_construct {txt=Lident "false"; loc=mkloc loc} None))) + | ExAss loc e v -> + let e = + match e with + [ <:expr@loc< $x$.val >> -> + Pexp_apply (mkexp loc (Pexp_ident (lident_with_loc ":=" loc))) + [(Nolabel, expr x); (Nolabel, 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 loc e1 e2 -> + Pexp_apply (mkexp loc (Pexp_ident (array_function loc "Array" "set"))) + [(Nolabel, expr e1); (Nolabel, expr e2); (Nolabel, expr v)] + | <: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 loc "String" "set"))) + [(Nolabel, expr e1); (Nolabel, expr e2); (Nolabel, expr v)] + | _ -> error loc "bad left part of assignment" ] + in + mkexp loc e + | ExAsr loc e -> mkexp loc (Pexp_assert (expr e)) + | ExChr loc s -> + mkexp loc (Pexp_constant (Pconst_char (char_of_char_token loc s))) + | ExCoe loc e t1 t2 -> + let t1 = + match t1 with + [ <:ctyp<>> -> None + | t -> Some (ctyp t) ] in + mkexp loc (Pexp_coerce (expr e) t1 (ctyp t2)) + | ExFlo loc s -> mkexp loc (Pexp_constant (Pconst_float (remove_underscores s, None))) + | ExFor loc p e1 e2 df el -> + let e3 = ExSeq loc el in + mkexp loc (Pexp_for (patt p) (expr e1) (expr e2) (mkdirection df) (expr e3)) + | <:expr@loc< fun [ $PaLab _ lab po$ when $w$ -> $e$ ] >> -> + mkfun loc (Labelled lab) None (patt_of_lab loc lab po) e w + | <:expr@loc< fun [ $PaOlbi _ lab p e1$ when $w$ -> $e2$ ] >> -> + let lab = paolab lab p in + mkfun loc (Optional lab) (Some (expr e1)) (patt p) e2 w + | <:expr@loc< fun [ $PaOlb _ lab p$ when $w$ -> $e$ ] >> -> + let lab = paolab lab p in + mkfun loc (Optional lab) None (patt_of_lab loc lab p) e w + | ExFun loc a -> mkexp loc (Pexp_function (match_case a [])) + | ExIfe loc e1 e2 e3 -> + mkexp loc (Pexp_ifthenelse (expr e1) (expr e2) (Some (expr e3))) + | ExInt loc s -> mkexp loc (Pexp_constant (Pconst_integer (s, None))) + | ExInt32 loc s -> mkexp loc (Pexp_constant (Pconst_integer (s, Some 'l'))) + | ExInt64 loc s -> mkexp loc (Pexp_constant (Pconst_integer (s, Some 'L'))) + | ExNativeInt loc s -> mkexp loc (Pexp_constant (Pconst_integer (s, Some 'n'))) + | ExLab loc _ _ -> error loc "labeled expression not allowed here" + | ExLaz loc e -> mkexp loc (Pexp_lazy (expr e)) + | ExLet loc rf bi e -> + let e = expr e in + match binding bi [] with + [ [] -> e + | bi -> mkexp loc (Pexp_let (mkrf rf) bi 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 -> + let p = + match po with + [ <:patt<>> -> <:patt@loc< _ >> + | p -> p ] + in + let cil = class_str_item cfl [] in + mkexp loc (Pexp_object { pcstr_self = 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 -> + match lel with + [ <:rec_binding<>> -> error loc "empty record" + | _ -> + let eo = + match eo with + [ <:expr<>> -> None + | e -> Some (expr e) ] in + mkexp loc (Pexp_record (mklabexp lel []) eo) ] + | ExSeq _loc e -> + let rec loop = + fun + [ [] -> expr <:expr< () >> + | [e] -> expr e + | [e :: el] -> + let _loc = Loc.merge (loc_of_expr e) _loc in + mkexp _loc (Pexp_sequence (expr e) (loop el)) ] + in + loop (list_of_expr e []) + | ExSnd loc e s -> mkexp loc (Pexp_send (expr e) (with_loc s loc)) + | ExSte loc e1 e2 -> + mkexp loc + (Pexp_apply (mkexp loc (Pexp_ident (array_function loc "String" "get"))) + [(Nolabel, expr e1); (Nolabel, expr e2)]) + | ExStr loc s -> + mkexp loc (Pexp_constant (Pconst_string (string_of_string_token loc s) None)) + | ExTry loc e a -> mkexp loc (Pexp_try (expr e) (match_case a [])) + | <:expr@loc< ($e1$, $e2$) >> -> + mkexp loc (Pexp_tuple (List.map expr (list_of_expr e1 (list_of_expr e2 [])))) + | <:expr@loc< ($tup:_$) >> -> error loc "singleton tuple" + | ExTyc loc e t -> mkexp loc (Pexp_constraint (expr e) (ctyp t)) + | <:expr@loc< () >> -> + mkexp loc (Pexp_construct (lident_with_loc "()" loc) None) + | <:expr@loc< $lid:s$ >> -> + mkexp loc (Pexp_ident (lident_with_loc s loc)) + | <:expr@loc< $uid:s$ >> -> + mkexp loc (Pexp_construct (lident_with_loc (conv_con s) loc) None) + | ExVrn loc s -> mkexp loc (Pexp_variant (conv_con s) None) + | ExWhi loc e1 el -> + let e2 = ExSeq loc el in + mkexp loc (Pexp_while (expr e1) (expr e2)) + | ExOpI loc i ov e -> + let fresh = override_flag loc ov in + mkexp loc (Pexp_open fresh (long_uident i) (expr e)) + | <:expr@loc< (module $me$ : $pt$) >> -> + mkexp loc (Pexp_constraint (mkexp loc (Pexp_pack (module_expr me)), + mktyp loc (Ptyp_package (package_type pt)))) + | <:expr@loc< (module $me$) >> -> + mkexp loc (Pexp_pack (module_expr me)) + | ExFUN loc i e -> + mkexp loc (Pexp_newtype (with_loc i loc) (expr e)) + | <:expr@loc< $_$,$_$ >> -> error loc "expr, expr: not allowed here" + | <:expr@loc< $_$;$_$ >> -> + error loc "expr; expr: not allowed here, use do {...} or [|...|] to surround them" + | ExAtt loc s str e -> + let e = expr e in + {(e) with pexp_attributes = e.pexp_attributes @ [attribute loc s str]} + | ExId _ _ | ExNil _ as e -> error (loc_of_expr e) "invalid expr" ] + and patt_of_lab _loc lab = + fun + [ <:patt<>> -> patt <:patt< $lid:lab$ >> + | p -> patt p ] + and expr_of_lab _loc lab = + fun + [ <:expr<>> -> expr <:expr< $lid:lab$ >> + | e -> expr e ] + and label_expr = + fun + [ ExLab loc lab eo -> (Labelled lab, expr_of_lab loc lab eo) + | ExOlb loc lab eo -> (Optional lab, expr_of_lab loc lab eo) + | e -> (Nolabel, expr e) ] + and binding x acc = + match x with + [ <:binding< $x$ and $y$ >> -> + binding x (binding y acc) + | <: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@loc< $lid:x$ >> -> [with_loc x loc] + | <: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 -> + { loc = x.loc; txt = "&" ^ x.txt}) vars in + let ty' = varify_constructors vars (ctyp ty) in + let mkexp = mkexp _loc in + let mkpat = mkpat _loc in + let e = mkexp (Pexp_constraint (expr e) (ctyp ty)) in + let rec mk_newtypes x = + match x with + [ [newtype :: []] -> mkexp (Pexp_newtype(newtype, e)) + | [newtype :: newtypes] -> + mkexp(Pexp_newtype (newtype,mk_newtypes newtypes)) + | [] -> assert False] + in + let pat = + mkpat (Ppat_constraint (mkpat (Ppat_var (with_loc bind_name sloc)), + mktyp _loc (Ptyp_poly ampersand_vars ty'))) + in + let e = mk_newtypes vars in + [{pvb_pat=pat; pvb_expr=e; pvb_attributes=[]; pvb_loc = mkloc _loc} :: acc] + | <:binding@_loc< $p$ = ($e$ : ! $vs$ . $ty$) >> -> + [{pvb_pat=patt <:patt< ($p$ : ! $vs$ . $ty$ ) >>; + pvb_expr=expr e; + pvb_attributes=[]; + pvb_loc=mkloc _loc} :: acc] + | <:binding@_loc< $p$ = $e$ >> -> [{pvb_pat=patt p; pvb_expr=expr e; pvb_attributes=[]; + pvb_loc=mkloc _loc} :: acc] + | <:binding<>> -> acc + | _ -> assert False ] + and match_case x acc = + match x with + [ <:match_case< $x$ | $y$ >> -> match_case x (match_case y acc) + | <:match_case< $pat:p$ when $w$ -> $e$ >> -> + [when_expr (patt p) e w :: acc] + | <:match_case<>> -> acc + | _ -> assert False ] + and when_expr p e w = + let g = match w with + [ <:expr<>> -> None + | g -> Some (expr g) ] + in + {pc_lhs = p; pc_guard = g; pc_rhs = expr e} + and mkfun loc lab def p e w = + let () = + match w with + [ <:expr<>> -> () + | _ -> assert False ] + in + mkexp loc (Pexp_fun lab def p (expr e)) + and mklabexp x acc = + match x with + [ <:rec_binding< $x$; $y$ >> -> + mklabexp x (mklabexp y acc) + | <:rec_binding< $i$ = $e$ >> -> [(ident ~conv_lid:conv_lab i, expr e) :: acc] + | _ -> assert False ] + and mkideexp x acc = + match x with + [ <:rec_binding<>> -> acc + | <:rec_binding< $x$; $y$ >> -> + mkideexp x (mkideexp y acc) + | <:rec_binding< $id:( <:ident@sloc< $lid:s$ >>)$ = $e$ >> -> [(with_loc s sloc, expr e) :: acc] + | _ -> assert False ] + and mktype_decl_or_ext x acc = + match x with + [ <:ctyp< $x$ and $y$ >> -> + mktype_decl_or_ext x (mktype_decl_or_ext y acc) + | Ast.TyDcl cloc c tl td cl -> + let cl = + List.map + (fun (t1, t2) -> + let loc = Loc.merge (loc_of_ctyp t1) (loc_of_ctyp t2) in + (ctyp t1, ctyp t2, mkloc loc)) + cl + in + let td = + type_decl (with_loc c cloc) (List.fold_right optional_type_parameters tl []) + cl td cloc + in + match acc with + [ `Unknown -> `Dcl [td] + | `Dcl acc -> `Dcl [td :: acc] + | `Ext _ -> + error cloc "cannot mix type declaration and extension" ] + | Ast.TyExt cloc c tl td -> + match acc with + [ `Unknown -> + `Ext(type_ext (long_type_ident c) + (List.fold_right optional_type_parameters tl []) td cloc) + | `Dcl _ -> + error cloc "cannot mix type declaration and extension" + | `Ext _ -> + error cloc "only one type extension allowed" ] + | _ -> 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)) + | Ast.MtFun(loc, "*", Ast.MtNil _, mt) -> + mkmty loc (Pmty_functor (with_loc "*" loc) None (module_type mt)) + | <:module_type@loc< functor ($n$ : $nt$) -> $mt$ >> -> + mkmty loc (Pmty_functor (with_loc n loc) (Some (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 [])) + | <:module_type@loc< $mt$ with $wc$ >> -> + mkmty loc (Pmty_with (module_type mt) (mkwithc wc [])) + | <:module_type@loc< module type of $me$ >> -> + mkmty loc (Pmty_typeof (module_expr me)) + | MtAtt loc s str e -> + let e = module_type e in + {(e) with pmty_attributes = e.pmty_attributes @ [attribute loc s str]} + | Ast.MtAlias(loc, id) -> + mkmty loc (Pmty_alias (long_uident id)) + | <:module_type< $anti:_$ >> -> assert False ] + and sig_item s l = + match s with + [ <:sig_item<>> -> l + | SgCls loc cd -> + [mksig loc (Psig_class + (List.map class_info_class_type (list_of_class_type cd []))) :: l] + | SgClt loc ctd -> + [mksig loc (Psig_class_type + (List.map class_info_class_type (list_of_class_type ctd []))) :: l] + | <:sig_item< $sg1$; $sg2$ >> -> sig_item sg1 (sig_item sg2 l) + | SgDir _ _ _ -> l + | <:sig_item@loc< exception $uid:s$ >> -> + [mksig loc (Psig_exception { pext_name = with_loc (conv_con s) loc + ; pext_kind = Pext_decl (Pcstr_tuple [], None) + ; pext_attributes = [] + ; pext_loc = mkloc loc }) + :: l] + | <:sig_item@loc< exception $uid:s$ of $t$ >> -> + [mksig loc (Psig_exception { pext_name = with_loc (conv_con s) loc + ; pext_kind = Pext_decl (Pcstr_tuple (List.map ctyp (list_of_ctyp t [])), None) + ; pext_attributes = [] + ; pext_loc = mkloc loc }) + :: l] + | SgExc _ _ -> assert False (*FIXME*) + | SgExt loc n t sl -> [mksig loc (Psig_value (mkvalue_desc loc (with_loc n loc) t (list_of_meta_list sl))) :: l] + | SgInc loc mt -> [mksig loc (Psig_include {pincl_mod=module_type mt; + pincl_attributes=[]; + pincl_loc = mkloc loc}) :: l] + | SgMod loc n mt -> [mksig loc (Psig_module {pmd_loc=mkloc loc; pmd_name=with_loc n loc; pmd_type=module_type mt; pmd_attributes=[]}) :: l] + | SgRecMod loc mb -> + [mksig loc (Psig_recmodule (module_sig_binding mb [])) :: l] + | SgMty loc n mt -> + let si = + match mt with + [ MtQuo _ _ -> None + | _ -> Some (module_type mt) ] + in + [mksig loc (Psig_modtype {pmtd_loc=mkloc loc; pmtd_name=with_loc n loc; pmtd_type=si; pmtd_attributes=[]}) :: l] + | SgOpn loc ov id -> + let fresh = override_flag loc ov in + [mksig loc (Psig_open {popen_override=fresh; popen_lid=long_uident id; + popen_attributes=[]; popen_loc = mkloc loc}) :: l] + | SgTyp loc rf tdl -> + let rf = mknrf rf in + let ty = + match mktype_decl_or_ext tdl `Unknown with + [ `Unknown -> Psig_type (rf, []) + | `Dcl l -> Psig_type (rf, l) + | `Ext e -> Psig_typext e ] + in + [mksig loc ty :: l] + | SgVal loc n t -> [mksig loc (Psig_value (mkvalue_desc loc (with_loc n 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@loc< $s$ : $mt$ >> -> + [{pmd_loc=mkloc loc; pmd_name=with_loc s loc; pmd_type=module_type mt; pmd_attributes=[]} :: 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@loc< $s$ : $mt$ = $me$ >> -> + [{pmb_loc=mkloc loc; + pmb_name=with_loc s loc; + pmb_expr= + {pmod_loc=Location.none; + pmod_desc=Pmod_constraint(module_expr me,module_type mt); + pmod_attributes=[]; + }; + pmb_attributes=[]} :: acc] + | _ -> assert False ] + and module_expr = + fun + [ <:module_expr@loc<>> -> error loc "nil module expression" + | <:module_expr@loc< $id:i$ >> -> mkmod loc (Pmod_ident (long_uident i)) + | <:module_expr@loc< $me1$ $me2$ >> -> + mkmod loc (Pmod_apply (module_expr me1) (module_expr me2)) + | Ast.MeFun(loc, "*", Ast.MtNil _, me) -> + mkmod loc (Pmod_functor (with_loc "*" loc) None (module_expr me)) + | <:module_expr@loc< functor ($n$ : $mt$) -> $me$ >> -> + mkmod loc (Pmod_functor (with_loc n loc) (Some (module_type mt)) (module_expr me)) + | <:module_expr@loc< struct $sl$ end >> -> + mkmod loc (Pmod_structure (str_item sl [])) + | <:module_expr@loc< ($me$ : $mt$) >> -> + mkmod loc (Pmod_constraint (module_expr me) (module_type mt)) + | <:module_expr@loc< (value $e$ : $pt$) >> -> + mkmod loc (Pmod_unpack ( + mkexp loc (Pexp_constraint (expr e, + mktyp loc (Ptyp_package (package_type pt)))))) + | <:module_expr@loc< (value $e$) >> -> + mkmod loc (Pmod_unpack (expr e)) + | MeAtt loc s str e -> + let e = module_expr e in + {(e) with pmod_attributes = e.pmod_attributes @ [attribute loc s str]} + | <:module_expr@loc< $anti:_$ >> -> error loc "antiquotation in module_expr" ] + and str_item s l = + match s with + [ <:str_item<>> -> l + | StCls loc cd -> + [mkstr loc (Pstr_class + (List.map class_info_class_expr (list_of_class_expr cd []))) :: l] + | StClt loc ctd -> + [mkstr loc (Pstr_class_type + (List.map class_info_class_type (list_of_class_type ctd []))) :: l] + | <:str_item< $st1$; $st2$ >> -> str_item st1 (str_item st2 l) + | StDir _ _ _ -> l + | <:str_item@loc< exception $uid:s$ >> -> + [mkstr loc (Pstr_exception { pext_name = with_loc (conv_con s) loc + ; pext_kind = Pext_decl (Pcstr_tuple [], None) + ; pext_attributes = [] + ; pext_loc = mkloc loc }) + :: l ] + | <:str_item@loc< exception $uid:s$ of $t$ >> -> + [mkstr loc (Pstr_exception { pext_name = with_loc (conv_con s) loc + ; pext_kind = Pext_decl (Pcstr_tuple (List.map ctyp (list_of_ctyp t [])), None) + ; pext_attributes = [] + ; pext_loc = mkloc loc }) + :: l ] + | <:str_item@loc< exception $uid:s$ = $i$ >> -> + [mkstr loc (Pstr_exception { pext_name = with_loc (conv_con s) loc + ; pext_kind = Pext_rebind (long_uident ~conv_con i) + ; pext_attributes = [] + ; pext_loc = mkloc loc }) + :: 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 (mkvalue_desc loc (with_loc n loc) t (list_of_meta_list sl))) :: l] + | StInc loc me -> [mkstr loc (Pstr_include {pincl_mod=module_expr me; + pincl_attributes=[]; + pincl_loc=mkloc loc}) :: l] + | StMod loc n me -> [mkstr loc (Pstr_module {pmb_loc=mkloc loc; pmb_name=with_loc n loc;pmb_expr=module_expr me;pmb_attributes=[]}) :: l] + | StRecMod loc mb -> + [mkstr loc (Pstr_recmodule (module_str_binding mb [])) :: l] + | StMty loc n mt -> + let si = + match mt with + [ MtQuo _ _ -> None + | _ -> Some (module_type mt) ] + in + [mkstr loc (Pstr_modtype {pmtd_loc=mkloc loc; pmtd_name=with_loc n loc; pmtd_type=si; pmtd_attributes=[]}) :: l] + | StOpn loc ov id -> + let fresh = override_flag loc ov in + [mkstr loc (Pstr_open {popen_override=fresh; + popen_lid=long_uident id; + popen_attributes=[]; + popen_loc=mkloc loc}) :: l] + | StTyp loc rf tdl -> + let rf = mknrf rf in + let ty = + match mktype_decl_or_ext tdl `Unknown with + [ `Unknown -> Pstr_type (rf, []) + | `Dcl l -> Pstr_type (rf, l) + | `Ext e -> Pstr_typext e ] + in + [mkstr loc ty :: l] + | StVal loc rf bi -> + [mkstr loc (Pstr_value (mkrf rf) (binding bi [])) :: l] + | <:str_item@loc< $anti:_$ >> -> error loc "antiquotation in str_item" ] + and class_type = + fun + [ CtCon loc ViNil id tl -> + mkcty loc + (Pcty_constr (long_class_ident id) (List.map ctyp (list_of_opt_ctyp tl []))) + | CtFun loc (TyLab _ lab t) ct -> + mkcty loc (Pcty_arrow (Labelled lab) (ctyp t) (class_type ct)) + | CtFun loc (TyOlb _ lab t) ct -> + mkcty loc (Pcty_arrow (Optional lab) (ctyp t) (class_type ct)) + | CtFun loc t ct -> mkcty loc (Pcty_arrow Nolabel (ctyp t) (class_type ct)) + | CtSig loc t_o ctfl -> + let t = + match t_o with + [ <:ctyp<>> -> <:ctyp@loc< _ >> + | t -> t ] + in + let cil = class_sig_item ctfl [] in + mkcty loc (Pcty_signature { + pcsig_self = ctyp t; + pcsig_fields = cil; + }) + | CtAtt loc s str e -> + let e = class_type e in + {(e) with pcty_attributes = e.pcty_attributes @ [attribute loc s str]} + | 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 nloc name) params) ce -> + let params = + match params with + [ <:ctyp<>> -> [] + | t -> class_parameters t [] ] + in + {pci_virt = mkvirtual vir; + pci_params = params; + pci_name = with_loc name nloc; + pci_expr = class_expr ce; + pci_loc = mkloc loc; + pci_attributes = [] + } + | ce -> error (loc_of_class_expr ce) "bad class definition" ] + and class_info_class_type ci = + match ci with + [ CtEq _ (CtCon loc vir (IdLid nloc name) params) ct | + CtCol _ (CtCon loc vir (IdLid nloc name) params) ct -> + let params = + match params with + [ <:ctyp<>> -> [] + | t -> class_parameters t [] ] + in + {pci_virt = mkvirtual vir; + pci_params = params; + pci_name = with_loc name nloc; + pci_expr = class_type ct; + pci_attributes = []; + pci_loc = mkloc loc + } + | ct -> error (loc_of_class_type ct) + "bad class/class type declaration/definition" ] + and class_sig_item c l = + match c with + [ <:class_sig_item<>> -> l + | CgCtr loc t1 t2 -> [mkctf loc (Pctf_constraint (ctyp t1, ctyp t2)) :: l] + | <:class_sig_item< $csg1$; $csg2$ >> -> + class_sig_item csg1 (class_sig_item csg2 l) + | CgInh loc ct -> [mkctf loc (Pctf_inherit (class_type ct)) :: l] + | CgMth loc s pf t -> + [mkctf loc (Pctf_method (with_loc s loc, mkprivate pf, Concrete, mkpolytype (ctyp t))) :: l] + | CgVal loc s b v t -> + [mkctf loc (Pctf_val (with_loc s loc, mkmutable b, mkvirtual v, ctyp t)) :: l] + | CgVir loc s b t -> + [mkctf loc (Pctf_method (with_loc s loc, mkprivate b, Virtual, 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 + mkcl loc (Pcl_apply (class_expr ce) el) + | CeCon loc ViNil id tl -> + mkcl loc + (Pcl_constr (long_class_ident id) (List.map ctyp (list_of_opt_ctyp tl []))) + | CeFun loc (PaLab _ lab po) ce -> + mkcl loc + (Pcl_fun (Labelled lab) None (patt_of_lab loc lab po) (class_expr ce)) + | CeFun loc (PaOlbi _ lab p e) ce -> + let lab = paolab lab p in + mkcl loc (Pcl_fun (Optional lab) (Some (expr e)) (patt p) (class_expr ce)) + | CeFun loc (PaOlb _ lab p) ce -> + let lab = paolab lab p in + mkcl loc + (Pcl_fun (Optional lab) None (patt_of_lab loc lab p) (class_expr ce)) + | CeFun loc p ce -> mkcl loc (Pcl_fun Nolabel None (patt p) (class_expr ce)) + | CeLet loc rf bi ce -> + mkcl loc (Pcl_let (mkrf rf) (binding bi []) (class_expr ce)) + | CeStr loc po cfl -> + let p = + match po with + [ <:patt<>> -> <:patt@loc< _ >> + | p -> p ] + in + let cil = class_str_item cfl [] in + mkcl loc (Pcl_structure { + pcstr_self = patt p; + pcstr_fields = cil; + }) + | CeTyc loc ce ct -> + mkcl loc (Pcl_constraint (class_expr ce) (class_type ct)) + | CeAtt loc s str e -> + let e = class_expr e in + {(e) with pcl_attributes = e.pcl_attributes @ [attribute loc s str]} + | 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 -> [mkcf loc (Pcf_constraint (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 (with_loc pb loc) in + [mkcf loc (Pcf_inherit (override_flag loc ov) (class_expr ce) opb) :: l] + | CrIni loc e -> [mkcf loc (Pcf_initializer (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 + [mkcf loc (Pcf_method (with_loc s loc, mkprivate pf, Cfk_concrete (override_flag loc ov, e))) :: l] + | CrVal loc s ov mf e -> + [mkcf loc (Pcf_val (with_loc s loc, mkmutable mf, Cfk_concrete (override_flag loc ov, expr e))) :: l] + | CrVir loc s pf t -> + [mkcf loc (Pcf_method (with_loc s loc, mkprivate pf, Cfk_virtual (mkpolytype (ctyp t)))) :: l] + | CrVvr loc s mf t -> + [mkcf loc (Pcf_val (with_loc s loc, mkmutable mf, Cfk_virtual (ctyp t))) :: l] + | CrAnt _ _ -> assert False ]; + + value sig_item ast = sig_item ast []; + value str_item ast = str_item ast []; + + value directive_arg = + fun + [ ExStr _ s -> Pdir_string s + | ExInt _ i -> Pdir_int (i, None) + | <:expr< True >> -> Pdir_bool True + | <:expr< False >> -> Pdir_bool False + | <:expr< >> -> Pdir_none + | e -> Pdir_ident (ident_noloc (ident_of_expr e)) ] + ; + + value phrase = + fun + [ StDir _ d arg -> Ptop_dir d (directive_arg arg) + | si -> Ptop_def (str_item si) ] + ; + + value attribute loc s str = + (with_loc s loc, PStr (str_item str)); + + value () = + attribute_fwd.val := attribute; +end; diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli new file mode 100644 index 0000000..0b76efd --- /dev/null +++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli @@ -0,0 +1,32 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2002-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + + + +module Make (Camlp4Ast : Sig.Camlp4Ast) : sig + open Camlp4Ast; + + (** {6 Useful functions} *) + + value sig_item : sig_item -> Parsetree.signature; + value str_item : str_item -> Parsetree.structure; + value phrase : str_item -> Parsetree.toplevel_phrase; + +end; diff --git a/camlp4/Camlp4/Struct/CleanAst.ml b/camlp4/Camlp4/Struct/CleanAst.ml new file mode 100644 index 0000000..6b59d8f --- /dev/null +++ b/camlp4/Camlp4/Struct/CleanAst.ml @@ -0,0 +1,145 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +(** This module is suppose to contain nils elimination. *) +module Make (Ast : Sig.Camlp4Ast) = struct + + class clean_ast = object + + inherit Ast.map as super; + + method with_constr wc = + match super#with_constr wc with + [ <:with_constr< $ <:with_constr<>> $ and $wc$ >> | + <:with_constr< $wc$ and $ <:with_constr<>> $ >> -> wc + | wc -> wc ]; + + method expr e = + match super#expr e with + [ <:expr< let $rec:_$ $ <:binding<>> $ in $e$ >> | + <:expr< { ($e$) with $ <:rec_binding<>> $ } >> | + <:expr< $ <:expr<>> $, $e$ >> | + <:expr< $e$, $ <:expr<>> $ >> | + <:expr< $ <:expr<>> $; $e$ >> | + <:expr< $e$; $ <:expr<>> $ >> -> e + | e -> e ]; + + method patt p = + match super#patt p with + [ <:patt< ( $p$ as $ <:patt<>> $ ) >> | + <:patt< $ <:patt<>> $ | $p$ >> | + <:patt< $p$ | $ <:patt<>> $ >> | + <:patt< $ <:patt<>> $, $p$ >> | + <:patt< $p$, $ <:patt<>> $ >> | + <:patt< $ <:patt<>> $; $p$ >> | + <:patt< $p$; $ <:patt<>> $ >> -> p + | p -> p ]; + + method match_case mc = + match super#match_case mc with + [ <:match_case< $ <:match_case<>> $ | $mc$ >> | + <:match_case< $mc$ | $ <:match_case<>> $ >> -> mc + | mc -> mc ]; + + method binding bi = + match super#binding bi with + [ <:binding< $ <:binding<>> $ and $bi$ >> | + <:binding< $bi$ and $ <:binding<>> $ >> -> bi + | bi -> bi ]; + + method rec_binding rb = + match super#rec_binding rb with + [ <:rec_binding< $ <:rec_binding<>> $ ; $bi$ >> | + <:rec_binding< $bi$ ; $ <:rec_binding<>> $ >> -> bi + | bi -> bi ]; + + method module_binding mb = + match super#module_binding mb with + [ <:module_binding< $ <:module_binding<>> $ and $mb$ >> | + <:module_binding< $mb$ and $ <:module_binding<>> $ >> -> mb + | mb -> mb ]; + + method ctyp t = + match super#ctyp t with + [ <:ctyp< ! $ <:ctyp<>> $ . $t$ >> | + <:ctyp< $ <:ctyp<>> $ as $t$ >> | + <:ctyp< $t$ as $ <:ctyp<>> $ >> | + <:ctyp< $t$ -> $ <:ctyp<>> $ >> | + <:ctyp< $ <:ctyp<>> $ -> $t$ >> | + <:ctyp< $ <:ctyp<>> $ | $t$ >> | + <:ctyp< $t$ | $ <:ctyp<>> $ >> | + <:ctyp< $t$ of $ <:ctyp<>> $ >> | + <:ctyp< $ <:ctyp<>> $ and $t$ >> | + <:ctyp< $t$ and $ <:ctyp<>> $ >> | + <:ctyp< $t$; $ <:ctyp<>> $ >> | + <:ctyp< $ <:ctyp<>> $; $t$ >> | + <:ctyp< $ <:ctyp<>> $, $t$ >> | + <:ctyp< $t$, $ <:ctyp<>> $ >> | + <:ctyp< $t$ & $ <:ctyp<>> $ >> | + <:ctyp< $ <:ctyp<>> $ & $t$ >> | + <:ctyp< $ <:ctyp<>> $ * $t$ >> | + <:ctyp< $t$ * $ <:ctyp<>> $ >> -> t + | t -> t ]; + + method sig_item sg = + match super#sig_item sg with + [ <:sig_item< $ <:sig_item<>> $; $sg$ >> | + <:sig_item< $sg$; $ <:sig_item<>> $ >> -> sg + | Ast.SgTyp (loc, _, Ast.TyNil _) -> <:sig_item@loc<>> + | sg -> sg ]; + + method str_item st = + match super#str_item st with + [ <:str_item< $ <:str_item<>> $; $st$ >> | + <:str_item< $st$; $ <:str_item<>> $ >> -> st + | Ast.StTyp (loc, _, Ast.TyNil _) -> <:str_item@loc<>> + | <:str_item@loc< value $rec:_$ $ <:binding<>> $ >> -> <:str_item@loc<>> + | st -> st ]; + + method module_type mt = + match super#module_type mt with + [ <:module_type< $mt$ with $ <:with_constr<>> $ >> -> mt + | mt -> mt ]; + + method class_expr ce = + match super#class_expr ce with + [ <:class_expr< $ <:class_expr<>> $ and $ce$ >> | + <:class_expr< $ce$ and $ <:class_expr<>> $ >> -> ce + | ce -> ce ]; + + method class_type ct = + match super#class_type ct with + [ <:class_type< $ <:class_type<>> $ and $ct$ >> | + <:class_type< $ct$ and $ <:class_type<>> $ >> -> ct + | ct -> ct ]; + + method class_sig_item csg = + match super#class_sig_item csg with + [ <:class_sig_item< $ <:class_sig_item<>> $; $csg$ >> | + <:class_sig_item< $csg$; $ <:class_sig_item<>> $ >> -> csg + | csg -> csg ]; + + method class_str_item cst = + match super#class_str_item cst with + [ <:class_str_item< $ <:class_str_item<>> $; $cst$ >> | + <:class_str_item< $cst$; $ <:class_str_item<>> $ >> -> cst + | cst -> cst ]; + + end; + +end; diff --git a/camlp4/Camlp4/Struct/CommentFilter.ml b/camlp4/Camlp4/Struct/CommentFilter.ml new file mode 100644 index 0000000..41cd0d9 --- /dev/null +++ b/camlp4/Camlp4/Struct/CommentFilter.ml @@ -0,0 +1,56 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) +module Make (Token : Sig.Camlp4Token) = struct + open Token; + + type t = (Stream.t (string * Loc.t) * Queue.t (string * Loc.t)); + + value mk () = + let q = Queue.create () in + let f _ = + debug comments "take...@\n" in + try Some (Queue.take q) with [ Queue.Empty -> None ] + in (Stream.from f, q); + + value filter (_, q) = + let rec self = + parser + [ [: ` (Sig.COMMENT x, loc); xs :] -> + do { Queue.add (x, loc) q; + debug comments "add: %S at %a@\n" x Loc.dump loc in + self xs } + | [: ` x; xs :] -> + (* debug comments "Found %a at %a@." Token.print x Loc.dump loc in *) + [: ` x; self xs :] + | [: :] -> [: :] ] + in self; + + value take_list (_, q) = + let rec self accu = + if Queue.is_empty q then accu else self [Queue.take q :: accu] + in self []; + + value take_stream = fst; + + value define token_fiter comments_strm = + debug comments "Define a comment filter@\n" in + Token.Filter.define_filter token_fiter + (fun previous strm -> previous (filter comments_strm strm)); + +end; diff --git a/camlp4/Camlp4/Struct/CommentFilter.mli b/camlp4/Camlp4/Struct/CommentFilter.mli new file mode 100644 index 0000000..3ca0814 --- /dev/null +++ b/camlp4/Camlp4/Struct/CommentFilter.mli @@ -0,0 +1,33 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) +module Make (Token : Sig.Camlp4Token) : sig + open Token; + + type t; + + value mk : unit -> t; + + value define : Token.Filter.t -> t -> unit; + + value filter : t -> Stream.t (Token.t * Loc.t) -> Stream.t (Token.t * Loc.t); + + value take_list : t -> list (string * Loc.t); + + value take_stream : t -> Stream.t (string * Loc.t); +end; diff --git a/camlp4/Camlp4/Struct/DynAst.ml b/camlp4/Camlp4/Struct/DynAst.ml new file mode 100644 index 0000000..fbd795f --- /dev/null +++ b/camlp4/Camlp4/Struct/DynAst.ml @@ -0,0 +1,91 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +module Make (Ast : Sig.Ast) : Sig.DynAst with module Ast = Ast = struct + module Ast = Ast; + type tag 'a = + [ Tag_ctyp + | Tag_patt + | Tag_expr + | Tag_module_type + | Tag_sig_item + | Tag_with_constr + | Tag_module_expr + | Tag_str_item + | Tag_class_type + | Tag_class_sig_item + | Tag_class_expr + | Tag_class_str_item + | Tag_match_case + | Tag_ident + | Tag_binding + | Tag_rec_binding + | Tag_module_binding ]; + + value string_of_tag = + fun + [ Tag_ctyp -> "ctyp" + | Tag_patt -> "patt" + | Tag_expr -> "expr" + | Tag_module_type -> "module_type" + | Tag_sig_item -> "sig_item" + | Tag_with_constr -> "with_constr" + | Tag_module_expr -> "module_expr" + | Tag_str_item -> "str_item" + | Tag_class_type -> "class_type" + | Tag_class_sig_item -> "class_sig_item" + | Tag_class_expr -> "class_expr" + | Tag_class_str_item -> "class_str_item" + | Tag_match_case -> "match_case" + | Tag_ident -> "ident" + | Tag_binding -> "binding" + | Tag_rec_binding -> "rec_binding" + | Tag_module_binding -> "module_binding" ]; + + value ctyp_tag = Tag_ctyp; + value patt_tag = Tag_patt; + value expr_tag = Tag_expr; + value module_type_tag = Tag_module_type; + value sig_item_tag = Tag_sig_item; + value with_constr_tag = Tag_with_constr; + value module_expr_tag = Tag_module_expr; + value str_item_tag = Tag_str_item; + value class_type_tag = Tag_class_type; + value class_sig_item_tag = Tag_class_sig_item; + value class_expr_tag = Tag_class_expr; + value class_str_item_tag = Tag_class_str_item; + value match_case_tag = Tag_match_case; + value ident_tag = Tag_ident; + value binding_tag = Tag_binding; + value rec_binding_tag = Tag_rec_binding; + value module_binding_tag = Tag_module_binding; + + type dyn; + external dyn_tag : tag 'a -> tag dyn = "%identity"; + + module Pack(X : sig type t 'a; end) = struct + (* These Obj.* hacks should be avoided with GADTs *) + type pack = (tag dyn * Obj.t); + exception Pack_error; + value pack tag v = (dyn_tag tag, Obj.repr v); + value unpack (tag : tag 'a) (tag', obj) = + if dyn_tag tag = tag' then (Obj.obj obj : X.t 'a) else raise Pack_error; + value print_tag f (tag, _) = Format.pp_print_string f (string_of_tag tag); + end; +end; diff --git a/camlp4/Camlp4/Struct/DynLoader.ml b/camlp4/Camlp4/Struct/DynLoader.ml new file mode 100644 index 0000000..1c9711c --- /dev/null +++ b/camlp4/Camlp4/Struct/DynLoader.ml @@ -0,0 +1,84 @@ +(* camlp4r pa_macro.cmo *) +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2001-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + + + + +type t = Queue.t string; + +exception Error of string and string; + +value include_dir x y = Queue.add y x; + +value fold_load_path x f acc = Queue.fold (fun x y -> f y x) acc x; + +value mk ?(ocaml_stdlib = True) ?(camlp4_stdlib = True) () = + let q = Queue.create () in do { + if ocaml_stdlib then include_dir q Camlp4_config.ocaml_standard_library else (); + if camlp4_stdlib then do { + include_dir q Camlp4_config.camlp4_standard_library; + include_dir q (Filename.concat Camlp4_config.camlp4_standard_library "Camlp4Parsers"); + include_dir q (Filename.concat Camlp4_config.camlp4_standard_library "Camlp4Printers"); + include_dir q (Filename.concat Camlp4_config.camlp4_standard_library "Camlp4Filters"); + } else (); + include_dir q "."; + q +}; + +(* Load files in core *) + +value find_in_path x name = + if not (Filename.is_implicit name) then + if Sys.file_exists name then name else raise Not_found + else + let res = + fold_load_path x + (fun dir -> + fun + [ None -> + let fullname = Filename.concat dir name in + if Sys.file_exists fullname then Some fullname else None + | x -> x ]) None + in match res with [ None -> raise Not_found | Some x -> x ]; + +value load = + let _initialized = ref False in + fun _path file -> + do { + if not _initialized.val then + try do { + Dynlink.init (); + Dynlink.allow_unsafe_modules True; + _initialized.val := True + } + with + [ Dynlink.Error e -> + raise (Error "Camlp4's dynamic loader initialization" (Dynlink.error_message e)) ] + else (); + let fname = + try find_in_path _path file with + [ Not_found -> raise (Error file "file not found in path") ] + in + try Dynlink.loadfile fname with + [ Dynlink.Error e -> raise (Error fname (Dynlink.error_message e)) ] + }; + + +value is_native = Dynlink.is_native; diff --git a/camlp4/Camlp4/Struct/DynLoader.mli b/camlp4/Camlp4/Struct/DynLoader.mli new file mode 100644 index 0000000..87f849b --- /dev/null +++ b/camlp4/Camlp4/Struct/DynLoader.mli @@ -0,0 +1,20 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +include Sig.DynLoader; diff --git a/camlp4/Camlp4/Struct/EmptyError.ml b/camlp4/Camlp4/Struct/EmptyError.ml new file mode 100644 index 0000000..631dff1 --- /dev/null +++ b/camlp4/Camlp4/Struct/EmptyError.ml @@ -0,0 +1,22 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) +type t = unit; +exception E of t; +value print _ = assert False; +value to_string _ = assert False; diff --git a/camlp4/Camlp4/Struct/EmptyError.mli b/camlp4/Camlp4/Struct/EmptyError.mli new file mode 100644 index 0000000..2755086 --- /dev/null +++ b/camlp4/Camlp4/Struct/EmptyError.mli @@ -0,0 +1,19 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) +include Sig.Error; diff --git a/camlp4/Camlp4/Struct/EmptyPrinter.ml b/camlp4/Camlp4/Struct/EmptyPrinter.ml new file mode 100644 index 0000000..c5bec16 --- /dev/null +++ b/camlp4/Camlp4/Struct/EmptyPrinter.ml @@ -0,0 +1,22 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +module Make (Ast : Sig.Ast) = struct + value print_interf ?input_file:(_) ?output_file:(_) _ = failwith "No interface printer"; + value print_implem ?input_file:(_) ?output_file:(_) _ = failwith "No implementation printer"; +end; diff --git a/camlp4/Camlp4/Struct/EmptyPrinter.mli b/camlp4/Camlp4/Struct/EmptyPrinter.mli new file mode 100644 index 0000000..4c8b7b2 --- /dev/null +++ b/camlp4/Camlp4/Struct/EmptyPrinter.mli @@ -0,0 +1,19 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +module Make (Ast : Sig.Ast) : (Sig.Printer Ast).S; diff --git a/camlp4/Camlp4/Struct/FreeVars.ml b/camlp4/Camlp4/Struct/FreeVars.ml new file mode 100644 index 0000000..75f4193 --- /dev/null +++ b/camlp4/Camlp4/Struct/FreeVars.ml @@ -0,0 +1,127 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +module Make (Ast : Sig.Camlp4Ast) = struct + + module S = Set.Make String; + + class c_fold_pattern_vars ['accu] f init = + object + inherit Ast.fold as super; + value acc = init; + method acc : 'accu = acc; + method patt = + fun + [ <:patt< $lid:s$ >> | <:patt< ~ $s$ >> | <:patt< ? $s$ >> -> + {< acc = f s acc >} + | p -> super#patt p ]; + end; + + value fold_pattern_vars f p init = ((new c_fold_pattern_vars f init)#patt p)#acc; + + value rec fold_binding_vars f bi acc = + match bi with + [ <:binding< $bi1$ and $bi2$ >> -> + fold_binding_vars f bi1 (fold_binding_vars f bi2 acc) + | <:binding< $p$ = $_$ >> -> fold_pattern_vars f p acc + | <:binding<>> -> acc + | <:binding< $anti:_$ >> -> assert False ]; + + class fold_free_vars ['accu] (f : string -> 'accu -> 'accu) ?(env_init = S.empty) free_init = + object (o) + inherit Ast.fold as super; + value free : 'accu = free_init; + value env : S.t = env_init; + + method free = free; + method set_env env = {< env = env >}; + method add_atom s = {< env = S.add s env >}; + method add_patt p = {< env = fold_pattern_vars S.add p env >}; + method add_binding bi = {< env = fold_binding_vars S.add bi env >}; + + method expr = + fun + [ <:expr< $lid:s$ >> | <:expr< ~ $s$ >> | <:expr< ? $s$ >> -> + if S.mem s env then o else {< free = f s free >} + + | <:expr< let $bi$ in $e$ >> -> + (((o#add_binding bi)#expr e)#set_env env)#binding bi + + | <:expr< let rec $bi$ in $e$ >> -> + (((o#add_binding bi)#expr e)#binding bi)#set_env env + + | <:expr< for $p$ = $e1$ $to:_$ $e2$ do { $e3$ } >> -> + ((((o#expr e1)#expr e2)#patt p)#expr e3)#set_env env + + | <:expr< $id:_$ >> | <:expr< new $_$ >> -> o + + | <:expr< object ($p$) $cst$ end >> -> + ((o#add_patt p)#class_str_item cst)#set_env env + + | e -> super#expr e ]; + + method match_case = + fun + [ <:match_case< $p$ when $e1$ -> $e2$ >> -> + (((o#add_patt p)#expr e1)#expr e2)#set_env env + | m -> super#match_case m ]; + + method str_item = + fun + [ <:str_item< external $s$ : $t$ = $_$ >> -> + (o#ctyp t)#add_atom s + | <:str_item< value $bi$ >> -> + (o#binding bi)#add_binding bi + | <:str_item< value rec $bi$ >> -> + (o#add_binding bi)#binding bi + | st -> super#str_item st ]; + + method class_expr = + fun + [ <:class_expr< fun $p$ -> $ce$ >> -> + ((o#add_patt p)#class_expr ce)#set_env env + | <:class_expr< let $bi$ in $ce$ >> -> + (((o#binding bi)#add_binding bi)#class_expr ce)#set_env env + | <:class_expr< let rec $bi$ in $ce$ >> -> + (((o#add_binding bi)#binding bi)#class_expr ce)#set_env env + | <:class_expr< object ($p$) $cst$ end >> -> + ((o#add_patt p)#class_str_item cst)#set_env env + | ce -> super#class_expr ce ]; + + method class_str_item = + fun + [ <:class_str_item< inherit $override:_$ $_$ >> as cst -> super#class_str_item cst + | <:class_str_item< inherit $override:_$ $ce$ as $s$ >> -> + (o#class_expr ce)#add_atom s + | <:class_str_item< value $override:_$ $mutable:_$ $s$ = $e$ >> -> + (o#expr e)#add_atom s + | <:class_str_item< value virtual $mutable:_$ $s$ : $t$ >> -> + (o#ctyp t)#add_atom s + | cst -> super#class_str_item cst ]; + + method module_expr = fun + [ <:module_expr< struct $st$ end >> -> + (o#str_item st)#set_env env + | me -> super#module_expr me ]; + + end; + + value free_vars env_init e = + let fold = new fold_free_vars S.add ~env_init S.empty in (fold#expr e)#free; +end; diff --git a/camlp4/Camlp4/Struct/FreeVars.mli b/camlp4/Camlp4/Struct/FreeVars.mli new file mode 100644 index 0000000..c9362c8 --- /dev/null +++ b/camlp4/Camlp4/Struct/FreeVars.mli @@ -0,0 +1,48 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +module Make (Ast : Sig.Camlp4Ast) : sig + module S : Set.S with type elt = string; + + value fold_binding_vars : (string -> 'accu -> 'accu) -> Ast.binding -> 'accu -> 'accu; + + class c_fold_pattern_vars ['accu] : [string -> 'accu -> 'accu] -> ['accu] -> + object + inherit Ast.fold; + value acc : 'accu; + method acc : 'accu; + end; + + value fold_pattern_vars : (string -> 'accu -> 'accu) -> Ast.patt -> 'accu -> 'accu; + + class fold_free_vars ['accu] : [string -> 'accu -> 'accu] -> [?env_init:S.t] -> ['accu] -> + object ('self_type) + inherit Ast.fold; + value free : 'accu; + value env : S.t; + method free : 'accu; + method set_env : S.t -> 'self_type; + method add_atom : string -> 'self_type; + method add_patt : Ast.patt -> 'self_type; + method add_binding : Ast.binding -> 'self_type; + end; + + value free_vars : S.t -> Ast.expr -> S.t; + +end; diff --git a/camlp4/Camlp4/Struct/Grammar.mlpack b/camlp4/Camlp4/Struct/Grammar.mlpack new file mode 100644 index 0000000..46fb34f --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar.mlpack @@ -0,0 +1,13 @@ +Delete +Dynamic +Entry +Failed +Find +Fold +Insert +Parser +Print +Search +Static +Structure +Tools diff --git a/camlp4/Camlp4/Struct/Grammar/Delete.ml b/camlp4/Camlp4/Struct/Grammar/Delete.ml new file mode 100644 index 0000000..48bda4f --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Delete.ml @@ -0,0 +1,187 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +exception Rule_not_found of (string * string); + +let () = + Printexc.register_printer + (fun + [ Rule_not_found (symbols, entry) -> + let msg = Printf.sprintf "rule %S cannot be found in entry\n%s" symbols entry in + Some msg + | _ -> None ]) in () +; + +module Make (Structure : Structure.S) = struct + module Tools = Tools.Make Structure; + module Parser = Parser.Make Structure; + module Print = Print.Make Structure; + open Structure; + +value raise_rule_not_found entry symbols = + let to_string f x = + let buff = Buffer.create 128 in + let ppf = Format.formatter_of_buffer buff in + do { + f ppf x; + Format.pp_print_flush ppf (); + Buffer.contents buff + } in + let entry = to_string Print.entry entry in + let symbols = to_string Print.print_rule symbols in + raise (Rule_not_found (symbols, entry)) +; + +(* Deleting a rule *) + +(* [delete_rule_in_tree] returns + [Some (dsl, t)] if success + [dsl] = + Some (list of deleted nodes) if branch deleted + None if action replaced by previous version of action + [t] = remaining tree + [None] if failure *) + +value delete_rule_in_tree entry = + let rec delete_in_tree symbols tree = + match (symbols, tree) with + [ ([s :: sl], Node n) -> + if Tools.logically_eq_symbols entry s n.node then delete_son sl n + else + match delete_in_tree symbols n.brother with + [ Some (dsl, t) -> + Some (dsl, Node {node = n.node; son = n.son; brother = t}) + | None -> None ] + | ([_ :: _], _) -> None + | ([], Node n) -> + match delete_in_tree [] n.brother with + [ Some (dsl, t) -> + Some (dsl, Node {node = n.node; son = n.son; brother = t}) + | None -> None ] + | ([], DeadEnd) -> None + | ([], LocAct _ []) -> Some (Some [], DeadEnd) + | ([], LocAct _ [action :: list]) -> Some (None, LocAct action list) ] + and delete_son sl n = + match delete_in_tree sl n.son with + [ Some (Some dsl, DeadEnd) -> Some (Some [n.node :: dsl], n.brother) + | Some (Some dsl, t) -> + let t = Node {node = n.node; son = t; brother = n.brother} in + Some (Some [n.node :: dsl], t) + | Some (None, t) -> + let t = Node {node = n.node; son = t; brother = n.brother} in + Some (None, t) + | None -> None ] + in + delete_in_tree +; +value rec decr_keyw_use gram = + fun + [ Skeyword kwd -> removing gram kwd + | Smeta _ sl _ -> List.iter (decr_keyw_use gram) sl + | Slist0 s | Slist1 s | Sopt s | Stry s -> decr_keyw_use gram s + | Slist0sep s1 s2 -> do { decr_keyw_use gram s1; decr_keyw_use gram s2 } + | Slist1sep s1 s2 -> do { decr_keyw_use gram s1; decr_keyw_use gram s2 } + | Stree t -> decr_keyw_use_in_tree gram t + | Sself | Snext | Snterm _ | Snterml _ _ | Stoken _ -> () ] +and decr_keyw_use_in_tree gram = + fun + [ DeadEnd | LocAct _ _ -> () + | Node n -> + do { + decr_keyw_use gram n.node; + decr_keyw_use_in_tree gram n.son; + decr_keyw_use_in_tree gram n.brother + } ] +; +value rec delete_rule_in_suffix entry symbols = + fun + [ [lev :: levs] -> + match delete_rule_in_tree entry symbols lev.lsuffix with + [ Some (dsl, t) -> + do { + match dsl with + [ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl + | None -> () ]; + match t with + [ DeadEnd when lev.lprefix == DeadEnd -> levs + | _ -> + let lev = + {assoc = lev.assoc; lname = lev.lname; lsuffix = t; + lprefix = lev.lprefix} + in + [lev :: levs] ] + } + | None -> + let levs = delete_rule_in_suffix entry symbols levs in + [lev :: levs] ] + | [] -> raise_rule_not_found entry symbols ] +; + +value rec delete_rule_in_prefix entry symbols = + fun + [ [lev :: levs] -> + match delete_rule_in_tree entry symbols lev.lprefix with + [ Some (dsl, t) -> + do { + match dsl with + [ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl + | None -> () ]; + match t with + [ DeadEnd when lev.lsuffix == DeadEnd -> levs + | _ -> + let lev = + {assoc = lev.assoc; lname = lev.lname; + lsuffix = lev.lsuffix; lprefix = t} + in + [lev :: levs] ] + } + | None -> + let levs = delete_rule_in_prefix entry symbols levs in + [lev :: levs] ] + | [] -> raise_rule_not_found entry symbols ] +; + +value rec delete_rule_in_level_list entry symbols levs = + match symbols with + [ [Sself :: symbols] -> delete_rule_in_suffix entry symbols levs + | [Snterm e :: symbols] when e == entry -> + delete_rule_in_suffix entry symbols levs + | _ -> delete_rule_in_prefix entry symbols levs ] +; + + +value delete_rule entry sl = + match entry.edesc with + [ Dlevels levs -> + let levs = delete_rule_in_level_list entry sl levs in + do { + entry.edesc := Dlevels levs; + entry.estart := + fun lev strm -> + let f = Parser.start_parser_of_entry entry in + do { entry.estart := f; f lev strm }; + entry.econtinue := + fun lev bp a strm -> + let f = Parser.continue_parser_of_entry entry in + do { entry.econtinue := f; f lev bp a strm } + } + | Dparser _ -> () ] +; + +end; diff --git a/camlp4/Camlp4/Struct/Grammar/Dynamic.ml b/camlp4/Camlp4/Struct/Grammar/Dynamic.ml new file mode 100644 index 0000000..b337a75 --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Dynamic.ml @@ -0,0 +1,73 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) +module Make (Lexer : Sig.Lexer) +: Sig.Grammar.Dynamic with module Loc = Lexer.Loc + and module Token = Lexer.Token += struct + module Structure = Structure.Make Lexer; + module Delete = Delete.Make Structure; + module Insert = Insert.Make Structure; + module Entry = Entry.Make Structure; + module Fold = Fold.Make Structure; + module Tools = Tools.Make Structure; + include Structure; + + value mk () = + let gkeywords = Hashtbl.create 301 in + { + gkeywords = gkeywords; + gfilter = Token.Filter.mk (Hashtbl.mem gkeywords); + glexer = Lexer.mk (); + warning_verbose = ref True; (* FIXME *) + error_verbose = Camlp4_config.verbose + }; + + value get_filter g = g.gfilter; + + value lex g loc cs = g.glexer loc cs; + + value lex_string g loc str = lex g loc (Stream.of_string str); + + value filter g ts = Tools.keep_prev_loc (Token.Filter.filter g.gfilter ts); + + value parse_tokens_after_filter entry ts = Entry.parse_tokens_after_filter entry ts; + + value parse_tokens_before_filter entry ts = parse_tokens_after_filter entry (filter entry.egram ts); + + value parse entry loc cs = parse_tokens_before_filter entry (lex entry.egram loc cs); + + value parse_string entry loc str = + parse_tokens_before_filter entry (lex_string entry.egram loc str); + + value delete_rule = Delete.delete_rule; + + value srules e rl = + let t = + List.fold_left + (fun tree (symbols, action) -> Insert.insert_tree e symbols action tree) + DeadEnd rl + in + Stree t; + value sfold0 = Fold.sfold0; + value sfold1 = Fold.sfold1; + value sfold0sep = Fold.sfold0sep; + (* value sfold1sep = Fold.sfold1sep; *) + + value extend = Insert.extend; +end; diff --git a/camlp4/Camlp4/Struct/Grammar/Entry.ml b/camlp4/Camlp4/Struct/Grammar/Entry.ml new file mode 100644 index 0000000..5d81435 --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Entry.ml @@ -0,0 +1,92 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Make (Structure : Structure.S) = struct + module Dump = Print.MakeDump Structure; + module Print = Print.Make Structure; + module Tools = Tools.Make Structure; + open Format; + open Structure; + open Tools; + + type t 'a = internal_entry; + + value name e = e.ename; + + value print ppf e = fprintf ppf "%a@\n" Print.entry e; + value dump ppf e = fprintf ppf "%a@\n" Dump.entry e; + + (* value find e s = Find.entry e s; *) + + value mk g n = + { egram = g; + ename = n; + estart = empty_entry n; + econtinue _ _ _ = parser []; + edesc = Dlevels [] }; + + value action_parse entry ts : Action.t = + try entry.estart 0 ts with + [ Stream.Failure -> + Loc.raise (get_prev_loc ts) + (Stream.Error ("illegal begin of " ^ entry.ename)) + | Loc.Exc_located _ _ as exc -> raise exc + | exc -> Loc.raise (get_prev_loc ts) exc ]; + + value lex entry loc cs = entry.egram.glexer loc cs; + + value lex_string entry loc str = lex entry loc (Stream.of_string str); + + value filter entry ts = + keep_prev_loc (Token.Filter.filter (get_filter entry.egram) ts); + + value parse_tokens_after_filter entry ts = Action.get (action_parse entry ts); + + value parse_tokens_before_filter entry ts = parse_tokens_after_filter entry (filter entry ts); + + value parse entry loc cs = parse_tokens_before_filter entry (lex entry loc cs); + + value parse_string entry loc str = + parse_tokens_before_filter entry (lex_string entry loc str); + + value of_parser g n (p : Stream.t (Token.t * token_info) -> 'a) : t 'a = + let f ts = Action.mk (p ts) in + { egram = g; + ename = n; + estart _ = f; + econtinue _ _ _ = parser []; + edesc = Dparser f }; + + value setup_parser e (p : Stream.t (Token.t * token_info) -> 'a) = + let f ts = Action.mk (p ts) in do { + e.estart := fun _ -> f; + e.econtinue := fun _ _ _ -> parser []; + e.edesc := Dparser f + }; + + value clear e = + do { + e.estart := fun _ -> parser []; + e.econtinue := fun _ _ _ -> parser []; + e.edesc := Dlevels [] + }; + + value obj x = x; + +end; diff --git a/camlp4/Camlp4/Struct/Grammar/Failed.ml b/camlp4/Camlp4/Struct/Grammar/Failed.ml new file mode 100644 index 0000000..31b42d3 --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Failed.ml @@ -0,0 +1,132 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Make (Structure : Structure.S) = struct + module Tools = Tools.Make Structure; + module Search = Search.Make Structure; + module Print = Print.Make Structure; + open Structure; + open Format; + +value rec name_of_symbol entry = + fun + [ Snterm e -> "[" ^ e.ename ^ "]" + | Snterml e l -> "[" ^ e.ename ^ " level " ^ l ^ "]" + | Sself | Snext -> "[" ^ entry.ename ^ "]" + | Stoken (_, descr) -> descr + | Skeyword kwd -> "\"" ^ kwd ^ "\"" + | _ -> "???" ] +; + + +value rec name_of_symbol_failed entry = + fun + [ Slist0 s | Slist0sep s _ | + Slist1 s | Slist1sep s _ | + Sopt s | Stry s -> name_of_symbol_failed entry s + | Stree t -> name_of_tree_failed entry t + | s -> name_of_symbol entry s ] +and name_of_tree_failed entry = + fun + [ Node {node = s; brother = bro; son = son} -> + let tokl = + match s with + [ Stoken _ | Skeyword _ -> Tools.get_token_list entry [] s son + | _ -> None ] + in + match tokl with + [ None -> + let txt = name_of_symbol_failed entry s in + let txt = + match (s, son) with + [ (Sopt _, Node _) -> txt ^ " or " ^ name_of_tree_failed entry son + | _ -> txt ] + in + let txt = + match bro with + [ DeadEnd | LocAct _ _ -> txt + | Node _ -> txt ^ " or " ^ name_of_tree_failed entry bro ] + in + txt + | Some (tokl, _, _) -> + List.fold_left + (fun s tok -> + (if s = "" then "" else s ^ " then ") ^ + match tok with + [ Stoken (_, descr) -> descr + | Skeyword kwd -> kwd + | _ -> assert False ]) + "" tokl ] + | DeadEnd | LocAct _ _ -> "???" ] +; +value magic _s x = debug magic "Obj.magic: %s@." _s in Obj.magic x; +value tree_failed entry prev_symb_result prev_symb tree = + let txt = name_of_tree_failed entry tree in + let txt = + match prev_symb with + [ Slist0 s -> + let txt1 = name_of_symbol_failed entry s in + txt1 ^ " or " ^ txt ^ " expected" + | Slist1 s -> + let txt1 = name_of_symbol_failed entry s in + txt1 ^ " or " ^ txt ^ " expected" + | Slist0sep s sep -> + match magic "tree_failed: 'a -> list 'b" prev_symb_result with + [ [] -> + let txt1 = name_of_symbol_failed entry s in + txt1 ^ " or " ^ txt ^ " expected" + | _ -> + let txt1 = name_of_symbol_failed entry sep in + txt1 ^ " or " ^ txt ^ " expected" ] + | Slist1sep s sep -> + match magic "tree_failed: 'a -> list 'b" prev_symb_result with + [ [] -> + let txt1 = name_of_symbol_failed entry s in + txt1 ^ " or " ^ txt ^ " expected" + | _ -> + let txt1 = name_of_symbol_failed entry sep in + txt1 ^ " or " ^ txt ^ " expected" ] + | Stry _(*NP: not sure about this*) | Sopt _ | Stree _ -> txt ^ " expected" + | _ -> txt ^ " expected after " ^ name_of_symbol entry prev_symb ] + in + do { + if entry.egram.error_verbose.val then do { + let tree = Search.tree_in_entry prev_symb tree entry.edesc; + let ppf = err_formatter; + fprintf ppf "@[@,"; + fprintf ppf "----------------------------------@,"; + fprintf ppf "Parse error in entry [%s], rule:@;<0 2>" entry.ename; + fprintf ppf "@["; + Print.print_level ppf pp_force_newline (Print.flatten_tree tree); + fprintf ppf "@]@,"; + fprintf ppf "----------------------------------@,"; + fprintf ppf "@]@." + } + else (); + txt ^ " (in [" ^ entry.ename ^ "])" + } +; +value symb_failed entry prev_symb_result prev_symb symb = + let tree = Node {node = symb; brother = DeadEnd; son = DeadEnd} in + tree_failed entry prev_symb_result prev_symb tree +; + +value symb_failed_txt e s1 s2 = symb_failed e 0 s1 s2; + +end; diff --git a/camlp4/Camlp4/Struct/Grammar/Find.ml b/camlp4/Camlp4/Struct/Grammar/Find.ml new file mode 100644 index 0000000..5d1c366 --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Find.ml @@ -0,0 +1,68 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) +(* + value entry e s = + let rec find_levels = + fun + [ [] -> None + | [lev :: levs] -> + match find_tree lev.lsuffix with + [ None -> + match find_tree lev.lprefix with + [ None -> find_levels levs + | x -> x ] + | x -> x ] ] + and symbol = + fun + [ Snterm e -> if e.ename = s then Some e else None + | Snterml e _ -> if e.ename = s then Some e else None + | Smeta _ sl _ -> find_symbol_list sl + | Slist0 s -> find_symbol s + | Slist0sep s _ -> find_symbol s + | Slist1 s -> find_symbol s + | Slist1sep s _ -> find_symbol s + | Sopt s -> find_symbol s + | Stree t -> find_tree t + | Sself | Snext | Stoken _ | Stoken_fun _ -> None ] + and symbol_list = + fun + [ [s :: sl] -> + match find_symbol s with + [ None -> find_symbol_list sl + | x -> x ] + | [] -> None ] + and tree = + fun + [ Node {node = s; brother = bro; son = son} -> + match find_symbol s with + [ None -> + match find_tree bro with + [ None -> find_tree son + | x -> x ] + | x -> x ] + | LocAct _ _ | DeadEnd -> None ] + in + match e.edesc with + [ Dlevels levs -> + match find_levels levs with + [ Some e -> e + | None -> raise Not_found ] + | Dparser _ -> raise Not_found ] + ; +*) diff --git a/camlp4/Camlp4/Struct/Grammar/Fold.ml b/camlp4/Camlp4/Struct/Grammar/Fold.ml new file mode 100644 index 0000000..19c358a --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Fold.ml @@ -0,0 +1,95 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + + + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) +module Make (Structure : Structure.S) = struct + open Structure; + open Format; + module Parse = Parser.Make Structure; + module Fail = Failed.Make Structure; + open Sig.Grammar; + + (* Prevent from implict usage. *) + module Stream = struct + type t 'a = Stream.t 'a; + exception Failure = Stream.Failure; + exception Error = Stream.Error; + end; + + value sfold0 f e _entry _symbl psymb = + let rec fold accu = + parser + [ [: a = psymb; s :] -> fold (f a accu) s + | [: :] -> accu ] + in + parser [: a = fold e :] -> a + ; + + value sfold1 f e _entry _symbl psymb = + let rec fold accu = + parser + [ [: a = psymb; s :] -> fold (f a accu) s + | [: :] -> accu ] + in + parser [: a = psymb; a = fold (f a e) :] -> a + ; + + value sfold0sep f e entry symbl psymb psep = + let failed = + fun + [ [symb; sep] -> Fail.symb_failed_txt entry sep symb + | _ -> "failed" ] + in + let rec kont accu = + parser + [ [: () = psep; a = psymb ?? failed symbl; s :] -> kont (f a accu) s + | [: :] -> accu ] + in + parser + [ [: a = psymb; s :] -> kont (f a e) s + | [: :] -> e ] + ; + + value sfold1sep f e entry symbl psymb psep = + let failed = + fun + [ [symb; sep] -> Fail.symb_failed_txt entry sep symb + | _ -> "failed" ] + in + let parse_top = + fun + [ [symb; _] -> Parse.parse_top_symb entry symb (* FIXME context *) + | _ -> raise Stream.Failure ] + in + let rec kont accu = + parser + [ [: () = psep; + a = + parser + [ [: a = psymb :] -> a + | [: a = parse_top symbl :] -> Obj.magic a + | [: :] -> raise (Stream.Error (failed symbl)) ]; + s :] -> + kont (f a accu) s + | [: :] -> accu ] + in + parser [: a = psymb; s :] -> kont (f a e) s + ; +end; diff --git a/camlp4/Camlp4/Struct/Grammar/Fold.mli b/camlp4/Camlp4/Struct/Grammar/Fold.mli new file mode 100644 index 0000000..7fa0699 --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Fold.mli @@ -0,0 +1,30 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + + + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Make (Structure : Structure.S) : sig + open Structure; + + value sfold0 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; + value sfold1 : ('a -> 'b -> 'b) -> 'b -> fold _ 'a 'b; + value sfold0sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; + (* value sfold1sep : ('a -> 'b -> 'b) -> 'b -> foldsep _ 'a 'b; *) +end; diff --git a/camlp4/Camlp4/Struct/Grammar/Insert.ml b/camlp4/Camlp4/Struct/Grammar/Insert.ml new file mode 100644 index 0000000..5757cfb --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Insert.ml @@ -0,0 +1,323 @@ +(* -*- camlp4r -*- *) +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Make (Structure : Structure.S) = struct + module Tools = Tools.Make Structure; + module Parser = Parser.Make Structure; + open Structure; + open Format; + open Sig.Grammar; + + value is_before s1 s2 = + match (s1, s2) with + [ (Skeyword _ | Stoken _, Skeyword _ | Stoken _) -> False + | (Skeyword _ | Stoken _, _) -> True + | _ -> False ] + ; + value rec derive_eps = + fun + [ Slist0 _ | Slist0sep _ _ | Sopt _ -> True + | Stry s -> derive_eps s + | Stree t -> tree_derive_eps t + | Slist1 _ | Slist1sep _ _ | Stoken _ | Skeyword _ -> + (* For sure we cannot derive epsilon from these *) + False + | Smeta _ _ _ | Snterm _ | Snterml _ _ | Snext | Sself -> + (* Approximation *) + False ] + and tree_derive_eps = + fun + [ LocAct _ _ -> True + | Node {node = s; brother = bro; son = son} -> + derive_eps s && tree_derive_eps son || tree_derive_eps bro + | DeadEnd -> False ] + ; + + value empty_lev lname assoc = + let assoc = + match assoc with + [ Some a -> a + | None -> LeftA ] + in + {assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd} + ; + value change_lev entry lev n lname assoc = + let a = + match assoc with + [ None -> lev.assoc + | Some a -> + do { + if a <> lev.assoc && entry.egram.warning_verbose.val then do { + eprintf " Changing associativity of level \"%s\"\n" n; + flush Pervasives.stderr + } + else (); + a + } ] + in + do { + match lname with + [ Some n -> + if lname <> lev.lname && entry.egram.warning_verbose.val then do { + eprintf " Level label \"%s\" ignored\n" n; flush Pervasives.stderr + } + else () + | None -> () ]; + {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; + lprefix = lev.lprefix} + } + ; + value change_to_self entry = + fun + [ Snterm e when e == entry -> Sself + | x -> x ] + ; + + + value get_level entry position levs = + match position with + [ Some First -> ([], empty_lev, levs) + | Some Last -> (levs, empty_lev, []) + | Some (Level n) -> + let rec get = + fun + [ [] -> + do { + eprintf "No level labelled \"%s\" in entry \"%s\"\n" n + entry.ename; + flush Pervasives.stderr; + failwith "Grammar.extend" + } + | [lev :: levs] -> + if Tools.is_level_labelled n lev then ([], change_lev entry lev n, levs) + else + let (levs1, rlev, levs2) = get levs in + ([lev :: levs1], rlev, levs2) ] + in + get levs + | Some (Before n) -> + let rec get = + fun + [ [] -> + do { + eprintf "No level labelled \"%s\" in entry \"%s\"\n" n + entry.ename; + flush Pervasives.stderr; + failwith "Grammar.extend" + } + | [lev :: levs] -> + if Tools.is_level_labelled n lev then ([], empty_lev, [lev :: levs]) + else + let (levs1, rlev, levs2) = get levs in + ([lev :: levs1], rlev, levs2) ] + in + get levs + | Some (After n) -> + let rec get = + fun + [ [] -> + do { + eprintf "No level labelled \"%s\" in entry \"%s\"\n" n + entry.ename; + flush Pervasives.stderr; + failwith "Grammar.extend" + } + | [lev :: levs] -> + if Tools.is_level_labelled n lev then ([lev], empty_lev, levs) + else + let (levs1, rlev, levs2) = get levs in + ([lev :: levs1], rlev, levs2) ] + in + get levs + | None -> + match levs with + [ [lev :: levs] -> ([], change_lev entry lev "", levs) + | [] -> ([], empty_lev, []) ] ] + ; + + value rec check_gram entry = + fun + [ Snterm e -> + if e.egram != entry.egram then do { + eprintf "\ + Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" + entry.ename e.ename; + flush Pervasives.stderr; + failwith "Grammar.extend error" + } + else () + | Snterml e _ -> + if e.egram != entry.egram then do { + eprintf "\ + Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" + entry.ename e.ename; + flush Pervasives.stderr; + failwith "Grammar.extend error" + } + else () + | Smeta _ sl _ -> List.iter (check_gram entry) sl + | Slist0sep s t -> do { check_gram entry t; check_gram entry s } + | Slist1sep s t -> do { check_gram entry t; check_gram entry s } + | Slist0 s | Slist1 s | Sopt s | Stry s -> check_gram entry s + | Stree t -> tree_check_gram entry t + | Snext | Sself | Stoken _ | Skeyword _ -> () ] + and tree_check_gram entry = + fun + [ Node {node = n; brother = bro; son = son} -> + do { + check_gram entry n; + tree_check_gram entry bro; + tree_check_gram entry son + } + | LocAct _ _ | DeadEnd -> () ] + ; + value get_initial = + fun + [ [Sself :: symbols] -> (True, symbols) + | symbols -> (False, symbols) ] + ; + + + value insert_tokens gram symbols = + let rec insert = + fun + [ Smeta _ sl _ -> List.iter insert sl + | Slist0 s | Slist1 s | Sopt s | Stry s -> insert s + | Slist0sep s t -> do { insert s; insert t } + | Slist1sep s t -> do { insert s; insert t } + | Stree t -> tinsert t + | Skeyword kwd -> using gram kwd + | Snterm _ | Snterml _ _ | Snext | Sself | Stoken _ -> () ] + and tinsert = + fun + [ Node {node = s; brother = bro; son = son} -> + do { insert s; tinsert bro; tinsert son } + | LocAct _ _ | DeadEnd -> () ] + in + List.iter insert symbols + ; + + value insert_tree entry gsymbols action tree = + let rec insert symbols tree = + match symbols with + [ [s :: sl] -> insert_in_tree s sl tree + | [] -> + match tree with + [ Node {node = s; son = son; brother = bro} -> + Node {node = s; son = son; brother = insert [] bro} + | LocAct old_action action_list -> + let () = + if entry.egram.warning_verbose.val then + eprintf " Grammar extension: in [%s] some rule has been masked@." + entry.ename + else () + in LocAct action [old_action :: action_list] + | DeadEnd -> LocAct action [] ] ] + and insert_in_tree s sl tree = + match try_insert s sl tree with + [ Some t -> t + | None -> Node {node = s; son = insert sl DeadEnd; brother = tree} ] + and try_insert s sl tree = + match tree with + [ Node {node = s1; son = son; brother = bro} -> + if Tools.eq_symbol s s1 then + let t = Node {node = s1; son = insert sl son; brother = bro} in + Some t + else if is_before s1 s || derive_eps s && not (derive_eps s1) then + let bro = + match try_insert s sl bro with + [ Some bro -> bro + | None -> + Node {node = s; son = insert sl DeadEnd; brother = bro} ] + in + let t = Node {node = s1; son = son; brother = bro} in + Some t + else + match try_insert s sl bro with + [ Some bro -> + let t = Node {node = s1; son = son; brother = bro} in + Some t + | None -> None ] + | LocAct _ _ | DeadEnd -> None ] + in + insert gsymbols tree + ; + value insert_level entry e1 symbols action slev = + match e1 with + [ True -> + {assoc = slev.assoc; lname = slev.lname; + lsuffix = insert_tree entry symbols action slev.lsuffix; + lprefix = slev.lprefix} + | False -> + {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix; + lprefix = insert_tree entry symbols action slev.lprefix} ] + ; + + value levels_of_rules entry position rules = + let elev = + match entry.edesc with + [ Dlevels elev -> elev + | Dparser _ -> + do { + eprintf "Error: entry not extensible: \"%s\"\n" entry.ename; + flush Pervasives.stderr; + failwith "Grammar.extend" + } ] + in + if rules = [] then elev + else + let (levs1, make_lev, levs2) = get_level entry position elev in + let (levs, _) = + List.fold_left + (fun (levs, make_lev) (lname, assoc, level) -> + let lev = make_lev lname assoc in + let lev = + List.fold_left + (fun lev (symbols, action) -> + let symbols = List.map (change_to_self entry) symbols in + do { + List.iter (check_gram entry) symbols; + let (e1, symbols) = get_initial symbols; + insert_tokens entry.egram symbols; + insert_level entry e1 symbols action lev + }) + lev level + in + ([lev :: levs], empty_lev)) + ([], make_lev) rules + in + levs1 @ List.rev levs @ levs2 + ; + + value extend entry (position, rules) = + let elev = levels_of_rules entry position rules in + do { + entry.edesc := Dlevels elev; + entry.estart := + fun lev strm -> + let f = Parser.start_parser_of_entry entry in + do { entry.estart := f; f lev strm }; + entry.econtinue := + fun lev bp a strm -> + let f = Parser.continue_parser_of_entry entry in + do { entry.econtinue := f; f lev bp a strm } + }; + + end; diff --git a/camlp4/Camlp4/Struct/Grammar/Parser.ml b/camlp4/Camlp4/Struct/Grammar/Parser.ml new file mode 100644 index 0000000..3aece5c --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Parser.ml @@ -0,0 +1,431 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Make (Structure : Structure.S) = struct + module Tools = Tools.Make Structure; + module Failed = Failed.Make Structure; + module Print = Print.Make Structure; + open Structure; + open Sig.Grammar; + + module StreamOrig = Stream; + + value njunk strm n = + for i = 1 to n do Stream.junk strm done; + + value loc_bp = Tools.get_cur_loc; + value loc_ep = Tools.get_prev_loc; + value drop_prev_loc = Tools.drop_prev_loc; + + value add_loc bp parse_fun strm = + let x = parse_fun strm in + let ep = loc_ep strm in + let loc = + 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); + + value stream_peek_nth strm n = + let rec loop i = fun + [ [x :: xs] -> if i = 1 then Some x else loop (i - 1) xs + | [] -> None ] + in + loop n (Stream.npeek n strm); + + (* We don't want Stream's functions to be used implictly. *) + module Stream = struct + type t 'a = StreamOrig.t 'a; + exception Failure = StreamOrig.Failure; + exception Error = StreamOrig.Error; + value peek = StreamOrig.peek; + value junk = StreamOrig.junk; + + value dup strm = + (* This version of peek_nth is off-by-one from Stream.peek_nth *) + let peek_nth n = + loop n (Stream.npeek (n + 1) strm) where rec loop n = + fun + [ [] -> None + | [x] -> if n = 0 then Some x else None + | [_ :: l] -> loop (n - 1) l ] + in + Stream.from peek_nth; + end; + + value try_parser ps strm = + let strm' = Stream.dup strm in + let r = + try ps strm' + with + [ Stream.Error _ | Loc.Exc_located _ (Stream.Error _) -> + raise Stream.Failure + | exc -> raise exc ] + in do { + njunk strm (StreamOrig.count strm'); + r; + }; + + value level_number entry lab = + let rec lookup levn = + fun + [ [] -> failwith ("unknown level " ^ lab) + | [lev :: levs] -> + if Tools.is_level_labelled lab lev then levn else lookup (succ levn) levs ] + in + match entry.edesc with + [ Dlevels elev -> lookup 0 elev + | Dparser _ -> raise Not_found ] + ; + value strict_parsing = ref False; + value strict_parsing_warning = ref False; + + value rec top_symb entry = + fun + [ Sself | Snext -> Snterm entry + | Snterml e _ -> Snterm e + | Slist1sep s sep -> Slist1sep (top_symb entry s) sep + | _ -> raise Stream.Failure ] + ; + + value top_tree entry = + fun + [ Node {node = s; brother = bro; son = son} -> + Node {node = top_symb entry s; brother = bro; son = son} + | LocAct _ _ | DeadEnd -> raise Stream.Failure ] + ; + + value entry_of_symb entry = + fun + [ Sself | Snext -> entry + | Snterm e -> e + | Snterml e _ -> e + | _ -> raise Stream.Failure ] + ; + + value continue entry loc a s son p1 = + parser + [: a = (entry_of_symb entry s).econtinue 0 loc a; + act = p1 ?? Failed.tree_failed entry a s son :] -> + Action.mk (fun _ -> Action.getf act a) + ; + + (* PR#4603, PR#4330, PR#4551: + Here loc_bp replaced get_loc_ep to fix all these bugs. + If you do change it again look at these bugs. *) + value skip_if_empty bp strm = + if loc_bp strm = bp then Action.mk (fun _ -> raise Stream.Failure) + else + raise Stream.Failure + ; + + value do_recover parser_of_tree entry nlevn alevn loc a s son = + parser + [ [: a = parser_of_tree entry nlevn alevn (top_tree entry son) :] -> a + | [: a = skip_if_empty loc :] -> a + | [: a = + continue entry loc a s son + (parser_of_tree entry nlevn alevn son) :] -> + a ] + ; + + + value recover parser_of_tree entry nlevn alevn loc a s son strm = + if strict_parsing.val then raise (Stream.Error (Failed.tree_failed entry a s son)) + else + let _ = + if strict_parsing_warning.val then begin + let msg = Failed.tree_failed entry a s son; + Format.eprintf "Warning: trying to recover from syntax error"; + if entry.ename <> "" then Format.eprintf " in [%s]" entry.ename else (); + Format.eprintf "\n%s%a@." msg Loc.print loc; + end else () in + do_recover parser_of_tree entry nlevn alevn loc a s son strm + ; + + value rec parser_of_tree entry nlevn alevn = + fun + [ DeadEnd -> parser [] + | LocAct act _ -> parser [: :] -> act + | Node {node = Sself; son = LocAct act _; brother = DeadEnd} -> + parser [: a = entry.estart alevn :] -> Action.getf act a + | Node {node = Sself; son = LocAct act _; brother = bro} -> + let p2 = parser_of_tree entry nlevn alevn bro in + parser + [ [: a = entry.estart alevn :] -> Action.getf act a + | [: a = p2 :] -> a ] + | Node {node = s; son = son; brother = DeadEnd} -> + let tokl = + match s with + [ Stoken _ | Skeyword _ -> Tools.get_token_list entry [] s son + | _ -> None ] + in + match tokl with + [ None -> + let ps = parser_of_symbol entry nlevn s in + let p1 = parser_of_tree entry nlevn alevn son in + let p1 = parser_cont p1 entry nlevn alevn s son in + fun strm -> + let bp = loc_bp strm in + match strm with parser + [: a = ps; act = p1 bp a :] -> Action.getf act a + | Some (tokl, last_tok, son) -> + let p1 = parser_of_tree entry nlevn alevn son in + let p1 = parser_cont p1 entry nlevn alevn last_tok son in + parser_of_token_list p1 tokl ] + | Node {node = s; son = son; brother = bro} -> + let tokl = + match s with + [ Stoken _ | Skeyword _ -> Tools.get_token_list entry [] s son + | _ -> None ] + in + match tokl with + [ None -> + let ps = parser_of_symbol entry nlevn s in + let p1 = parser_of_tree entry nlevn alevn son in + let p1 = parser_cont p1 entry nlevn alevn s son in + let p2 = parser_of_tree entry nlevn alevn bro in + fun strm -> + let bp = loc_bp strm in + match strm with parser + [ [: a = ps; act = p1 bp a :] -> Action.getf act a + | [: a = p2 :] -> a ] + | Some (tokl, last_tok, son) -> + let p1 = parser_of_tree entry nlevn alevn son in + let p1 = parser_cont p1 entry nlevn alevn last_tok son in + let p1 = parser_of_token_list p1 tokl in + let p2 = parser_of_tree entry nlevn alevn bro in + parser + [ [: a = p1 :] -> a + | [: a = p2 :] -> a ] ] ] + and parser_cont p1 entry nlevn alevn s son loc a = + parser + [ [: a = p1 :] -> a + | [: a = recover parser_of_tree entry nlevn alevn loc a s son :] -> a + | [: :] -> raise (Stream.Error (Failed.tree_failed entry a s son)) ] + and parser_of_token_list p1 tokl = + loop 1 tokl where rec loop n = + fun + [ [Stoken (tematch, _) :: tokl] -> + match tokl with + [ [] -> + let ps strm = + match stream_peek_nth strm n with + [ Some (tok, _) when tematch tok -> (njunk strm n; Action.mk tok) + | _ -> raise Stream.Failure ] + in + fun strm -> + let bp = loc_bp strm in + match strm with parser + [: a = ps; act = p1 bp a :] -> Action.getf act a + | _ -> + let ps strm = + match stream_peek_nth strm n with + [ Some (tok, _) when tematch tok -> tok + | _ -> raise Stream.Failure ] + in + let p1 = loop (n + 1) tokl in + parser [: tok = ps; s :] -> + let act = p1 s in Action.getf act tok ] + | [Skeyword kwd :: tokl] -> + match tokl with + [ [] -> + let ps strm = + match stream_peek_nth strm n with + [ Some (tok, _) when Token.match_keyword kwd tok -> + (njunk strm n; Action.mk tok) + | _ -> raise Stream.Failure ] + in + fun strm -> + let bp = loc_bp strm in + match strm with parser + [: a = ps; act = p1 bp a :] -> Action.getf act a + | _ -> + let ps strm = + match stream_peek_nth strm n with + [ Some (tok, _) when Token.match_keyword kwd tok -> tok + | _ -> raise Stream.Failure ] + in + let p1 = loop (n + 1) tokl in + parser [: tok = ps; s :] -> + let act = p1 s in Action.getf act tok ] + | _ -> invalid_arg "parser_of_token_list" ] + and parser_of_symbol entry nlevn = + fun + [ Smeta _ symbl act -> + let act = Obj.magic act entry symbl in + let pl = List.map (parser_of_symbol entry nlevn) symbl in + Obj.magic (List.fold_left (fun act p -> Obj.magic act p) act pl) + | Slist0 s -> + let ps = parser_of_symbol entry nlevn s in + let rec loop al = + parser + [ [: a = ps; s :] -> loop [a :: al] s + | [: :] -> al ] + in + parser [: a = loop [] :] -> Action.mk (List.rev a) + | Slist0sep symb sep -> + let ps = parser_of_symbol entry nlevn symb in + let pt = parser_of_symbol entry nlevn sep in + let rec kont al = + parser + [ [: v = pt; a = ps ?? Failed.symb_failed entry v sep symb; + s :] -> + kont [a :: al] s + | [: :] -> al ] + in + parser + [ [: a = ps; s :] -> Action.mk (List.rev (kont [a] s)) + | [: :] -> Action.mk [] ] + | Slist1 s -> + let ps = parser_of_symbol entry nlevn s in + let rec loop al = + parser + [ [: a = ps; s :] -> loop [a :: al] s + | [: :] -> al ] + in + parser [: a = ps; s :] -> Action.mk (List.rev (loop [a] s)) + | Slist1sep symb sep -> + let ps = parser_of_symbol entry nlevn symb in + let pt = parser_of_symbol entry nlevn sep in + let rec kont al = + parser + [ [: v = pt; + a = + parser + [ [: a = ps :] -> a + | [: a = parse_top_symb entry symb :] -> a + | [: :] -> + raise (Stream.Error (Failed.symb_failed entry v sep symb)) ]; + s :] -> + kont [a :: al] s + | [: :] -> al ] + in + parser [: a = ps; s :] -> Action.mk (List.rev (kont [a] s)) + | Sopt s -> + let ps = parser_of_symbol entry nlevn s in + parser + [ [: a = ps :] -> Action.mk (Some a) + | [: :] -> Action.mk None ] + | Stry s -> + let ps = parser_of_symbol entry nlevn s in + try_parser ps + | Stree t -> + let pt = parser_of_tree entry 1 0 t in + fun strm -> + let bp = loc_bp strm in + match strm with parser + [: (act, loc) = add_loc bp pt :] -> + Action.getf act loc + | Snterm e -> parser [: a = e.estart 0 :] -> a + | Snterml e l -> + parser [: a = e.estart (level_number e l) :] -> a + | Sself -> parser [: a = entry.estart 0 :] -> a + | Snext -> parser [: a = entry.estart nlevn :] -> a + | Skeyword kwd -> + parser + [: `(tok, _) when Token.match_keyword kwd tok :] -> + Action.mk tok + | Stoken (f, _) -> + parser + [: `(tok,_) when f tok :] -> Action.mk tok ] + and parse_top_symb entry symb strm = + parser_of_symbol entry 0 (top_symb entry symb) strm; + + value rec start_parser_of_levels entry clevn = + fun + [ [] -> fun _ -> parser [] + | [lev :: levs] -> + let p1 = start_parser_of_levels entry (succ clevn) levs in + match lev.lprefix with + [ DeadEnd -> p1 + | tree -> + let alevn = + match lev.assoc with + [ LeftA | NonA -> succ clevn + | RightA -> clevn ] + in + let p2 = parser_of_tree entry (succ clevn) alevn tree in + match levs with + [ [] -> + fun levn strm -> + let bp = loc_bp strm in + match strm with parser + [: (act, loc) = add_loc bp p2; strm :] -> + let a = Action.getf act loc in + entry.econtinue levn loc a strm + | _ -> + fun levn strm -> + if levn > clevn then p1 levn strm + else + let bp = loc_bp strm in + match strm with parser + [ [: (act, loc) = add_loc bp p2 :] -> + let a = Action.getf act loc in + entry.econtinue levn loc a strm + | [: act = p1 levn :] -> act ] ] ] ] + ; + + value start_parser_of_entry entry = + debug gram "start_parser_of_entry: @[<2>%a@]@." Print.entry entry in + match entry.edesc with + [ Dlevels [] -> Tools.empty_entry entry.ename + | Dlevels elev -> start_parser_of_levels entry 0 elev + | Dparser p -> fun _ -> p ] + ; + value rec continue_parser_of_levels entry clevn = + fun + [ [] -> fun _ _ _ -> parser [] + | [lev :: levs] -> + let p1 = continue_parser_of_levels entry (succ clevn) levs in + match lev.lsuffix with + [ DeadEnd -> p1 + | tree -> + let alevn = + match lev.assoc with + [ LeftA | NonA -> succ clevn + | RightA -> clevn ] + in + let p2 = parser_of_tree entry (succ clevn) alevn tree in + fun levn bp a strm -> + if levn > clevn then p1 levn bp a strm + else + match strm with parser + [ [: act = p1 levn bp a :] -> act + | [: (act, loc) = add_loc bp p2 :] -> + let a = Action.getf2 act a loc in + entry.econtinue levn loc a strm ] ] ] + ; + + value continue_parser_of_entry entry = + debug gram "continue_parser_of_entry: @[<2>%a@]@." Print.entry entry in + match entry.edesc with + [ Dlevels elev -> + let p = continue_parser_of_levels entry 0 elev in + fun levn bp a -> + parser + [ [: a = p levn bp a :] -> a + | [: :] -> a ] + | Dparser _ -> fun _ _ _ -> parser [] ] + ; + +end; diff --git a/camlp4/Camlp4/Struct/Grammar/Parser.mli b/camlp4/Camlp4/Struct/Grammar/Parser.mli new file mode 100644 index 0000000..fd080af --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Parser.mli @@ -0,0 +1,62 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + + + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Make (Structure : Structure.S) : sig + open Structure; + value add_loc : + Loc.t -> (token_stream -> 'b) -> token_stream -> ('b * Loc.t); + value level_number : internal_entry -> string -> int; + value strict_parsing : ref bool; + value strict_parsing_warning : ref bool; + value top_symb : + internal_entry -> symbol -> symbol; + value top_tree : + internal_entry -> tree -> tree; + value entry_of_symb : + internal_entry -> symbol -> internal_entry; + value continue : + internal_entry -> Loc.t -> Action.t -> symbol -> tree -> efun -> efun; + value do_recover : + (internal_entry -> 'a -> 'b -> tree -> efun) -> internal_entry -> + 'a -> 'b -> Loc.t -> Action.t -> symbol -> tree -> efun; + value recover : + (internal_entry -> 'a -> 'b -> tree -> efun) -> internal_entry -> + 'a -> 'b -> Loc.t -> Action.t -> symbol -> tree -> efun; + value parser_of_tree : + internal_entry -> int -> int -> tree -> efun; + value parser_cont : + efun -> internal_entry -> int -> int -> symbol -> tree -> Loc.t -> Action.t -> efun; + value parser_of_token_list : + (Loc.t -> Action.t -> efun) -> list symbol -> efun; + value parser_of_symbol : + internal_entry -> int -> symbol -> efun; + value parse_top_symb : + internal_entry -> symbol -> efun; + value start_parser_of_levels : + internal_entry -> int -> list level -> int -> efun; + value start_parser_of_entry : + internal_entry -> int -> efun; + value continue_parser_of_levels : + internal_entry -> int -> list level -> int -> Loc.t -> 'a -> efun; + value continue_parser_of_entry : + internal_entry -> int -> Loc.t -> Action.t -> efun; +end; diff --git a/camlp4/Camlp4/Struct/Grammar/Print.ml b/camlp4/Camlp4/Struct/Grammar/Print.ml new file mode 100644 index 0000000..70d70b6 --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Print.ml @@ -0,0 +1,270 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Make (Structure : Structure.S) = struct + open Structure; + open Format; + open Sig.Grammar; + + value rec flatten_tree = + fun + [ DeadEnd -> [] + | LocAct _ _ -> [[]] + | Node {node = n; brother = b; son = s} -> + [ [n :: l] | l <- flatten_tree s ] @ flatten_tree b ]; + + value rec print_symbol ppf = + fun + [ Smeta n sl _ -> print_meta ppf n sl + | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s + | Slist0sep s t -> + fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t + | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s + | Slist1sep s t -> + fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t + | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s + | Stry s -> fprintf ppf "TRY %a" print_symbol1 s + | Snterml e l -> fprintf ppf "%s@ LEVEL@ %S" e.ename l + | Snterm _ | Snext | Sself | Stree _ | Stoken _ | Skeyword _ as s -> + print_symbol1 ppf s ] + and print_meta ppf n sl = + loop 0 sl where rec loop i = + fun + [ [] -> () + | [s :: sl] -> + let j = + try String.index_from n i ' ' with [ Not_found -> String.length n ] + in + do { + fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s; + if sl = [] then () + else do { fprintf ppf " "; loop (min (j + 1) (String.length n)) sl } + } ] + and print_symbol1 ppf = + fun + [ Snterm e -> pp_print_string ppf e.ename + | Sself -> pp_print_string ppf "SELF" + | Snext -> pp_print_string ppf "NEXT" + | Stoken (_, descr) -> pp_print_string ppf descr + | Skeyword s -> fprintf ppf "%S" s + | Stree t -> print_level ppf pp_print_space (flatten_tree t) + | Smeta _ _ _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ | + Slist1sep _ _ | Sopt _ | Stry _ as s -> + fprintf ppf "(%a)" print_symbol s ] + and print_rule ppf symbols = + do { + fprintf ppf "@["; + let _ = + List.fold_left + (fun sep symbol -> + do { + fprintf ppf "%t%a" sep print_symbol symbol; + fun ppf -> fprintf ppf ";@ " + }) + (fun _ -> ()) symbols + in + fprintf ppf "@]" + } + and print_level ppf pp_print_space rules = + do { + fprintf ppf "@[[ "; + let _ = + List.fold_left + (fun sep rule -> + do { + fprintf ppf "%t%a" sep print_rule rule; + fun ppf -> fprintf ppf "%a| " pp_print_space () + }) + (fun _ -> ()) rules + in + fprintf ppf " ]@]" + } + ; + + value levels ppf elev = + let _ = + List.fold_left + (fun sep lev -> + let rules = + [ [Sself :: t] | t <- flatten_tree lev.lsuffix ] @ + flatten_tree lev.lprefix + in + do { + fprintf ppf "%t@[" sep; + match lev.lname with + [ Some n -> fprintf ppf "%S@;<1 2>" n + | None -> () ]; + match lev.assoc with + [ LeftA -> fprintf ppf "LEFTA" + | RightA -> fprintf ppf "RIGHTA" + | NonA -> fprintf ppf "NONA" ]; + fprintf ppf "@]@;<1 2>"; + print_level ppf pp_force_newline rules; + fun ppf -> fprintf ppf "@,| " + }) + (fun _ -> ()) elev + in + (); + + value entry ppf e = + do { + fprintf ppf "@[%s: [ " e.ename; + match e.edesc with + [ Dlevels elev -> levels ppf elev + | Dparser _ -> fprintf ppf "" ]; + fprintf ppf " ]@]" + }; + +end; + +module MakeDump (Structure : Structure.S) = struct + open Structure; + open Format; + open Sig.Grammar; + + type brothers = [ Bro of symbol and list brothers ]; + + value rec print_tree ppf tree = + let rec get_brothers acc = + fun + [ DeadEnd -> List.rev acc + | LocAct _ _ -> List.rev acc + | Node {node = n; brother = b; son = s} -> get_brothers [Bro n (get_brothers [] s) :: acc] b ] + and print_brothers ppf brothers = + if brothers = [] then fprintf ppf "@ []" + else + List.iter (fun [ Bro n xs -> do { + fprintf ppf "@ @[- %a" print_symbol n; + match xs with + [ [] -> () + | [_] -> try print_children ppf (get_children [] xs) + with [ Exit -> fprintf ppf ":%a" print_brothers xs ] + | _ -> fprintf ppf ":%a" print_brothers xs ]; + fprintf ppf "@]"; + }]) brothers + and print_children ppf = List.iter (fprintf ppf ";@ %a" print_symbol) + and get_children acc = + fun + [ [] -> List.rev acc + | [Bro n x] -> get_children [n::acc] x + | _ -> raise Exit ] + in print_brothers ppf (get_brothers [] tree) + and print_symbol ppf = + fun + [ Smeta n sl _ -> print_meta ppf n sl + | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s + | Slist0sep s t -> + fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t + | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s + | Slist1sep s t -> + fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t + | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s + | Stry s -> fprintf ppf "TRY %a" print_symbol1 s + | Snterml e l -> fprintf ppf "%s@ LEVEL@ %S" e.ename l + | Snterm _ | Snext | Sself | Stree _ | Stoken _ | Skeyword _ as s -> + print_symbol1 ppf s ] + and print_meta ppf n sl = + loop 0 sl where rec loop i = + fun + [ [] -> () + | [s :: sl] -> + let j = + try String.index_from n i ' ' with [ Not_found -> String.length n ] + in + do { + fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s; + if sl = [] then () + else do { fprintf ppf " "; loop (min (j + 1) (String.length n)) sl } + } ] + and print_symbol1 ppf = + fun + [ Snterm e -> pp_print_string ppf e.ename + | Sself -> pp_print_string ppf "SELF" + | Snext -> pp_print_string ppf "NEXT" + | Stoken (_, descr) -> pp_print_string ppf descr + | Skeyword s -> fprintf ppf "%S" s + | Stree t -> print_tree ppf t + | Smeta _ _ _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ | + Slist1sep _ _ | Sopt _ | Stry _ as s -> + fprintf ppf "(%a)" print_symbol s ] + and print_rule ppf symbols = + do { + fprintf ppf "@["; + let _ = + List.fold_left + (fun sep symbol -> + do { + fprintf ppf "%t%a" sep print_symbol symbol; + fun ppf -> fprintf ppf ";@ " + }) + (fun _ -> ()) symbols + in + fprintf ppf "@]" + } + and print_level ppf pp_print_space rules = + do { + fprintf ppf "@[[ "; + let _ = + List.fold_left + (fun sep rule -> + do { + fprintf ppf "%t%a" sep print_rule rule; + fun ppf -> fprintf ppf "%a| " pp_print_space () + }) + (fun _ -> ()) rules + in + fprintf ppf " ]@]" + } + ; + + value levels ppf elev = + let _ = + List.fold_left + (fun sep lev -> + do { + fprintf ppf "%t@[" sep; + match lev.lname with + [ Some n -> fprintf ppf "%S@;<1 2>" n + | None -> () ]; + match lev.assoc with + [ LeftA -> fprintf ppf "LEFTA" + | RightA -> fprintf ppf "RIGHTA" + | NonA -> fprintf ppf "NONA" ]; + fprintf ppf "@]@;<1 2>"; + fprintf ppf "@[suffix:@ "; + print_tree ppf lev.lsuffix; + fprintf ppf "@]@ @[prefix:@ "; + print_tree ppf lev.lprefix; + fprintf ppf "@]"; + fun ppf -> fprintf ppf "@,| " + }) + (fun _ -> ()) elev + in + (); + + value entry ppf e = + do { + fprintf ppf "@[%s: [ " e.ename; + match e.edesc with + [ Dlevels elev -> levels ppf elev + | Dparser _ -> fprintf ppf "" ]; + fprintf ppf " ]@]" + }; + +end; diff --git a/camlp4/Camlp4/Struct/Grammar/Print.mli b/camlp4/Camlp4/Struct/Grammar/Print.mli new file mode 100644 index 0000000..8c97e27 --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Print.mli @@ -0,0 +1,47 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Make (Structure : Structure.S) : sig + value flatten_tree : Structure.tree -> list (list Structure.symbol); + value print_symbol : Format.formatter -> Structure.symbol -> unit; + value print_meta : + Format.formatter -> string -> list Structure.symbol -> unit; + value print_symbol1 : Format.formatter -> Structure.symbol -> unit; + value print_rule : Format.formatter -> list Structure.symbol -> unit; + value print_level : + Format.formatter -> + (Format.formatter -> unit -> unit) -> + list (list Structure.symbol) -> unit; + value levels : Format.formatter -> list Structure.level -> unit; + value entry : Format.formatter -> Structure.internal_entry -> unit; +end; + +module MakeDump (Structure : Structure.S) : sig + value print_symbol : Format.formatter -> Structure.symbol -> unit; + value print_meta : + Format.formatter -> string -> list Structure.symbol -> unit; + value print_symbol1 : Format.formatter -> Structure.symbol -> unit; + value print_rule : Format.formatter -> list Structure.symbol -> unit; + value print_level : + Format.formatter -> + (Format.formatter -> unit -> unit) -> + list (list Structure.symbol) -> unit; + value levels : Format.formatter -> list Structure.level -> unit; + value entry : Format.formatter -> Structure.internal_entry -> unit; +end; diff --git a/camlp4/Camlp4/Struct/Grammar/Search.ml b/camlp4/Camlp4/Struct/Grammar/Search.ml new file mode 100644 index 0000000..0546e7f --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Search.ml @@ -0,0 +1,95 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) +module Make (Structure : Structure.S) = struct + open Structure; +value tree_in_entry prev_symb tree = + fun + [ Dlevels levels -> + let rec search_levels = + fun + [ [] -> tree + | [level :: levels] -> + match search_level level with + [ Some tree -> tree + | None -> search_levels levels ] ] + and search_level level = + match search_tree level.lsuffix with + [ Some t -> Some (Node {node = Sself; son = t; brother = DeadEnd}) + | None -> search_tree level.lprefix ] + and search_tree t = + if tree <> DeadEnd && t == tree then Some t + else + match t with + [ Node n -> + match search_symbol n.node with + [ Some symb -> + Some (Node {node = symb; son = n.son; brother = DeadEnd}) + | None -> + match search_tree n.son with + [ Some t -> + Some (Node {node = n.node; son = t; brother = DeadEnd}) + | None -> search_tree n.brother ] ] + | LocAct _ _ | DeadEnd -> None ] + and search_symbol symb = + match symb with + [ Snterm _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ | + Slist1sep _ _ | Sopt _ | Stry _ | Stoken _ | Stree _ | Skeyword _ + when symb == prev_symb -> + Some symb + | Slist0 symb -> + match search_symbol symb with + [ Some symb -> Some (Slist0 symb) + | None -> None ] + | Slist0sep symb sep -> + match search_symbol symb with + [ Some symb -> Some (Slist0sep symb sep) + | None -> + match search_symbol sep with + [ Some sep -> Some (Slist0sep symb sep) + | None -> None ] ] + | Slist1 symb -> + match search_symbol symb with + [ Some symb -> Some (Slist1 symb) + | None -> None ] + | Slist1sep symb sep -> + match search_symbol symb with + [ Some symb -> Some (Slist1sep symb sep) + | None -> + match search_symbol sep with + [ Some sep -> Some (Slist1sep symb sep) + | None -> None ] ] + | Sopt symb -> + match search_symbol symb with + [ Some symb -> Some (Sopt symb) + | None -> None ] + | Stry symb -> + match search_symbol symb with + [ Some symb -> Some (Stry symb) + | None -> None ] + | Stree t -> + match search_tree t with + [ Some t -> Some (Stree t) + | None -> None ] + | _ -> None ] + in + search_levels levels + | Dparser _ -> tree ] +; + +end; diff --git a/camlp4/Camlp4/Struct/Grammar/Static.ml b/camlp4/Camlp4/Struct/Grammar/Static.ml new file mode 100644 index 0000000..c4a072c --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Static.ml @@ -0,0 +1,84 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring +*) + +value uncurry f (x,y) = f x y; +value flip f x y = f y x; + +module Make (Lexer : Sig.Lexer) +: Sig.Grammar.Static with module Loc = Lexer.Loc + and module Token = Lexer.Token += struct + module Structure = Structure.Make Lexer; + module Delete = Delete.Make Structure; + module Insert = Insert.Make Structure; + module Fold = Fold.Make Structure; + module Tools = Tools.Make Structure; + include Structure; + + value gram = + let gkeywords = Hashtbl.create 301 in + { + gkeywords = gkeywords; + gfilter = Token.Filter.mk (Hashtbl.mem gkeywords); + glexer = Lexer.mk (); + warning_verbose = ref True; (* FIXME *) + error_verbose = Camlp4_config.verbose + }; + + module Entry = struct + module E = Entry.Make Structure; + type t 'a = E.t 'a; + value mk = E.mk gram; + value of_parser name strm = E.of_parser gram name strm; + value setup_parser = E.setup_parser; + value name = E.name; + value print = E.print; + value clear = E.clear; + value dump = E.dump; + value obj x = x; + end; + + value get_filter () = gram.gfilter; + + value lex loc cs = gram.glexer loc cs; + + value lex_string loc str = lex loc (Stream.of_string str); + + value filter ts = Tools.keep_prev_loc (Token.Filter.filter gram.gfilter ts); + + value parse_tokens_after_filter entry ts = Entry.E.parse_tokens_after_filter entry ts; + + value parse_tokens_before_filter entry ts = parse_tokens_after_filter entry (filter ts); + + value parse entry loc cs = parse_tokens_before_filter entry (lex loc cs); + + value parse_string entry loc str = parse_tokens_before_filter entry (lex_string loc str); + + value delete_rule = Delete.delete_rule; + + value srules e rl = + Stree (List.fold_left (flip (uncurry (Insert.insert_tree e))) DeadEnd rl); + value sfold0 = Fold.sfold0; + value sfold1 = Fold.sfold1; + value sfold0sep = Fold.sfold0sep; + (* value sfold1sep = Fold.sfold1sep; *) + + value extend = Insert.extend; + +end; diff --git a/camlp4/Camlp4/Struct/Grammar/Structure.ml b/camlp4/Camlp4/Struct/Grammar/Structure.ml new file mode 100644 index 0000000..b17b73d --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Structure.ml @@ -0,0 +1,294 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +open Sig.Grammar; + +module type S = sig + module Loc : Sig.Loc; + module Token : Sig.Token with module Loc = Loc; + module Lexer : Sig.Lexer + with module Loc = Loc + and module Token = Token; + module Action : Sig.Grammar.Action; + + type gram = + { gfilter : Token.Filter.t; + gkeywords : Hashtbl.t string (ref int); + glexer : Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t); + warning_verbose : ref bool; + error_verbose : ref bool }; + + type token_info = { prev_loc : Loc.t + ; cur_loc : Loc.t + ; prev_loc_only : bool + }; + + type token_stream = Stream.t (Token.t * token_info); + + type efun = token_stream -> Action.t; + + type token_pattern = ((Token.t -> bool) * string); + + type internal_entry = + { egram : gram; + ename : string; + estart : mutable int -> efun; + econtinue : mutable int -> Loc.t -> Action.t -> efun; + edesc : mutable desc } + and desc = + [ Dlevels of list level + | Dparser of token_stream -> Action.t ] + and level = + { assoc : assoc ; + lname : option string ; + lsuffix : tree ; + lprefix : tree } + and symbol = + [ Smeta of string and list symbol and Action.t + | Snterm of internal_entry + | Snterml of internal_entry and string + | Slist0 of symbol + | Slist0sep of symbol and symbol + | Slist1 of symbol + | Slist1sep of symbol and symbol + | Sopt of symbol + | Stry of symbol + | Sself + | Snext + | Stoken of token_pattern + | Skeyword of string + | Stree of tree ] + and tree = + [ Node of node + | LocAct of Action.t and list Action.t + | DeadEnd ] + and node = + { node : symbol ; + son : tree ; + brother : tree }; + + type production_rule = (list symbol * Action.t); + type single_extend_statment = + (option string * option assoc * list production_rule); + type extend_statment = + (option position * list single_extend_statment); + type delete_statment = list symbol; + + type fold 'a 'b 'c = + internal_entry -> list symbol -> + (Stream.t 'a -> 'b) -> Stream.t 'a -> 'c; + + type foldsep 'a 'b 'c = + internal_entry -> list symbol -> + (Stream.t 'a -> 'b) -> (Stream.t 'a -> unit) -> Stream.t 'a -> 'c; + + (* Accessors *) + value get_filter : gram -> Token.Filter.t; + + (* Useful functions *) + value using : gram -> string -> unit; + value removing : gram -> string -> unit; +end; + +module Make (Lexer : Sig.Lexer) = struct + module Loc = Lexer.Loc; + module Token = Lexer.Token; + module Action : Sig.Grammar.Action = struct + type t = Obj.t ; + value mk = Obj.repr; + value get = Obj.obj ; + value getf = Obj.obj ; + value getf2 = Obj.obj ; + end; + module Lexer = Lexer; + + type gram = + { gfilter : Token.Filter.t; + gkeywords : Hashtbl.t string (ref int); + glexer : Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t); + warning_verbose : ref bool; + error_verbose : ref bool }; + + type token_info = { prev_loc : Loc.t + ; cur_loc : Loc.t + ; prev_loc_only : bool + }; + + type token_stream = Stream.t (Token.t * token_info); + + type efun = token_stream -> Action.t; + + type token_pattern = ((Token.t -> bool) * string); + + type internal_entry = + { egram : gram; + ename : string; + estart : mutable int -> efun; + econtinue : mutable int -> Loc.t -> Action.t -> efun; + edesc : mutable desc } + and desc = + [ Dlevels of list level + | Dparser of token_stream -> Action.t ] + and level = + { assoc : assoc ; + lname : option string ; + lsuffix : tree ; + lprefix : tree } + and symbol = + [ Smeta of string and list symbol and Action.t + | Snterm of internal_entry + | Snterml of internal_entry and string + | Slist0 of symbol + | Slist0sep of symbol and symbol + | Slist1 of symbol + | Slist1sep of symbol and symbol + | Sopt of symbol + | Stry of symbol + | Sself + | Snext + | Stoken of token_pattern + | Skeyword of string + | Stree of tree ] + and tree = + [ Node of node + | LocAct of Action.t and list Action.t + | DeadEnd ] + and node = + { node : symbol ; + son : tree ; + brother : tree }; + + type production_rule = (list symbol * Action.t); + type single_extend_statment = + (option string * option assoc * list production_rule); + type extend_statment = + (option position * list single_extend_statment); + type delete_statment = list symbol; + + type fold 'a 'b 'c = + internal_entry -> list symbol -> + (Stream.t 'a -> 'b) -> Stream.t 'a -> 'c; + + type foldsep 'a 'b 'c = + internal_entry -> list symbol -> + (Stream.t 'a -> 'b) -> (Stream.t 'a -> unit) -> Stream.t 'a -> 'c; + + value get_filter g = g.gfilter; + value token_location r = r.cur_loc; + + type not_filtered 'a = 'a; + value using { gkeywords = table; gfilter = filter } kwd = + let r = try Hashtbl.find table kwd with + [ Not_found -> + let r = ref 0 in do { Hashtbl.add table kwd r; r } ] + in do { Token.Filter.keyword_added filter kwd (r.val = 0); + incr r }; + + value removing { gkeywords = table; gfilter = filter } kwd = + let r = Hashtbl.find table kwd in + let () = decr r in + if r.val = 0 then do { + Token.Filter.keyword_removed filter kwd; + Hashtbl.remove table kwd + } else (); +end; + +(* +value iter_entry f e = + let treated = ref [] in + let rec do_entry e = + if List.memq e treated.val then () + else do { + treated.val := [e :: treated.val]; + f e; + match e.edesc with + [ Dlevels ll -> List.iter do_level ll + | Dparser _ -> () ] + } + and do_level lev = do { do_tree lev.lsuffix; do_tree lev.lprefix } + and do_tree = + fun + [ Node n -> do_node n + | LocAct _ _ | DeadEnd -> () ] + and do_node n = do { do_symbol n.node; do_tree n.son; do_tree n.brother } + and do_symbol = + fun + [ Smeta _ sl _ -> List.iter do_symbol sl + | Snterm e | Snterml e _ -> do_entry e + | Slist0 s | Slist1 s | Sopt s | Stry s -> do_symbol s + | Slist0sep s1 s2 | Slist1sep s1 s2 -> do { do_symbol s1; do_symbol s2 } + | Stree t -> do_tree t + | Sself | Snext | Stoken _ | Stoken_fun _ -> () ] + in + do_entry e +; + +value fold_entry f e init = + let treated = ref [] in + let rec do_entry accu e = + if List.memq e treated.val then accu + else do { + treated.val := [e :: treated.val]; + let accu = f e accu in + match e.edesc with + [ Dlevels ll -> List.fold_left do_level accu ll + | Dparser _ -> accu ] + } + and do_level accu lev = + let accu = do_tree accu lev.lsuffix in + do_tree accu lev.lprefix + and do_tree accu = + fun + [ Node n -> do_node accu n + | LocAct _ _ | DeadEnd -> accu ] + and do_node accu n = + let accu = do_symbol accu n.node in + let accu = do_tree accu n.son in + do_tree accu n.brother + and do_symbol accu = + fun + [ Smeta _ sl _ -> List.fold_left do_symbol accu sl + | Snterm e | Snterml e _ -> do_entry accu e + | Slist0 s | Slist1 s | Sopt s | Stry s -> do_symbol accu s + | Slist0sep s1 s2 | Slist1sep s1 s2 -> + let accu = do_symbol accu s1 in + do_symbol accu s2 + | Stree t -> do_tree accu t + | Sself | Snext | Stoken _ | Stoken_fun _ -> accu ] + in + do_entry init e +; + +value is_level_labelled n lev = + match lev.lname with + [ Some n1 -> n = n1 + | None -> False ] +; + +value tokens g con = + let list = ref [] in + do { + Hashtbl.iter + (fun (p_con, p_prm) c -> + if p_con = con then list.val := [(p_prm, c.val) :: list.val] else ()) + g.gtokens; + list.val + } +; +*) diff --git a/camlp4/Camlp4/Struct/Grammar/Tools.ml b/camlp4/Camlp4/Struct/Grammar/Tools.ml new file mode 100644 index 0000000..235ccbe --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Tools.ml @@ -0,0 +1,132 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +(* PR#5090: don't do lookahead on get_prev_loc. *) +value get_prev_loc_only = ref False; + +module Make (Structure : Structure.S) = struct + open Structure; + + value empty_entry ename _ = + raise (Stream.Error ("entry [" ^ ename ^ "] is empty")); + + value rec stream_map f = parser + [ [: ` x; strm :] -> [: ` (f x); stream_map f strm :] + | [: :] -> [: :] ]; + + value keep_prev_loc strm = + match Stream.peek strm with + [ None -> [: :] + | Some (tok0,init_loc) -> + let rec go prev_loc strm1 = + if get_prev_loc_only.val then + [: `(tok0, {prev_loc; cur_loc = prev_loc; prev_loc_only = True}); + go prev_loc strm1 :] + else + match strm1 with parser + [ [: `(tok,cur_loc); strm :] -> + [: `(tok, {prev_loc; cur_loc; prev_loc_only = False}); + go cur_loc strm :] + | [: :] -> [: :] ] + in go init_loc strm ]; + + value drop_prev_loc strm = stream_map (fun (tok,r) -> (tok,r.cur_loc)) strm; + + value get_cur_loc strm = + match Stream.peek strm with + [ Some (_,r) -> r.cur_loc + | None -> Loc.ghost ]; + + value get_prev_loc strm = + begin + get_prev_loc_only.val := True; + let result = match Stream.peek strm with + [ Some (_, {prev_loc; prev_loc_only = True}) -> + begin Stream.junk strm; prev_loc end + | Some (_, {prev_loc; prev_loc_only = False}) -> prev_loc + | None -> Loc.ghost ]; + get_prev_loc_only.val := False; + result + end; + + value is_level_labelled n lev = + match lev.lname with + [ Some n1 -> n = n1 + | None -> False ]; + + value warning_verbose = ref True; + + value rec get_token_list entry tokl last_tok tree = + match tree with + [ Node {node = (Stoken _ | Skeyword _ as tok); son = son; brother = DeadEnd} -> + get_token_list entry [last_tok :: tokl] tok son + | _ -> + if tokl = [] then None + else Some (List.rev [last_tok :: tokl], last_tok, tree) ]; + + value is_antiquot s = + let len = String.length s in + len > 1 && s.[0] = '$'; + + value eq_Stoken_ids s1 s2 = + not (is_antiquot s1) && not (is_antiquot s2) && s1 = s2; + + value logically_eq_symbols entry = + let rec eq_symbols s1 s2 = + match (s1, s2) with + [ (Snterm e1, Snterm e2) -> e1.ename = e2.ename + | (Snterm e1, Sself) -> e1.ename = entry.ename + | (Sself, Snterm e2) -> entry.ename = e2.ename + | (Snterml e1 l1, Snterml e2 l2) -> e1.ename = e2.ename && l1 = l2 + | (Slist0 s1, Slist0 s2) | + (Slist1 s1, Slist1 s2) | + (Sopt s1, Sopt s2) | + (Stry s1, Stry s2) -> eq_symbols s1 s2 + | (Slist0sep s1 sep1, Slist0sep s2 sep2) | + (Slist1sep s1 sep1, Slist1sep s2 sep2) -> + eq_symbols s1 s2 && eq_symbols sep1 sep2 + | (Stree t1, Stree t2) -> eq_trees t1 t2 + | (Stoken (_, s1), Stoken (_, s2)) -> eq_Stoken_ids s1 s2 + | _ -> s1 = s2 ] + and eq_trees t1 t2 = + match (t1, t2) with + [ (Node n1, Node n2) -> + eq_symbols n1.node n2.node && eq_trees n1.son n2.son && + eq_trees n1.brother n2.brother + | (LocAct _ _ | DeadEnd, LocAct _ _ | DeadEnd) -> True + | _ -> False ] + in + eq_symbols; + + value rec eq_symbol s1 s2 = + match (s1, s2) with + [ (Snterm e1, Snterm e2) -> e1 == e2 + | (Snterml e1 l1, Snterml e2 l2) -> e1 == e2 && l1 = l2 + | (Slist0 s1, Slist0 s2) | + (Slist1 s1, Slist1 s2) | + (Sopt s1, Sopt s2) | + (Stry s1, Stry s2) -> eq_symbol s1 s2 + | (Slist0sep s1 sep1, Slist0sep s2 sep2) | + (Slist1sep s1 sep1, Slist1sep s2 sep2) -> + eq_symbol s1 s2 && eq_symbol sep1 sep2 + | (Stree _, Stree _) -> False + | (Stoken (_, s1), Stoken (_, s2)) -> eq_Stoken_ids s1 s2 + | _ -> s1 = s2 ] + ; +end; diff --git a/camlp4/Camlp4/Struct/Lexer.mll b/camlp4/Camlp4/Struct/Lexer.mll new file mode 100644 index 0000000..18a9e7e --- /dev/null +++ b/camlp4/Camlp4/Struct/Lexer.mll @@ -0,0 +1,502 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + + + +(* The lexer definition *) + + +{ + +(** A lexical analyzer. *) + +(* FIXME interface module Make (Token : Token) |+ Note that this Token sig is not in Sig +| *) +(* : Sig.Lexer. S with module Loc = Token.Loc and module Token = Token; *) + +(* type context = +{ loc : Loc.t ; + in_comment : bool ; + |+* FIXME When True, all lexers built by [Plexer.make ()] do not lex the + quotation syntax any more. Default is False (quotations are + lexed). +| + quotations : bool }; + +value default_context : context; + +value mk : Loc.t -> Stream.t char -> Stream.t (Token.t * Loc.t); + +value mk' : context -> Stream.t char -> Stream.t (Token.t * Loc.t); *) +(* FIXME Beware the context argument must be given like that: + * mk' { (default_context) with ... = ... } strm + *) + +module TokenEval = Token.Eval +module Make (Token : Sig.Camlp4Token) += struct + module Loc = Token.Loc + module Token = Token + + open Lexing + open Sig + + (* Error report *) + module Error = struct + + type t = + | Illegal_character of char + | Illegal_escape of string + | Unterminated_comment + | Unterminated_string + | Unterminated_quotation + | Unterminated_antiquot + | Unterminated_string_in_comment + | Comment_start + | Comment_not_end + | Literal_overflow of string + | Invalid_literal of string + + exception E of t + + open Format + + let print ppf = + function + | Illegal_character c -> + fprintf ppf "Illegal character (%s)" (Char.escaped c) + | Illegal_escape s -> + fprintf ppf "Illegal backslash escape in string or character (%s)" s + | Unterminated_comment -> + fprintf ppf "Comment not terminated" + | Unterminated_string -> + fprintf ppf "String literal not terminated" + | Unterminated_string_in_comment -> + fprintf ppf "This comment contains an unterminated string literal" + | Unterminated_quotation -> + fprintf ppf "Quotation not terminated" + | Unterminated_antiquot -> + fprintf ppf "Antiquotation not terminated" + | Literal_overflow ty -> + fprintf ppf "Integer literal exceeds the range of representable integers of type %s" ty + | Comment_start -> + fprintf ppf "this is the start of a comment" + | Comment_not_end -> + fprintf ppf "this is not the end of a comment" + | Invalid_literal s -> + fprintf ppf "Invalid literal %s" s + + let to_string x = + let b = Buffer.create 50 in + let () = bprintf b "%a" print x in Buffer.contents b + end;; + + let module M = ErrorHandler.Register(Error) in () + + open Error + + (* To store some context information: + * loc : position of the beginning of a string, quotation and comment + * in_comment: are we in a comment? + * quotations: shall we lex quotation? + * If quotations is false it's a SYMBOL token. + * antiquots : shall we lex antiquotations. + *) + + type context = + { loc : Loc.t ; + in_comment : bool ; + quotations : bool ; + antiquots : bool ; + lexbuf : lexbuf ; + buffer : Buffer.t } + + let default_context lb = + { loc = Loc.ghost ; + in_comment = false ; + quotations = true ; + antiquots = false ; + lexbuf = lb ; + buffer = Buffer.create 256 } + + (* To buffer string literals, quotations and antiquotations *) + + let store c = Buffer.add_string c.buffer (Lexing.lexeme c.lexbuf) + let istore_char c i = Buffer.add_char c.buffer (Lexing.lexeme_char c.lexbuf i) + let buff_contents c = + let contents = Buffer.contents c.buffer in + Buffer.reset c.buffer; contents + + let loc c = Loc.merge c.loc (Loc.of_lexbuf c.lexbuf) + let quotations c = c.quotations + let antiquots c = c.antiquots + let is_in_comment c = c.in_comment + let in_comment c = { (c) with in_comment = true } + let set_start_p c = c.lexbuf.lex_start_p <- Loc.start_pos c.loc + let move_start_p shift c = (* FIXME Please see PR#5820*) + let p = c.lexbuf.lex_start_p in + c.lexbuf.lex_start_p <- { (p) with pos_cnum = p.pos_cnum + shift } + + let update_loc c = { (c) with loc = Loc.of_lexbuf c.lexbuf } + let with_curr_loc f c = f (update_loc c) c.lexbuf + let parse_nested f c = + with_curr_loc f c; + set_start_p c; + buff_contents c + let shift n c = { (c) with loc = Loc.move `both n c.loc } + let store_parse f c = store c ; f c c.lexbuf + let parse f c = f c c.lexbuf + let mk_quotation quotation c name loc shift = + let s = parse_nested quotation (update_loc c) in + let contents = String.sub s 0 (String.length s - 2) in + QUOTATION { q_name = name ; + q_loc = loc ; + q_shift = shift ; + q_contents = contents } + + + (* Update the current location with file name and line number. *) + + let update_loc c file line absolute chars = + let lexbuf = c.lexbuf in + let pos = lexbuf.lex_curr_p in + let new_file = match file with + | None -> pos.pos_fname + | Some s -> s + in + lexbuf.lex_curr_p <- { pos with + pos_fname = new_file; + 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 = + Int32.neg (Int32.of_string ("-" ^ s)) + let cvt_int64_literal s = + Int64.neg (Int64.of_string ("-" ^ s)) + let cvt_nativeint_literal s = + Nativeint.neg (Nativeint.of_string ("-" ^ s)) + + + let err error loc = + raise(Loc.Exc_located(loc, Error.E error)) + + let warn error loc = + Format.eprintf "Warning: %a: %a@." Loc.print loc Error.print error + + } + + let newline = ('\010' | '\013' | "\013\010") + let blank = [' ' '\009' '\012'] + let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] + let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] + let identchar = + ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] + let ident = (lowercase|uppercase) identchar* + let quote_tag = (lowercase|uppercase) (identchar|'.')* + let locname = ident + let not_star_symbolchar = + ['$' '!' '%' '&' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~' '\\'] + let symbolchar = '*' | not_star_symbolchar + let quotchar = + ['!' '%' '&' '+' '-' '.' '/' ':' '=' '?' '@' '^' '|' '~' '\\' '*'] + let hexa_char = ['0'-'9' 'A'-'F' 'a'-'f'] + let decimal_literal = + ['0'-'9'] ['0'-'9' '_']* + let hex_literal = + '0' ['x' 'X'] hexa_char ['0'-'9' 'A'-'F' 'a'-'f' '_']* + let oct_literal = + '0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']* + let bin_literal = + '0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']* + let int_literal = + decimal_literal | hex_literal | oct_literal | bin_literal + let float_literal = + ['0'-'9'] ['0'-'9' '_']* + ('.' ['0'-'9' '_']* )? + (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)? + + (* Delimitors are extended (from 3.09) in a conservative way *) + + (* These chars that can't start an expression or a pattern: *) + let safe_delimchars = ['%' '&' '/' '@' '^'] + + (* These symbols are unsafe since "[<", "[|", etc. exsist. *) + let delimchars = safe_delimchars | ['|' '<' '>' ':' '=' '.'] + + let left_delims = ['(' '[' '{'] + let right_delims = [')' ']' '}'] + + let left_delimitor = + (* At least a safe_delimchars *) + left_delims delimchars* safe_delimchars (delimchars|left_delims)* + + (* A '(' or a new super '(' without "(<" *) + | '(' (['|' ':'] delimchars*)? + (* Old brackets, no new brackets starting with "[|" or "[:" *) + | '[' ['|' ':']? + (* Old "[<","{<" and new ones *) + | ['[' '{'] delimchars* '<' + (* Old brace and new ones *) + | '{' (['|' ':'] delimchars*)? + + let right_delimitor = + (* At least a safe_delimchars *) + (delimchars|right_delims)* safe_delimchars (delimchars|right_delims)* right_delims + (* A ')' or a new super ')' without ">)" *) + | (delimchars* ['|' ':'])? ')' + (* Old brackets, no new brackets ending with "|]" or ":]" *) + | ['|' ':']? ']' + (* Old ">]",">}" and new ones *) + | '>' delimchars* [']' '}'] + (* Old brace and new ones *) + | (delimchars* ['|' ':'])? '}' + + + rule token c = parse + | newline { update_loc c None 1 false 0; NEWLINE } + | blank + as x { BLANKS x } + | "~" (lowercase identchar * as x) ':' { LABEL x } + | "?" (lowercase identchar * as x) ':' { OPTLABEL x } + | lowercase identchar * as x { LIDENT x } + | uppercase identchar * as x { UIDENT x } + | int_literal as i + { try INT(cvt_int_literal i, i) + with Failure _ -> err (Literal_overflow "int") (Loc.of_lexbuf lexbuf) } + | float_literal as f + { try FLOAT(float_of_string f, f) + with Failure _ -> err (Literal_overflow "float") (Loc.of_lexbuf lexbuf) } + | (int_literal as i) "l" + { try INT32(cvt_int32_literal i, i) + with Failure _ -> err (Literal_overflow "int32") (Loc.of_lexbuf lexbuf) } + | (int_literal as i) "L" + { try INT64(cvt_int64_literal i, i) + with Failure _ -> err (Literal_overflow "int64") (Loc.of_lexbuf lexbuf) } + | (int_literal as i) "n" + { try NATIVEINT(cvt_nativeint_literal i, i) + with Failure _ -> err (Literal_overflow "nativeint") (Loc.of_lexbuf lexbuf) } + | (float_literal | int_literal) identchar+ + { err (Invalid_literal (Lexing.lexeme lexbuf)) (Loc.of_lexbuf lexbuf) } + | '"' + { with_curr_loc string c; + let s = buff_contents c in STRING (TokenEval.string s, s) } + | "'" (newline as x) "'" + { update_loc c None 1 false 1; CHAR (TokenEval.char x, x) } + | "'" ( [^ '\\' '\010' '\013'] + | '\\' (['\\' '"' 'n' 't' 'b' 'r' ' ' '\''] + |['0'-'9'] ['0'-'9'] ['0'-'9'] + |'x' hexa_char hexa_char) + as x) "'" { CHAR (TokenEval.char x, x) } + | "'\\" (_ as c) + { err (Illegal_escape (String.make 1 c)) (Loc.of_lexbuf lexbuf) } + | "(*" + { store c; COMMENT(parse_nested comment (in_comment c)) } + | "(*)" + { warn Comment_start (Loc.of_lexbuf lexbuf) ; + parse comment (in_comment c); COMMENT (buff_contents c) } + | "*)" + { warn Comment_not_end (Loc.of_lexbuf lexbuf) ; + c.lexbuf.lex_curr_pos <- c.lexbuf.lex_curr_pos - 1; + SYMBOL "*" } + | "<<" (quotchar* as beginning) + { if quotations c + then (move_start_p (-String.length beginning); + mk_quotation quotation c "" "" 2) + else parse (symbolchar_star ("<<" ^ beginning)) c } + | "<<>>" + { if quotations c + then QUOTATION { q_name = ""; q_loc = ""; q_shift = 2; q_contents = "" } + else parse (symbolchar_star "<<>>") c } + | "<@" + { if quotations c then with_curr_loc maybe_quotation_at c + else parse (symbolchar_star "<@") c } + | "<:" + { if quotations c then with_curr_loc maybe_quotation_colon c + else parse (symbolchar_star "<:") c } + | "#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']* + ("\"" ([^ '\010' '\013' '"' ] * as name) "\"")? + [^ '\010' '\013'] * newline + { let inum = int_of_string num + in update_loc c name inum true 0; LINE_DIRECTIVE(inum, name) } + | '(' (not_star_symbolchar as op) ')' + { ESCAPED_IDENT (String.make 1 op) } + | '(' (not_star_symbolchar symbolchar* not_star_symbolchar as op) ')' + { ESCAPED_IDENT op } + | '(' (not_star_symbolchar symbolchar* as op) blank+ ')' + { ESCAPED_IDENT op } + | '(' blank+ (symbolchar* not_star_symbolchar as op) ')' + { ESCAPED_IDENT op } + | '(' blank+ (symbolchar+ as op) blank+ ')' + { ESCAPED_IDENT op } + | ( "#" | "`" | "'" | "," | "." | ".." | ":" | "::" + | ":=" | ":>" | ";" | ";;" | "_" + | left_delimitor | right_delimitor ) as x { SYMBOL x } + | '$' { if antiquots c + then with_curr_loc dollar (shift 1 c) + else parse (symbolchar_star "$") c } + | ['~' '?' '!' '=' '<' '>' '|' '&' '@' '^' '+' '-' '*' '/' '%' '\\'] symbolchar * + as x { SYMBOL x } + | eof + { let pos = lexbuf.lex_curr_p in + lexbuf.lex_curr_p <- { pos with pos_bol = pos.pos_bol + 1 ; + pos_cnum = pos.pos_cnum + 1 }; EOI } + | _ as c { err (Illegal_character c) (Loc.of_lexbuf lexbuf) } + + and comment c = parse + "(*" + { store c; with_curr_loc comment c; parse comment c } + | "*)" { store c } + | '<' (':' quote_tag)? ('@' locname)? '<' + { store c; + if quotations c then with_curr_loc quotation c; parse comment c } + | ident { store_parse comment c } + | "\"" + { store c; + begin try with_curr_loc string c + with Loc.Exc_located(_, Error.E Unterminated_string) -> + err Unterminated_string_in_comment (loc c) + end; + Buffer.add_char c.buffer '"'; + parse comment c } + | "''" { store_parse comment c } + | "'''" { store_parse comment c } + | "'" newline "'" + { update_loc c None 1 false 1; store_parse comment c } + | "'" [^ '\\' '\'' '\010' '\013' ] "'" { store_parse comment c } + | "'\\" ['\\' '"' '\'' 'n' 't' 'b' 'r' ' '] "'" { store_parse comment c } + | "'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "'" { store_parse comment c } + | "'\\" 'x' hexa_char hexa_char "'" { store_parse comment c } + | eof + { err Unterminated_comment (loc c) } + | newline + { update_loc c None 1 false 0; store_parse comment c } + | _ { store_parse comment c } + + and string c = parse + '"' { set_start_p c } + | '\\' newline ([' ' '\t'] * as space) + { update_loc c None 1 false (String.length space); + store_parse string c } + | '\\' ['\\' '"' 'n' 't' 'b' 'r' ' ' '\''] { store_parse string c } + | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] { store_parse string c } + | '\\' 'x' hexa_char hexa_char { store_parse string c } + | '\\' (_ as x) + { if is_in_comment c + then store_parse string c + else begin + warn (Illegal_escape (String.make 1 x)) (Loc.of_lexbuf lexbuf); + store_parse string c + end } + | newline + { update_loc c None 1 false 0; store_parse string c } + | eof { err Unterminated_string (loc c) } + | _ { store_parse string c } + + and symbolchar_star beginning c = parse + | symbolchar* as tok { move_start_p (-String.length beginning) c ; + SYMBOL(beginning ^ tok) } + + and maybe_quotation_at c = parse + | (ident as loc) '<' + { mk_quotation quotation c "" loc (1 + String.length loc) } + | symbolchar* as tok { SYMBOL("<@" ^ tok) } + + and maybe_quotation_colon c = parse + | (quote_tag as name) '<' + { mk_quotation quotation c name "" (1 + String.length name) } + | (quote_tag as name) '@' (locname as loc) '<' + { mk_quotation quotation c name loc + (2 + String.length loc + String.length name) } + | symbolchar* as tok { SYMBOL("<:" ^ tok) } + + and quotation c = parse + | '<' (':' quote_tag)? ('@' locname)? '<' { store c ; + with_curr_loc quotation c ; + parse quotation c } + | ">>" { store c } + | eof { err Unterminated_quotation (loc c) } + | newline { update_loc c None 1 false 0 ; + store_parse quotation c } + | _ { store_parse quotation c } + + and dollar c = parse + | '$' { set_start_p c; ANTIQUOT("", "") } + | ('`'? (identchar*|['.' '!']+) as name) ':' + { with_curr_loc (antiquot name) (shift (1 + String.length name) c) } + | _ { store_parse (antiquot "") c } + + and antiquot name c = parse + | '$' { set_start_p c; ANTIQUOT(name, buff_contents c) } + | eof { err Unterminated_antiquot (loc c) } + | newline + { update_loc c None 1 false 0; store_parse (antiquot name) c } + | '<' (':' quote_tag)? ('@' locname)? '<' + { store c; with_curr_loc quotation c; parse (antiquot name) c } + | _ { store_parse (antiquot name) c } + + { + + let lexing_store s buff max = + let rec self n s = + if n >= max then n + else + match Stream.peek s with + | Some x -> + Stream.junk s; + buff.[n] <- x; + succ n + | _ -> n + in + self 0 s + + let from_context c = + let next _ = + let tok = with_curr_loc token c in + let loc = Loc.of_lexbuf c.lexbuf in + Some ((tok, loc)) + in Stream.from next + + let from_lexbuf ?(quotations = true) lb = + let c = { (default_context lb) with + loc = Loc.of_lexbuf lb; + antiquots = !Camlp4_config.antiquotations; + quotations = quotations } + in from_context c + + let setup_loc lb loc = + let start_pos = Loc.start_pos loc in + lb.lex_abs_pos <- start_pos.pos_cnum; + lb.lex_curr_p <- start_pos + + let from_string ?quotations loc str = + let lb = Lexing.from_string str in + setup_loc lb loc; + from_lexbuf ?quotations lb + + let from_stream ?quotations loc strm = + let lb = Lexing.from_function (lexing_store strm) in + setup_loc lb loc; + from_lexbuf ?quotations lb + + let mk () loc strm = + from_stream ~quotations:!Camlp4_config.quotations loc strm +end +} diff --git a/camlp4/Camlp4/Struct/Loc.ml b/camlp4/Camlp4/Struct/Loc.ml new file mode 100644 index 0000000..0c9668e --- /dev/null +++ b/camlp4/Camlp4/Struct/Loc.ml @@ -0,0 +1,307 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) +(* camlp4r *) + +open Format; + +(* FIXME + Study these 2 others implementations which change the ghost + handling: + + type pos = ... the same ... + + 1/ + + type loc = { + file_name : string; + start : pos; + stop : pos + }; + + type t = + [ Nowhere + | Ghost of loc (* the closest non ghost loc *) + | Concrete of loc ]; + + 2/ + + type loc = { + file_name : string; + start : pos; + stop : pos + }; + + type t = option loc; + + 3/ + + type t = { + file_name : option string; + start : pos; + stop : pos + }; + +*) + +type pos = { + line : int; + bol : int; + off : int +}; + +type t = { + file_name : string; + start : pos; + stop : pos; + ghost : bool +}; + +(* Debug section *) +value dump_sel f x = + let s = + match x with + [ `start -> "`start" + | `stop -> "`stop" + | `both -> "`both" + | _ -> "" ] + in pp_print_string f s; +value dump_pos f x = + fprintf f "@[{ line = %d ;@ bol = %d ;@ off = %d } : pos@]" + x.line x.bol x.off; +value dump_long f x = + fprintf f + "@[{ file_name = %s ;@ start = %a (%d-%d);@ stop = %a (%d);@ ghost = %b@ } : Loc.t@]" + x.file_name dump_pos x.start (x.start.off - x.start.bol) + (x.stop.off - x.start.bol) dump_pos x.stop + (x.stop.off - x.stop.bol) x.ghost; +value dump f x = + fprintf f "[%S: %d:%d-%d %d:%d%t]" + x.file_name x.start.line (x.start.off - x.start.bol) + (x.stop.off - x.start.bol) x.stop.line (x.stop.off - x.stop.bol) + (fun o -> if x.ghost then fprintf o " (ghost)" else ()); + +value start_pos = { line = 1 ; bol = 0 ; off = 0 }; + +value ghost = + { file_name = "ghost-location"; + start = start_pos; + stop = start_pos; + ghost = True }; + +value mk file_name = + debug loc "mk %s@\n" file_name in + { file_name = file_name; + start = start_pos; + stop = start_pos; + ghost = False }; + +value of_tuple (file_name, start_line, start_bol, start_off, + stop_line, stop_bol, stop_off, ghost) = + { file_name = file_name; + start = { line = start_line ; bol = start_bol ; off = start_off }; + stop = { line = stop_line ; bol = stop_bol ; off = stop_off }; + ghost = ghost }; + +value to_tuple + { file_name = file_name; + start = { line = start_line ; bol = start_bol ; off = start_off }; + stop = { line = stop_line ; bol = stop_bol ; off = stop_off }; + ghost = ghost } = + (file_name, start_line, start_bol, start_off, + stop_line, stop_bol, stop_off, ghost); + +value pos_of_lexing_position p = + let pos = + { line = p.Lexing.pos_lnum ; + bol = p.Lexing.pos_bol ; + off = p.Lexing.pos_cnum } in + debug loc "pos_of_lexing_position: %a@\n" dump_pos pos in + pos; + +value pos_to_lexing_position p file_name = + (* debug loc "pos_to_lexing_position: %a@\n" dump_pos p in *) + { Lexing. + pos_fname = file_name; + pos_lnum = p.line ; + pos_bol = p.bol ; + pos_cnum = p.off }; + +value better_file_name a b = + match (a, b) with + [ ("", "") -> a + | ("", x) -> x + | (x, "") -> x + | ("-", x) -> x + | (x, "-") -> x + | (x, _) -> x ]; + +value of_lexbuf lb = + let start = Lexing.lexeme_start_p lb + and stop = Lexing.lexeme_end_p lb in + let loc = + { file_name = better_file_name start.Lexing.pos_fname stop.Lexing.pos_fname; + start = pos_of_lexing_position start; + stop = pos_of_lexing_position stop; + ghost = False } in + debug loc "of_lexbuf: %a@\n" dump loc in + loc; + +value of_lexing_position pos = + let loc = + { file_name = pos.Lexing.pos_fname; + start = pos_of_lexing_position pos; + stop = pos_of_lexing_position pos; + ghost = False } in + debug loc "of_lexing_position: %a@\n" dump loc in + loc; + +value to_ocaml_location x = + debug loc "to_ocaml_location: %a@\n" dump x in + { Location. + loc_start = pos_to_lexing_position x.start x.file_name; + loc_end = pos_to_lexing_position x.stop x.file_name; + loc_ghost = x.ghost }; + +value of_ocaml_location { Location.loc_start = a; loc_end = b; loc_ghost = g } = + let res = + { file_name = better_file_name a.Lexing.pos_fname b.Lexing.pos_fname; + start = pos_of_lexing_position a; + stop = pos_of_lexing_position b; + ghost = g } in + debug loc "of_ocaml_location: %a@\n" dump res in + res; + +value start_pos x = pos_to_lexing_position x.start x.file_name; +value stop_pos x = pos_to_lexing_position x.stop x.file_name; + +value merge a b = + if a == b then + debug loc "trivial merge@\n" in + a + else + let r = + match (a.ghost, b.ghost) with + [ (False, False) -> + (* FIXME if a.file_name <> b.file_name then + raise (Invalid_argument + (sprintf "Loc.merge: Filenames must be equal: %s <> %s" + a.file_name b.file_name)) *) + (* else *) + { (a) with stop = b.stop } + | (True, True) -> { (a) with stop = b.stop } + | (True, _) -> { (a) with stop = b.stop } + | (_, True) -> { (b) with start = a.start } ] + in debug loc "@[merge %a@ %a@ %a@]@\n" dump a dump b dump r in r; + +value join x = { (x) with stop = x.start }; + +value map f start_stop_both x = + match start_stop_both with + [ `start -> { (x) with start = f x.start } + | `stop -> { (x) with stop = f x.stop } + | `both -> { (x) with start = f x.start; stop = f x.stop } ]; + +value move_pos chars x = { (x) with off = x.off + chars }; + +value move s chars x = + debug loc "move %a %d %a@\n" dump_sel s chars dump x in + map (move_pos chars) s x; + +value move_line lines x = + debug loc "move_line %d %a@\n" lines dump x in + let move_line_pos x = + { (x) with line = x.line + lines ; bol = x.off } + in map move_line_pos `both x; + +value shift width x = + { (x) with start = x.stop ; stop = move_pos width x.stop }; + +value file_name x = x.file_name; +value start_line x = x.start.line; +value stop_line x = x.stop.line; +value start_bol x = x.start.bol; +value stop_bol x = x.stop.bol; +value start_off x = x.start.off; +value stop_off x = x.stop.off; +value is_ghost x = x.ghost; + +value set_file_name s x = + debug loc "set_file_name: %a@\n" dump x in + { (x) with file_name = s }; + +value ghostify x = + debug loc "ghostify: %a@\n" dump x in + { (x) with ghost = True }; + +value make_absolute x = + debug loc "make_absolute: %a@\n" dump x in + let pwd = Sys.getcwd () in + if Filename.is_relative x.file_name then + { (x) with file_name = Filename.concat pwd x.file_name } + else x; + +value strictly_before x y = + let b = x.stop.off < y.start.off && x.file_name = y.file_name in + debug loc "%a [strictly_before] %a => %b@\n" dump x dump y b in + b; + +value to_string x = do { + let (a, b) = (x.start, x.stop) in + let res = sprintf "File \"%s\", line %d, characters %d-%d" + x.file_name a.line (a.off - a.bol) (b.off - a.bol) in + if x.start.line <> x.stop.line then + sprintf "%s (end at line %d, character %d)" + res x.stop.line (b.off - b.bol) + else res +}; + +value print out x = pp_print_string out (to_string x); + +value check x msg = + if ((start_line x) > (stop_line x) || + (start_bol x) > (stop_bol x) || + (start_off x) > (stop_off x) || + (start_line x) < 0 || (stop_line x) < 0 || + (start_bol x) < 0 || (stop_bol x) < 0 || + (start_off x) < 0 || (stop_off x) < 0) + (* Here, we don't check + (start_off x) < (start_bol x) || (stop_off x) < (start_bol x) + since the lexer is called on antiquotations, with off=0, but line and bolpos + have "correct" values *) + then do { + eprintf "*** Warning: (%s) strange positions ***\n%a@\n" msg print x; + False + } + else True; + +exception Exc_located of t and exn; + +ErrorHandler.register + (fun ppf -> + fun [ Exc_located loc exn -> + fprintf ppf "%a:@\n%a" print loc ErrorHandler.print exn + | exn -> raise exn ]); + +value name = ref "_loc"; + +value raise loc exc = + match exc with + [ Exc_located _ _ -> raise exc + | _ -> raise (Exc_located loc exc) ] +; diff --git a/camlp4/Camlp4/Struct/Loc.mli b/camlp4/Camlp4/Struct/Loc.mli new file mode 100644 index 0000000..9c95187 --- /dev/null +++ b/camlp4/Camlp4/Struct/Loc.mli @@ -0,0 +1,19 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) +include Sig.Loc; diff --git a/camlp4/Camlp4/Struct/Quotation.ml b/camlp4/Camlp4/Struct/Quotation.ml new file mode 100644 index 0000000..5e7e2cc --- /dev/null +++ b/camlp4/Camlp4/Struct/Quotation.ml @@ -0,0 +1,166 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2002-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + + + +module Make (Ast : Sig.Camlp4Ast) +: Sig.Quotation with module Ast = Ast += struct + module Ast = Ast; + module DynAst = DynAst.Make Ast; + module Loc = Ast.Loc; + open Format; + open Sig; + + type expand_fun 'a = Loc.t -> option string -> string -> 'a; + + module Exp_key = DynAst.Pack(struct + type t 'a = unit; + end); + + module Exp_fun = DynAst.Pack(struct + type t 'a = expand_fun 'a; + end); + + value expanders_table = + (ref [] : ref (list ((string * Exp_key.pack) * Exp_fun.pack))); + + value default = ref ""; + value translate = ref (fun x -> x); + + value expander_name name = + match translate.val name with + [ "" -> default.val + | name -> name ]; + + value find name tag = + let key = (expander_name name, Exp_key.pack tag ()) in + Exp_fun.unpack tag (List.assoc key expanders_table.val); + + value add name tag f = + let elt = ((name, Exp_key.pack tag ()), Exp_fun.pack tag f) in + expanders_table.val := [elt :: expanders_table.val]; + + value dump_file = ref None; + + module Error = struct + type error = + [ Finding + | Expanding + | ParsingResult of Loc.t and string + | Locating ]; + type t = (string * string * error * exn); + exception E of t; + + value print ppf (name, position, ctx, exn) = + let name = if name = "" then default.val else name in + let pp x = fprintf ppf "@?@[<2>While %s %S in a position of %S:" x name position in + let () = + match ctx with + [ Finding -> begin + pp "finding quotation"; + if expanders_table.val = [] then + fprintf ppf "@ There is no quotation expander available." + else + begin + fprintf ppf "@ @[Available quotation expanders are:@\n"; + List.iter begin fun ((s,t),_) -> + fprintf ppf "@[<2>%s@ (in@ a@ position@ of %a)@]@ " + s Exp_key.print_tag t + end expanders_table.val; + fprintf ppf "@]" + end + end + | Expanding -> pp "expanding quotation" + | Locating -> pp "parsing" + | ParsingResult loc str -> + let () = pp "parsing result of quotation" in + match dump_file.val with + [ Some dump_file -> + let () = fprintf ppf " dumping result...\n" in + try + let oc = open_out_bin dump_file in + begin + output_string oc str; + output_string oc "\n"; + flush oc; + close_out oc; + fprintf ppf "%a:" Loc.print (Loc.set_file_name dump_file loc); + end + with _ -> + fprintf ppf + "Error while dumping result in file %S; dump aborted" + dump_file + | None -> + fprintf ppf + "\n(consider setting variable Quotation.dump_file, or using the -QD option)" + ] + ] + in fprintf ppf "@\n%a@]@." ErrorHandler.print exn; + + value to_string x = + Format.asprintf "%a" print x; + end; + let module M = ErrorHandler.Register Error in (); + open Error; + + value expand_quotation loc expander pos_tag quot = + debug quot "expand_quotation: name: %s, str: %S@." quot.q_name quot.q_contents in + let loc_name_opt = if quot.q_loc = "" then None else Some quot.q_loc in + try expander loc loc_name_opt quot.q_contents with + [ Loc.Exc_located _ (Error.E _) as exc -> + raise exc + | Loc.Exc_located iloc exc -> + let exc1 = Error.E (quot.q_name, pos_tag, Expanding, exc) in + raise (Loc.Exc_located iloc exc1) + | exc -> + let exc1 = Error.E (quot.q_name, pos_tag, Expanding, exc) in + raise (Loc.Exc_located loc exc1) ]; + + value parse_quotation_result parse loc quot pos_tag str = + try parse loc str with + [ Loc.Exc_located iloc (Error.E (n, pos_tag, Expanding, exc)) -> + let ctx = ParsingResult iloc quot.q_contents in + let exc1 = Error.E (n, pos_tag, ctx, exc) in + raise (Loc.Exc_located iloc exc1) + | Loc.Exc_located iloc (Error.E _ as exc) -> + raise (Loc.Exc_located iloc exc) + | Loc.Exc_located iloc exc -> + let ctx = ParsingResult iloc quot.q_contents in + let exc1 = Error.E (quot.q_name, pos_tag, ctx, exc) in + raise (Loc.Exc_located iloc exc1) ]; + + value expand loc quotation tag = + let pos_tag = DynAst.string_of_tag tag in + let name = quotation.q_name in + debug quot "handle_quotation: name: %s, str: %S@." name quotation.q_contents in + let expander = + try find name tag + with + [ Loc.Exc_located _ (Error.E _) as exc -> raise exc + | Loc.Exc_located qloc exc -> + raise (Loc.Exc_located qloc (Error.E (name, pos_tag, Finding, exc))) + | exc -> + raise (Loc.Exc_located loc (Error.E (name, pos_tag, Finding, exc))) ] + in + let loc = Loc.join (Loc.move `start quotation.q_shift loc) in + expand_quotation loc expander pos_tag quotation; + +end; diff --git a/camlp4/Camlp4/Struct/Token.ml b/camlp4/Camlp4/Struct/Token.ml new file mode 100644 index 0000000..b96c19d --- /dev/null +++ b/camlp4/Camlp4/Struct/Token.ml @@ -0,0 +1,243 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +open Format; + +module Make (Loc : Sig.Loc) +: Sig.Camlp4Token with module Loc = Loc += struct + module Loc = Loc; + open Sig; + type t = camlp4_token; + type token = t; + + value to_string = + fun + [ KEYWORD s -> sprintf "KEYWORD %S" s + | SYMBOL s -> sprintf "SYMBOL %S" s + | LIDENT s -> sprintf "LIDENT %S" s + | UIDENT s -> sprintf "UIDENT %S" s + | INT _ s -> sprintf "INT %s" s + | INT32 _ s -> sprintf "INT32 %sd" s + | INT64 _ s -> sprintf "INT64 %sd" s + | NATIVEINT _ s-> sprintf "NATIVEINT %sd" s + | FLOAT _ s -> sprintf "FLOAT %s" s + | CHAR _ s -> sprintf "CHAR '%s'" s + | STRING _ s -> sprintf "STRING \"%s\"" s + (* here it's not %S since the string is already escaped *) + | LABEL s -> sprintf "LABEL %S" s + | OPTLABEL s -> sprintf "OPTLABEL %S" s + | ANTIQUOT n s -> sprintf "ANTIQUOT %s: %S" n s + | QUOTATION x -> sprintf "QUOTATION { q_name=%S; q_loc=%S; q_shift=%d; q_contents=%S }" + x.q_name x.q_loc x.q_shift x.q_contents + | COMMENT s -> sprintf "COMMENT %S" s + | BLANKS s -> sprintf "BLANKS %S" s + | NEWLINE -> sprintf "NEWLINE" + | EOI -> sprintf "EOI" + | ESCAPED_IDENT s -> sprintf "ESCAPED_IDENT %S" s + | LINE_DIRECTIVE i None -> sprintf "LINE_DIRECTIVE %d" i + | LINE_DIRECTIVE i (Some s) -> sprintf "LINE_DIRECTIVE %d %S" i s ]; + + value print ppf x = pp_print_string ppf (to_string x); + + value match_keyword kwd = + fun + [ KEYWORD kwd' when kwd = kwd' -> True + | _ -> False ]; + + value extract_string = + fun + [ KEYWORD s | SYMBOL s | LIDENT s | UIDENT s | INT _ s | INT32 _ s | + INT64 _ s | NATIVEINT _ s | FLOAT _ s | CHAR _ s | STRING _ s | + LABEL s | OPTLABEL s | COMMENT s | BLANKS s | ESCAPED_IDENT s -> s + | tok -> + invalid_arg ("Cannot extract a string from this token: "^ + to_string tok) ]; + + module Error = struct + type t = + [ Illegal_token of string + | Keyword_as_label of string + | Illegal_token_pattern of string and string + | Illegal_constructor of string ]; + + exception E of t; + + value print ppf = + fun + [ Illegal_token s -> + fprintf ppf "Illegal token (%s)" s + | Keyword_as_label kwd -> + fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd + | Illegal_token_pattern p_con p_prm -> + fprintf ppf "Illegal token pattern: %s %S" p_con p_prm + | Illegal_constructor con -> + fprintf ppf "Illegal constructor %S" con ]; + + value to_string x = + Format.asprintf "%a" print x; + end; + let module M = ErrorHandler.Register Error in (); + + module Filter = struct + type token_filter = stream_filter t Loc.t; + + type t = + { is_kwd : string -> bool; + filter : mutable token_filter }; + + value err error loc = + raise (Loc.Exc_located loc (Error.E error)); + + value keyword_conversion tok is_kwd = + match tok with + [ SYMBOL s | LIDENT s | UIDENT s when is_kwd s -> KEYWORD s + | ESCAPED_IDENT s -> LIDENT s + | _ -> tok ]; + + value check_keyword_as_label tok loc is_kwd = + let s = + match tok with + [ LABEL s -> s + | OPTLABEL s -> s + | _ -> "" ] + in if s <> "" && is_kwd s then err (Error.Keyword_as_label s) loc else (); + + value check_unknown_keywords tok loc = + match tok with + [ SYMBOL s -> err (Error.Illegal_token s) loc + | _ -> () ]; + + value error_no_respect_rules p_con p_prm = + raise (Error.E (Error.Illegal_token_pattern p_con p_prm)); + + value check_keyword _ = True; + (* FIXME let lb = Lexing.from_string s in + let next () = token default_context lb in + try + match next () with + [ SYMBOL _ | UIDENT _ | LIDENT _ -> (next () = EOI) + | _ -> False ] + with [ Stream.Error _ -> False ]; *) + + value error_on_unknown_keywords = ref False; + + value rec ignore_layout = + parser + [ [: `(COMMENT _ | BLANKS _ | NEWLINE | LINE_DIRECTIVE _ _, _); s :] -> + ignore_layout s + | [: ` x; s :] -> [: ` x; ignore_layout s :] + | [: :] -> [: :] ]; + + value mk is_kwd = + { is_kwd = is_kwd; + filter = ignore_layout }; + + value filter x = + let f tok loc = do { + let tok = keyword_conversion tok x.is_kwd; + check_keyword_as_label tok loc x.is_kwd; + if error_on_unknown_keywords.val + then check_unknown_keywords tok loc else (); + debug token "@[Lexer before filter:@ %a@ at@ %a@]@." + print tok Loc.dump loc in + (tok, loc) + } in + let rec filter = + parser + [ [: `(tok, loc); s :] -> [: ` f tok loc; filter s :] + | [: :] -> [: :] ] + in + let rec tracer = (* FIXME add a debug block construct *) + parser + [ [: `((_tok, _loc) as x); xs :] -> + debug token "@[Lexer after filter:@ %a@ at@ %a@]@." + print _tok Loc.dump _loc in + [: ` x; tracer xs :] + | [: :] -> [: :] ] + in fun strm -> tracer (x.filter (filter strm)); + + value define_filter x f = x.filter := f x.filter; + + value keyword_added _ _ _ = (); + value keyword_removed _ _ = (); + end; + +end; + +(* Char and string tokens to real chars and string *) +module Eval = struct + + value valch x = Char.code x - Char.code '0'; + value valch_hex x = + let d = Char.code x in + if d >= 97 then d - 87 + else if d >= 65 then d - 55 + else d - 48; + + value rec skip_indent = parser + [ [: `' ' | '\t'; s :] -> skip_indent s + | [: :] -> () ]; + + value skip_opt_linefeed = parser + [ [: `'\010' :] -> () + | [: :] -> () ]; + + value chr c = + if c < 0 || c > 255 then failwith "invalid char token" else Char.chr c; + + value rec backslash = parser + [ [: `'\010' :] -> '\010' + | [: `'\013' :] -> '\013' + | [: `'n' :] -> '\n' + | [: `'r' :] -> '\r' + | [: `'t' :] -> '\t' + | [: `'b' :] -> '\b' + | [: `'\\' :] -> '\\' + | [: `'"' :] -> '"' + | [: `'\'' :] -> '\'' + | [: `' ' :] -> ' ' + | [: `('0'..'9' as c1); `('0'..'9' as c2); `('0'..'9' as c3) :] -> + chr (100 * (valch c1) + 10 * (valch c2) + (valch c3)) + | [: `'x'; `('0'..'9' | 'a'..'f' | 'A'..'F' as c1) ; + `('0'..'9' | 'a'..'f' | 'A'..'F' as c2) :] -> + chr (16 * (valch_hex c1) + (valch_hex c2)) ]; + + value rec backslash_in_string strict store = parser + [ [: `'\010'; s :] -> skip_indent s + | [: `'\013'; s :] -> do { skip_opt_linefeed s; skip_indent s } + | [: x = backslash :] -> store x + | [: `c when not strict :] -> do { store '\\'; store c } + | [: :] -> failwith "invalid string token" ]; + + value char s = + if String.length s = 1 then s.[0] + else if String.length s = 0 then failwith "invalid char token" + else match Stream.of_string s with parser + [ [: `'\\'; x = backslash :] -> x + | [: :] -> failwith "invalid char token" ]; + + value string ?strict s = + let buf = Buffer.create 23 in + let store = Buffer.add_char buf in + let rec parse = parser + [ [: `'\\'; _ = backslash_in_string (strict <> None) store; s :] -> parse s + | [: `c; s :] -> do { store c; parse s } + | [: :] -> Buffer.contents buf ] + in parse (Stream.of_string s); +end; diff --git a/camlp4/Camlp4/Struct/Token.mli b/camlp4/Camlp4/Struct/Token.mli new file mode 100644 index 0000000..7448ba2 --- /dev/null +++ b/camlp4/Camlp4/Struct/Token.mli @@ -0,0 +1,35 @@ +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Make (Loc : Sig.Loc) : Sig.Camlp4Token with module Loc = Loc; + +module Eval : sig + value char : string -> char; + (** Convert a char token, where the escape sequences (backslashes) + remain to be interpreted; raise [Failure] if an + incorrect backslash sequence is found; [Token.Eval.char (Char.escaped c)] + returns [c] *) + + value string : ?strict:unit -> string -> string; + (** [Taken.Eval.string strict s] + Convert a string token, where the escape sequences (backslashes) + remain to be interpreted; raise [Failure] if [strict] and an + incorrect backslash sequence is found; + [Token.Eval.string strict (String.escaped s)] returns [s] *) +end; diff --git a/camlp4/Camlp4/Utils.ml b/camlp4/Camlp4/Utils.ml new file mode 100644 index 0000000..e529d10 --- /dev/null +++ b/camlp4/Camlp4/Utils.ml @@ -0,0 +1,26 @@ +(* Imported from typing/oprint.ml *) + +value valid_float_lexeme s = + let l = String.length s in + let rec loop i = + if i >= l then s ^ "." else + match s.[i] with + [ '0' .. '9' | '-' -> loop (i+1) + | _ -> s ] + in loop 0 +; + +value float_repres f = + match classify_float f with + [ FP_nan -> "nan" + | FP_infinite -> + if f < 0.0 then "neg_infinity" else "infinity" + | _ -> + let float_val = + let s1 = Printf.sprintf "%.12g" f in + if f = float_of_string s1 then s1 else + let s2 = Printf.sprintf "%.15g" f in + if f = float_of_string s2 then s2 else + Printf.sprintf "%.18g" f + in valid_float_lexeme float_val ] +; diff --git a/camlp4/Camlp4/Utils.mli b/camlp4/Camlp4/Utils.mli new file mode 100644 index 0000000..2642ea5 --- /dev/null +++ b/camlp4/Camlp4/Utils.mli @@ -0,0 +1 @@ +value float_repres : float -> string; diff --git a/camlp4/Camlp4Bin.ml b/camlp4/Camlp4Bin.ml new file mode 100644 index 0000000..3a2a6b2 --- /dev/null +++ b/camlp4/Camlp4Bin.ml @@ -0,0 +1,332 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + + + +open Camlp4; +open PreCast.Syntax; +open PreCast; +open Format; +module CleanAst = Camlp4.Struct.CleanAst.Make Ast; +module SSet = Set.Make String; + +value pa_r = "Camlp4OCamlRevisedParser"; +value pa_rr = "Camlp4OCamlReloadedParser"; +value pa_o = "Camlp4OCamlParser"; +value pa_rp = "Camlp4OCamlRevisedParserParser"; +value pa_op = "Camlp4OCamlParserParser"; +value pa_g = "Camlp4GrammarParser"; +value pa_m = "Camlp4MacroParser"; +value pa_qb = "Camlp4QuotationCommon"; +value pa_q = "Camlp4QuotationExpander"; +value pa_rq = "Camlp4OCamlRevisedQuotationExpander"; +value pa_oq = "Camlp4OCamlOriginalQuotationExpander"; +value pa_l = "Camlp4ListComprehension"; + +open Register; + +value dyn_loader = ref (fun []); +value rcall_callback = ref (fun () -> ()); +value loaded_modules = ref SSet.empty; +value add_to_loaded_modules name = + loaded_modules.val := SSet.add name loaded_modules.val; + +value (objext,libext) = + if DynLoader.is_native then (".cmxs",".cmxs") + else (".cmo",".cma"); + +value rewrite_and_load n x = + let dyn_loader = dyn_loader.val () in + let find_in_path = DynLoader.find_in_path dyn_loader in + let real_load name = do { + add_to_loaded_modules name; + DynLoader.load dyn_loader name + } in + let load = List.iter begin fun n -> + if SSet.mem n loaded_modules.val || List.mem n Register.loaded_modules.val then () + else begin + add_to_loaded_modules n; + DynLoader.load dyn_loader (n ^ objext); + end + end in + do { + match (n, String.lowercase_ascii x) with + [ ("Parsers"|"", "pa_r.cmo" | "r" | "ocamlr" | "ocamlrevised" | "camlp4ocamlrevisedparser.cmo") -> load [pa_r] + | ("Parsers"|"", "rr" | "reloaded" | "ocamlreloaded" | "camlp4ocamlreloadedparser.cmo") -> load [pa_rr] + | ("Parsers"|"", "pa_o.cmo" | "o" | "ocaml" | "camlp4ocamlparser.cmo") -> load [pa_r; pa_o] + | ("Parsers"|"", "pa_rp.cmo" | "rp" | "rparser" | "camlp4ocamlrevisedparserparser.cmo") -> load [pa_r; pa_rp] + | ("Parsers"|"", "pa_op.cmo" | "op" | "parser" | "camlp4ocamlparserparser.cmo") -> load [pa_r; pa_o; pa_rp; pa_op] + | ("Parsers"|"", "pa_extend.cmo" | "pa_extend_m.cmo" | "g" | "grammar" | "camlp4grammarparser.cmo") -> load [pa_g] + | ("Parsers"|"", "pa_macro.cmo" | "m" | "macro" | "camlp4macroparser.cmo") -> load [pa_m] + | ("Parsers"|"", "q" | "camlp4quotationexpander.cmo") -> load [pa_qb; pa_q] + | ("Parsers"|"", "q_mlast.cmo" | "rq" | "camlp4ocamlrevisedquotationexpander.cmo") -> load [pa_qb; pa_rq] + | ("Parsers"|"", "oq" | "camlp4ocamloriginalquotationexpander.cmo") -> load [pa_r; pa_o; pa_qb; pa_oq] + | ("Parsers"|"", "rf") -> load [pa_r; pa_rp; pa_qb; pa_q; pa_g; pa_l; pa_m] + | ("Parsers"|"", "of") -> load [pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_q; pa_g; pa_l; pa_m] + | ("Parsers"|"", "comp" | "camlp4listcomprehension.cmo") -> load [pa_l] + | ("Filters"|"", "lift" | "camlp4astlifter.cmo") -> load ["Camlp4AstLifter"] + | ("Filters"|"", "exn" | "camlp4exceptiontracer.cmo") -> load ["Camlp4ExceptionTracer"] + | ("Filters"|"", "prof" | "camlp4profiler.cmo") -> load ["Camlp4Profiler"] + (* map is now an alias of fold since fold handles map too *) + | ("Filters"|"", "map" | "camlp4mapgenerator.cmo") -> load ["Camlp4FoldGenerator"] + | ("Filters"|"", "fold" | "camlp4foldgenerator.cmo") -> load ["Camlp4FoldGenerator"] + | ("Filters"|"", "meta" | "camlp4metagenerator.cmo") -> load ["Camlp4MetaGenerator"] + | ("Filters"|"", "trash" | "camlp4trashremover.cmo") -> load ["Camlp4TrashRemover"] + | ("Filters"|"", "striploc" | "camlp4locationstripper.cmo") -> load ["Camlp4LocationStripper"] + | ("Printers"|"", "pr_r.cmo" | "r" | "ocamlr" | "camlp4ocamlrevisedprinter.cmo") -> + Register.enable_ocamlr_printer () + | ("Printers"|"", "pr_o.cmo" | "o" | "ocaml" | "camlp4ocamlprinter.cmo") -> + Register.enable_ocaml_printer () + | ("Printers"|"", "pr_dump.cmo" | "p" | "dumpocaml" | "camlp4ocamlastdumper.cmo") -> + Register.enable_dump_ocaml_ast_printer () + | ("Printers"|"", "d" | "dumpcamlp4" | "camlp4astdumper.cmo") -> + Register.enable_dump_camlp4_ast_printer () + | ("Printers"|"", "a" | "auto" | "camlp4autoprinter.cmo") -> + load ["Camlp4AutoPrinter"] + | _ -> + let y = "Camlp4"^n^"/"^x^objext in + real_load (try find_in_path y with [ Not_found -> x ]) ]; + rcall_callback.val (); + }; + +value print_warning = eprintf "%a:\n%s@." Loc.print; + +value rec parse_file dyn_loader name pa getdir = + let directive_handler = Some (fun ast -> + match getdir ast with + [ Some x -> + match x with + [ (_, "load", s) -> do { rewrite_and_load "" s; None } + | (_, "directory", s) -> do { DynLoader.include_dir dyn_loader s; None } + | (_, "use", s) -> Some (parse_file dyn_loader s pa getdir) + | (_, "default_quotation", s) -> do { Quotation.default.val := s; None } + | (loc, _, _) -> Loc.raise loc (Stream.Error "bad directive") ] + | None -> None ]) in + let loc = Loc.mk name + in do { + current_warning.val := print_warning; + let ic = if name = "-" then stdin else open_in_bin name; + let cs = Stream.of_channel ic; + let clear () = if name = "-" then () else close_in ic; + let phr = + try pa ?directive_handler loc cs + with x -> do { clear (); raise x }; + clear (); + phr + }; + +value output_file = ref None; + +value process dyn_loader name pa pr clean fold_filters getdir = + let ast = parse_file dyn_loader name pa getdir in + let ast = fold_filters (fun t filter -> filter t) ast in + let ast = clean ast in + pr ?input_file:(Some name) ?output_file:output_file.val ast; + +value gind = + fun + [ Ast.SgDir loc n (Ast.ExStr _ s) -> Some (loc, n, s) + | _ -> None ]; + +value gimd = + fun + [ Ast.StDir loc n (Ast.ExStr _ s) -> Some (loc, n, s) + | _ -> None ]; + +value process_intf dyn_loader name = + process dyn_loader name CurrentParser.parse_interf CurrentPrinter.print_interf + (new CleanAst.clean_ast)#sig_item + AstFilters.fold_interf_filters gind; +value process_impl dyn_loader name = + process dyn_loader name CurrentParser.parse_implem CurrentPrinter.print_implem + (new CleanAst.clean_ast)#str_item + AstFilters.fold_implem_filters gimd; + +value just_print_the_version () = + do { printf "%s@." Camlp4_config.version; exit 0 }; + +value print_version () = + do { eprintf "Camlp4 version %s@." Camlp4_config.version; exit 0 }; + +value print_stdlib () = + do { printf "%s@." Camlp4_config.camlp4_standard_library; exit 0 }; + +value usage ini_sl ext_sl = + do { + eprintf "\ +Usage: camlp4 [load-options] [--] [other-options]\n\ +Options:\n\ +.ml Parse this implementation file\n\ +.mli Parse this interface file\n\ +.%s Load this module inside the Camlp4 core@." +(if DynLoader.is_native then "cmxs " else "(cmo|cma)") +; + Options.print_usage_list ini_sl; + (* loop (ini_sl @ ext_sl) where rec loop = + fun + [ [(y, _, _) :: _] when y = "-help" -> () + | [_ :: sl] -> loop sl + | [] -> eprintf " -help Display this list of options.@." ]; *) + if ext_sl <> [] then do { + eprintf "Options added by loaded object files:@."; + Options.print_usage_list ext_sl; + } + else (); + }; + +value warn_noassert () = + do { + eprintf "\ +camlp4 warning: option -noassert is obsolete\n\ +You should give the -noassert option to the ocaml compiler instead.@."; + }; + +type file_kind = + [ Intf of string + | Impl of string + | Str of string + | ModuleImpl of string + | IncludeDir of string ]; + +value search_stdlib = ref True; +value print_loaded_modules = ref False; +value (task, do_task) = + let t = ref None in + let task f x = + let () = Camlp4_config.current_input_file.val := x in + t.val := Some (if t.val = None then (fun _ -> f x) + else (fun usage -> usage ())) in + let do_task usage = match t.val with [ Some f -> f usage | None -> () ] in + (task, do_task); +value input_file x = + let dyn_loader = dyn_loader.val () in + do { + rcall_callback.val (); + match x with + [ Intf file_name -> task (process_intf dyn_loader) file_name + | Impl file_name -> task (process_impl dyn_loader) file_name + | Str s -> + begin + let (f, o) = Filename.open_temp_file "from_string" ".ml"; + output_string o s; + close_out o; + task (process_impl dyn_loader) f; + at_exit (fun () -> Sys.remove f); + end + | ModuleImpl file_name -> rewrite_and_load "" file_name + | IncludeDir dir -> DynLoader.include_dir dyn_loader dir ]; + rcall_callback.val (); + }; + +value expand_directory alt s = + if String.length s > 0 && s.[0] = '+' then + Filename.concat alt (String.sub s 1 (String.length s - 1)) + else + s +; + +value initial_spec_list = + [("-I", Arg.String (fun x -> input_file (IncludeDir (expand_directory Camlp4_config.camlp4_standard_library x))), + " Add directory in search patch for object files."); + ("-where", Arg.Unit print_stdlib, + "Print camlp4 library directory and exit."); + ("-nolib", Arg.Clear search_stdlib, + "No automatic search for object files in library directory."); + ("-intf", Arg.String (fun x -> input_file (Intf x)), + " Parse as an interface, whatever its extension."); + ("-impl", Arg.String (fun x -> input_file (Impl x)), + " Parse as an implementation, whatever its extension."); + ("-str", Arg.String (fun x -> input_file (Str x)), + " Parse as an implementation."); + ("-unsafe", Arg.Set Camlp4_config.unsafe, + "Generate unsafe accesses to array and strings."); + ("-noassert", Arg.Unit warn_noassert, + "Obsolete, do not use this option."); + ("-verbose", Arg.Set Camlp4_config.verbose, + "More verbose in parsing errors."); + ("-loc", Arg.Set_string Loc.name, + " Name of the location variable (default: " ^ Loc.name.val ^ ")."); + ("-QD", Arg.String (fun x -> Quotation.dump_file.val := Some x), + " Dump quotation expander result in case of syntax error."); + ("-o", Arg.String (fun x -> output_file.val := Some x), + " Output on instead of standard output."); + ("-v", Arg.Unit print_version, + "Print Camlp4 version and exit."); + ("-version", Arg.Unit just_print_the_version, + "Print Camlp4 version number and exit."); + ("-vnum", Arg.Unit just_print_the_version, + "Print Camlp4 version number and exit."); + ("-no_quot", Arg.Clear Camlp4_config.quotations, + "Don't parse quotations, allowing to use, e.g. \"<:>\" as token."); + ("-loaded-modules", Arg.Set print_loaded_modules, "Print the list of loaded modules."); + ("-parser", Arg.String (rewrite_and_load "Parsers"), + " Load the parser Camlp4Parsers/.cm(o|a|xs)"); + ("-printer", Arg.String (rewrite_and_load "Printers"), + " Load the printer Camlp4Printers/.cm(o|a|xs)"); + ("-filter", Arg.String (rewrite_and_load "Filters"), + " Load the filter Camlp4Filters/.cm(o|a|xs)"); + ("-ignore", Arg.String ignore, "ignore the next argument"); + ("--", Arg.Unit ignore, "Deprecated, does nothing") +]; + +Options.init initial_spec_list; + +value anon_fun name = + input_file + (if Filename.check_suffix name ".mli" then Intf name + else if Filename.check_suffix name ".ml" then Impl name + else if Filename.check_suffix name objext then ModuleImpl name + else if Filename.check_suffix name libext then ModuleImpl name + else raise (Arg.Bad ("don't know what to do with " ^ name))); + +value main argv = + let usage () = do { usage initial_spec_list (Options.ext_spec_list ()); exit 0 } in + try do { + let dynloader = DynLoader.mk ~ocaml_stdlib:search_stdlib.val + ~camlp4_stdlib:search_stdlib.val (); + dyn_loader.val := fun () -> dynloader; + let call_callback () = + Register.iter_and_take_callbacks + (fun (name, module_callback) -> + let () = add_to_loaded_modules name in + module_callback ()); + call_callback (); + rcall_callback.val := call_callback; + match Options.parse anon_fun argv with + [ [] -> () + | ["-help"|"--help"|"-h"|"-?" :: _] -> usage () + | [s :: _] -> + do { eprintf "%s: unknown or misused option\n" s; + eprintf "Use option -help for usage@."; + exit 2 } ]; + do_task usage; + call_callback (); + if print_loaded_modules.val then do { + SSet.iter (eprintf "%s@.") loaded_modules.val; + } else () + } + with + [ Arg.Bad s -> do { eprintf "Error: %s\n" s; + eprintf "Use option -help for usage@."; + exit 2 } + | Arg.Help _ -> usage () + | exc -> do { eprintf "@[%a@]@." ErrorHandler.print exc; exit 2 } ]; + +main Sys.argv; diff --git a/camlp4/Camlp4Filters/Camlp4AstLifter.ml b/camlp4/Camlp4Filters/Camlp4AstLifter.ml new file mode 100644 index 0000000..88f62e4 --- /dev/null +++ b/camlp4/Camlp4Filters/Camlp4AstLifter.ml @@ -0,0 +1,44 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + + +open Camlp4; + +module Id = struct + value name = "Camlp4AstLifter"; + value version = Sys.ocaml_version; +end; + +module Make (AstFilters : Camlp4.Sig.AstFilters) = struct + open AstFilters; + + module MetaLoc = struct + module Ast = Ast; + value meta_loc_patt _loc _ = <:patt< loc >>; + value meta_loc_expr _loc _ = <:expr< loc >>; + end; + module MetaAst = Ast.Meta.Make MetaLoc; + + register_str_item_filter (fun ast -> + let _loc = Ast.loc_of_str_item ast in + <:str_item< let loc = Loc.ghost in $exp:MetaAst.Expr.meta_str_item _loc ast$ >>); + +end; + +let module M = Camlp4.Register.AstFilter Id Make in (); diff --git a/camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml b/camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml new file mode 100644 index 0000000..2e7ead1 --- /dev/null +++ b/camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml @@ -0,0 +1,68 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + + +open Camlp4; + +module Id = struct + value name = "Camlp4ExceptionTracer"; + value version = Sys.ocaml_version; +end; + +module Make (AstFilters : Camlp4.Sig.AstFilters) = struct + open AstFilters; + open Ast; + + value add_debug_expr e = + (* let _loc = Loc.make_absolute (MLast.loc_of_expr e) in *) + let _loc = Ast.loc_of_expr e in + let msg = "camlp4-debug: exc: %s at " ^ Loc.to_string _loc ^ "@." in + <:expr< + try $e$ + with + [ Stream.Failure | Exit as exc -> raise exc + | exc -> do { + if Debug.mode "exc" then + Format.eprintf $`str:msg$ (Printexc.to_string exc) else (); + raise exc + } ] >>; + + value rec map_match_case = + fun + [ <:match_case@_loc< $m1$ | $m2$ >> -> + <:match_case< $map_match_case m1$ | $map_match_case m2$ >> + | <:match_case@_loc< $p$ when $w$ -> $e$ >> -> + <:match_case@_loc< $p$ when $w$ -> $add_debug_expr e$ >> + | m -> m ]; + + value filter = object + inherit Ast.map as super; + method expr = fun + [ <:expr@_loc< fun [ $m$ ] >> -> <:expr< fun [ $map_match_case m$ ] >> + | x -> super#expr x ]; + method str_item = fun + [ <:str_item< module Debug = $_$ >> as st -> st + | st -> super#str_item st ]; + end; + + register_str_item_filter filter#str_item; + +end; + +let module M = Camlp4.Register.AstFilter Id Make in (); diff --git a/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml b/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml new file mode 100644 index 0000000..c65c507 --- /dev/null +++ b/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml @@ -0,0 +1,628 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* OCaml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006-2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Camlp4 *) +(* source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + + +open Camlp4; + +module Id = struct + value name = "Camlp4FoldGenerator"; + value version = Sys.ocaml_version; +end; + +module Make (AstFilters : Camlp4.Sig.AstFilters) = struct + open AstFilters; + module StringMap = Map.Make String; + open Ast; + + value _loc = Loc.ghost; + + value sf = Printf.sprintf; + + value xik i k = + let i = + if i < 0 then assert False + else if i = 0 then "" + else sf "_i%d" i + in + let k = + if k < 1 then assert False + else if k = 1 then "" + else sf "_k%d" k + in + sf "_x%s%s" i k; + value exik i k = <:expr< $lid:xik i k$ >>; + value pxik i k = <:patt< $lid:xik i k$ >>; + value elidk y k = <:expr< $lid:sf "%s_%d" y k$ >>; + value plidk y k = <:patt< $lid:sf "%s_%d" y k$ >>; + + value xs s = "_x_" ^ s; + value xsk = sf "_x_%s_%d"; + value exsk s k = <:expr< $lid:xsk s k$>>; + + value rec apply_expr accu = + fun + [ [] -> accu + | [x :: xs] -> + let _loc = Ast.loc_of_expr x + in apply_expr <:expr< $accu$ $x$ >> xs ]; + + value rec apply_patt accu = + fun + [ [] -> accu + | [x :: xs] -> + let _loc = Ast.loc_of_patt x + in apply_patt <:patt< $accu$ $x$ >> xs ]; + + value rec apply_ctyp accu = + fun + [ [] -> accu + | [x :: xs] -> + let _loc = Ast.loc_of_ctyp x + in apply_ctyp <:ctyp< $accu$ $x$ >> xs ]; + + value opt_map f = fun [ Some x -> Some (f x) | None -> None ]; + + value list_init f n = + let rec self m = + if m = n then [] + else [f m :: self (succ m)] + in self 0; + + value rec lid_of_ident sep = + fun + [ <:ident< $lid:s$ >> | <:ident< $uid:s$ >> -> s + | <:ident< $i1$.$i2$ >> -> lid_of_ident sep i1 ^ sep ^ lid_of_ident sep i2 + | _ -> assert False ]; + + type type_decl = (string * Ast.ident * list Ast.ctyp * Ast.ctyp * bool); + + value builtin_types = + let tyMap = StringMap.empty in + let tyMap = + let abstr = ["string"; "int"; "float"; "int32"; "int64"; "nativeint"; "char"] in + List.fold_right + (fun name -> StringMap.add name (name, <:ident< $lid:name$ >>, [], <:ctyp<>>, False)) + abstr tyMap + in + let tyMap = + let concr = + [("bool", <:ident>, [], <:ctyp< [ False | True ] >>, False); + ("list", <:ident>, [ <:ctyp< 'a >> ], <:ctyp< [ $uid:"[]"$ | $uid:"::"$ of 'a and list 'a ] >>, False); + ("option", <:ident