From: Stefano Zacchiroli Date: Wed, 11 Apr 2007 09:23:08 +0000 (+0000) Subject: Imported Upstream version 3.10.0~beta X-Git-Tag: archive/raspbian/4.08.1-4+rpi1~3^2~63^2~34 X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=320c8884927e3556848073e9f2b462a9c13dbcbf;p=ocaml.git Imported Upstream version 3.10.0~beta --- diff --git a/.cvsignore b/.cvsignore index 413f2784..76ae30ef 100644 --- a/.cvsignore +++ b/.cvsignore @@ -12,3 +12,8 @@ ocamlcompopt.sh package-macosx .DS_Store *.annot +_boot_log1 +_boot_log2 +_build +_log +myocamlbuild_config.ml diff --git a/.depend b/.depend index bfe50fa3..dee02ef9 100644 --- a/.depend +++ b/.depend @@ -112,11 +112,11 @@ typing/datarepr.cmx: typing/types.cmx typing/predef.cmx utils/misc.cmx \ typing/env.cmo: typing/types.cmi utils/tbl.cmi typing/subst.cmi \ typing/predef.cmi typing/path.cmi utils/misc.cmi parsing/longident.cmi \ typing/ident.cmi typing/datarepr.cmi utils/consistbl.cmi utils/config.cmi \ - typing/btype.cmi parsing/asttypes.cmi typing/env.cmi + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/env.cmi typing/env.cmx: typing/types.cmx utils/tbl.cmx typing/subst.cmx \ typing/predef.cmx typing/path.cmx utils/misc.cmx parsing/longident.cmx \ typing/ident.cmx typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \ - typing/btype.cmx parsing/asttypes.cmi typing/env.cmi + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/env.cmi typing/ident.cmo: typing/ident.cmi typing/ident.cmx: typing/ident.cmi typing/includeclass.cmo: typing/types.cmi typing/printtyp.cmi \ @@ -235,14 +235,16 @@ typing/typemod.cmo: typing/types.cmi typing/typedtree.cmi typing/typedecl.cmi \ parsing/parsetree.cmi typing/mtype.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi typing/includemod.cmi \ typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/config.cmi \ - utils/clflags.cmi typing/btype.cmi typing/typemod.cmi + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + typing/typemod.cmi typing/typemod.cmx: typing/types.cmx typing/typedtree.cmx typing/typedecl.cmx \ typing/typecore.cmx typing/typeclass.cmx typing/subst.cmx \ typing/stypes.cmx typing/printtyp.cmx typing/path.cmx \ parsing/parsetree.cmi typing/mtype.cmx utils/misc.cmx \ parsing/longident.cmx parsing/location.cmx typing/includemod.cmx \ typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \ - utils/clflags.cmx typing/btype.cmx typing/typemod.cmi + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + typing/typemod.cmi typing/types.cmo: typing/primitive.cmi typing/path.cmi utils/misc.cmi \ typing/ident.cmi parsing/asttypes.cmi typing/types.cmi typing/types.cmx: typing/primitive.cmx typing/path.cmx utils/misc.cmx \ @@ -250,11 +252,11 @@ typing/types.cmx: typing/primitive.cmx typing/path.cmx utils/misc.cmx \ typing/typetexp.cmo: utils/warnings.cmi typing/types.cmi utils/tbl.cmi \ typing/printtyp.cmi typing/path.cmi parsing/parsetree.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi typing/env.cmi \ - typing/ctype.cmi typing/btype.cmi typing/typetexp.cmi + typing/ctype.cmi utils/clflags.cmi typing/btype.cmi typing/typetexp.cmi typing/typetexp.cmx: utils/warnings.cmx typing/types.cmx utils/tbl.cmx \ typing/printtyp.cmx typing/path.cmx parsing/parsetree.cmi utils/misc.cmx \ parsing/longident.cmx parsing/location.cmx typing/env.cmx \ - typing/ctype.cmx typing/btype.cmx typing/typetexp.cmi + typing/ctype.cmx utils/clflags.cmx typing/btype.cmx typing/typetexp.cmi typing/unused_var.cmo: utils/warnings.cmi parsing/parsetree.cmi \ parsing/longident.cmi parsing/location.cmi parsing/asttypes.cmi \ typing/unused_var.cmi @@ -262,10 +264,10 @@ typing/unused_var.cmx: utils/warnings.cmx parsing/parsetree.cmi \ parsing/longident.cmx parsing/location.cmx parsing/asttypes.cmi \ typing/unused_var.cmi bytecomp/bytegen.cmi: bytecomp/lambda.cmi bytecomp/instruct.cmi -bytecomp/bytelink.cmi: bytecomp/symtable.cmi bytecomp/emitcode.cmi +bytecomp/bytelink.cmi: bytecomp/symtable.cmi bytecomp/cmo_format.cmi bytecomp/bytepackager.cmi: typing/ident.cmi -bytecomp/emitcode.cmi: bytecomp/lambda.cmi bytecomp/instruct.cmi \ - typing/ident.cmi +bytecomp/cmo_format.cmi: bytecomp/lambda.cmi typing/ident.cmi +bytecomp/emitcode.cmi: bytecomp/instruct.cmi bytecomp/cmo_format.cmi bytecomp/instruct.cmi: typing/types.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 \ @@ -275,9 +277,9 @@ bytecomp/matching.cmi: typing/typedtree.cmi parsing/location.cmi \ bytecomp/printinstr.cmi: bytecomp/instruct.cmi bytecomp/printlambda.cmi: bytecomp/lambda.cmi bytecomp/simplif.cmi: bytecomp/lambda.cmi -bytecomp/symtable.cmi: typing/ident.cmi bytecomp/emitcode.cmi +bytecomp/symtable.cmi: typing/ident.cmi bytecomp/cmo_format.cmi bytecomp/translclass.cmi: typing/typedtree.cmi parsing/location.cmi \ - bytecomp/lambda.cmi typing/ident.cmi + bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi bytecomp/translcore.cmi: typing/types.cmi typing/typedtree.cmi \ typing/primitive.cmi typing/path.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi @@ -294,44 +296,46 @@ bytecomp/bytegen.cmx: typing/types.cmx bytecomp/switch.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 bytecomp/emitcode.cmi \ - utils/config.cmi utils/clflags.cmi bytecomp/bytelink.cmi \ +bytecomp/bytelibrarian.cmo: utils/misc.cmi utils/config.cmi \ + bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytelink.cmi \ bytecomp/bytelibrarian.cmi -bytecomp/bytelibrarian.cmx: utils/misc.cmx bytecomp/emitcode.cmx \ - utils/config.cmx utils/clflags.cmx bytecomp/bytelink.cmx \ +bytecomp/bytelibrarian.cmx: utils/misc.cmx utils/config.cmx \ + bytecomp/cmo_format.cmi utils/clflags.cmx bytecomp/bytelink.cmx \ bytecomp/bytelibrarian.cmi bytecomp/bytelink.cmo: bytecomp/symtable.cmi bytecomp/opcodes.cmo \ - utils/misc.cmi bytecomp/instruct.cmi typing/ident.cmi \ - bytecomp/emitcode.cmi bytecomp/dll.cmi utils/consistbl.cmi \ - utils/config.cmi utils/clflags.cmi utils/ccomp.cmi \ - bytecomp/bytesections.cmi bytecomp/bytelink.cmi + utils/misc.cmi bytecomp/instruct.cmi typing/ident.cmi bytecomp/dll.cmi \ + utils/consistbl.cmi utils/config.cmi bytecomp/cmo_format.cmi \ + utils/clflags.cmi utils/ccomp.cmi bytecomp/bytesections.cmi \ + bytecomp/bytelink.cmi bytecomp/bytelink.cmx: bytecomp/symtable.cmx bytecomp/opcodes.cmx \ - utils/misc.cmx bytecomp/instruct.cmx typing/ident.cmx \ - bytecomp/emitcode.cmx bytecomp/dll.cmx utils/consistbl.cmx \ - utils/config.cmx utils/clflags.cmx utils/ccomp.cmx \ - bytecomp/bytesections.cmx bytecomp/bytelink.cmi + utils/misc.cmx bytecomp/instruct.cmx typing/ident.cmx bytecomp/dll.cmx \ + utils/consistbl.cmx utils/config.cmx bytecomp/cmo_format.cmi \ + utils/clflags.cmx utils/ccomp.cmx bytecomp/bytesections.cmx \ + bytecomp/bytelink.cmi bytecomp/bytepackager.cmo: typing/typemod.cmi bytecomp/translmod.cmi \ utils/misc.cmi bytecomp/instruct.cmi typing/ident.cmi typing/env.cmi \ - bytecomp/emitcode.cmi utils/config.cmi utils/clflags.cmi \ - bytecomp/bytelink.cmi bytecomp/bytegen.cmi bytecomp/bytepackager.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 \ utils/misc.cmx bytecomp/instruct.cmx typing/ident.cmx typing/env.cmx \ - bytecomp/emitcode.cmx utils/config.cmx utils/clflags.cmx \ - bytecomp/bytelink.cmx bytecomp/bytegen.cmx bytecomp/bytepackager.cmi + bytecomp/emitcode.cmx utils/config.cmx bytecomp/cmo_format.cmi \ + utils/clflags.cmx bytecomp/bytelink.cmx bytecomp/bytegen.cmx \ + bytecomp/bytepackager.cmi bytecomp/bytesections.cmo: utils/config.cmi bytecomp/bytesections.cmi bytecomp/bytesections.cmx: utils/config.cmx bytecomp/bytesections.cmi bytecomp/dll.cmo: utils/misc.cmi utils/config.cmi bytecomp/dll.cmi bytecomp/dll.cmx: utils/misc.cmx utils/config.cmx bytecomp/dll.cmi bytecomp/emitcode.cmo: bytecomp/translmod.cmi bytecomp/opcodes.cmo \ utils/misc.cmi bytecomp/meta.cmi bytecomp/lambda.cmi \ - bytecomp/instruct.cmi typing/ident.cmi typing/env.cmi utils/config.cmi \ - utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ - bytecomp/emitcode.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 bytecomp/opcodes.cmx \ utils/misc.cmx bytecomp/meta.cmx bytecomp/lambda.cmx \ - bytecomp/instruct.cmx typing/ident.cmx typing/env.cmx utils/config.cmx \ - utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ - bytecomp/emitcode.cmi + 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 parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi bytecomp/instruct.cmi bytecomp/instruct.cmx: typing/types.cmx parsing/location.cmx \ @@ -376,23 +380,23 @@ bytecomp/switch.cmo: bytecomp/switch.cmi bytecomp/switch.cmx: bytecomp/switch.cmi bytecomp/symtable.cmo: utils/tbl.cmi bytecomp/runtimedef.cmi \ typing/predef.cmi utils/misc.cmi bytecomp/meta.cmi bytecomp/lambda.cmi \ - typing/ident.cmi bytecomp/emitcode.cmi bytecomp/dll.cmi utils/clflags.cmi \ - bytecomp/bytesections.cmi parsing/asttypes.cmi bytecomp/symtable.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 bytecomp/lambda.cmx \ - typing/ident.cmx bytecomp/emitcode.cmx bytecomp/dll.cmx utils/clflags.cmx \ - bytecomp/bytesections.cmx parsing/asttypes.cmi bytecomp/symtable.cmi + 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 typing/typeclass.cmi bytecomp/translobj.cmi \ - bytecomp/translcore.cmi typing/path.cmi utils/misc.cmi \ - bytecomp/matching.cmi parsing/location.cmi bytecomp/lambda.cmi \ - typing/ident.cmi typing/env.cmi typing/ctype.cmi utils/clflags.cmi \ + typing/typedtree.cmi bytecomp/translobj.cmi bytecomp/translcore.cmi \ + typing/path.cmi utils/misc.cmi bytecomp/matching.cmi parsing/location.cmi \ + bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi utils/clflags.cmi \ typing/btype.cmi parsing/asttypes.cmi bytecomp/translclass.cmi bytecomp/translclass.cmx: typing/types.cmx bytecomp/typeopt.cmx \ - typing/typedtree.cmx typing/typeclass.cmx bytecomp/translobj.cmx \ - bytecomp/translcore.cmx typing/path.cmx utils/misc.cmx \ - bytecomp/matching.cmx parsing/location.cmx bytecomp/lambda.cmx \ - typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/clflags.cmx \ + typing/typedtree.cmx bytecomp/translobj.cmx bytecomp/translcore.cmx \ + typing/path.cmx utils/misc.cmx bytecomp/matching.cmx parsing/location.cmx \ + bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx utils/clflags.cmx \ typing/btype.cmx parsing/asttypes.cmi bytecomp/translclass.cmi bytecomp/translcore.cmo: typing/types.cmi bytecomp/typeopt.cmi \ typing/typedtree.cmi bytecomp/translobj.cmi typing/primitive.cmi \ @@ -437,18 +441,21 @@ bytecomp/typeopt.cmx: typing/types.cmx typing/typedtree.cmx \ asmcomp/asmgen.cmi: bytecomp/lambda.cmi asmcomp/cmm.cmi asmcomp/asmlink.cmi: asmcomp/compilenv.cmi asmcomp/clambda.cmi: bytecomp/lambda.cmi typing/ident.cmi \ - parsing/asttypes.cmi + asmcomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/closure.cmi: bytecomp/lambda.cmi asmcomp/clambda.cmi -asmcomp/cmm.cmi: typing/ident.cmi +asmcomp/cmm.cmi: typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/cmmgen.cmi: asmcomp/cmm.cmi asmcomp/clambda.cmi asmcomp/codegen.cmi: asmcomp/cmm.cmi asmcomp/comballoc.cmi: asmcomp/mach.cmi asmcomp/compilenv.cmi: typing/ident.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/linearize.cmi: asmcomp/reg.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/liveness.cmi: asmcomp/mach.cmi -asmcomp/mach.cmi: asmcomp/reg.cmi asmcomp/cmm.cmi asmcomp/arch.cmo +asmcomp/mach.cmi: asmcomp/reg.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ + asmcomp/arch.cmo asmcomp/printcmm.cmi: asmcomp/cmm.cmi asmcomp/printlinear.cmi: asmcomp/linearize.cmi asmcomp/printmach.cmi: asmcomp/reg.cmi asmcomp/mach.cmi @@ -459,12 +466,12 @@ 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/cmm.cmi asmcomp/arch.cmo + 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: utils/misc.cmi -asmcomp/arch.cmx: utils/misc.cmx +asmcomp/arch.cmo: utils/misc.cmi utils/config.cmi +asmcomp/arch.cmx: utils/misc.cmx utils/config.cmx asmcomp/asmgen.cmo: 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 \ @@ -508,29 +515,31 @@ asmcomp/asmpackager.cmx: typing/typemod.cmx bytecomp/translmod.cmx \ asmcomp/clambda.cmx utils/ccomp.cmx asmcomp/asmlink.cmx \ asmcomp/asmgen.cmx asmcomp/asmpackager.cmi asmcomp/clambda.cmo: bytecomp/lambda.cmi typing/ident.cmi \ - parsing/asttypes.cmi asmcomp/clambda.cmi + asmcomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/clambda.cmi asmcomp/clambda.cmx: bytecomp/lambda.cmx typing/ident.cmx \ - parsing/asttypes.cmi asmcomp/clambda.cmi + 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/compilenv.cmi \ - utils/clflags.cmi asmcomp/clambda.cmi parsing/asttypes.cmi \ - asmcomp/closure.cmi + utils/misc.cmi bytecomp/lambda.cmi typing/ident.cmi asmcomp/debuginfo.cmi \ + asmcomp/compilenv.cmi utils/clflags.cmi asmcomp/clambda.cmi \ + parsing/asttypes.cmi asmcomp/closure.cmi asmcomp/closure.cmx: utils/tbl.cmx bytecomp/switch.cmx typing/primitive.cmx \ - utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx asmcomp/compilenv.cmx \ - utils/clflags.cmx asmcomp/clambda.cmx parsing/asttypes.cmi \ - asmcomp/closure.cmi -asmcomp/cmm.cmo: typing/ident.cmi asmcomp/arch.cmo asmcomp/cmm.cmi -asmcomp/cmm.cmx: typing/ident.cmx asmcomp/arch.cmx asmcomp/cmm.cmi + utils/misc.cmx bytecomp/lambda.cmx typing/ident.cmx asmcomp/debuginfo.cmx \ + asmcomp/compilenv.cmx utils/clflags.cmx asmcomp/clambda.cmx \ + parsing/asttypes.cmi asmcomp/closure.cmi +asmcomp/cmm.cmo: typing/ident.cmi asmcomp/debuginfo.cmi asmcomp/arch.cmo \ + asmcomp/cmm.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 \ - utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmm.cmi utils/clflags.cmi \ - asmcomp/clambda.cmi parsing/asttypes.cmi asmcomp/arch.cmo \ - asmcomp/cmmgen.cmi + asmcomp/debuginfo.cmi utils/config.cmi asmcomp/compilenv.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 \ - utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmm.cmx utils/clflags.cmx \ - asmcomp/clambda.cmx parsing/asttypes.cmi asmcomp/arch.cmx \ - asmcomp/cmmgen.cmi + asmcomp/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \ + 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 \ @@ -551,42 +560,58 @@ asmcomp/compilenv.cmo: utils/misc.cmi typing/ident.cmi typing/env.cmi \ utils/config.cmi asmcomp/clambda.cmi asmcomp/compilenv.cmi asmcomp/compilenv.cmx: utils/misc.cmx typing/ident.cmx typing/env.cmx \ utils/config.cmx 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 parsing/location.cmi asmcomp/linearize.cmi \ - asmcomp/emitaux.cmi utils/config.cmi asmcomp/compilenv.cmi \ - asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/emit.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 parsing/location.cmx asmcomp/linearize.cmx \ - asmcomp/emitaux.cmx utils/config.cmx asmcomp/compilenv.cmx \ - asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/emit.cmi -asmcomp/emitaux.cmo: asmcomp/emitaux.cmi -asmcomp/emitaux.cmx: asmcomp/emitaux.cmi + asmcomp/emitaux.cmx asmcomp/debuginfo.cmx utils/config.cmx \ + asmcomp/compilenv.cmx asmcomp/cmm.cmx utils/clflags.cmx asmcomp/arch.cmx \ + asmcomp/emit.cmi +asmcomp/emitaux.cmo: asmcomp/reg.cmi asmcomp/linearize.cmi \ + asmcomp/debuginfo.cmi asmcomp/cmm.cmi asmcomp/arch.cmo \ + asmcomp/emitaux.cmi +asmcomp/emitaux.cmx: asmcomp/reg.cmx asmcomp/linearize.cmx \ + asmcomp/debuginfo.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ + asmcomp/emitaux.cmi asmcomp/interf.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ asmcomp/mach.cmi asmcomp/interf.cmi asmcomp/interf.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ asmcomp/mach.cmx asmcomp/interf.cmi asmcomp/linearize.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ - asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/linearize.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/cmm.cmx asmcomp/linearize.cmi + 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/cmm.cmi asmcomp/arch.cmo \ - asmcomp/mach.cmi -asmcomp/mach.cmx: asmcomp/reg.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ - asmcomp/mach.cmi -asmcomp/printcmm.cmo: typing/ident.cmi asmcomp/cmm.cmi asmcomp/printcmm.cmi -asmcomp/printcmm.cmx: typing/ident.cmx asmcomp/cmm.cmx asmcomp/printcmm.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/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/printlinear.cmi + asmcomp/linearize.cmi asmcomp/debuginfo.cmi asmcomp/printlinear.cmi asmcomp/printlinear.cmx: asmcomp/printmach.cmx asmcomp/mach.cmx \ - asmcomp/linearize.cmx asmcomp/printlinear.cmi + 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/cmm.cmi asmcomp/arch.cmo asmcomp/printmach.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/cmm.cmx asmcomp/arch.cmx asmcomp/printmach.cmi + 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 @@ -595,8 +620,10 @@ asmcomp/proc.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.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/reload.cmi -asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reload.cmi +asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ + asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/reload.cmi +asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \ + asmcomp/cmm.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 \ @@ -607,20 +634,20 @@ asmcomp/schedgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ asmcomp/schedgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ asmcomp/linearize.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ asmcomp/schedgen.cmi -asmcomp/scheduling.cmo: asmcomp/schedgen.cmi asmcomp/mach.cmi \ - asmcomp/arch.cmo asmcomp/scheduling.cmi -asmcomp/scheduling.cmx: asmcomp/schedgen.cmx asmcomp/mach.cmx \ - asmcomp/arch.cmx asmcomp/scheduling.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 asmcomp/reg.cmi asmcomp/proc.cmi \ - utils/misc.cmi asmcomp/mach.cmi typing/ident.cmi asmcomp/cmm.cmi \ - asmcomp/arch.cmo asmcomp/selectgen.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 asmcomp/reg.cmx asmcomp/proc.cmx \ - utils/misc.cmx asmcomp/mach.cmx typing/ident.cmx asmcomp/cmm.cmx \ - asmcomp/arch.cmx asmcomp/selectgen.cmi -asmcomp/selection.cmo: asmcomp/selectgen.cmi asmcomp/reg.cmi utils/misc.cmi \ - asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/selection.cmi -asmcomp/selection.cmx: asmcomp/selectgen.cmx asmcomp/reg.cmx utils/misc.cmx \ - asmcomp/mach.cmx asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/selection.cmi + utils/misc.cmx asmcomp/mach.cmx typing/ident.cmx asmcomp/debuginfo.cmx \ + asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/selectgen.cmi +asmcomp/selection.cmo: asmcomp/selectgen.cmi asmcomp/reg.cmi asmcomp/proc.cmi \ + utils/misc.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ + asmcomp/arch.cmo asmcomp/selection.cmi +asmcomp/selection.cmx: asmcomp/selectgen.cmx asmcomp/reg.cmx asmcomp/proc.cmx \ + utils/misc.cmx asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \ + asmcomp/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 \ @@ -736,17 +763,15 @@ toplevel/genprintval.cmx: typing/types.cmx typing/printtyp.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/emitcode.cmi bytecomp/dll.cmi typing/ctype.cmi \ - utils/consistbl.cmi utils/config.cmi utils/clflags.cmi \ - toplevel/topdirs.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/emitcode.cmx bytecomp/dll.cmx typing/ctype.cmx \ - utils/consistbl.cmx utils/config.cmx utils/clflags.cmx \ - toplevel/topdirs.cmi + parsing/longident.cmx typing/ident.cmx typing/env.cmx bytecomp/dll.cmx \ + typing/ctype.cmx utils/consistbl.cmx utils/config.cmx \ + bytecomp/cmo_format.cmi utils/clflags.cmx toplevel/topdirs.cmi toplevel/toploop.cmo: utils/warnings.cmi typing/unused_var.cmi \ typing/types.cmi typing/typemod.cmi typing/typedtree.cmi \ typing/typecore.cmi bytecomp/translmod.cmi bytecomp/symtable.cmi \ diff --git a/Changes b/Changes index 4a3d4e15..2e06234d 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,79 @@ +Objective Caml 3.10.0: +---------------------- + +(Changes that can break existing programs are marked with a "*" ) + +Language features: +- Added virtual instance variables in classes "val virtual v : t" +* Changed the behaviour of instance variable overriding; the new + definition replaces the old one, rather than creating a new + variable. + +New tools: +- ocamlbuild: compilation manager for OCaml applications and libraries. + See draft documentation at http://gallium.inria.fr/~pouillar/ +* Camlp4: heavily revised implementation, new API. + +New ports: +- MacOS X PowerPC 64 bits. +- MS Windows 64 bits (x64) using the Microsoft PSDK toolchain. +- MS Windows 32 bits using the Visual Studio 2005 toolchain. + +Compilers: +- Faster type-checking of functor applications. +- Referencing an interface compiled with -rectypes from a module + not compiled with -rectypes is now an error. +- Revised the "fragile matching" warning. + +Native-code compiler: +- Print a stack backtrace on an uncaught exception. + (Compile and link with ocamlopt -g; execute with OCAMLRUNPARAM=b.) + Supported on Intel/AMD in 32 and 64 bits, PPC in 32 and 64 bits. +- Stack overflow detection on MS Windows 32 bits (courtesy O. Andrieu). +- Stack overflow detection on MacOS X PPC and Intel. +- Intel/AMD 64 bits: generate position-independent code by default. +- Fixed bug involving -for-pack and missing .cmx files (PR#4124). +- Fixed bug causing duplication of literals (PR#4152). + +Run-time system: +- C/Caml interface functions take "char const *" arguments + instead of "char *" when appropriate. +- Faster string comparisons (fast case if strings are ==). + +Standard library: +- Refined typing of format strings (type format6). +- Printf, Format: new function ifprintf that consumes its arguments + and prints nothing (useful to print conditionally). +- Scanf: + new function format_from_string to convert a string to a format string; + new %r conversion to accomodate user defined scanners. +- Filename: improved Win32 implementation of Filename.quote. +- List: List.nth now tail-recursive. +- Sys: added Sys.is_directory. Some functions (e.g. Sys.command) that + could incorrectly raise Sys_io_blocked now raise Sys_error as intended. + +Other libraries: +- Bigarray: mmap_file takes an optional argument specifying + the start position of the data in the mapped file. +- Dynlink: now defines only two modules, Dynlink and Dynlinkaux (internal), + reducing risks of name conflicts with user modules. +- Labltk under Win32: now uses Tcl/Tk 8.4 instead of 8.3 by default. +- VM threads: improved performance of I/O operations (less polling). +- Unix: new function Unix.isatty. +- Unix emulation under Win32: + fixed incorrect error reporting in several functions (PR#4097); + better handling of channels opened on sockets (PR#4098); + fixed GC bug in Unix.system (PR#4112). + +Documentation generator (OCamldoc): +- correctly handle '?' in value names (PR#4215) +- new option -hide-warnings not to print ocamldoc warnings + +Lexer generator (ocamllex): improved error reporting. + +License: fixed a typo in the "special exception" to the LGPL. + + Objective Caml 3.09.3: ---------------------- @@ -33,6 +109,7 @@ New features: - ocamlprof: added "-version" option + Objective Caml 3.09.2: ---------------------- @@ -2073,4 +2150,4 @@ Caml Special Light 1.06: * First public release. -$Id: Changes,v 1.156.2.16 2006/09/12 08:58:01 doligez Exp $ +$Id: Changes,v 1.168.2.3 2007/03/06 15:38:21 xleroy Exp $ diff --git a/INSTALL b/INSTALL index 1105a143..a1f06f4f 100644 --- a/INSTALL +++ b/INSTALL @@ -185,6 +185,11 @@ An alternative, and faster approach to steps 2 to 5 is The result is equivalent to "make world opt opt.opt", but this may fail if anything goes wrong in native-code generation. +Another alternative, is to use the experimental build system that use +ocamlbuild instead of make (it replaces steps 2 to 5): + + ./build/fastworld.sh + 6- You can now install the Objective Caml system. This will create the following commands (in the binary directory selected during autoconfiguration): @@ -214,6 +219,10 @@ From the top directory, become superuser and do: umask 022 # make sure to give read & execute permission to all make install + In the ocamlbuild setting instead of make install do: + + ./build/install.sh + 7- Installation is complete. Time to clean up. From the toplevel directory, do "make clean". @@ -261,6 +270,9 @@ pinpoint the problem. COMMON PROBLEMS: +* The Makefiles do not support parallel make (e.g. make -j2). +Fix: do not pass the -j option to make, and be patient. + * The Makefiles use the "include" directive, which is not supported by all versions of make. Use GNU make if this is a problem. diff --git a/LICENSE b/LICENSE index fce2fad2..cecc326c 100644 --- a/LICENSE +++ b/LICENSE @@ -30,7 +30,7 @@ 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 3 of the GNU Library General Public +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. diff --git a/Makefile b/Makefile index 70164cd2..e9b30144 100644 --- a/Makefile +++ b/Makefile @@ -10,7 +10,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.199.2.1 2006/02/09 09:17:23 garrigue Exp $ +# $Id: Makefile,v 1.207.4.1 2007/03/05 09:18:22 pouillar Exp $ # The main Makefile @@ -68,7 +68,8 @@ BYTECOMP=bytecomp/meta.cmo bytecomp/instruct.cmo bytecomp/bytegen.cmo \ bytecomp/bytesections.cmo bytecomp/dll.cmo bytecomp/symtable.cmo \ bytecomp/bytelink.cmo bytecomp/bytelibrarian.cmo bytecomp/bytepackager.cmo -ASMCOMP=asmcomp/arch.cmo asmcomp/cmm.cmo asmcomp/printcmm.cmo \ +ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ + asmcomp/cmm.cmo asmcomp/printcmm.cmo \ asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \ asmcomp/clambda.cmo asmcomp/compilenv.cmo \ asmcomp/closure.cmo asmcomp/cmmgen.cmo \ @@ -123,7 +124,7 @@ defaultentry: # Recompile the system using the bootstrap compiler all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml \ - otherlibraries camlp4out $(DEBUGGER) ocamldoc + otherlibraries ocamlbuild.byte camlp4out $(DEBUGGER) ocamldoc # The compilation of ocaml will fail if the runtime has changed. # Never mind, just do make bootstrap to reach fixpoint again. @@ -223,12 +224,12 @@ cleanboot: # Compile the native-code compiler opt-core:runtimeopt ocamlopt libraryopt -opt: runtimeopt ocamlopt libraryopt otherlibrariesopt camlp4opt +opt: runtimeopt ocamlopt libraryopt otherlibrariesopt # Native-code versions of the tools opt.opt: checkstack runtime core ocaml opt-core ocamlc.opt otherlibraries \ - camlp4out $(DEBUGGER) ocamldoc ocamlopt.opt otherlibrariesopt \ - camlp4opt ocamllex.opt ocamltoolsopt.opt camlp4optopt ocamldoc.opt + ocamlbuild.byte camlp4out $(DEBUGGER) ocamldoc ocamlopt.opt otherlibrariesopt \ + ocamllex.opt ocamltoolsopt.opt ocamlbuild.native camlp4opt ocamldoc.opt # Installation install: FORCE @@ -257,10 +258,10 @@ install: FORCE done cd ocamldoc; $(MAKE) install if test -f ocamlopt; then $(MAKE) installopt; else :; fi - cd camlp4; $(MAKE) install BINDIR=$(BINDIR) LIBDIR=$(LIBDIR) MANDIR=$(MANDIR) if test -f debugger/ocamldebug; then (cd debugger; $(MAKE) install); \ else :; fi cp config/Makefile $(LIBDIR)/Makefile.config + ./build/partial-install.sh # Installation of the native-code compiler installopt: @@ -324,8 +325,8 @@ utils/config.ml: utils/config.mlp config/Makefile -e 's|%%BYTELINK%%|$(BYTECC) $(BYTECCLINKOPTS)|' \ -e 's|%%NATIVECC%%|$(NATIVECC) $(NATIVECCCOMPOPTS)|' \ -e 's|%%NATIVELINK%%|$(NATIVECC) $(NATIVECCLINKOPTS)|' \ - -e 's|%%PARTIALLD%%|ld -r $(NATIVECCLINKOPTS)|' \ - -e 's|%%PACKLD%%|ld -r $(NATIVECCLINKOPTS)|' \ + -e 's|%%PARTIALLD%%|$(PARTIALLD) $(NATIVECCLINKOPTS)|' \ + -e 's|%%PACKLD%%|$(PARTIALLD) $(NATIVECCLINKOPTS) -o |' \ -e 's|%%BYTECCLIBS%%|$(BYTECCLIBS)|' \ -e 's|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|' \ -e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \ @@ -604,16 +605,23 @@ alldepend:: # Camlp4 -camlp4out: ocamlc - cd camlp4; $(MAKE) all -camlp4opt: ocamlopt - cd camlp4; $(MAKE) opt -camlp4optopt: ocamlopt - cd camlp4; $(MAKE) opt.opt +camlp4out: ocamlc otherlibraries ocamlbuild-partial-boot ocamlbuild.byte + ./build/camlp4-byte-only.sh +camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-partial-boot ocamlbuild.native + ./build/camlp4-native-only.sh + +# Ocamlbuild + +ocamlbuild.byte: ocamlc otherlibraries ocamlbuild-partial-boot + ./build/ocamlbuild-byte-only.sh +ocamlbuild.native: ocamlopt otherlibrariesopt ocamlbuild-partial-boot + ./build/ocamlbuild-native-only.sh + +.PHONY: ocamlbuild-partial-boot +ocamlbuild-partial-boot: + ./build/partial-boot.sh partialclean:: - cd camlp4; $(MAKE) clean -alldepend:: - cd camlp4; $(MAKE) depend + rm -rf _build # Check that the stack limit is reasonable. diff --git a/Makefile.nt b/Makefile.nt index a9b5f6c5..91e9ed8e 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -10,7 +10,7 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.98 2005/09/24 16:20:36 xleroy Exp $ +# $Id: Makefile.nt,v 1.102.4.1 2007/03/05 09:18:22 pouillar Exp $ # The main Makefile @@ -64,7 +64,8 @@ BYTECOMP=bytecomp/meta.cmo bytecomp/instruct.cmo bytecomp/bytegen.cmo \ bytecomp/bytesections.cmo bytecomp/dll.cmo bytecomp/symtable.cmo \ bytecomp/bytelink.cmo bytecomp/bytelibrarian.cmo bytecomp/bytepackager.cmo -ASMCOMP=asmcomp/arch.cmo asmcomp/cmm.cmo asmcomp/printcmm.cmo \ +ASMCOMP=asmcomp/arch.cmo asmcomp/debuginfo.cmo \ + asmcomp/cmm.cmo asmcomp/printcmm.cmo \ asmcomp/reg.cmo asmcomp/mach.cmo asmcomp/proc.cmo \ asmcomp/clambda.cmo asmcomp/compilenv.cmo \ asmcomp/closure.cmo asmcomp/cmmgen.cmo \ @@ -113,7 +114,7 @@ defaultentry: @echo "Please refer to the installation instructions in file README.win32." # Recompile the system using the bootstrap compiler -all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml otherlibraries ocamldoc.byte camlp4out win32gui +all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml otherlibraries ocamldoc.byte ocamlbuild.byte camlp4out win32gui # The compilation of ocaml will fail if the runtime has changed. # Never mind, just do make bootstrap to reach fixpoint again. @@ -197,11 +198,11 @@ cleanboot: rm -rf boot/Saved/Saved.prev/* # Compile the native-code compiler -opt: runtimeopt ocamlopt libraryopt otherlibrariesopt camlp4opt +opt: runtimeopt ocamlopt libraryopt otherlibrariesopt # Native-code versions of the tools opt.opt: ocamlc.opt ocamlopt.opt ocamllex.opt ocamltoolsopt.opt \ - camlp4optopt ocamldoc.opt + ocamlbuild.native camlp4opt ocamldoc.opt # Installation install: installbyt installopt @@ -227,7 +228,7 @@ installbyt: mkdir -p $(STUBLIBDIR) for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i install; done cd win32caml ; $(MAKE) install - cd camlp4 ; make install + ./build/partial-install.sh cp config/Makefile $(LIBDIR)/Makefile.config cp README $(DISTRIB)/Readme.general.txt cp README.win32 $(DISTRIB)/Readme.windows.txt @@ -563,25 +564,23 @@ alldepend:: # Camlp4 -camlp4out: - cd camlp4/config ; \ - (cat Makefile.tpl; \ - echo 'EXE=.exe'; \ - echo 'O=$(O)'; \ - echo 'A=$(A)'; \ - echo 'OPT='; \ - echo 'OTOP=../..'; \ - echo 'OLIBDIR=$$(OTOP)/boot'; \ - echo 'BINDIR=$(BINDIR)'; \ - echo 'LIBDIR=$(LIBDIR)'; \ - echo 'MANDIR=' ) > Makefile - cd camlp4 ; $(MAKE) -camlp4opt: - cd camlp4 ; $(MAKE) opt -camlp4optopt: - cd camlp4; $(MAKE) opt.opt +camlp4out: ocamlc otherlibraries ocamlbuild-partial-boot ocamlbuild.byte + ./build/camlp4-byte-only.sh +camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-partial-boot ocamlbuild.native + ./build/camlp4-native-only.sh + +# Ocamlbuild + +ocamlbuild.byte: ocamlc otherlibraries ocamlbuild-partial-boot + ./build/ocamlbuild-byte-only.sh +ocamlbuild.native: ocamlopt otherlibrariesopt ocamlbuild-partial-boot + ./build/ocamlbuild-native-only.sh + +.PHONY: ocamlbuild-partial-boot +ocamlbuild-partial-boot: + ./build/partial-boot.sh partialclean:: - cd camlp4 ; $(MAKE) clean + rm -rf _build # The Win32 toplevel GUI diff --git a/README b/README index 0b621d03..bda82a15 100644 --- a/README +++ b/README @@ -133,3 +133,6 @@ configuration you are using (machine type, etc). You can also contact the implementors directly at caml@inria.fr. + +---- +$Id: README,v 1.44 2006/09/20 11:14:30 doligez Exp $ diff --git a/README.win32 b/README.win32 index cd13bdef..2ab75a6f 100644 --- a/README.win32 +++ b/README.win32 @@ -1,16 +1,20 @@ Release notes on the MS Windows ports of Objective Caml ------------------------------------------------------- -Starting with OCaml 3.05, there are no less than three ports of -Objective Caml for MS Windows available: +There are no less than four ports of Objective Caml for MS Windows available: - a native Win32 port, built with the Microsoft development tools; - a native Win32 port, built with the Cygwin/MinGW development tools; - a port consisting of the Unix sources compiled under the Cygwin - Unix-like environment for Windows. + Unix-like environment for Windows; + - a native Win64 port (64-bit Windows), built with the Microsoft + development tools. Here is a summary of the main differences between these ports: Native MS Native MinGW Cygwin + +64 bits? Win32 or Win64 Win32 only Win32 only + Third-party software required - for base bytecode system none none none - for ocamlc -custom MSVC Cygwin Cygwin @@ -56,7 +60,7 @@ out of the box, without additional software. The native-code compiler (ocamlopt) requires Visual C++ (items [1], [2]) and the Microsoft assembler MASM (item [3]). -The LablTk GUI requires Tcl/Tk 8.3 (item [4]). +The LablTk GUI requires Tcl/Tk 8.4 (item [4]). INSTALLATION: @@ -65,11 +69,11 @@ The binary distribution is a self-installing executable archive. Just run it and it should install OCaml automatically. To run programs that use the LablTK GUI, the directory where the -DLLs tk83.dll and tcl83.dll were installed (by the Tcl/Tk +DLLs tk84.dll and tcl84.dll were installed (by the Tcl/Tk installer) must be added to the PATH environment variable. To compile programs that use the LablTK GUI, the directory where the -libraries tk83.lib and tcl83.lib were installed (by the Tcl/Tk +libraries tk84.lib and tcl84.lib were installed (by the Tcl/Tk installer) must be added to the library search path in the LIB environment variable. E.g. if Tcl/Tk was installed in C:\tcl, add "C:\tcl\lib" to the LIB environment variable. @@ -77,11 +81,9 @@ environment variable. E.g. if Tcl/Tk was installed in C:\tcl, add THIRD-PARTY SOFTWARE: -[1] Visual C++ version 6 or later. We use Visual C++ 2003. - The free download Visual C++ 2005 Express Edition works under - Windows 2000, but not under Windows XP because of the "manifest" - annotations on DLLs, which are not yet supported by OCaml. - So, please stick with the 2003 edition for the time being. +[1] Visual C++ version 2005, 2003, or 6. + We use Visual C++ 2005 Express Edition, which can be downloaded for free + from http://www.microsoft.com. [2] Windows header files and development libraries. We found them in the Microsoft Windows Server 2003 SP1 Platform SDK, which can @@ -91,9 +93,8 @@ THIRD-PARTY SOFTWARE: downloaded for free from Microsoft's Web site; for directions, see http://users.easystreet.com/jkirwan/new/pctools.html. -[4] TCL/TK version 8.3. Windows binaries are available from - http://prdownloads.sourceforge.net/tcl/tcl832.exe. - +[4] TCL/TK version 8.4. Windows binaries are available as part of the + ActiveTCL distribution at http://www.activestate.com/products/ActiveTcl/ RECOMPILATION FROM THE SOURCES: @@ -106,8 +107,8 @@ You will need the following software components to perform the recompilation: - Items [1], [2], [3] and [4] from the list of recommended software above. - The Cygwin port of GNU tools, available from http://www.cygwin.com/ -Remember to add the directory where the libraries tk83.lib and -tcl83.lib were installed (by the Tcl/Tk installer) to the LIB variable +Remember to add the directory where the libraries tk84.lib and +tcl84.lib were installed (by the Tcl/Tk installer) to the LIB variable (library search path). To recompile, start a Cygwin shell and change to the top-level @@ -122,7 +123,7 @@ Normally, the only variables that need to be changed are PREFIX where to install everything TK_ROOT where TCL/TK was installed -Finally, use "make -f Makefile.nt" to build the system, e.g. +Finally, use "make -f Makefile.nt" to build the system, e.g. make -f Makefile.nt world make -f Makefile.nt bootstrap @@ -130,6 +131,10 @@ Finally, use "make -f Makefile.nt" to build the system, e.g. make -f Makefile.nt opt.opt make -f Makefile.nt install +Alternatively you can use the experimental build procdure using ocamlbuild: + + ./build/fastworld.sh + ./build/install.sh NOTES: @@ -177,9 +182,9 @@ Do *not* install the Mingw/MSYS development tools from www.mingw.org: these are not compatible with this Caml port (@responsefile not recognized on the command line). -The LablTk GUI requires Tcl/Tk 8.3. Windows binaries are -available from http://prdownloads.sourceforge.net/tcl/tcl832.exe. - +The LablTk GUI requires Tcl/Tk 8.4. Windows binaries are available +as part of the ActiveTCL distribution at +http://www.activestate.com/products/ActiveTcl/ INSTALLATION: @@ -187,11 +192,11 @@ The binary distribution is a self-installing executable archive. Just run it and it should install OCaml automatically. To run programs that use the LablTK GUI, the directory where the -DLLs tk83.dll and tcl83.dll were installed (by the Tcl/Tk +DLLs tk84.dll and tcl84.dll were installed (by the Tcl/Tk installer) must be added to the PATH environment variable. To compile programs that use the LablTK GUI, the directory where the -libraries tk83.lib and tcl83.lib were installed (by the Tcl/Tk +libraries tk84.lib and tcl84.lib were installed (by the Tcl/Tk installer) must be added to the library search path in the LIB environment variable. E.g. if Tcl/Tk was installed in C:\tcl, add "C:\tcl\lib" to the LIB environment variable. @@ -202,7 +207,7 @@ RECOMPILATION FROM THE SOURCES: You will need the following software components to perform the recompilation: - Windows NT, 2000, or XP. - Cygwin: http://sourceware.cygnus.com/cygwin/ -- TCL/TK version 8.3 (see above). +- TCL/TK version 8.4 (see above). Do *not* install the standalone distribution of MinGW, nor the companion MSYS tools: these have problems with long command lines. @@ -269,3 +274,82 @@ The libraries available in this port are "num", "str", "threads", "unix" and "labltk". "graph" is not available. The replay debugger is supported. +------------------------------------------------------------------------------ + + The native Win64 port built with the Microsoft Platform SDK compilers + --------------------------------------------------------------------- + +REQUIREMENTS: + +This port runs under MS Windows XP 64 and Server 64 on Intel64/AMD64 machines. + +The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...) +runs without any additional tools. + +Statically linking Caml bytecode with C code (ocamlc -custom) requires the +Microsoft Platform SDK compiler (item [1] in the section +"third-party software" below). Dynamic loading of DLLs is supported +out of the box, without additional software. + +The native-code compiler (ocamlopt) requires the Microsoft compiler +and the Microsoft assembler MASM64 (item [1]). + + +INSTALLATION: + +There is no binary distribution yet. Please compile from sources as +described below. + + +THIRD-PARTY SOFTWARE: + +[1] Microsoft Windows Server 2003 R2 Platform SDK for AMD64 (PSDK-amd64.exe). + Can be downloaded for free from http://www.microsoft.com/. + Includes all we need, namely a C compiler, the masm64 assembler, + Windows libraries and include files. + + +RECOMPILATION FROM THE SOURCES: + +The command-line tools can be recompiled from the Unix source +distribution (ocaml-X.YZ.tar.gz), which also contains the files modified +for Windows. + +You will need the following software components to perform the recompilation: +- Windows XP 64 or Server 64. +- The Platform SDK (item [1] from the list of recommended software above). +- The Cygwin port of GNU tools, available from http://www.cygwin.com/ + +To recompile, start a Cygwin shell and change to the top-level +directory of the OCaml distribution. Then, do + + cp config/m-nt.h config/m.h + cp config/s-nt.h config/s.h + cp config/Makefile.msvc64 config/Makefile + +Then, edit config/Makefile as needed, following the comments in this file. +Normally, the only variable that need to be changed is + PREFIX where to install everything + +If, for whatever reason, you want to use the Microsoft Visual C++ 2005 +compiler for AMD64 instead of the Platform SDK compiler, replace the line + EXTRALIBS=bufferoverflowu.lib +by + EXTRALIBS= + +Finally, use "make -f Makefile.nt" to build the system, e.g. + + make -f Makefile.nt world + make -f Makefile.nt bootstrap + make -f Makefile.nt opt + make -f Makefile.nt opt.opt + make -f Makefile.nt install + + +NOTES: + +* Libraries available in this port: "num", "str", "threads", "graphics", + and large parts of "unix". + +* The replay debugger and the graphical browser are not supported. + diff --git a/VERSION b/VERSION new file mode 100644 index 00000000..7f012712 --- /dev/null +++ b/VERSION @@ -0,0 +1,6 @@ +3.10.0+beta + +# The version string is the first line of this file. +# It must be in the format described in stdlib/sys.mli + +# $Id: VERSION,v 1.2.2.1 2007/03/05 15:45:05 xleroy Exp $ diff --git a/_tags b/_tags new file mode 100644 index 00000000..1ab6035f --- /dev/null +++ b/_tags @@ -0,0 +1,82 @@ +# Ocamlbuild tags file + +true: -traverse + +# Traverse only these directories +<{bytecomp,driver,stdlib,tools,asmcomp,camlp4,ocamlbuild,toplevel,ocamldoc,typing,otherlibs,utils,debugger,lex,parsing,byterun,asmrun}/**>: traverse + +"boot" or "byterun" or "asmrun": not_hygienic + +# These should not be required but it fails on *BSD and Windows... +"yacc" or "win32caml": not_hygienic + +# We want -g everywhere it's possible +true: debug + +# By default everything we link needs the stdlib +true: use_stdlib + +# The stdlib don't require the stdlib +: -use_stdlib + +<**/*.ml*>: warn_Alez + +"toplevel/topstart.byte": linkall + +: ocamldoc_sources +: include_unix, include_str, include_dynlink +"ocamldoc/odoc.byte": use_unix, use_str, use_dynlink +"ocamldoc/odoc_opt.native": use_unix, use_str + +: camlp4boot, -warn_Alez, warn_Ale +: -camlp4boot + or or "camlp4/Camlp4/Struct/Lexer.ml": -camlp4boot, -warn_Ale, warn_a +"camlp4/Camlp4Bin.byte" or "camlp4/mkcamlp4.byte" or "camlp4/camlp4lib.cma": use_dynlink +"camlp4/Camlp4/Printers/OCaml.ml" or "camlp4/Camlp4/Printers/OCamlr.ml": warn_Alezv +: include_unix +"camlp4/Camlp4/Struct/DynLoader.ml": include_dynlink +: include_toplevel + +: -warn_Alez, include_unix + +<**/pervasives.ml> or <**/pervasives.mli> or <**/camlinternalOO.mli>: nopervasives +<**/camlinternalOO*.cmx>: inline(0) +<**/scanf*.cmx>: inline(9) +<**/*Labels.ml*>: nolabels + +"tools/addlabels.ml": warn_s + + or : use_unix, use_dynlink, linkall +: include_unix + + or : ocamlmklib + or : ocamlmklib +: ocamlmklib +: ocamlmklib +: ocamlmklib + +: include_unix + +# See the remark about static linking of threads.cmxa in myocamlbuild.ml +: ocamlmklib + +"otherlibs/threads/pervasives.ml": include_unix + +: otherlibs +: otherlibs_unix +: otherlibs_win32unix +: otherlibs_bigarray +: otherlibs_num +: otherlibs_threads +: otherlibs_systhreads +: otherlibs_dbm +: otherlibs_graph +: otherlibs_win32graph +: otherlibs_labltk + + or : bootstrap_thread +: ocamlmklib +"otherlibs/labltk/browser/jglib.cma": -ocamlmklib +"otherlibs/labltk/browser/main.byte": use_unix, use_str, ocamlbrowser, bootstrap_thread +: include_unix, include_str +: include_unix diff --git a/asmcomp/alpha/emit.mlp b/asmcomp/alpha/emit.mlp index d52c2d80..3ef5cd45 100644 --- a/asmcomp/alpha/emit.mlp +++ b/asmcomp/alpha/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp,v 1.41.2.1 2006/03/29 14:49:19 doligez Exp $ *) +(* $Id: emit.mlp,v 1.42 2006/04/16 23:28:14 doligez Exp $ *) module LabelSet = Set.Make(struct type t = Linearize.label let compare = compare end) diff --git a/asmcomp/amd64/arch.ml b/asmcomp/amd64/arch.ml index 8c003c5d..b0b5534e 100644 --- a/asmcomp/amd64/arch.ml +++ b/asmcomp/amd64/arch.ml @@ -10,15 +10,17 @@ (* *) (***********************************************************************) -(* $Id: arch.ml,v 1.2 2005/10/13 03:53:52 xleroy Exp $ *) +(* $Id: arch.ml,v 1.3 2007/01/01 13:07:35 xleroy Exp $ *) (* Machine-specific command-line options *) -let pic_code = ref false +let pic_code = ref true let command_line_options = [ "-fPIC", Arg.Set pic_code, - " Generate position-independent machine code" ] + " Generate position-independent machine code (default)"; + "-fno-PIC", Arg.Clear pic_code, + " Generate position-dependent machine code" ] (* Specific operations for the AMD64 processor *) diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index 3c29ad0a..ae201a7a 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp,v 1.10.2.2 2006/03/29 14:49:19 doligez Exp $ *) +(* $Id: emit.mlp,v 1.13 2007/01/29 12:10:50 xleroy Exp $ *) (* Emission of x86-64 (AMD 64) assembly code *) @@ -65,11 +65,11 @@ let emit_label lbl = let emit_align n = ` .align {emit_int n}\n` - + let emit_Llabel fallthrough lbl = if not fallthrough && !fastcode_flag then emit_align 4; emit_label lbl - + (* Output a pseudo-register *) let emit_reg = function @@ -84,13 +84,13 @@ let emit_reg = function (* Output a reference to the lower 8, 16 or 32 bits of a register *) let reg_low_8_name = - [| "%al"; "%bl"; "%dil"; "%sil"; "%dl"; "%cl"; "%r8b"; "%r9b"; + [| "%al"; "%bl"; "%dil"; "%sil"; "%dl"; "%cl"; "%r8b"; "%r9b"; "%r10b"; "%r11b"; "%bpl"; "%r12b"; "%r13b" |] let reg_low_16_name = - [| "%ax"; "%bx"; "%di"; "%si"; "%dx"; "%cx"; "%r8w"; "%r9w"; + [| "%ax"; "%bx"; "%di"; "%si"; "%dx"; "%cx"; "%r8w"; "%r9w"; "%r10w"; "%r11w"; "%bp"; "%r12w"; "%r13w" |] let reg_low_32_name = - [| "%eax"; "%ebx"; "%edi"; "%esi"; "%edx"; "%ecx"; "%r8d"; "%r9d"; + [| "%eax"; "%ebx"; "%edi"; "%esi"; "%edx"; "%ecx"; "%r8d"; "%r9d"; "%r10d"; "%r11d"; "%ebp"; "%r12d"; "%r13d" |] let emit_subreg tbl r = @@ -131,16 +131,9 @@ let emit_addressing addr r n = if d <> 0 then emit_int d; `({emit_reg r.(n)}, {emit_reg r.(n+1)}, {emit_int scale})` -(* Record live pointers at call points *) - -type frame_descr = - { fd_lbl: int; (* Return address *) - fd_frame_size: int; (* Size of stack frame *) - fd_live_offset: int list } (* Offsets/regs of live addresses *) +(* Record live pointers at call points -- see Emitaux *) -let frame_descriptors = ref([] : frame_descr list) - -let record_frame_label live = +let record_frame_label live dbg = let lbl = new_label() in let live_offset = ref [] in Reg.Set.iter @@ -154,21 +147,12 @@ let record_frame_label live = frame_descriptors := { fd_lbl = lbl; fd_frame_size = frame_size(); - fd_live_offset = !live_offset } :: !frame_descriptors; + fd_live_offset = !live_offset; + fd_debuginfo = dbg } :: !frame_descriptors; lbl -let record_frame live = - let lbl = record_frame_label live in `{emit_label lbl}:\n` - -let emit_frame fd = - ` .quad {emit_label fd.fd_lbl}\n`; - ` .word {emit_int fd.fd_frame_size}\n`; - ` .word {emit_int (List.length fd.fd_live_offset)}\n`; - List.iter - (fun n -> - ` .word {emit_int n}\n`) - fd.fd_live_offset; - emit_align 8 +let record_frame live dbg = + let lbl = record_frame_label live dbg in `{emit_label lbl}:\n` (* Record calls to the GC -- we've moved them out of the way *) @@ -183,6 +167,38 @@ let emit_call_gc gc = `{emit_label gc.gc_lbl}: call {emit_symbol "caml_call_gc"}\n`; `{emit_label gc.gc_frame}: jmp {emit_label gc.gc_return_lbl}\n` +(* Record calls to caml_ml_array_bound_error. + In -g mode, we maintain one call to caml_ml_array_bound_error + per bound check site. Without -g, we can share a single call. *) + +type bound_error_call = + { bd_lbl: label; (* Entry label *) + bd_frame: label } (* Label of frame descriptor *) + +let bound_error_sites = ref ([] : bound_error_call list) +let bound_error_call = ref 0 + +let bound_error_label dbg = + if !Clflags.debug then begin + let lbl_bound_error = new_label() in + let lbl_frame = record_frame_label Reg.Set.empty dbg in + bound_error_sites := + { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; + lbl_bound_error + end else begin + if !bound_error_call = 0 then bound_error_call := new_label(); + !bound_error_call + end + +let emit_call_bound_error bd = + `{emit_label bd.bd_lbl}: call {emit_symbol "caml_ml_array_bound_error"}\n`; + `{emit_label bd.bd_frame}:\n` + +let emit_call_bound_errors () = + List.iter emit_call_bound_error !bound_error_sites; + if !bound_error_call > 0 then + `{emit_label !bound_error_call}: jmp {emit_symbol "caml_ml_array_bound_error"}\n` + (* Names for instructions *) let instr_for_intop = function @@ -217,7 +233,7 @@ let name_for_cond_branch = function | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" | Iunsigned Cle -> "be" | Iunsigned Cgt -> "a" | Iunsigned Clt -> "b" | Iunsigned Cge -> "ae" - + (* Output an = 0 or <> 0 test. *) let output_test_zero arg = @@ -277,8 +293,6 @@ let output_epilogue () = let function_name = ref "" (* Entry point for tail recursive calls *) let tailrec_entry_point = ref 0 -(* Label of trap for out-of-range accesses *) -let range_check_trap = ref 0 let float_constants = ref ([] : (int * string) list) @@ -318,10 +332,10 @@ let emit_instr fallthrough i = ` movq ${emit_symbol s}, {emit_reg i.res.(0)}\n` | Lop(Icall_ind) -> ` call *{emit_reg i.arg.(0)}\n`; - record_frame i.live - | Lop(Icall_imm s) -> + record_frame i.live i.dbg + | Lop(Icall_imm(s)) -> ` call {emit_symbol s}\n`; - record_frame i.live + record_frame i.live i.dbg | Lop(Itailcall_ind) -> output_epilogue(); ` jmp *{emit_reg i.arg.(0)}\n` @@ -336,7 +350,7 @@ let emit_instr fallthrough i = if alloc then begin ` leaq {emit_symbol s}(%rip), %rax\n`; ` call {emit_symbol "caml_c_call"}\n`; - record_frame i.live + record_frame i.live i.dbg end else begin ` call {emit_symbol s}\n` end @@ -389,7 +403,7 @@ let emit_instr fallthrough i = `{emit_label lbl_redo}: subq ${emit_int n}, %r15\n`; ` cmpq {emit_symbol "caml_young_limit"}(%rip), %r15\n`; let lbl_call_gc = new_label() in - let lbl_frame = record_frame_label i.live in + let lbl_frame = record_frame_label i.live Debuginfo.none in ` jb {emit_label lbl_call_gc}\n`; ` leaq 8(%r15), {emit_reg i.res.(0)}\n`; call_gc_sites := @@ -404,7 +418,7 @@ let emit_instr fallthrough i = | _ -> ` movq ${emit_int n}, %rax\n`; ` call {emit_symbol "caml_allocN"}\n` end; - `{record_frame i.live} leaq 8(%r15), {emit_reg i.res.(0)}\n` + `{record_frame i.live Debuginfo.none} leaq 8(%r15), {emit_reg i.res.(0)}\n` end | Lop(Iintop(Icomp cmp)) -> ` cmpq {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; @@ -417,13 +431,13 @@ let emit_instr fallthrough i = ` set{emit_string b} %al\n`; ` movzbq %al, {emit_reg i.res.(0)}\n` | Lop(Iintop Icheckbound) -> - if !range_check_trap = 0 then range_check_trap := new_label(); + let lbl = bound_error_label i.dbg in ` cmpq {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; - ` jbe {emit_label !range_check_trap}\n` + ` jbe {emit_label lbl}\n` | Lop(Iintop_imm(Icheckbound, n)) -> - if !range_check_trap = 0 then range_check_trap := new_label(); + let lbl = bound_error_label i.dbg in ` cmpq ${emit_int n}, {emit_reg i.arg.(0)}\n`; - ` jbe {emit_label !range_check_trap}\n` + ` jbe {emit_label lbl}\n` | Lop(Iintop(Idiv | Imod)) -> ` cqto\n`; ` idivq {emit_reg i.arg.(1)}\n` @@ -558,9 +572,14 @@ let emit_instr fallthrough i = ` addq $8, %rsp\n`; stack_offset := !stack_offset - 16 | Lraise -> - ` movq %r14, %rsp\n`; - ` popq %r14\n`; - ` ret\n` + if !Clflags.debug then begin + ` call {emit_symbol "caml_raise_exn"}\n`; + record_frame Reg.Set.empty i.dbg + end else begin + ` movq %r14, %rsp\n`; + ` popq %r14\n`; + ` ret\n` + end let rec emit_all fallthrough i = match i.desc with @@ -582,7 +601,7 @@ let emit_profile () = (* mcount preserves rax, rcx, rdx, rsi, rdi, r8, r9 explicitly and rbx, rbp, r12-r15 like all C functions. We need to preserve r10 and r11 ourselves, since Caml can - use them for argument passing. *) + use them for argument passing. *) ` pushq %r10\n`; ` movq %rsp, %rbp\n`; ` pushq %r11\n`; @@ -601,7 +620,8 @@ let fundecl fundecl = stack_offset := 0; float_constants := []; call_gc_sites := []; - range_check_trap := 0; + bound_error_sites := []; + bound_error_call := 0; ` .text\n`; emit_align 16; ` .globl {emit_symbol fundecl.fun_name}\n`; @@ -614,9 +634,7 @@ let fundecl fundecl = `{emit_label !tailrec_entry_point}:\n`; emit_all true fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; - if !range_check_trap > 0 then - `{emit_label !range_check_trap}: call {emit_symbol "caml_ml_array_bound_error"}\n`; - (* Never returns, but useful to have retaddr on stack for debugging *) + emit_call_bound_errors (); if !float_constants <> [] then begin ` .section .rodata.cst8,\"a\",@progbits\n`; List.iter emit_float_constant !float_constants @@ -683,6 +701,13 @@ let end_assembly() = let lbl = Compilenv.make_symbol (Some "frametable") in ` .globl {emit_symbol lbl}\n`; `{emit_symbol lbl}:\n`; - ` .quad {emit_int (List.length !frame_descriptors)}\n`; - List.iter emit_frame !frame_descriptors; - frame_descriptors := [] + emit_frames + { efa_label = (fun l -> ` .quad {emit_label l}\n`); + efa_16 = (fun n -> ` .word {emit_int n}\n`); + efa_32 = (fun n -> ` .long {emit_int32 n}\n`); + efa_word = (fun n -> ` .quad {emit_int n}\n`); + efa_align = emit_align; + efa_label_rel = (fun lbl ofs -> + ` .long ({emit_label lbl} - .) + {emit_int32 ofs}\n`); + efa_def_label = (fun l -> `{emit_label l}:\n`); + efa_string = (fun s -> emit_string_directive " .asciz " s) } diff --git a/asmcomp/amd64/emit_nt.mlp b/asmcomp/amd64/emit_nt.mlp new file mode 100644 index 00000000..da7de6a6 --- /dev/null +++ b/asmcomp/amd64/emit_nt.mlp @@ -0,0 +1,771 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: emit_nt.mlp,v 1.6 2007/03/01 10:26:51 xleroy Exp $ *) + +(* Emission of x86-64 (AMD 64) assembly code, MASM syntax *) + +module StringSet = + Set.Make(struct type t = string let compare = compare end) + +open Misc +open Cmm +open Arch +open Proc +open Reg +open Mach +open Linearize +open Emitaux + +(* Tradeoff between code size and code speed *) + +let fastcode_flag = ref true + +let stack_offset = ref 0 + +(* Layout of the stack frame *) + +let frame_required () = + !contains_calls || num_stack_slots.(0) > 0 || num_stack_slots.(1) > 0 + +let frame_size () = (* includes return address *) + if frame_required() then begin + let sz = + (!stack_offset + 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + 8) + in Misc.align sz 16 + end else + !stack_offset + 8 + +let slot_offset loc cl = + match loc with + Incoming n -> frame_size() + n + | Local n -> + if cl = 0 + then !stack_offset + n * 8 + else !stack_offset + (num_stack_slots.(0) + n) * 8 + | Outgoing n -> n + +(* Output a 32 bit integer in hex *) + +let emit_int32 n = emit_printf "0%lxh" n + +(* Symbols *) + +let emit_symbol s = + Emitaux.emit_symbol '$' s + +(* Record symbols used and defined - at the end generate extern for those + used but not defined *) + +let symbols_defined = ref StringSet.empty +let symbols_used = ref StringSet.empty + +let add_def_symbol s = + symbols_defined := StringSet.add s !symbols_defined + +let add_used_symbol s = + symbols_used := StringSet.add s !symbols_used + +(* Output a label *) + +let emit_label lbl = + emit_string "L"; emit_int lbl + +(* Output a .align directive. *) + +let emit_align n = + ` ALIGN {emit_int n}\n` + +let emit_Llabel fallthrough lbl = + if not fallthrough && !fastcode_flag then emit_align 4; + emit_label lbl + +(* Output a pseudo-register *) + +let emit_reg = function + { loc = Reg r } -> + emit_string (register_name r) + | { loc = Stack s; typ = Float } as r -> + let ofs = slot_offset s (register_class r) in + `REAL8 PTR {emit_int ofs}[rsp]` + | { loc = Stack s; typ = _ } as r -> + let ofs = slot_offset s (register_class r) in + `QWORD PTR {emit_int ofs}[rsp]` + | { loc = Unknown } -> + assert false + +(* Output a reference to the lower 8, 16 or 32 bits of a register *) + +let reg_low_8_name = + [| "al"; "bl"; "dil"; "sil"; "dl"; "cl"; "r8b"; "r9b"; + "r10b"; "r11b"; "bpl"; "r12b"; "r13b" |] +let reg_low_16_name = + [| "ax"; "bx"; "di"; "si"; "dx"; "cx"; "r8w"; "r9w"; + "r10w"; "r11w"; "bp"; "r12w"; "r13w" |] +let reg_low_32_name = + [| "eax"; "ebx"; "edi"; "esi"; "edx"; "ecx"; "r8d"; "r9d"; + "r10d"; "r11d"; "ebp"; "r12d"; "r13d" |] + +let emit_subreg tbl pref r = + match r.loc with + Reg r when r < 13 -> + emit_string tbl.(r) + | Stack s -> + let ofs = slot_offset s (register_class r) in + `{emit_string pref} PTR {emit_int ofs}[rsp]` + | _ -> + assert false + +let emit_reg8 r = emit_subreg reg_low_8_name "BYTE" r +let emit_reg16 r = emit_subreg reg_low_16_name "WORD" r +let emit_reg32 r = emit_subreg reg_low_32_name "DWORD" r + +(* Output an addressing mode *) + +let emit_signed_int d = + if d > 0 then emit_char '+'; + if d <> 0 then emit_int d + +let emit_addressing addr r n = + match addr with + Ibased(s, d) -> + add_used_symbol s; + `{emit_symbol s}{emit_signed_int d}` + | Iindexed d -> + `[{emit_reg r.(n)}{emit_signed_int d}]` + | Iindexed2 d -> + `[{emit_reg r.(n)}+{emit_reg r.(n+1)}{emit_signed_int d}]` + | Iscaled(2, d) -> + `[{emit_reg r.(n)}+{emit_reg r.(n)}{emit_signed_int d}]` + | Iscaled(scale, d) -> + `[{emit_reg r.(n)}*{emit_int scale}{emit_signed_int d}]` + | Iindexed2scaled(scale, d) -> + `[{emit_reg r.(n)}+{emit_reg r.(n+1)}*{emit_int scale}{emit_signed_int d}]` + +(* Record live pointers at call points *) + +let record_frame_label live dbg = + let lbl = new_label() in + let live_offset = ref [] in + Reg.Set.iter + (function + {typ = Addr; loc = Reg r} -> + live_offset := ((r lsl 1) + 1) :: !live_offset + | {typ = Addr; loc = Stack s} as reg -> + live_offset := slot_offset s (register_class reg) :: !live_offset + | _ -> ()) + live; + frame_descriptors := + { fd_lbl = lbl; + fd_frame_size = frame_size(); + fd_live_offset = !live_offset; + fd_debuginfo = dbg } :: !frame_descriptors; + lbl + +let record_frame live dbg = + let lbl = record_frame_label live dbg in `{emit_label lbl}:\n` + +(* Record calls to the GC -- we've moved them out of the way *) + +type gc_call = + { gc_lbl: label; (* Entry label *) + gc_return_lbl: label; (* Where to branch after GC *) + gc_frame: label } (* Label of frame descriptor *) + +let call_gc_sites = ref ([] : gc_call list) + +let emit_call_gc gc = + `{emit_label gc.gc_lbl}: call {emit_symbol "caml_call_gc"}\n`; + `{emit_label gc.gc_frame}: jmp {emit_label gc.gc_return_lbl}\n` + +(* Record calls to caml_ml_array_bound_error. + In -g mode, we maintain one call to caml_ml_array_bound_error + per bound check site. Without -g, we can share a single call. *) + +type bound_error_call = + { bd_lbl: label; (* Entry label *) + bd_frame: label } (* Label of frame descriptor *) + +let bound_error_sites = ref ([] : bound_error_call list) +let bound_error_call = ref 0 + +let bound_error_label dbg = + if !Clflags.debug then begin + let lbl_bound_error = new_label() in + let lbl_frame = record_frame_label Reg.Set.empty dbg in + bound_error_sites := + { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; + lbl_bound_error + end else begin + if !bound_error_call = 0 then bound_error_call := new_label(); + !bound_error_call + end + +let emit_call_bound_error bd = + `{emit_label bd.bd_lbl}: call caml_ml_array_bound_error\n`; + `{emit_label bd.bd_frame}:\n` + +let emit_call_bound_errors () = + List.iter emit_call_bound_error !bound_error_sites; + if !bound_error_call > 0 then + `{emit_label !bound_error_call}: jmp caml_ml_array_bound_error\n` + +(* Names for instructions *) + +let instr_for_intop = function + Iadd -> "add" + | Isub -> "sub" + | Imul -> "imul" + | Iand -> "and" + | Ior -> "or" + | Ixor -> "xor" + | Ilsl -> "sal" + | Ilsr -> "shr" + | Iasr -> "sar" + | _ -> assert false + +let instr_for_floatop = function + Iaddf -> "addsd" + | Isubf -> "subsd" + | Imulf -> "mulsd" + | Idivf -> "divsd" + | _ -> assert false + +let instr_for_floatarithmem = function + Ifloatadd -> "addsd" + | Ifloatsub -> "subsd" + | Ifloatmul -> "mulsd" + | Ifloatdiv -> "divsd" + +let name_for_cond_branch = function + Isigned Ceq -> "e" | Isigned Cne -> "ne" + | Isigned Cle -> "le" | Isigned Cgt -> "g" + | Isigned Clt -> "l" | Isigned Cge -> "ge" + | Iunsigned Ceq -> "e" | Iunsigned Cne -> "ne" + | Iunsigned Cle -> "be" | Iunsigned Cgt -> "a" + | Iunsigned Clt -> "b" | Iunsigned Cge -> "ae" + +(* Output an = 0 or <> 0 test. *) + +let output_test_zero arg = + match arg.loc with + Reg r -> ` test {emit_reg arg}, {emit_reg arg}\n` + | _ -> ` cmp {emit_reg arg}, 0\n` + +(* Output a floating-point compare and branch *) + +let emit_float_test cmp neg arg lbl = + begin match cmp with + | Ceq | Cne -> ` ucomisd ` + | _ -> ` comisd ` + end; + `{emit_reg arg.(0)}, {emit_reg arg.(1)}\n`; + let (branch_opcode, need_jp) = + match (cmp, neg) with + (Ceq, false) -> ("je", true) + | (Ceq, true) -> ("jne", true) + | (Cne, false) -> ("jne", true) + | (Cne, true) -> ("je", true) + | (Clt, false) -> ("jb", true) + | (Clt, true) -> ("jae", true) + | (Cle, false) -> ("jbe", true) + | (Cle, true) -> ("ja", true) + | (Cgt, false) -> ("ja", false) + | (Cgt, true) -> ("jbe", false) + | (Cge, false) -> ("jae", true) + | (Cge, true) -> ("jb", false) in + let branch_if_not_comparable = + if cmp = Cne then not neg else neg in + if need_jp then + if branch_if_not_comparable then begin + ` jp {emit_label lbl}\n`; + ` {emit_string branch_opcode} {emit_label lbl}\n` + end else begin + let next = new_label() in + ` jp {emit_label next}\n`; + ` {emit_string branch_opcode} {emit_label lbl}\n`; + `{emit_label next}:\n` + end + else begin + ` {emit_string branch_opcode} {emit_label lbl}\n` + end + +(* Deallocate the stack frame before a return or tail call *) + +let output_epilogue () = + if frame_required() then begin + let n = frame_size() - 8 in + ` add rsp, {emit_int n}\n` + end + +(* Output the assembly code for an instruction *) + +(* Name of current function *) +let function_name = ref "" +(* Entry point for tail recursive calls *) +let tailrec_entry_point = ref 0 + +let float_constants = ref ([] : (int * string) list) + +let emit_instr fallthrough i = + match i.desc with + Lend -> () + | Lop(Imove | Ispill | Ireload) -> + let src = i.arg.(0) and dst = i.res.(0) in + if src.loc <> dst.loc then begin + if src.typ = Float then + ` movsd {emit_reg dst}, {emit_reg src}\n` + else + ` mov {emit_reg dst}, {emit_reg src}\n` + end + | Lop(Iconst_int n) -> + if n = 0n then begin + match i.res.(0).loc with + Reg n -> ` xor {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` + | _ -> ` mov {emit_reg i.res.(0)}, 0\n` + end else if n >= -0x80000000n && n <= 0x7FFFFFFFn then + ` mov {emit_reg i.res.(0)}, {emit_nativeint n}\n` + else if n >= 0x80000000n && n <= 0xFFFFFFFFn then + (* work around bug in ml64 *) + ` mov {emit_reg32 i.res.(0)}, {emit_nativeint n}\n` + else + (* force ml64 to use mov reg, imm64 instruction *) + ` mov {emit_reg i.res.(0)}, {emit_printf "0%nxH" n}\n` + | Lop(Iconst_float s) -> + begin match Int64.bits_of_float (float_of_string s) with + | 0x0000_0000_0000_0000L -> (* +0.0 *) + ` xorpd {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` + | _ -> + let lbl = new_label() in + float_constants := (lbl, s) :: !float_constants; + ` movlpd {emit_reg i.res.(0)}, {emit_label lbl}\n` + end + | Lop(Iconst_symbol s) -> + add_used_symbol s; + if !pic_code then + ` lea {emit_reg i.res.(0)}, {emit_symbol s}\n` + else + ` mov {emit_reg i.res.(0)}, OFFSET {emit_symbol s}\n` + | Lop(Icall_ind) -> + ` call {emit_reg i.arg.(0)}\n`; + record_frame i.live i.dbg + | Lop(Icall_imm s) -> + add_used_symbol s; + ` call {emit_symbol s}\n`; + record_frame i.live i.dbg + | Lop(Itailcall_ind) -> + output_epilogue(); + ` jmp {emit_reg i.arg.(0)}\n` + | Lop(Itailcall_imm s) -> + if s = !function_name then + ` jmp {emit_label !tailrec_entry_point}\n` + else begin + add_used_symbol s; + output_epilogue(); + ` jmp {emit_symbol s}\n` + end + | Lop(Iextcall(s, alloc)) -> + add_used_symbol s; + if alloc then begin + ` lea rax, {emit_symbol s}\n`; + ` call {emit_symbol "caml_c_call"}\n`; + record_frame i.live i.dbg + end else begin + ` call {emit_symbol s}\n` + end + | Lop(Istackoffset n) -> + if n < 0 + then ` add rsp, {emit_int(-n)}\n` + else ` sub rsp, {emit_int(n)}\n`; + stack_offset := !stack_offset + n + | Lop(Iload(chunk, addr)) -> + let dest = i.res.(0) in + begin match chunk with + | Word -> + ` mov {emit_reg dest}, QWORD PTR {emit_addressing addr i.arg 0}\n` + | Byte_unsigned -> + ` movzx {emit_reg dest}, BYTE PTR {emit_addressing addr i.arg 0}\n` + | Byte_signed -> + ` movsx {emit_reg dest}, BYTE PTR {emit_addressing addr i.arg 0}\n` + | Sixteen_unsigned -> + ` movzx {emit_reg dest}, WORD PTR {emit_addressing addr i.arg 0}\n` + | Sixteen_signed -> + ` movsx {emit_reg dest}, WORD PTR {emit_addressing addr i.arg 0}\n` + | Thirtytwo_unsigned -> + (* load to low 32 bits sets high 32 bits to 0 *) + ` mov {emit_reg32 dest}, DWORD PTR {emit_addressing addr i.arg 0}\n` + | Thirtytwo_signed -> + ` movsxd {emit_reg dest}, DWORD PTR {emit_addressing addr i.arg 0}\n` + | Single -> + ` cvtss2sd {emit_reg dest}, REAL4 PTR {emit_addressing addr i.arg 0}\n` + | Double | Double_u -> + ` movlpd {emit_reg dest}, REAL8 PTR {emit_addressing addr i.arg 0}\n` + end + | Lop(Istore(chunk, addr)) -> + begin match chunk with + | Word -> + ` mov QWORD PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n` + | Byte_unsigned | Byte_signed -> + ` mov BYTE PTR {emit_addressing addr i.arg 1}, {emit_reg8 i.arg.(0)}\n` + | Sixteen_unsigned | Sixteen_signed -> + ` mov WORD PTR {emit_addressing addr i.arg 1}, {emit_reg16 i.arg.(0)}\n` + | Thirtytwo_signed | Thirtytwo_unsigned -> + ` mov DWORD PTR {emit_addressing addr i.arg 1}, {emit_reg32 i.arg.(0)}\n` + | Single -> + ` cvtsd2ss xmm15, {emit_reg i.arg.(0)}\n`; + ` movss REAL4 PTR {emit_addressing addr i.arg 1}, xmm15\n` + | Double | Double_u -> + ` movlpd REAL8 PTR {emit_addressing addr i.arg 1}, {emit_reg i.arg.(0)}\n` + end + | Lop(Ialloc n) -> + if !fastcode_flag then begin + let lbl_redo = new_label() in + `{emit_label lbl_redo}: sub r15, {emit_int n}\n`; + ` cmp r15, {emit_symbol "caml_young_limit"}\n`; + let lbl_call_gc = new_label() in + let lbl_frame = record_frame_label i.live Debuginfo.none in + ` jb {emit_label lbl_call_gc}\n`; + ` lea {emit_reg i.res.(0)}, [r15+8]\n`; + call_gc_sites := + { gc_lbl = lbl_call_gc; + gc_return_lbl = lbl_redo; + gc_frame = lbl_frame } :: !call_gc_sites + end else begin + begin match n with + 16 -> ` call {emit_symbol "caml_alloc1"}\n` + | 24 -> ` call {emit_symbol "caml_alloc2"}\n` + | 32 -> ` call {emit_symbol "caml_alloc3"}\n` + | _ -> ` mov rax, {emit_int n}\n`; + ` call {emit_symbol "caml_allocN"}\n` + end; + `{record_frame i.live Debuginfo.none} lea {emit_reg i.res.(0)}, [r15+8]\n` + end + | Lop(Iintop(Icomp cmp)) -> + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + let b = name_for_cond_branch cmp in + ` set{emit_string b} al\n`; + ` movzx {emit_reg i.res.(0)}, al\n` + | Lop(Iintop_imm(Icomp cmp, n)) -> + ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; + let b = name_for_cond_branch cmp in + ` set{emit_string b} al\n`; + ` movzx {emit_reg i.res.(0)}, al\n` + | Lop(Iintop Icheckbound) -> + let lbl = bound_error_label i.dbg in + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` jbe {emit_label lbl}\n` + | Lop(Iintop_imm(Icheckbound, n)) -> + let lbl = bound_error_label i.dbg in + ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; + ` jbe {emit_label lbl}\n` + | Lop(Iintop(Idiv | Imod)) -> + ` cqo\n`; + ` idiv {emit_reg i.arg.(1)}\n` + | Lop(Iintop(Ilsl | Ilsr | Iasr as op)) -> + (* We have i.arg.(0) = i.res.(0) and i.arg.(1) = %rcx *) + ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, cl\n` + | Lop(Iintop op) -> + (* We have i.arg.(0) = i.res.(0) *) + ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n` + | Lop(Iintop_imm(Iadd, n)) when i.arg.(0).loc <> i.res.(0).loc -> + ` lea {emit_reg i.res.(0)}, {emit_int n}[{emit_reg i.arg.(0)}]\n` + | Lop(Iintop_imm(Iadd, 1) | Iintop_imm(Isub, -1)) -> + ` inc {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Iadd, -1) | Iintop_imm(Isub, 1)) -> + ` dec {emit_reg i.res.(0)}\n` + | Lop(Iintop_imm(Idiv, n)) -> + (* Note: i.arg.(0) = i.res.(0) = rdx (cf. selection.ml) *) + let l = Misc.log2 n in + ` mov rax, {emit_reg i.arg.(0)}\n`; + ` add {emit_reg i.arg.(0)}, {emit_int(n-1)}\n`; + ` test rax, rax\n`; + ` cmovns {emit_reg i.arg.(0)}, rax\n`; + ` sar {emit_reg i.res.(0)}, {emit_int l}\n` + | Lop(Iintop_imm(Imod, n)) -> + (* Note: i.arg.(0) = i.res.(0) = rdx (cf. selection.ml) *) + ` mov rax, {emit_reg i.arg.(0)}\n`; + ` test rax, rax\n`; + ` lea rax, {emit_int(n-1)}[rax]\n`; + ` cmovns rax, {emit_reg i.arg.(0)}\n`; + ` and rax, {emit_int (-n)}\n`; + ` sub {emit_reg i.res.(0)}, rax\n` + | Lop(Iintop_imm(op, n)) -> + (* We have i.arg.(0) = i.res.(0) *) + ` {emit_string(instr_for_intop op)} {emit_reg i.res.(0)}, {emit_int n}\n` + | Lop(Inegf) -> + ` xorpd {emit_reg i.res.(0)}, {emit_symbol "caml_negf_mask"}\n` + | Lop(Iabsf) -> + ` andpd {emit_reg i.res.(0)}, {emit_symbol "caml_absf_mask"}\n` + | Lop(Iaddf | Isubf | Imulf | Idivf as floatop) -> + ` {emit_string(instr_for_floatop floatop)} {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}\n` + | Lop(Ifloatofint) -> + ` cvtsi2sd {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` + | Lop(Iintoffloat) -> + ` cvttsd2si {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}\n` + | Lop(Ispecific(Ilea addr)) -> + ` lea {emit_reg i.res.(0)}, {emit_addressing addr i.arg 0}\n` + | Lop(Ispecific(Istore_int(n, addr))) -> + ` mov QWORD PTR {emit_addressing addr i.arg 0}, {emit_nativeint n}\n` + | Lop(Ispecific(Istore_symbol(s, addr))) -> + assert (not !pic_code); + add_used_symbol s; + ` mov QWORD PTR {emit_addressing addr i.arg 0}, OFFSET {emit_symbol s}\n` + | Lop(Ispecific(Ioffset_loc(n, addr))) -> + ` add QWORD PTR {emit_addressing addr i.arg 0}, {emit_int n}\n` + | Lop(Ispecific(Ifloatarithmem(op, addr))) -> + ` {emit_string(instr_for_floatarithmem op)} {emit_reg i.res.(0)}, REAL8 PTR {emit_addressing addr i.arg 1}\n` + | Lreloadretaddr -> + () + | Lreturn -> + output_epilogue(); + ` ret\n` + | Llabel lbl -> + `{emit_Llabel fallthrough lbl}:\n` + | Lbranch lbl -> + ` jmp {emit_label lbl}\n` + | Lcondbranch(tst, lbl) -> + begin match tst with + Itruetest -> + output_test_zero i.arg.(0); + ` jne {emit_label lbl}\n` + | Ifalsetest -> + output_test_zero i.arg.(0); + ` je {emit_label lbl}\n` + | Iinttest cmp -> + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + let b = name_for_cond_branch cmp in + ` j{emit_string b} {emit_label lbl}\n` + | Iinttest_imm((Isigned Ceq | Isigned Cne | + Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> + output_test_zero i.arg.(0); + let b = name_for_cond_branch cmp in + ` j{emit_string b} {emit_label lbl}\n` + | Iinttest_imm(cmp, n) -> + ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; + let b = name_for_cond_branch cmp in + ` j{emit_string b} {emit_label lbl}\n` + | Ifloattest(cmp, neg) -> + emit_float_test cmp neg i.arg lbl + | Ioddtest -> + ` test {emit_reg8 i.arg.(0)}, 1\n`; + ` jne {emit_label lbl}\n` + | Ieventest -> + ` test {emit_reg8 i.arg.(0)}, 1\n`; + ` je {emit_label lbl}\n` + end + | Lcondbranch3(lbl0, lbl1, lbl2) -> + ` cmp {emit_reg i.arg.(0)}, 1\n`; + begin match lbl0 with + None -> () + | Some lbl -> ` jb {emit_label lbl}\n` + end; + begin match lbl1 with + None -> () + | Some lbl -> ` je {emit_label lbl}\n` + end; + begin match lbl2 with + None -> () + | Some lbl -> ` jg {emit_label lbl}\n` + end + | Lswitch jumptbl -> + let lbl = new_label() in + if !pic_code then begin + ` lea r11, {emit_label lbl}\n`; + ` jmp QWORD PTR [r11+{emit_reg i.arg.(0)}*8]\n` + end else begin + ` jmp QWORD PTR [{emit_reg i.arg.(0)}*8 + {emit_label lbl}]\n` + end; + ` .DATA\n`; + emit_align 8; + `{emit_label lbl} LABEL QWORD\n`; + for i = 0 to Array.length jumptbl - 1 do + ` QWORD {emit_label jumptbl.(i)}\n` + done; + ` .CODE\n` + | Lsetuptrap lbl -> + ` call {emit_label lbl}\n` + | Lpushtrap -> + ` push r14\n`; + ` mov r14, rsp\n`; + stack_offset := !stack_offset + 16 + | Lpoptrap -> + ` pop r14\n`; + ` add rsp, 8\n`; + stack_offset := !stack_offset - 16 + | Lraise -> + if !Clflags.debug then begin + ` call caml_raise_exn\n`; + record_frame Reg.Set.empty i.dbg + end else begin + ` mov rsp, r14\n`; + ` pop r14\n`; + ` ret\n` + end + +let rec emit_all fallthrough i = + match i.desc with + | Lend -> () + | _ -> + emit_instr fallthrough i; + emit_all (Linearize.has_fallthrough i.desc) i.next + +(* Emission of the floating-point constants *) + +let emit_float s = + (* MASM doesn't like floating-point constants such as 2e9. + Turn them into 2.0e9. *) + let pos_e = ref (-1) and pos_dot = ref (-1) in + for i = 0 to String.length s - 1 do + match s.[i] with + 'e'|'E' -> pos_e := i + | '.' -> pos_dot := i + | _ -> () + done; + if !pos_dot < 0 && !pos_e >= 0 then begin + emit_string (String.sub s 0 !pos_e); + emit_string ".0"; + emit_string (String.sub s !pos_e (String.length s - !pos_e)) + end else + emit_string s + +let emit_float_constant (lbl, cst) = + `{emit_label lbl} REAL8 {emit_float cst}\n` + +(* Emission of a function declaration *) + +let fundecl fundecl = + function_name := fundecl.fun_name; + fastcode_flag := fundecl.fun_fast; + tailrec_entry_point := new_label(); + stack_offset := 0; + float_constants := []; + call_gc_sites := []; + bound_error_sites := []; + bound_error_call := 0; + ` .CODE\n`; + emit_align 16; + add_def_symbol fundecl.fun_name; + ` PUBLIC {emit_symbol fundecl.fun_name}\n`; + `{emit_symbol fundecl.fun_name}:\n`; + if frame_required() then begin + let n = frame_size() - 8 in + ` sub rsp, {emit_int n}\n` + end; + `{emit_label !tailrec_entry_point}:\n`; + emit_all true fundecl.fun_body; + List.iter emit_call_gc !call_gc_sites; + emit_call_bound_errors(); + if !float_constants <> [] then begin + ` .DATA\n`; + List.iter emit_float_constant !float_constants + end + +(* Emission of data *) + +let emit_item = function + Cglobal_symbol s -> + ` PUBLIC {emit_symbol s}\n`; + | Cdefine_symbol s -> + add_def_symbol s; + `{emit_symbol s} LABEL QWORD\n` + | Cdefine_label lbl -> + `{emit_label (100000 + lbl)} LABEL QWORD\n` + | Cint8 n -> + ` BYTE {emit_int n}\n` + | Cint16 n -> + ` WORD {emit_int n}\n` + | Cint32 n -> + ` DWORD {emit_nativeint n}\n` + | Cint n -> + ` QWORD {emit_nativeint n}\n` + | Csingle f -> + ` REAL4 {emit_float f}\n` + | Cdouble f -> + ` REAL8 {emit_float f}\n` + | Csymbol_address s -> + add_used_symbol s; + ` QWORD {emit_symbol s}\n` + | Clabel_address lbl -> + ` QWORD {emit_label (100000 + lbl)}\n` + | Cstring s -> + emit_bytes_directive " BYTE " s + | Cskip n -> + if n > 0 then ` BYTE {emit_int n} DUP (?)\n` + | Calign n -> + emit_align n + +let data l = + ` .DATA\n`; + List.iter emit_item l + +(* Beginning / end of an assembly file *) + +let begin_assembly() = + ` EXTRN caml_young_ptr: QWORD\n`; + ` EXTRN caml_young_limit: QWORD\n`; + ` EXTRN caml_exception_pointer: QWORD\n`; + ` EXTRN caml_absf_mask: QWORD\n`; + ` EXTRN caml_negf_mask: QWORD\n`; + ` EXTRN caml_call_gc: NEAR\n`; + ` EXTRN caml_c_call: NEAR\n`; + ` EXTRN caml_allocN: NEAR\n`; + ` EXTRN caml_alloc1: NEAR\n`; + ` EXTRN caml_alloc2: NEAR\n`; + ` EXTRN caml_alloc3: NEAR\n`; + ` EXTRN caml_ml_array_bound_error: NEAR\n`; + ` EXTRN caml_raise_exn: NEAR\n`; + let lbl_begin = Compilenv.make_symbol (Some "data_begin") in + add_def_symbol lbl_begin; + ` .DATA\n`; + ` PUBLIC {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin} LABEL QWORD\n`; + let lbl_begin = Compilenv.make_symbol (Some "code_begin") in + add_def_symbol lbl_begin; + ` .CODE\n`; + ` PUBLIC {emit_symbol lbl_begin}\n`; + `{emit_symbol lbl_begin} LABEL QWORD\n` + +let end_assembly() = + let lbl_end = Compilenv.make_symbol (Some "code_end") in + add_def_symbol lbl_end; + ` .CODE\n`; + ` PUBLIC {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end} LABEL QWORD\n`; + ` .DATA\n`; + let lbl_end = Compilenv.make_symbol (Some "data_end") in + add_def_symbol lbl_end; + ` PUBLIC {emit_symbol lbl_end}\n`; + `{emit_symbol lbl_end} LABEL QWORD\n`; + ` QWORD 0\n`; + let lbl = Compilenv.make_symbol (Some "frametable") in + add_def_symbol lbl; + ` PUBLIC {emit_symbol lbl}\n`; + `{emit_symbol lbl} LABEL QWORD\n`; + emit_frames + { efa_label = (fun l -> ` QWORD {emit_label l}\n`); + efa_16 = (fun n -> ` WORD {emit_int n}\n`); + efa_32 = (fun n -> ` DWORD {emit_int32 n}\n`); + efa_word = (fun n -> ` QWORD {emit_int n}\n`); + efa_align = emit_align; + efa_label_rel = (fun lbl ofs -> + ` DWORD {emit_label lbl} - THIS BYTE + {emit_int32 ofs}\n`); + efa_def_label = (fun l -> `{emit_label l} LABEL QWORD\n`); + efa_string = (fun s -> emit_bytes_directive " BYTE " (s ^ "\000")) }; + `\n;External functions\n\n`; + StringSet.iter + (fun s -> + if not (StringSet.mem s !symbols_defined) then + ` EXTRN {emit_symbol s}: NEAR\n`) + !symbols_used; + symbols_used := StringSet.empty; + symbols_defined := StringSet.empty; + `END\n` diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml index aef2e394..473ef43c 100644 --- a/asmcomp/amd64/proc.ml +++ b/asmcomp/amd64/proc.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: proc.ml,v 1.1.18.1 2005/12/17 16:23:09 xleroy Exp $ *) +(* $Id: proc.ml,v 1.3 2007/01/29 12:10:50 xleroy Exp $ *) (* Description of the AMD64 processor *) diff --git a/asmcomp/amd64/proc_nt.ml b/asmcomp/amd64/proc_nt.ml new file mode 100644 index 00000000..1119eebd --- /dev/null +++ b/asmcomp/amd64/proc_nt.ml @@ -0,0 +1,237 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2000 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: proc_nt.ml,v 1.3 2006/05/09 16:00:57 xleroy Exp $ *) + +(* Description of the AMD64 processor with Win64 conventions *) + +open Misc +open Arch +open Cmm +open Reg +open Mach + +(* Registers available for register allocation *) + +(* Register map: + rax 0 rax - r11: Caml function arguments + rbx 1 rcx - r9: C function arguments + rdi 2 rax: Caml and C function results + rsi 3 rbx, rbp, rsi, rdi r12-r15 are preserved by C + rdx 4 + rcx 5 + r8 6 + r9 7 + r10 8 + r11 9 + rbp 10 + r12 11 + r13 12 + r14 trap pointer + r15 allocation pointer + + xmm0 - xmm15 100 - 115 xmm0 - xmm9: Caml function arguments + xmm0 - xmm3: C function arguments + xmm0: Caml and C function results + xmm6-xmm15 are preserved by C *) + +let int_reg_name = + [| "rax"; "rbx"; "rdi"; "rsi"; "rdx"; "rcx"; "r8"; "r9"; + "r10"; "r11"; "rbp"; "r12"; "r13" |] + +let float_reg_name = + [| "xmm0"; "xmm1"; "xmm2"; "xmm3"; "xmm4"; "xmm5"; "xmm6"; "xmm7"; + "xmm8"; "xmm9"; "xmm10"; "xmm11"; "xmm12"; "xmm13"; "xmm14"; "xmm15" |] + +let num_register_classes = 2 + +let register_class r = + match r.typ with + Int -> 0 + | Addr -> 0 + | Float -> 1 + +let num_available_registers = [| 13; 16 |] + +let first_available_register = [| 0; 100 |] + +let register_name r = + if r < 100 then int_reg_name.(r) else float_reg_name.(r - 100) + +(* Pack registers starting at %rax so as to reduce the number of REX + prefixes and thus improve code density *) +let rotate_registers = false + +(* Representation of hard registers by pseudo-registers *) + +let hard_int_reg = + let v = Array.create 13 Reg.dummy in + for i = 0 to 12 do v.(i) <- Reg.at_location Int (Reg i) done; + v + +let hard_float_reg = + let v = Array.create 16 Reg.dummy in + for i = 0 to 15 do v.(i) <- Reg.at_location Float (Reg (100 + i)) done; + v + +let all_phys_regs = + Array.append hard_int_reg hard_float_reg + +let phys_reg n = + if n < 100 then hard_int_reg.(n) else hard_float_reg.(n - 100) + +let rax = phys_reg 0 +let rcx = phys_reg 5 +let rdx = phys_reg 4 +let r11 = phys_reg 9 +let rxmm15 = phys_reg 115 + +let stack_slot slot ty = + Reg.at_location ty (Stack slot) + +(* Instruction selection *) + +let word_addressed = false + +(* Calling conventions *) + +let calling_conventions first_int last_int first_float last_float make_stack + arg = + let loc = Array.create (Array.length arg) Reg.dummy in + let int = ref first_int in + let float = ref first_float in + let ofs = ref 0 in + for i = 0 to Array.length arg - 1 do + match arg.(i).typ with + Int | Addr as ty -> + if !int <= last_int then begin + loc.(i) <- phys_reg !int; + incr int + end else begin + loc.(i) <- stack_slot (make_stack !ofs) ty; + ofs := !ofs + size_int + end + | Float -> + if !float <= last_float then begin + loc.(i) <- phys_reg !float; + incr float + end else begin + loc.(i) <- stack_slot (make_stack !ofs) Float; + ofs := !ofs + size_float + end + done; + (loc, Misc.align !ofs 16) (* keep stack 16-aligned *) + +let incoming ofs = Incoming ofs +let outgoing ofs = Outgoing ofs +let not_supported ofs = fatal_error "Proc.loc_results: cannot call" + +let loc_arguments arg = + calling_conventions 0 9 100 109 outgoing arg +let loc_parameters arg = + let (loc, ofs) = calling_conventions 0 9 100 109 incoming arg in loc +let loc_results res = + let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc + +(* C calling conventions (Win64): + first integer args in rcx, rdx, r8, r9 (4 - 7) + first float args in xmm0 ... xmm3 (100 - 103) + each integer arg consumes a float reg, and conversely + remaining args on stack + always 32 bytes reserved at bottom of stack. + Return value in rax or xmm0 +*) + +let loc_external_results res = + let (loc, ofs) = calling_conventions 0 0 100 100 not_supported res in loc + +let int_external_arguments = + [| 5 (*rcx*); 4 (*rdx*); 6 (*r8*); 7 (*r9*) |] +let float_external_arguments = + [| 100 (*xmm0*); 101 (*xmm1*); 102 (*xmm2*); 103 (*xmm3*) |] + +let loc_external_arguments arg = + let loc = Array.create (Array.length arg) Reg.dummy in + let reg = ref 0 + and ofs = ref 32 in + for i = 0 to Array.length arg - 1 do + match arg.(i).typ with + Int | Addr as ty -> + if !reg < 4 then begin + loc.(i) <- phys_reg int_external_arguments.(!reg); + incr reg + end else begin + loc.(i) <- stack_slot (Outgoing !ofs) ty; + ofs := !ofs + size_int + end + | Float -> + if !reg < 4 then begin + loc.(i) <- phys_reg float_external_arguments.(!reg); + incr reg + end else begin + loc.(i) <- stack_slot (Outgoing !ofs) Float; + ofs := !ofs + size_float + end + done; + (loc, Misc.align !ofs 16) (* keep stack 16-aligned *) + +let loc_exn_bucket = rax + +(* Registers destroyed by operations *) + +let destroyed_at_c_call = + (* Win64: rbx, rbp, rsi, rdi, r12-r15, xmm6-xmm15 preserved *) + Array.of_list(List.map phys_reg + [0;4;5;6;7;8;9; + 100;101;102;103;104;105]) + +let destroyed_at_oper = function + Iop(Icall_ind | Icall_imm _ | Iextcall(_, true)) -> all_phys_regs + | Iop(Iextcall(_, false)) -> destroyed_at_c_call + | Iop(Iintop(Idiv | Imod)) -> [| rax; rdx |] + | Iop(Istore(Single, _)) -> [| rxmm15 |] + | Iop(Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _)) + -> [| rax |] + | Iswitch(_, _) when !pic_code -> [| r11 |] + | _ -> [||] + +let destroyed_at_raise = all_phys_regs + +(* Maximal register pressure *) + +let safe_register_pressure = function + Iextcall(_,_) -> 8 + | _ -> 11 + +let max_register_pressure = function + Iextcall(_, _) -> [| 8; 10 |] + | Iintop(Idiv | Imod) -> [| 11; 16 |] + | Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _) + -> [| 12; 16 |] + | Istore(Single, _) -> [| 13; 15 |] + | _ -> [| 13; 16 |] + +(* Layout of the stack frame *) + +let num_stack_slots = [| 0; 0 |] +let contains_calls = ref false + +(* Calling the assembler *) + +let assemble_file infile outfile = + Ccomp.command ("ml64 /nologo /Cp /c /Fo" ^ + Filename.quote outfile ^ " " ^ + Filename.quote infile ^ "> NUL") + + (* /Cp preserve case of all used identifiers + /c assemble only + /Fo output file name *) diff --git a/asmcomp/amd64/reload.ml b/asmcomp/amd64/reload.ml index f4238a6b..b3c1181f 100644 --- a/asmcomp/amd64/reload.ml +++ b/asmcomp/amd64/reload.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: reload.ml,v 1.2.2.1 2006/08/01 01:01:43 xleroy Exp $ *) +(* $Id: reload.ml,v 1.5 2007/01/29 12:10:50 xleroy Exp $ *) open Cmm open Arch @@ -19,12 +19,12 @@ open Mach (* Reloading for the AMD64 *) -(* Summary of instruction set constraints: +(* Summary of instruction set constraints: "S" means either stack or register, "R" means register only. Operation Res Arg1 Arg2 Imove R S or S R - Iconst_int S + Iconst_int S if 32-bit signed, R otherwise Iconst_float R Iconst_symbol (not PIC) S Iconst_symbol (PIC) R diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml index 29c23d8d..a20273cf 100644 --- a/asmcomp/amd64/selection.ml +++ b/asmcomp/amd64/selection.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: selection.ml,v 1.3 2005/10/13 03:53:52 xleroy Exp $ *) +(* $Id: selection.ml,v 1.6 2007/02/09 13:31:14 doligez Exp $ *) (* Instruction selection for the AMD64 *) @@ -72,7 +72,7 @@ let rec select_addr exp = end | arg -> (Alinear arg, 0) - + (* Special constraints on operand and result registers *) exception Use_default @@ -87,10 +87,10 @@ let pseudoregs_for_operation op arg res = Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) | Iaddf|Isubf|Imulf|Idivf -> ([|res.(0); arg.(1)|], res) (* One-address unary operations: arg.(0) and res.(0) must be the same *) - | Iintop_imm((Iadd|Isub|Imul|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _) + | Iintop_imm((Iadd|Isub|Imul|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _) | Iabsf | Inegf -> (res, res) - | Ispecific(Ifloatarithmem(_,_)) -> + | Ispecific(Ifloatarithmem(_,_)) -> let arg' = Array.copy arg in arg'.(0) <- res.(0); (arg', res) @@ -186,7 +186,7 @@ method select_operation op args = | Cstore Word -> begin match args with [loc; Cop(Caddi, [Cop(Cload _, [loc']); Cconst_int n])] - when loc = loc' -> + when loc = loc' && self#is_immediate n -> let (addr, arg) = self#select_addressing loc in (Ispecific(Ioffset_loc(n, addr)), [arg]) | _ -> @@ -213,17 +213,19 @@ method select_floatarith commutative regular_op mem_op args = (* Deal with register constraints *) -method insert_op op rs rd = +method insert_op_debug op dbg rs rd = try let (rsrc, rdst) = pseudoregs_for_operation op rs rd in self#insert_moves rs rsrc; - self#insert (Iop op) rsrc rdst; + self#insert_debug (Iop op) dbg rsrc rdst; self#insert_moves rdst rd; rd with Use_default -> - super#insert_op op rs rd + super#insert_op_debug op dbg rs rd + +method insert_op op rs rd = + self#insert_op_debug op Debuginfo.none rs rd end let fundecl f = (new selector)#emit_fundecl f - diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index fc197ed7..ac5d676f 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: asmlink.ml,v 1.65 2004/05/26 11:10:27 garrigue Exp $ *) +(* $Id: asmlink.ml,v 1.70 2007/02/15 18:35:20 frisch Exp $ *) (* Link a set of .cmx/.o files and produce an executable *) @@ -28,6 +28,7 @@ type error = | Assembler_error of string | Linking_error | Multiple_definition of string * string * string + | Missing_cmx of string * string exception Error of error @@ -37,6 +38,7 @@ let crc_interfaces = Consistbl.create () let crc_implementations = Consistbl.create () let extra_implementations = ref ([] : string list) let implementations_defined = ref ([] : (string * string) list) +let cmx_required = ref ([] : string list) let check_consistency file_name unit crc = begin try @@ -52,10 +54,12 @@ let check_consistency file_name unit crc = begin try List.iter (fun (name, crc) -> - if crc = cmx_not_found_crc then - extra_implementations := name :: !extra_implementations + if crc <> cmx_not_found_crc then + Consistbl.check crc_implementations name crc file_name + else if List.mem name !cmx_required then + raise(Error(Missing_cmx(file_name, name))) else - Consistbl.check crc_implementations name crc file_name) + extra_implementations := name :: !extra_implementations) unit.ui_imports_cmx with Consistbl.Inconsistency(name, user, auth) -> raise(Error(Inconsistent_implementation(name, user, auth))) @@ -67,7 +71,9 @@ let check_consistency file_name unit crc = end; Consistbl.set crc_implementations unit.ui_name crc file_name; implementations_defined := - (unit.ui_name, file_name) :: !implementations_defined + (unit.ui_name, file_name) :: !implementations_defined; + if unit.ui_symbol <> unit.ui_name then + cmx_required := unit.ui_name :: !cmx_required let extract_crc_interfaces () = Consistbl.extract crc_interfaces @@ -229,9 +235,9 @@ let call_linker file_list startup_file output_name = raise(Error(File_not_found libname)) in let c_lib = if !Clflags.nopervasives then "" else Config.native_c_libraries in - let cmd = - match Config.ccomp_type with - "cc" -> + match Config.ccomp_type with + | "cc" -> + let cmd = if not !Clflags.output_c_object then Printf.sprintf "%s %s -o %s %s %s %s %s %s %s %s %s" !Clflags.c_linker @@ -253,8 +259,10 @@ let call_linker file_list startup_file output_name = (Filename.quote output_name) (Filename.quote startup_file) (Ccomp.quote_files (List.rev file_list)) - | "msvc" -> - if not !Clflags.output_c_object then + in if Ccomp.command cmd <> 0 then raise(Error Linking_error) + | "msvc" -> + if not !Clflags.output_c_object then begin + let cmd = Printf.sprintf "%s /Fe%s %s %s %s %s %s %s %s" !Clflags.c_linker (Filename.quote output_name) @@ -265,15 +273,19 @@ let call_linker file_list startup_file output_name = (List.rev_map Ccomp.expand_libname !Clflags.ccobjs)) (Filename.quote runtime_lib) c_lib - (String.concat " " (List.rev !Clflags.ccopts)) - else + (Ccomp.make_link_options !Clflags.ccopts) in + if Ccomp.command cmd <> 0 then raise(Error Linking_error); + if Ccomp.merge_manifest output_name <> 0 then raise(Error Linking_error) + end else begin + let cmd = Printf.sprintf "%s /out:%s %s %s" Config.native_partial_linker (Filename.quote output_name) (Filename.quote startup_file) (Ccomp.quote_files (List.rev file_list)) - | _ -> assert false - in if Ccomp.command cmd <> 0 then raise(Error Linking_error) + in if Ccomp.command cmd <> 0 then raise(Error Linking_error) + end + | _ -> assert false let object_file_name name = let file_name = @@ -364,3 +376,11 @@ let report_error ppf = function fprintf ppf "@[Files %s@ and %s@ both define a module named %s@]" file1 file2 modname + | Missing_cmx(filename, name) -> + fprintf ppf + "@[File %s@ was compiled without access@ \ + to the .cmx file@ for module %s,@ \ + which was produced by `ocamlopt -for-pack'.@ \ + Please recompile %s@ with the correct `-I' option@ \ + so that %s.cmx@ is found.@]" + filename name filename name diff --git a/asmcomp/asmlink.mli b/asmcomp/asmlink.mli index e57fbff3..90bc3674 100644 --- a/asmcomp/asmlink.mli +++ b/asmcomp/asmlink.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: asmlink.mli,v 1.10 2002/06/11 14:15:11 xleroy Exp $ *) +(* $Id: asmlink.mli,v 1.11 2006/10/17 12:33:58 xleroy Exp $ *) (* Link a set of .cmx/.o files and produce an executable *) @@ -31,6 +31,7 @@ type error = | Assembler_error of string | Linking_error | Multiple_definition of string * string * string + | Missing_cmx of string * string exception Error of error diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index c0a39600..a13dc720 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: asmpackager.ml,v 1.19.2.2 2005/12/17 16:49:57 xleroy Exp $ *) +(* $Id: asmpackager.ml,v 1.24 2007/03/01 13:38:54 xleroy Exp $ *) (* "Package" a set of .cmx/.o files into one .cmx/.o file having the original compilation units as sub-modules. *) @@ -43,7 +43,7 @@ type pack_member = let read_member_info pack_path file = let name = - String.capitalize(Filename.basename(chop_extension_if_any file)) in + String.capitalize(Filename.basename(chop_extensions file)) in let kind = if Filename.check_suffix file ".cmx" then begin let (info, crc) = Compilenv.read_unit_info file in @@ -53,6 +53,7 @@ let read_member_info pack_path file = (Compilenv.current_unit_infos()).ui_symbol ^ "__" ^ info.ui_name then raise(Error(Wrong_for_pack(file, pack_path))); Asmlink.check_consistency file info crc; + Compilenv.cache_unit_info info; PM_impl info end else PM_intf in @@ -79,7 +80,10 @@ let check_units members = (* Make the .o file for the package *) let make_package_object ppf members targetobj targetname coercion = - let objtemp = Filename.temp_file "camlpackage" Config.ext_obj in + (* Put the full name of the module in the temporary file name + to avoid collisions with MSVC's link /lib in case of successive packs *) + let objtemp = + Filename.temp_file (Compilenv.make_symbol (Some "")) Config.ext_obj in let components = List.map (fun m -> @@ -96,7 +100,7 @@ let make_package_object ppf members targetobj targetname coercion = (fun m -> chop_extension_if_any m.pm_file ^ Config.ext_obj) (List.filter (fun m -> m.pm_kind <> PM_intf) members) in let ld_cmd = - sprintf "%s -o %s %s %s" + sprintf "%s%s %s %s" Config.native_pack_linker (Filename.quote targetobj) (Filename.quote objtemp) @@ -168,9 +172,9 @@ let package_files ppf files targetcmx = try find_in_path !Config.load_path f with Not_found -> raise(Error(File_not_found f))) files in - let prefix = chop_extension_if_any targetcmx in + let prefix = chop_extensions targetcmx in let targetcmi = prefix ^ ".cmi" in - let targetobj = prefix ^ Config.ext_obj in + let targetobj = chop_extension_if_any targetcmx ^ Config.ext_obj in let targetname = String.capitalize(Filename.basename prefix) in (* Set the name of the current "input" *) Location.input_name := targetcmx; diff --git a/asmcomp/clambda.ml b/asmcomp/clambda.ml index 9eb82319..2d264d14 100644 --- a/asmcomp/clambda.ml +++ b/asmcomp/clambda.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: clambda.ml,v 1.16.8.2 2005/12/11 10:21:12 xleroy Exp $ *) +(* $Id: clambda.ml,v 1.17 2007/01/29 12:10:50 xleroy Exp $ *) (* A variant of the "lambda" code with direct / indirect calls explicit and closures explicit too *) @@ -23,14 +23,14 @@ type function_label = string type ulambda = Uvar of Ident.t | Uconst of structured_constant - | Udirect_apply of function_label * ulambda list - | Ugeneric_apply of ulambda * ulambda list + | Udirect_apply of function_label * ulambda list * Debuginfo.t + | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t | Uclosure of (function_label * int * Ident.t list * ulambda) list * ulambda list | Uoffset of ulambda * int | Ulet of Ident.t * ulambda * ulambda | Uletrec of (Ident.t * ulambda) list * ulambda - | Uprim of primitive * ulambda list + | Uprim of primitive * ulambda list * Debuginfo.t | Uswitch of ulambda * ulambda_switch | Ustaticfail of int * ulambda list | Ucatch of int * Ident.t list * ulambda * ulambda @@ -40,7 +40,7 @@ type ulambda = | Uwhile of ulambda * ulambda | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda | Uassign of Ident.t * ulambda - | Usend of meth_kind * ulambda * ulambda * ulambda list + | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t and ulambda_switch = { us_index_consts: int array; diff --git a/asmcomp/clambda.mli b/asmcomp/clambda.mli index 4f9a07cc..2f752501 100644 --- a/asmcomp/clambda.mli +++ b/asmcomp/clambda.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: clambda.mli,v 1.16.8.2 2005/12/11 10:21:12 xleroy Exp $ *) +(* $Id: clambda.mli,v 1.17 2007/01/29 12:10:50 xleroy Exp $ *) (* A variant of the "lambda" code with direct / indirect calls explicit and closures explicit too *) @@ -23,14 +23,14 @@ type function_label = string type ulambda = Uvar of Ident.t | Uconst of structured_constant - | Udirect_apply of function_label * ulambda list - | Ugeneric_apply of ulambda * ulambda list + | Udirect_apply of function_label * ulambda list * Debuginfo.t + | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t | Uclosure of (function_label * int * Ident.t list * ulambda) list * ulambda list | Uoffset of ulambda * int | Ulet of Ident.t * ulambda * ulambda | Uletrec of (Ident.t * ulambda) list * ulambda - | Uprim of primitive * ulambda list + | Uprim of primitive * ulambda list * Debuginfo.t | Uswitch of ulambda * ulambda_switch | Ustaticfail of int * ulambda list | Ucatch of int * Ident.t list * ulambda * ulambda @@ -40,7 +40,7 @@ type ulambda = | Uwhile of ulambda * ulambda | Ufor of Ident.t * ulambda * ulambda * direction_flag * ulambda | Uassign of Ident.t * ulambda - | Usend of meth_kind * ulambda * ulambda * ulambda list + | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t and ulambda_switch = { us_index_consts: int array; diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index 5a31e5f7..26f2208b 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: closure.ml,v 1.48.2.2 2005/12/11 10:21:12 xleroy Exp $ *) +(* $Id: closure.ml,v 1.51 2007/02/09 13:31:14 doligez Exp $ *) (* Introduction of closures, uncurrying, recognition of direct calls *) @@ -33,7 +33,7 @@ let rec split_list n l = let rec build_closure_env env_param pos = function [] -> Tbl.empty | id :: rem -> - Tbl.add id (Uprim(Pfield pos, [Uvar env_param])) + Tbl.add id (Uprim(Pfield pos, [Uvar env_param], Debuginfo.none)) (build_closure_env env_param (pos+1) rem) (* Auxiliary for accessing globals. We change the name of the global @@ -43,7 +43,7 @@ let rec build_closure_env env_param pos = function let getglobal id = Uprim(Pgetglobal (Ident.create_persistent (Compilenv.symbol_for_global id)), - []) + [], Debuginfo.none) (* Check if a variable occurs in a [clambda] term. *) @@ -51,14 +51,14 @@ let occurs_var var u = let rec occurs = function Uvar v -> v = var | Uconst cst -> false - | Udirect_apply(lbl, args) -> List.exists occurs args - | Ugeneric_apply(funct, args) -> occurs funct || List.exists occurs args + | Udirect_apply(lbl, args, _) -> List.exists occurs args + | Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args | Uclosure(fundecls, clos) -> List.exists occurs clos | Uoffset(u, ofs) -> occurs u | Ulet(id, def, body) -> occurs def || occurs body | Uletrec(decls, body) -> List.exists (fun (id, u) -> occurs u) decls || occurs body - | Uprim(p, args) -> List.exists occurs args + | Uprim(p, args, _) -> List.exists occurs args | Uswitch(arg, s) -> occurs arg || occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks @@ -71,7 +71,7 @@ let occurs_var var u = | Uwhile(cond, body) -> occurs cond || occurs body | Ufor(id, lo, hi, dir, body) -> occurs lo || occurs hi || occurs body | Uassign(id, u) -> id = var || occurs u - | Usend(_, met, obj, args) -> + | Usend(_, met, obj, args, _) -> occurs met || occurs obj || List.exists occurs args and occurs_array a = try @@ -96,6 +96,7 @@ let prim_size prim args = | Psetfield(f, isptr) -> if isptr then 4 else 1 | Pfloatfield f -> 1 | Psetfloatfield f -> 1 + | Pduprecord _ -> 10 + List.length args | Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args | Praise -> 4 | Pstringlength -> 5 @@ -124,9 +125,9 @@ let lambda_smaller lam threshold = Const_pointer _) -> incr size | Uconst _ -> raise Exit (* avoid duplication of structured constants *) - | Udirect_apply(fn, args) -> + | Udirect_apply(fn, args, _) -> size := !size + 4; lambda_list_size args - | Ugeneric_apply(fn, args) -> + | Ugeneric_apply(fn, args, _) -> size := !size + 6; lambda_size fn; lambda_list_size args | Uclosure(defs, vars) -> raise Exit (* inlining would duplicate function definitions *) @@ -136,7 +137,7 @@ let lambda_smaller lam threshold = lambda_size lam; lambda_size body | Uletrec(bindings, body) -> raise Exit (* usually too large *) - | Uprim(prim, args) -> + | Uprim(prim, args, _) -> size := !size + prim_size prim args; lambda_list_size args | Uswitch(lam, cases) -> @@ -161,7 +162,7 @@ let lambda_smaller lam threshold = size := !size + 4; lambda_size low; lambda_size high; lambda_size body | Uassign(id, lam) -> incr size; lambda_size lam - | Usend(_, met, obj, args) -> + | Usend(_, met, obj, args, _) -> size := !size + 8; lambda_size met; lambda_size obj; lambda_list_size args and lambda_list_size l = List.iter lambda_size l @@ -177,10 +178,10 @@ let lambda_smaller lam threshold = let rec is_pure_clambda = function Uvar v -> true | Uconst cst -> true - | Uprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | + | Uprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ | Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets | - Parraysetu _ | Parraysets _ | Pbigarrayset _), _) -> false - | Uprim(p, args) -> List.for_all is_pure_clambda args + Parraysetu _ | Parraysets _ | Pbigarrayset _), _, _) -> false + | Uprim(p, args, _) -> List.for_all is_pure_clambda args | _ -> false (* Simplify primitive operations on integers *) @@ -189,14 +190,14 @@ let make_const_int n = (Uconst(Const_base(Const_int n)), Value_integer n) let make_const_ptr n = (Uconst(Const_pointer n), Value_constptr n) let make_const_bool b = make_const_ptr(if b then 1 else 0) -let simplif_prim_pure p (args, approxs) = +let simplif_prim_pure p (args, approxs) dbg = match approxs with [Value_integer x] -> begin match p with Pidentity -> make_const_int x | Pnegint -> make_const_int (-x) | Poffsetint y -> make_const_int (x + y) - | _ -> (Uprim(p, args), Value_unknown) + | _ -> (Uprim(p, args, dbg), Value_unknown) end | [Value_integer x; Value_integer y] -> begin match p with @@ -220,28 +221,28 @@ let simplif_prim_pure p (args, approxs) = | Cle -> x <= y | Cge -> x >= y in make_const_bool result - | _ -> (Uprim(p, args), Value_unknown) + | _ -> (Uprim(p, args, dbg), Value_unknown) end | [Value_constptr x] -> begin match p with Pidentity -> make_const_ptr x | Pnot -> make_const_bool(x = 0) | Pisint -> make_const_bool true - | _ -> (Uprim(p, args), Value_unknown) + | _ -> (Uprim(p, args, dbg), Value_unknown) end | [Value_constptr x; Value_constptr y] -> begin match p with Psequand -> make_const_bool(x <> 0 && y <> 0) | Psequor -> make_const_bool(x <> 0 || y <> 0) - | _ -> (Uprim(p, args), Value_unknown) + | _ -> (Uprim(p, args, dbg), Value_unknown) end | _ -> - (Uprim(p, args), Value_unknown) + (Uprim(p, args, dbg), Value_unknown) -let simplif_prim p (args, approxs as args_approxs) = +let simplif_prim p (args, approxs as args_approxs) dbg = if List.for_all is_pure_clambda args - then simplif_prim_pure p args_approxs - else (Uprim(p, args), Value_unknown) + then simplif_prim_pure p args_approxs dbg + else (Uprim(p, args, dbg), Value_unknown) (* Substitute variables in a [ulambda] term (a body of an inlined function) and perform some more simplifications on integer primitives. @@ -263,10 +264,10 @@ let rec substitute sb ulam = Uvar v -> begin try Tbl.find v sb with Not_found -> ulam end | Uconst cst -> ulam - | Udirect_apply(lbl, args) -> - Udirect_apply(lbl, List.map (substitute sb) args) - | Ugeneric_apply(fn, args) -> - Ugeneric_apply(substitute sb fn, List.map (substitute sb) args) + | Udirect_apply(lbl, args, dbg) -> + Udirect_apply(lbl, List.map (substitute sb) args, dbg) + | Ugeneric_apply(fn, args, dbg) -> + Ugeneric_apply(substitute sb fn, List.map (substitute sb) args, dbg) | Uclosure(defs, env) -> (* Question: should we rename function labels as well? Otherwise, there is a risk that function labels are not globally unique. @@ -291,9 +292,9 @@ let rec substitute sb ulam = Uletrec( List.map (fun (id, id', rhs) -> (id', substitute sb' rhs)) bindings1, substitute sb' body) - | Uprim(p, args) -> + | Uprim(p, args, dbg) -> let sargs = List.map (substitute sb) args in - let (res, _) = simplif_prim p (sargs, List.map approx_ulam sargs) in + let (res, _) = simplif_prim p (sargs, List.map approx_ulam sargs) dbg in res | Uswitch(arg, sw) -> Uswitch(substitute sb arg, @@ -330,8 +331,8 @@ let rec substitute sb ulam = with Not_found -> id in Uassign(id', substitute sb u) - | Usend(k, u1, u2, ul) -> - Usend(k, substitute sb u1, substitute sb u2, List.map (substitute sb) ul) + | Usend(k, u1, u2, ul, dbg) -> + Usend(k, substitute sb u1, substitute sb u2, List.map (substitute sb) ul, dbg) (* Perform an inline expansion *) @@ -375,10 +376,11 @@ let bind_params params args body = let rec is_pure = function Lvar v -> true | Lconst cst -> true - | Lprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | + | Lprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ | Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets | Parraysetu _ | Parraysets _), _) -> false | Lprim(p, args) -> List.for_all is_pure args + | Levent(lam, ev) -> is_pure lam | _ -> false (* Generate a direct application *) @@ -388,7 +390,7 @@ let direct_apply fundesc funct ufunct uargs = if fundesc.fun_closed then uargs else uargs @ [ufunct] in let app = match fundesc.fun_inline with - None -> Udirect_apply(fundesc.fun_label, app_args) + None -> Udirect_apply(fundesc.fun_label, app_args, Debuginfo.none) | Some(params, body) -> bind_params params app_args body in (* If ufunct can contain side-effects or function definitions, we must make sure that it is evaluated exactly once. @@ -431,6 +433,32 @@ let global_approx = ref([||] : value_approximation array) let function_nesting_depth = ref 0 let excessive_function_nesting_depth = 5 +(* Decorate clambda term with debug information *) + +let rec add_debug_info ev u = + match ev.lev_kind with + | Lev_after _ -> + begin match u with + | Udirect_apply(lbl, args, dinfo) -> + Udirect_apply(lbl, args, Debuginfo.from_call ev) + | Ugeneric_apply(Udirect_apply(lbl, args1, dinfo1), + args2, dinfo2) -> + Ugeneric_apply(Udirect_apply(lbl, args1, Debuginfo.from_call ev), + args2, Debuginfo.from_call ev) + | Ugeneric_apply(fn, args, dinfo) -> + Ugeneric_apply(fn, args, Debuginfo.from_call ev) + | Uprim(Praise, args, dinfo) -> + Uprim(Praise, args, Debuginfo.from_call ev) + | Uprim(p, args, dinfo) -> + Uprim(p, args, Debuginfo.from_call ev) + | Usend(kind, u1, u2, args, dinfo) -> + Usend(kind, u1, u2, args, Debuginfo.from_call ev) + | Usequence(u1, u2) -> + Usequence(u1, add_debug_info ev u2) + | _ -> u + end + | _ -> u + (* Uncurry an expression and explicitate closures. Also return the approximation of the expression. The approximation environment [fenv] maps idents to approximations. @@ -452,8 +480,6 @@ let close_approx_var fenv cenv id = let close_var fenv cenv id = let (ulam, app) = close_approx_var fenv cenv id in ulam -exception Found of int - let rec close fenv cenv = function Lvar id -> close_approx_var fenv cenv id @@ -470,7 +496,7 @@ let rec close fenv cenv = function let nargs = List.length args in begin match (close fenv cenv funct, close_list fenv cenv args) with ((ufunct, Value_closure(fundesc, approx_res)), - [Uprim(Pmakeblock(_, _), uargs)]) + [Uprim(Pmakeblock(_, _), uargs, _)]) when List.length uargs = - fundesc.fun_arity -> let app = direct_apply fundesc funct ufunct uargs in (app, strengthen_approx app approx_res) @@ -482,15 +508,16 @@ let rec close fenv cenv = function when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity -> let (first_args, rem_args) = split_list fundesc.fun_arity uargs in (Ugeneric_apply(direct_apply fundesc funct ufunct first_args, - rem_args), + rem_args, Debuginfo.none), Value_unknown) | ((ufunct, _), uargs) -> - (Ugeneric_apply(ufunct, uargs), Value_unknown) + (Ugeneric_apply(ufunct, uargs, Debuginfo.none), Value_unknown) end | Lsend(kind, met, obj, args) -> let (umet, _) = close fenv cenv met in let (uobj, _) = close fenv cenv obj in - (Usend(kind, umet, uobj, close_list fenv cenv args), Value_unknown) + (Usend(kind, umet, uobj, close_list fenv cenv args, Debuginfo.none), + Value_unknown) | Llet(str, id, lam, body) -> let (ulam, alam) = close_named fenv cenv id lam in begin match (str, alam) with @@ -542,7 +569,7 @@ let rec close fenv cenv = function (Compilenv.global_approx id) | Lprim(Pmakeblock(tag, mut) as prim, lams) -> let (ulams, approxs) = List.split (List.map (close fenv cenv) lams) in - (Uprim(prim, ulams), + (Uprim(prim, ulams, Debuginfo.none), begin match mut with Immutable -> Value_tuple(Array.of_list approxs) | Mutable -> Value_unknown @@ -553,14 +580,18 @@ let rec close fenv cenv = function match approx with Value_tuple a when n < Array.length a -> a.(n) | _ -> Value_unknown in - check_constant_result lam (Uprim(Pfield n, [ulam])) fieldapprox + check_constant_result lam (Uprim(Pfield n, [ulam], Debuginfo.none)) fieldapprox | Lprim(Psetfield(n, _), [Lprim(Pgetglobal id, []); lam]) -> let (ulam, approx) = close fenv cenv lam in (!global_approx).(n) <- approx; - (Uprim(Psetfield(n, false), [getglobal id; ulam]), + (Uprim(Psetfield(n, false), [getglobal id; ulam], Debuginfo.none), + Value_unknown) + | Lprim(Praise, [Levent(arg, ev)]) -> + let (ulam, approx) = close fenv cenv arg in + (Uprim(Praise, [ulam], Debuginfo.from_raise ev), Value_unknown) | Lprim(p, args) -> - simplif_prim p (close_list_approx fenv cenv args) + simplif_prim p (close_list_approx fenv cenv args) Debuginfo.none | Lswitch(arg, sw) -> (* NB: failaction might get copied, thus it should be some Lstaticraise *) let (uarg, _) = close fenv cenv arg in @@ -610,7 +641,11 @@ let rec close fenv cenv = function | Lassign(id, lam) -> let (ulam, _) = close fenv cenv lam in (Uassign(id, ulam), Value_unknown) - | Levent _ | Lifused _ -> assert false + | Levent(lam, ev) -> + let (ulam, approx) = close fenv cenv lam in + (add_debug_info ev ulam, approx) + | Lifused _ -> + assert false and close_list fenv cenv = function [] -> [] diff --git a/asmcomp/cmm.ml b/asmcomp/cmm.ml index 6ec37fd4..1caa179c 100644 --- a/asmcomp/cmm.ml +++ b/asmcomp/cmm.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: cmm.ml,v 1.20 2002/11/24 15:55:24 xleroy Exp $ *) +(* $Id: cmm.ml,v 1.21 2007/01/29 12:10:50 xleroy Exp $ *) type machtype_component = Addr @@ -67,8 +67,8 @@ type memory_chunk = | Double_u type operation = - Capply of machtype - | Cextcall of string * machtype * bool + Capply of machtype * Debuginfo.t + | Cextcall of string * machtype * bool * Debuginfo.t | Cload of memory_chunk | Calloc | Cstore of memory_chunk @@ -81,8 +81,8 @@ type operation = | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat | Ccmpf of comparison - | Craise - | Ccheckbound + | Craise of Debuginfo.t + | Ccheckbound of Debuginfo.t type expression = Cconst_int of int diff --git a/asmcomp/cmm.mli b/asmcomp/cmm.mli index 6568d1a2..b2d29b81 100644 --- a/asmcomp/cmm.mli +++ b/asmcomp/cmm.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: cmm.mli,v 1.20 2002/11/24 15:55:24 xleroy Exp $ *) +(* $Id: cmm.mli,v 1.21 2007/01/29 12:10:50 xleroy Exp $ *) (* Second intermediate language (machine independent) *) @@ -53,8 +53,8 @@ type memory_chunk = | Double_u (* word-aligned 64-bit float *) type operation = - Capply of machtype - | Cextcall of string * machtype * bool + Capply of machtype * Debuginfo.t + | Cextcall of string * machtype * bool * Debuginfo.t | Cload of memory_chunk | Calloc | Cstore of memory_chunk @@ -67,8 +67,8 @@ type operation = | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat | Ccmpf of comparison - | Craise - | Ccheckbound + | Craise of Debuginfo.t + | Ccheckbound of Debuginfo.t type expression = Cconst_int of int diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 4785a9fb..be89c2e3 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: cmmgen.ml,v 1.103.2.3 2006/03/23 15:22:55 xleroy Exp $ *) +(* $Id: cmmgen.ml,v 1.109 2007/02/22 12:13:00 xleroy Exp $ *) (* Translation from closed lambda to C-- *) @@ -159,14 +159,15 @@ let is_nonzero_constant = function | Cconst_natint n -> n <> 0n | _ -> false -let safe_divmod op c1 c2 = +let safe_divmod op c1 c2 dbg = if !Clflags.fast || is_nonzero_constant c2 then Cop(op, [c1; c2]) else bind "divisor" c2 (fun c2 -> Cifthenelse(c2, Cop(op, [c1; c2]), - Cop(Craise, [Cconst_symbol "caml_bucket_Division_by_zero"]))) + Cop(Craise dbg, + [Cconst_symbol "caml_bucket_Division_by_zero"]))) (* Bool *) @@ -211,10 +212,10 @@ let rec remove_unit = function Ctrywith(remove_unit body, exn, remove_unit handler) | Clet(id, c1, c2) -> Clet(id, c1, remove_unit c2) - | Cop(Capply mty, args) -> - Cop(Capply typ_void, args) - | Cop(Cextcall(proc, mty, alloc), args) -> - Cop(Cextcall(proc, typ_void, alloc), args) + | Cop(Capply (mty, dbg), args) -> + Cop(Capply (typ_void, dbg), args) + | Cop(Cextcall(proc, mty, alloc, dbg), args) -> + Cop(Cextcall(proc, typ_void, alloc, dbg), args) | Cexit (_,_) as c -> c | Ctuple [] as c -> c | c -> Csequence(c, Ctuple []) @@ -290,7 +291,7 @@ let float_array_ref arr ofs = box_float(unboxed_float_array_ref arr ofs) let addr_array_set arr ofs newval = - Cop(Cextcall("caml_modify", typ_void, false), + Cop(Cextcall("caml_modify", typ_void, false, Debuginfo.none), [array_indexing log2_size_addr arr ofs; newval]) let int_array_set arr ofs newval = Cop(Cstore Word, [array_indexing log2_size_addr arr ofs; newval]) @@ -317,18 +318,19 @@ let string_length exp = let lookup_tag obj tag = bind "tag" tag (fun tag -> - Cop(Cextcall("caml_get_public_method", typ_addr, false), [obj; tag])) + Cop(Cextcall("caml_get_public_method", typ_addr, false, Debuginfo.none), + [obj; tag])) let lookup_label obj lab = bind "lab" lab (fun lab -> let table = Cop (Cload Word, [obj]) in addr_array_ref table lab) -let call_cached_method obj tag cache pos args = +let call_cached_method obj tag cache pos args dbg = let arity = List.length args in let cache = array_indexing log2_size_addr cache pos in Compilenv.need_send_fun arity; - Cop(Capply typ_addr, + Cop(Capply (typ_addr, dbg), Cconst_symbol("caml_send" ^ string_of_int arity) :: obj :: tag :: cache :: args) @@ -344,7 +346,7 @@ let make_alloc_generic set_fn tag wordsize args = | e1::el -> Csequence(set_fn (Cvar id) (Cconst_int idx) e1, fill_fields (idx + 2) el) in Clet(id, - Cop(Cextcall("caml_alloc", typ_addr, true), + Cop(Cextcall("caml_alloc", typ_addr, true, Debuginfo.none), [Cconst_int wordsize; Cconst_int tag]), fill_fields 1 args) end @@ -376,9 +378,9 @@ let rec expr_size = function expr_size body | Uletrec(bindings, body) -> expr_size body - | Uprim(Pmakeblock(tag, mut), args) -> + | Uprim(Pmakeblock(tag, mut), args, _) -> RHS_block (List.length args) - | Uprim(Pmakearray(Paddrarray | Pintarray), args) -> + | Uprim(Pmakearray(Paddrarray | Pintarray), args, _) -> RHS_block (List.length args) | Usequence(exp, exp') -> expr_size exp' @@ -505,14 +507,14 @@ let bigarray_elt_size = function | Pbigarray_complex32 -> 8 | Pbigarray_complex64 -> 16 -let bigarray_indexing elt_kind layout b args = +let bigarray_indexing elt_kind layout b args dbg = let rec ba_indexing dim_ofs delta_ofs = function [] -> assert false | [arg] -> bind "idx" (untag_int arg) (fun idx -> Csequence( - Cop(Ccheckbound, [Cop(Cload Word,[field_address b dim_ofs]); idx]), + Cop(Ccheckbound dbg, [Cop(Cload Word,[field_address b dim_ofs]); idx]), idx)) | arg1 :: argl -> let rem = ba_indexing (dim_ofs + delta_ofs) delta_ofs argl in @@ -520,7 +522,7 @@ let bigarray_indexing elt_kind layout b args = (fun idx -> bind "bound" (Cop(Cload Word, [field_address b dim_ofs])) (fun bound -> - Csequence(Cop(Ccheckbound, [bound; idx]), + Csequence(Cop(Ccheckbound dbg, [bound; idx]), add_int (mul_int rem bound) idx))) in let offset = match layout with @@ -553,33 +555,33 @@ let bigarray_word_kind = function | Pbigarray_complex32 -> Single | Pbigarray_complex64 -> Double -let bigarray_get elt_kind layout b args = +let bigarray_get elt_kind layout b args dbg = match elt_kind with Pbigarray_complex32 | Pbigarray_complex64 -> let kind = bigarray_word_kind elt_kind in let sz = bigarray_elt_size elt_kind / 2 in - bind "addr" (bigarray_indexing elt_kind layout b args) (fun addr -> + bind "addr" (bigarray_indexing elt_kind layout b args dbg) (fun addr -> box_complex (Cop(Cload kind, [addr])) (Cop(Cload kind, [Cop(Cadda, [addr; Cconst_int sz])]))) | _ -> Cop(Cload (bigarray_word_kind elt_kind), - [bigarray_indexing elt_kind layout b args]) + [bigarray_indexing elt_kind layout b args dbg]) -let bigarray_set elt_kind layout b args newval = +let bigarray_set elt_kind layout b args newval dbg = match elt_kind with Pbigarray_complex32 | Pbigarray_complex64 -> let kind = bigarray_word_kind elt_kind in let sz = bigarray_elt_size elt_kind / 2 in bind "newval" newval (fun newv -> - bind "addr" (bigarray_indexing elt_kind layout b args) (fun addr -> + bind "addr" (bigarray_indexing elt_kind layout b args dbg) (fun addr -> Csequence( Cop(Cstore kind, [addr; complex_re newv]), Cop(Cstore kind, [Cop(Cadda, [addr; Cconst_int sz]); complex_im newv])))) | _ -> Cop(Cstore (bigarray_word_kind elt_kind), - [bigarray_indexing elt_kind layout b args; newval]) + [bigarray_indexing elt_kind layout b args dbg; newval]) (* Simplification of some primitives into C calls *) @@ -615,21 +617,23 @@ let simplif_primitive_32bits = function | Pbintcomp(Pint64, Lambda.Cle) -> Pccall (default_prim "caml_lessequal") | Pbintcomp(Pint64, Lambda.Cge) -> Pccall (default_prim "caml_greaterequal") | Pbigarrayref(n, Pbigarray_int64, layout) -> - Pccall (default_prim ("bigarray_get_" ^ string_of_int n)) + Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) | Pbigarrayset(n, Pbigarray_int64, layout) -> - Pccall (default_prim ("bigarray_set_" ^ string_of_int n)) + Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) | p -> p let simplif_primitive p = match p with - Pbigarrayref(n, Pbigarray_unknown, layout) -> - Pccall (default_prim ("bigarray_get_" ^ string_of_int n)) + | Pduprecord _ -> + Pccall (default_prim "caml_obj_dup") + | Pbigarrayref(n, Pbigarray_unknown, layout) -> + Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) | Pbigarrayset(n, Pbigarray_unknown, layout) -> - Pccall (default_prim ("bigarray_set_" ^ string_of_int n)) + Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) | Pbigarrayref(n, kind, Pbigarray_unknown_layout) -> - Pccall (default_prim ("bigarray_get_" ^ string_of_int n)) + Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) | Pbigarrayset(n, kind, Pbigarray_unknown_layout) -> - Pccall (default_prim ("bigarray_set_" ^ string_of_int n)) + Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) | p -> if size_int = 8 then p else simplif_primitive_32bits p @@ -698,7 +702,7 @@ type unboxed_number_kind = let is_unboxed_number = function Uconst(Const_base(Const_float f)) -> Boxed_float - | Uprim(p, _) -> + | Uprim(p, _, _) -> begin match simplif_primitive p with Pccall p -> if p.prim_native_float then Boxed_float else No_unboxing | Pfloatfield _ -> Boxed_float @@ -808,23 +812,25 @@ let rec transl = function Cop(Calloc, transl_fundecls 0 fundecls) | Uoffset(arg, offset) -> field_address (transl arg) offset - | Udirect_apply(lbl, args) -> - Cop(Capply typ_addr, Cconst_symbol lbl :: List.map transl args) - | Ugeneric_apply(clos, [arg]) -> + | Udirect_apply(lbl, args, dbg) -> + Cop(Capply(typ_addr, dbg), Cconst_symbol lbl :: List.map transl args) + | Ugeneric_apply(clos, [arg], dbg) -> bind "fun" (transl clos) (fun clos -> - Cop(Capply typ_addr, [get_field clos 0; transl arg; clos])) - | Ugeneric_apply(clos, args) -> + Cop(Capply(typ_addr, dbg), [get_field clos 0; transl arg; clos])) + | Ugeneric_apply(clos, args, dbg) -> let arity = List.length args in let cargs = Cconst_symbol(apply_function arity) :: List.map transl (args @ [clos]) in - Cop(Capply typ_addr, cargs) - | Usend(kind, met, obj, args) -> + Cop(Capply(typ_addr, dbg), cargs) + | Usend(kind, met, obj, args, dbg) -> let call_met obj args clos = - if args = [] then Cop(Capply typ_addr,[get_field clos 0;obj;clos]) else - let arity = List.length args + 1 in - let cargs = Cconst_symbol(apply_function arity) :: obj :: - (List.map transl args) @ [clos] in - Cop(Capply typ_addr, cargs) + if args = [] then + Cop(Capply(typ_addr, dbg), [get_field clos 0;obj;clos]) + else + let arity = List.length args + 1 in + let cargs = Cconst_symbol(apply_function arity) :: obj :: + (List.map transl args) @ [clos] in + Cop(Capply(typ_addr, dbg), cargs) in bind "obj" (transl obj) (fun obj -> match kind, args with @@ -832,7 +838,7 @@ let rec transl = function bind "met" (lookup_label obj (transl met)) (call_met obj args) | Cached, cache :: pos :: args -> call_cached_method obj (transl met) (transl cache) (transl pos) - (List.map transl args) + (List.map transl args) dbg | _ -> bind "met" (lookup_tag obj (transl met)) (call_met obj args)) | Ulet(id, exp, body) -> @@ -850,7 +856,7 @@ let rec transl = function transl_letrec bindings (transl body) (* Primitives *) - | Uprim(prim, args) -> + | Uprim(prim, args, dbg) -> begin match (simplif_primitive prim, args) with (Pgetglobal id, []) -> Cconst_symbol (Ident.name id) @@ -861,14 +867,14 @@ let rec transl = function | (Pccall prim, args) -> if prim.prim_native_float then box_float - (Cop(Cextcall(prim.prim_native_name, typ_float, false), + (Cop(Cextcall(prim.prim_native_name, typ_float, false, dbg), List.map transl_unbox_float args)) else begin let name = if prim.prim_native_name <> "" then prim.prim_native_name else prim.prim_name in - Cop(Cextcall(name, typ_addr, prim.prim_alloc), + Cop(Cextcall(name, typ_addr, prim.prim_alloc, dbg), List.map transl args) end | (Pmakearray kind, []) -> @@ -876,7 +882,7 @@ let rec transl = function | (Pmakearray kind, args) -> begin match kind with Pgenarray -> - Cop(Cextcall("caml_make_array", typ_addr, true), + Cop(Cextcall("caml_make_array", typ_addr, true, Debuginfo.none), [make_alloc 0 (List.map transl args)]) | Paddrarray | Pintarray -> make_alloc 0 (List.map transl args) @@ -887,7 +893,7 @@ let rec transl = function | (Pbigarrayref(num_dims, elt_kind, layout), arg1 :: argl) -> let elt = bigarray_get elt_kind layout - (transl arg1) (List.map transl argl) in + (transl arg1) (List.map transl argl) dbg in begin match elt_kind with Pbigarray_float32 | Pbigarray_float64 -> box_float elt | Pbigarray_complex32 | Pbigarray_complex64 -> elt @@ -909,13 +915,14 @@ let rec transl = function | Pbigarray_int32 -> transl_unbox_int Pint32 argnewval | Pbigarray_int64 -> transl_unbox_int Pint64 argnewval | Pbigarray_native_int -> transl_unbox_int Pnativeint argnewval - | _ -> untag_int (transl argnewval))) + | _ -> untag_int (transl argnewval)) + dbg) | (p, [arg]) -> - transl_prim_1 p arg + transl_prim_1 p arg dbg | (p, [arg1; arg2]) -> - transl_prim_2 p arg1 arg2 + transl_prim_2 p arg1 arg2 dbg | (p, [arg1; arg2; arg3]) -> - transl_prim_3 p arg1 arg2 arg3 + transl_prim_3 p arg1 arg2 arg3 dbg | (_, _) -> fatal_error "Cmmgen.transl:prim" end @@ -948,19 +955,19 @@ let rec transl = function Ccatch(nfail, ids, transl body, transl handler) | Utrywith(body, exn, handler) -> Ctrywith(transl body, exn, transl handler) - | Uifthenelse(Uprim(Pnot, [arg]), ifso, ifnot) -> + | Uifthenelse(Uprim(Pnot, [arg], _), ifso, ifnot) -> transl (Uifthenelse(arg, ifnot, ifso)) | Uifthenelse(cond, ifso, Ustaticfail (nfail, [])) -> exit_if_false cond (transl ifso) nfail | Uifthenelse(cond, Ustaticfail (nfail, []), ifnot) -> exit_if_true cond nfail (transl ifnot) - | Uifthenelse(Uprim(Psequand, _) as cond, ifso, ifnot) -> + | Uifthenelse(Uprim(Psequand, _, _) as cond, ifso, ifnot) -> let raise_num = next_raise_count () in make_catch raise_num (exit_if_false cond (transl ifso) raise_num) (transl ifnot) - | Uifthenelse(Uprim(Psequor, _) as cond, ifso, ifnot) -> + | Uifthenelse(Uprim(Psequor, _, _) as cond, ifso, ifnot) -> let raise_num = next_raise_count () in make_catch raise_num @@ -1016,7 +1023,7 @@ let rec transl = function | Uassign(id, exp) -> return_unit(Cassign(id, transl exp)) -and transl_prim_1 p arg = +and transl_prim_1 p arg dbg = match p with (* Generic operations *) Pidentity -> @@ -1034,7 +1041,7 @@ and transl_prim_1 p arg = else Cop(Cadda, [ptr; Cconst_int(n * size_float)])])) (* Exceptions *) | Praise -> - Cop(Craise, [transl arg]) + Cop(Craise dbg, [transl arg]) (* Integer operations *) | Pnegint -> Cop(Csubi, [Cconst_int 2; transl arg]) @@ -1042,7 +1049,7 @@ and transl_prim_1 p arg = if no_overflow_lsl n then add_const (transl arg) (n lsl 1) else - transl_prim_2 Paddint arg (Uconst (Const_base(Const_int n))) + transl_prim_2 Paddint arg (Uconst (Const_base(Const_int n))) Debuginfo.none | Poffsetref n -> return_unit (bind "ref" (transl arg) (fun arg -> @@ -1096,12 +1103,12 @@ and transl_prim_1 p arg = | _ -> fatal_error "Cmmgen.transl_prim_1" -and transl_prim_2 p arg1 arg2 = +and transl_prim_2 p arg1 arg2 dbg = match p with (* Heap operations *) Psetfield(n, ptr) -> if ptr then - return_unit(Cop(Cextcall("caml_modify", typ_void, false), + return_unit(Cop(Cextcall("caml_modify", typ_void, false, Debuginfo.none), [field_address (transl arg1) n; transl arg2])) else return_unit(set_field (transl arg1) n (transl arg2)) @@ -1130,9 +1137,9 @@ and transl_prim_2 p arg1 arg2 = | Pmulint -> incr_int(Cop(Cmuli, [decr_int(transl arg1); untag_int(transl arg2)])) | Pdivint -> - tag_int(safe_divmod Cdivi (untag_int(transl arg1)) (untag_int(transl arg2))) + tag_int(safe_divmod Cdivi (untag_int(transl arg1)) (untag_int(transl arg2)) dbg) | Pmodint -> - tag_int(safe_divmod Cmodi (untag_int(transl arg1)) (untag_int(transl arg2))) + tag_int(safe_divmod Cmodi (untag_int(transl arg1)) (untag_int(transl arg2)) dbg) | Pandint -> Cop(Cand, [transl arg1; transl arg2]) | Porint -> @@ -1179,7 +1186,7 @@ and transl_prim_2 p arg1 arg2 = (bind "str" (transl arg1) (fun str -> bind "index" (untag_int (transl arg2)) (fun idx -> Csequence( - Cop(Ccheckbound, [string_length str; idx]), + Cop(Ccheckbound dbg, [string_length str; idx]), Cop(Cload Byte_unsigned, [add_int str idx]))))) (* Array operations *) @@ -1203,20 +1210,20 @@ and transl_prim_2 p arg1 arg2 = bind "arr" (transl arg1) (fun arr -> bind "header" (header arr) (fun hdr -> Cifthenelse(is_addr_array_hdr hdr, - Csequence(Cop(Ccheckbound, [addr_array_length hdr; idx]), + Csequence(Cop(Ccheckbound dbg, [addr_array_length hdr; idx]), addr_array_ref arr idx), - Csequence(Cop(Ccheckbound, [float_array_length hdr; idx]), + Csequence(Cop(Ccheckbound dbg, [float_array_length hdr; idx]), float_array_ref arr idx))))) | Paddrarray | Pintarray -> bind "index" (transl arg2) (fun idx -> bind "arr" (transl arg1) (fun arr -> - Csequence(Cop(Ccheckbound, [addr_array_length(header arr); idx]), + Csequence(Cop(Ccheckbound dbg, [addr_array_length(header arr); idx]), addr_array_ref arr idx))) | Pfloatarray -> box_float( bind "index" (transl arg2) (fun idx -> bind "arr" (transl arg1) (fun arr -> - Csequence(Cop(Ccheckbound, + Csequence(Cop(Ccheckbound dbg, [float_array_length(header arr); idx]), unboxed_float_array_ref arr idx)))) end @@ -1243,10 +1250,12 @@ and transl_prim_2 p arg1 arg2 = [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) | Pdivbint bi -> box_int bi (safe_divmod Cdivi - (transl_unbox_int bi arg1) (transl_unbox_int bi arg2)) + (transl_unbox_int bi arg1) (transl_unbox_int bi arg2) + dbg) | Pmodbint bi -> box_int bi (safe_divmod Cmodi - (transl_unbox_int bi arg1) (transl_unbox_int bi arg2)) + (transl_unbox_int bi arg1) (transl_unbox_int bi arg2) + dbg) | Pandbint bi -> box_int bi (Cop(Cand, [transl_unbox_int bi arg1; transl_unbox_int bi arg2])) @@ -1272,7 +1281,7 @@ and transl_prim_2 p arg1 arg2 = | _ -> fatal_error "Cmmgen.transl_prim_2" -and transl_prim_3 p arg1 arg2 arg3 = +and transl_prim_3 p arg1 arg2 arg3 dbg = match p with (* String operations *) Pstringsetu -> @@ -1284,7 +1293,7 @@ and transl_prim_3 p arg1 arg2 arg3 = (bind "str" (transl arg1) (fun str -> bind "index" (untag_int (transl arg2)) (fun idx -> Csequence( - Cop(Ccheckbound, [string_length str; idx]), + Cop(Ccheckbound dbg, [string_length str; idx]), Cop(Cstore Byte_unsigned, [add_int str idx; untag_int(transl arg3)]))))) @@ -1313,25 +1322,25 @@ and transl_prim_3 p arg1 arg2 arg3 = bind "arr" (transl arg1) (fun arr -> bind "header" (header arr) (fun hdr -> Cifthenelse(is_addr_array_hdr hdr, - Csequence(Cop(Ccheckbound, [addr_array_length hdr; idx]), + Csequence(Cop(Ccheckbound dbg, [addr_array_length hdr; idx]), addr_array_set arr idx newval), - Csequence(Cop(Ccheckbound, [float_array_length hdr; idx]), + Csequence(Cop(Ccheckbound dbg, [float_array_length hdr; idx]), float_array_set arr idx (unbox_float newval))))))) | Paddrarray -> bind "index" (transl arg2) (fun idx -> bind "arr" (transl arg1) (fun arr -> - Csequence(Cop(Ccheckbound, [addr_array_length(header arr); idx]), + Csequence(Cop(Ccheckbound dbg, [addr_array_length(header arr); idx]), addr_array_set arr idx (transl arg3)))) | Pintarray -> bind "index" (transl arg2) (fun idx -> bind "arr" (transl arg1) (fun arr -> - Csequence(Cop(Ccheckbound, [addr_array_length(header arr); idx]), + Csequence(Cop(Ccheckbound dbg, [addr_array_length(header arr); idx]), int_array_set arr idx (transl arg3)))) | Pfloatarray -> bind "index" (transl arg2) (fun idx -> bind "arr" (transl arg1) (fun arr -> - Csequence(Cop(Ccheckbound, [float_array_length(header arr);idx]), + Csequence(Cop(Ccheckbound dbg, [float_array_length(header arr);idx]), float_array_set arr idx (transl_unbox_float arg3)))) end) | _ -> @@ -1348,21 +1357,22 @@ and transl_unbox_int bi = function Cconst_natint n | Uconst(Const_base(Const_int64 n)) -> assert (size_int = 8); Cconst_natint (Int64.to_nativeint n) - | Uprim(Pbintofint bi', [Uconst(Const_base(Const_int i))]) when bi = bi' -> + | Uprim(Pbintofint bi', [Uconst(Const_base(Const_int i))], _) when bi = bi' -> Cconst_int i | exp -> unbox_int bi (transl exp) and transl_unbox_let box_fn unbox_fn transl_unbox_fn id exp body = let unboxed_id = Ident.create (Ident.name id) in - let (tr_body, need_boxed, is_assigned) = - subst_boxed_number unbox_fn id unboxed_id (transl body) in + let trbody1 = transl body in + let (trbody2, need_boxed, is_assigned) = + subst_boxed_number unbox_fn id unboxed_id trbody1 in if need_boxed && is_assigned then - Clet(id, transl exp, transl body) + Clet(id, transl exp, trbody1) else Clet(unboxed_id, transl_unbox_fn exp, if need_boxed - then Clet(id, box_fn(Cvar unboxed_id), tr_body) - else tr_body) + then Clet(id, box_fn(Cvar unboxed_id), trbody2) + else trbody2) and make_catch ncatch body handler = match body with | Cexit (nexit,[]) when nexit=ncatch -> handler @@ -1382,9 +1392,9 @@ and exit_if_true cond nfail otherwise = match cond with | Uconst (Const_pointer 0) -> otherwise | Uconst (Const_pointer 1) -> Cexit (nfail,[]) - | Uprim(Psequor, [arg1; arg2]) -> + | Uprim(Psequor, [arg1; arg2], _) -> exit_if_true arg1 nfail (exit_if_true arg2 nfail otherwise) - | Uprim(Psequand, _) -> + | Uprim(Psequand, _, _) -> begin match otherwise with | Cexit (raise_num,[]) -> exit_if_false cond (Cexit (nfail,[])) raise_num @@ -1395,7 +1405,7 @@ and exit_if_true cond nfail otherwise = (exit_if_false cond (Cexit (nfail,[])) raise_num) otherwise end - | Uprim(Pnot, [arg]) -> + | Uprim(Pnot, [arg], _) -> exit_if_false arg otherwise nfail | Uifthenelse (cond, ifso, ifnot) -> make_catch2 @@ -1412,9 +1422,9 @@ and exit_if_false cond otherwise nfail = match cond with | Uconst (Const_pointer 0) -> Cexit (nfail,[]) | Uconst (Const_pointer 1) -> otherwise - | Uprim(Psequand, [arg1; arg2]) -> + | Uprim(Psequand, [arg1; arg2], _) -> exit_if_false arg1 (exit_if_false arg2 otherwise nfail) nfail - | Uprim(Psequor, _ ) -> + | Uprim(Psequor, _, _) -> begin match otherwise with | Cexit (raise_num,[]) -> exit_if_true cond raise_num (Cexit (nfail,[])) @@ -1425,7 +1435,7 @@ and exit_if_false cond otherwise nfail = (exit_if_true cond raise_num (Cexit (nfail,[]))) otherwise end - | Uprim(Pnot, [arg]) -> + | Uprim(Pnot, [arg], _) -> exit_if_true arg nfail otherwise | Uifthenelse (cond, ifso, ifnot) -> make_catch2 @@ -1474,7 +1484,7 @@ and transl_letrec bindings cont = let rec init_blocks = function | [] -> fill_nonrec bsz | (id, exp, RHS_block sz) :: rem -> - Clet(id, Cop(Cextcall("caml_alloc_dummy", typ_addr, true), + Clet(id, Cop(Cextcall("caml_alloc_dummy", typ_addr, true, Debuginfo.none), [int_const sz]), init_blocks rem) | (id, exp, RHS_nonrec) :: rem -> @@ -1487,7 +1497,7 @@ and transl_letrec bindings cont = and fill_blocks = function | [] -> cont | (id, exp, RHS_block _) :: rem -> - Csequence(Cop(Cextcall("caml_update_dummy", typ_void, false), + Csequence(Cop(Cextcall("caml_update_dummy", typ_void, false, Debuginfo.none), [Cvar id; transl exp]), fill_blocks rem) | (id, exp, RHS_nonrec) :: rem -> @@ -1774,12 +1784,12 @@ let apply_function_body arity = let clos = Ident.create "clos" in let rec app_fun clos n = if n = arity-1 then - Cop(Capply typ_addr, + Cop(Capply(typ_addr, Debuginfo.none), [get_field (Cvar clos) 0; Cvar arg.(n); Cvar clos]) else begin let newclos = Ident.create "clos" in Clet(newclos, - Cop(Capply typ_addr, + Cop(Capply(typ_addr, Debuginfo.none), [get_field (Cvar clos) 0; Cvar arg.(n); Cvar clos]), app_fun newclos (n+1)) end in @@ -1789,7 +1799,7 @@ let apply_function_body arity = if arity = 1 then app_fun clos 0 else Cifthenelse( Cop(Ccmpi Ceq, [get_field (Cvar clos) 1; int_const arity]), - Cop(Capply typ_addr, + Cop(Capply(typ_addr, Debuginfo.none), get_field (Cvar clos) 2 :: List.map (fun s -> Cvar s) all_args), app_fun clos 0)) @@ -1854,7 +1864,7 @@ let tuplify_function arity = {fun_name = "caml_tuplify" ^ string_of_int arity; fun_args = [arg, typ_addr; clos, typ_addr]; fun_body = - Cop(Capply typ_addr, + Cop(Capply(typ_addr, Debuginfo.none), get_field (Cvar clos) 2 :: access_components 0 @ [Cvar clos]); fun_fast = true} @@ -1878,7 +1888,7 @@ let final_curry_function arity = let last_clos = Ident.create "clos" in let rec curry_fun args clos n = if n = 0 then - Cop(Capply typ_addr, + Cop(Capply(typ_addr, Debuginfo.none), get_field (Cvar clos) 2 :: args @ [Cvar last_arg; Cvar clos]) else begin @@ -1929,7 +1939,8 @@ let entry_point namelist = List.fold_right (fun name next -> let entry_sym = Compilenv.make_symbol ~unitname:name (Some "entry") in - Csequence(Cop(Capply typ_void, [Cconst_symbol entry_sym]), + Csequence(Cop(Capply(typ_void, Debuginfo.none), + [Cconst_symbol entry_sym]), Csequence(incr_global_inited, next))) namelist (Cconst_int 1) in Cfunction {fun_name = "caml_program"; diff --git a/asmcomp/cmmgen.mli b/asmcomp/cmmgen.mli index 49d90218..4c6fb0d4 100644 --- a/asmcomp/cmmgen.mli +++ b/asmcomp/cmmgen.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: cmmgen.mli,v 1.12 2004/05/26 11:10:28 garrigue Exp $ *) +(* $Id: cmmgen.mli,v 1.14 2007/02/15 18:36:08 frisch Exp $ *) (* Translation from closed lambda to C-- *) diff --git a/asmcomp/comballoc.ml b/asmcomp/comballoc.ml index fba74937..5888f864 100644 --- a/asmcomp/comballoc.ml +++ b/asmcomp/comballoc.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: comballoc.ml,v 1.3 2000/08/11 19:50:50 maranget Exp $ *) +(* $Id: comballoc.ml,v 1.4 2007/01/29 12:10:50 xleroy Exp $ *) (* Combine heap allocations occurring in the same basic block *) @@ -49,13 +49,14 @@ let rec combine i allocstate = (instr_cons (Iop(Ialloc newsz)) i.arg i.res newnext, ofs) end end - | Iop(Icall_ind | Icall_imm _ | Iextcall(_, _) | + | Iop(Icall_ind | Icall_imm _ | Iextcall _ | Itailcall_ind | Itailcall_imm _) -> let newnext = combine_restart i.next in - (instr_cons i.desc i.arg i.res newnext, allocated_size allocstate) + (instr_cons_debug i.desc i.arg i.res i.dbg newnext, + allocated_size allocstate) | Iop op -> let (newnext, sz) = combine i.next allocstate in - (instr_cons i.desc i.arg i.res newnext, sz) + (instr_cons_debug i.desc i.arg i.res i.dbg newnext, sz) | Iifthenelse(test, ifso, ifnot) -> let newifso = combine_restart ifso in let newifnot = combine_restart ifnot in diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml index fa0d83d9..447a46fb 100644 --- a/asmcomp/compilenv.ml +++ b/asmcomp/compilenv.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: compilenv.ml,v 1.22 2005/08/01 15:51:09 xleroy Exp $ *) +(* $Id: compilenv.ml,v 1.23 2006/10/17 12:33:58 xleroy Exp $ *) (* Compilation environments for compilation units *) @@ -155,6 +155,9 @@ let get_global_info global_ident = infos end +let cache_unit_info ui = + Hashtbl.add global_infos_table ui.ui_name (Some ui) + (* Return the approximation of a global identifier *) let global_approx id = diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli index 5091ddfd..425f4e14 100644 --- a/asmcomp/compilenv.mli +++ b/asmcomp/compilenv.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: compilenv.mli,v 1.15 2005/08/01 15:51:09 xleroy Exp $ *) +(* $Id: compilenv.mli,v 1.16 2006/10/17 12:33:58 xleroy Exp $ *) (* Compilation environments for compilation units *) @@ -83,6 +83,10 @@ val write_unit_info: unit_infos -> string -> unit (* Save the given infos in the given file *) val save_unit_info: string -> unit (* Save the infos for the current unit in the given file *) +val cache_unit_info: unit_infos -> unit + (* Enter the given infos in the cache. The infos will be + honored by [symbol_for_global] and [global_approx] + without looking at the corresponding .cmx file. *) val cmx_not_found_crc: Digest.t (* Special digest used in the [ui_imports_cmx] list to signal diff --git a/asmcomp/debuginfo.ml b/asmcomp/debuginfo.ml new file mode 100644 index 00000000..84390442 --- /dev/null +++ b/asmcomp/debuginfo.ml @@ -0,0 +1,52 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +open Lexing +open Location + +type kind = Dinfo_call | Dinfo_raise + +type t = { + dinfo_kind: kind; + dinfo_file: string; + dinfo_line: int; + dinfo_char_start: int; + dinfo_char_end: int +} + +let none = { + dinfo_kind = Dinfo_call; + dinfo_file = ""; + dinfo_line = 0; + dinfo_char_start = 0; + dinfo_char_end = 0 +} + +let to_string d = + if d == none + then "" + else Printf.sprintf "{%s:%d,%d-%d}" + d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end + +let from_location kind loc = + if loc.loc_ghost then none else + { dinfo_kind = kind; + dinfo_file = loc.loc_start.pos_fname; + dinfo_line = loc.loc_start.pos_lnum; + dinfo_char_start = loc.loc_start.pos_cnum - loc.loc_start.pos_bol; + dinfo_char_end = + if loc.loc_end.pos_fname = loc.loc_start.pos_fname + then loc.loc_end.pos_cnum - loc.loc_start.pos_bol + else loc.loc_start.pos_cnum - loc.loc_start.pos_bol } + +let from_call ev = from_location Dinfo_call ev.Lambda.lev_loc +let from_raise ev = from_location Dinfo_raise ev.Lambda.lev_loc diff --git a/asmcomp/debuginfo.mli b/asmcomp/debuginfo.mli new file mode 100644 index 00000000..151cd0ab --- /dev/null +++ b/asmcomp/debuginfo.mli @@ -0,0 +1,31 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +type kind = Dinfo_call | Dinfo_raise + +type t = { + dinfo_kind: kind; + dinfo_file: string; + dinfo_line: int; + dinfo_char_start: int; + dinfo_char_end: int +} + +val none: t + +val to_string: t -> string + +val from_location: kind -> Location.t -> t + +val from_call: Lambda.lambda_event -> t +val from_raise: Lambda.lambda_event -> t + diff --git a/asmcomp/emitaux.ml b/asmcomp/emitaux.ml index 1bfee7ac..ee381a59 100644 --- a/asmcomp/emitaux.ml +++ b/asmcomp/emitaux.ml @@ -10,10 +10,15 @@ (* *) (***********************************************************************) -(* $Id: emitaux.ml,v 1.11 1999/11/17 18:56:33 xleroy Exp $ *) +(* $Id: emitaux.ml,v 1.12 2007/01/29 12:10:50 xleroy Exp $ *) (* Common functions for emitting assembly code *) +open Debuginfo +open Cmm +open Reg +open Linearize + let output_channel = ref stdout let emit_string s = output_string !output_channel s @@ -27,6 +32,8 @@ let emit_nativeint n = output_string !output_channel (Nativeint.to_string n) let emit_printf fmt = Printf.fprintf !output_channel fmt +let emit_int32 n = emit_printf "0x%lx" n + let emit_symbol esc s = for i = 0 to String.length s - 1 do let c = s.[i] in @@ -86,3 +93,66 @@ let emit_bytes_directive directive s = done; if !pos > 0 then emit_char '\n' +(* Record live pointers at call points *) + +type frame_descr = + { fd_lbl: int; (* Return address *) + fd_frame_size: int; (* Size of stack frame *) + fd_live_offset: int list; (* Offsets/regs of live addresses *) + fd_debuginfo: Debuginfo.t } (* Location, if any *) + +let frame_descriptors = ref([] : frame_descr list) + +type emit_frame_actions = + { efa_label: int -> unit; + efa_16: int -> unit; + efa_32: int32 -> unit; + efa_word: int -> unit; + efa_align: int -> unit; + efa_label_rel: int -> int32 -> unit; + efa_def_label: int -> unit; + efa_string: string -> unit } + +let emit_frames a = + let filenames = Hashtbl.create 7 in + let lbl_filenames = ref 200000 in + let label_filename name = + try + Hashtbl.find filenames name + with Not_found -> + let lbl = !lbl_filenames in + Hashtbl.add filenames name lbl; + incr lbl_filenames; + lbl in + let emit_frame fd = + a.efa_label fd.fd_lbl; + a.efa_16 (if fd.fd_debuginfo == Debuginfo.none + then fd.fd_frame_size + else fd.fd_frame_size + 1); + a.efa_16 (List.length fd.fd_live_offset); + List.iter a.efa_16 fd.fd_live_offset; + a.efa_align Arch.size_addr; + if fd.fd_debuginfo != Debuginfo.none then begin + let d = fd.fd_debuginfo in + let line = min 0xFFFFF d.dinfo_line + and char_start = min 0xFF d.dinfo_char_start + and char_end = min 0x3FF d.dinfo_char_end + and kind = match d.dinfo_kind with Dinfo_call -> 0 | Dinfo_raise -> 1 in + let info = + Int64.add (Int64.shift_left (Int64.of_int line) 44) ( + Int64.add (Int64.shift_left (Int64.of_int char_start) 36) ( + Int64.add (Int64.shift_left (Int64.of_int char_end) 26) + (Int64.of_int kind))) in + a.efa_label_rel + (label_filename d.dinfo_file) + (Int64.to_int32 info); + a.efa_32 (Int64.to_int32 (Int64.shift_right info 32)) + end in + let emit_filename name lbl = + a.efa_def_label lbl; + a.efa_string name; + a.efa_align Arch.size_addr in + a.efa_word (List.length !frame_descriptors); + List.iter emit_frame !frame_descriptors; + Hashtbl.iter emit_filename filenames; + frame_descriptors := [] diff --git a/asmcomp/emitaux.mli b/asmcomp/emitaux.mli index f468df08..bf8ef1e7 100644 --- a/asmcomp/emitaux.mli +++ b/asmcomp/emitaux.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emitaux.mli,v 1.11 2003/07/05 11:12:39 xleroy Exp $ *) +(* $Id: emitaux.mli,v 1.12 2007/01/29 12:10:50 xleroy Exp $ *) (* Common functions for emitting assembly code *) @@ -18,9 +18,30 @@ val output_channel: out_channel ref val emit_string: string -> unit val emit_int: int -> unit val emit_nativeint: nativeint -> unit +val emit_int32: int32 -> unit val emit_symbol: char -> string -> unit val emit_printf: ('a, out_channel, unit) format -> 'a val emit_char: char -> unit val emit_string_literal: string -> unit val emit_string_directive: string -> string -> unit val emit_bytes_directive: string -> string -> unit + +type frame_descr = + { fd_lbl: int; (* Return address *) + fd_frame_size: int; (* Size of stack frame *) + fd_live_offset: int list; (* Offsets/regs of live addresses *) + fd_debuginfo: Debuginfo.t } (* Location, if any *) + +val frame_descriptors : frame_descr list ref + +type emit_frame_actions = + { efa_label: int -> unit; + efa_16: int -> unit; + efa_32: int32 -> unit; + efa_word: int -> unit; + efa_align: int -> unit; + efa_label_rel: int -> int32 -> unit; + efa_def_label: int -> unit; + efa_string: string -> unit } + +val emit_frames: emit_frame_actions -> unit diff --git a/asmcomp/hppa/emit.mlp b/asmcomp/hppa/emit.mlp index c44ab719..b1fa3455 100644 --- a/asmcomp/hppa/emit.mlp +++ b/asmcomp/hppa/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp,v 1.19.10.1 2006/03/29 14:49:19 doligez Exp $ *) +(* $Id: emit.mlp,v 1.20 2006/04/16 23:28:14 doligez Exp $ *) (* Emission of HP PA-RISC assembly code *) diff --git a/asmcomp/i386/arch.ml b/asmcomp/i386/arch.ml index cb0c8bae..3ccdb931 100644 --- a/asmcomp/i386/arch.ml +++ b/asmcomp/i386/arch.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: arch.ml,v 1.12.18.1 2006/03/01 13:46:56 xleroy Exp $ *) +(* $Id: arch.ml,v 1.13 2006/04/16 23:28:14 doligez Exp $ *) (* Machine-specific command-line options *) diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index 5223cec0..d13dea58 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp,v 1.35.4.2 2006/03/29 14:49:19 doligez Exp $ *) +(* $Id: emit.mlp,v 1.38.4.1 2007/03/07 09:14:29 xleroy Exp $ *) (* Emission of Intel 386 assembly code *) @@ -175,14 +175,7 @@ let emit_addressing addr r n = (* Record live pointers at call points *) -type frame_descr = - { fd_lbl: int; (* Return address *) - fd_frame_size: int; (* Size of stack frame *) - fd_live_offset: int list } (* Offsets/regs of live addresses *) - -let frame_descriptors = ref([] : frame_descr list) - -let record_frame_label live = +let record_frame_label live dbg = let lbl = new_label() in let live_offset = ref [] in Reg.Set.iter @@ -196,21 +189,12 @@ let record_frame_label live = frame_descriptors := { fd_lbl = lbl; fd_frame_size = frame_size(); - fd_live_offset = !live_offset } :: !frame_descriptors; + fd_live_offset = !live_offset; + fd_debuginfo = dbg } :: !frame_descriptors; lbl -let record_frame live = - let lbl = record_frame_label live in `{emit_label lbl}:\n` - -let emit_frame fd = - ` .long {emit_label fd.fd_lbl}\n`; - ` {emit_string word_dir} {emit_int fd.fd_frame_size}\n`; - ` {emit_string word_dir} {emit_int (List.length fd.fd_live_offset)}\n`; - List.iter - (fun n -> - ` {emit_string word_dir} {emit_int n}\n`) - fd.fd_live_offset; - emit_align 4 +let record_frame live dbg = + let lbl = record_frame_label live dbg in `{emit_label lbl}:\n` (* Record calls to the GC -- we've moved them out of the way *) @@ -225,6 +209,38 @@ let emit_call_gc gc = `{emit_label gc.gc_lbl}: call {emit_symbol "caml_call_gc"}\n`; `{emit_label gc.gc_frame}: jmp {emit_label gc.gc_return_lbl}\n` +(* Record calls to caml_ml_array_bound_error. + In -g mode, we maintain one call to caml_ml_array_bound_error + per bound check site. Without -g, we can share a single call. *) + +type bound_error_call = + { bd_lbl: label; (* Entry label *) + bd_frame: label } (* Label of frame descriptor *) + +let bound_error_sites = ref ([] : bound_error_call list) +let bound_error_call = ref 0 + +let bound_error_label dbg = + if !Clflags.debug then begin + let lbl_bound_error = new_label() in + let lbl_frame = record_frame_label Reg.Set.empty dbg in + bound_error_sites := + { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; + lbl_bound_error + end else begin + if !bound_error_call = 0 then bound_error_call := new_label(); + !bound_error_call + end + +let emit_call_bound_error bd = + `{emit_label bd.bd_lbl}: call {emit_symbol "caml_ml_array_bound_error"}\n`; + `{emit_label bd.bd_frame}:\n` + +let emit_call_bound_errors () = + List.iter emit_call_bound_error !bound_error_sites; + if !bound_error_call > 0 then + `{emit_label !bound_error_call}: jmp {emit_symbol "caml_ml_array_bound_error"}\n` + (* Names for instructions *) let instr_for_intop = function @@ -442,10 +458,10 @@ let emit_instr fallthrough i = ` movl ${emit_symbol s}, {emit_reg i.res.(0)}\n` | Lop(Icall_ind) -> ` call *{emit_reg i.arg.(0)}\n`; - record_frame i.live + record_frame i.live i.dbg | Lop(Icall_imm s) -> ` call {emit_symbol s}\n`; - record_frame i.live + record_frame i.live i.dbg | Lop(Itailcall_ind) -> output_epilogue(); ` jmp *{emit_reg i.arg.(0)}\n` @@ -466,7 +482,7 @@ let emit_instr fallthrough i = ` movl L{emit_symbol s}$non_lazy_ptr, %eax\n` end; ` call {emit_symbol "caml_c_call"}\n`; - record_frame i.live + record_frame i.live i.dbg end else begin if not macosx then ` call {emit_symbol s}\n` @@ -530,7 +546,7 @@ let emit_instr fallthrough i = ` movl %eax, {emit_symbol "caml_young_ptr"}\n`; ` cmpl {emit_symbol "caml_young_limit"}, %eax\n`; let lbl_call_gc = new_label() in - let lbl_frame = record_frame_label i.live in + let lbl_frame = record_frame_label i.live Debuginfo.none in ` jb {emit_label lbl_call_gc}\n`; ` leal 4(%eax), {emit_reg i.res.(0)}\n`; call_gc_sites := @@ -545,7 +561,7 @@ let emit_instr fallthrough i = | _ -> ` movl ${emit_int n}, %eax\n`; ` call {emit_symbol "caml_allocN"}\n` end; - `{record_frame i.live} leal 4(%eax), {emit_reg i.res.(0)}\n` + `{record_frame i.live Debuginfo.none} leal 4(%eax), {emit_reg i.res.(0)}\n` end | Lop(Iintop(Icomp cmp)) -> ` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; @@ -558,13 +574,13 @@ let emit_instr fallthrough i = ` set{emit_string b} %al\n`; ` movzbl %al, {emit_reg i.res.(0)}\n` | Lop(Iintop Icheckbound) -> - if !range_check_trap = 0 then range_check_trap := new_label(); + let lbl = bound_error_label i.dbg in ` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; - ` jbe {emit_label !range_check_trap}\n` + ` jbe {emit_label lbl}\n` | Lop(Iintop_imm(Icheckbound, n)) -> - if !range_check_trap = 0 then range_check_trap := new_label(); + let lbl = bound_error_label i.dbg in ` cmpl ${emit_int n}, {emit_reg i.arg.(0)}\n`; - ` jbe {emit_label !range_check_trap}\n` + ` jbe {emit_label lbl}\n` | Lop(Iintop(Idiv | Imod)) -> ` cltd\n`; ` idivl {emit_reg i.arg.(1)}\n` @@ -775,14 +791,18 @@ let emit_instr fallthrough i = ` addl ${emit_int (trap_frame_size - 4)}, %esp\n`; stack_offset := !stack_offset - trap_frame_size | Lraise -> - ` movl {emit_symbol "caml_exception_pointer"}, %esp\n`; - ` popl {emit_symbol "caml_exception_pointer"}\n`; - if trap_frame_size > 8 then - ` addl ${emit_int (trap_frame_size - 8)}, %esp\n`; - ` ret\n` + if !Clflags.debug then begin + ` call {emit_symbol "caml_raise_exn"}\n`; + record_frame Reg.Set.empty i.dbg + end else begin + ` movl {emit_symbol "caml_exception_pointer"}, %esp\n`; + ` popl {emit_symbol "caml_exception_pointer"}\n`; + if trap_frame_size > 8 then + ` addl ${emit_int (trap_frame_size - 8)}, %esp\n`; + ` ret\n` + end let rec emit_all fallthrough i = - match i.desc with | Lend -> () | _ -> @@ -815,7 +835,12 @@ let emit_external_symbols () = external_symbols_indirect := StringSet.empty; ` .section __IMPORT,__jump_table,symbol_stubs,self_modifying_code+pure_instructions,5\n`; StringSet.iter emit_external_symbol_direct !external_symbols_direct; - external_symbols_direct := StringSet.empty + external_symbols_direct := StringSet.empty; + if !Clflags.gprofile then begin + `Lmcount$stub:\n`; + ` .indirect_symbol mcount\n`; + ` hlt ; hlt ; hlt ; hlt ; hlt\n` + end (* Emission of the profiling prelude *) @@ -839,6 +864,15 @@ let emit_profile () = ` popl %edx\n`; ` popl %ecx\n`; ` popl %eax\n` + | "macosx" -> + ` pushl %eax\n`; + ` movl %esp, %ebp\n`; + ` pushl %ecx\n`; + ` pushl %edx\n`; + ` call Lmcount$stub\n`; + ` popl %edx\n`; + ` popl %ecx\n`; + ` popl %eax\n` | _ -> () (*unsupported yet*) (* Declare a global function symbol *) @@ -859,7 +893,8 @@ let fundecl fundecl = stack_offset := 0; float_constants := []; call_gc_sites := []; - range_check_trap := 0; + bound_error_sites := []; + bound_error_call := 0; ` .text\n`; emit_align 16; declare_function_symbol fundecl.fun_name; @@ -871,9 +906,7 @@ let fundecl fundecl = `{emit_label !tailrec_entry_point}:\n`; emit_all true fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; - if !range_check_trap > 0 then - `{emit_label !range_check_trap}: call {emit_symbol "caml_ml_array_bound_error"}\n`; - (* Never returns, but useful to have retaddr on stack for debugging *) + emit_call_bound_errors (); List.iter emit_float_constant !float_constants (* Emission of data *) @@ -939,7 +972,18 @@ let end_assembly() = let lbl = Compilenv.make_symbol (Some "frametable") in ` .globl {emit_symbol lbl}\n`; `{emit_symbol lbl}:\n`; - ` .long {emit_int (List.length !frame_descriptors)}\n`; - List.iter emit_frame !frame_descriptors; - frame_descriptors := []; + emit_frames + { efa_label = (fun l -> ` .long {emit_label l}\n`); + efa_16 = (fun n -> ` {emit_string word_dir} {emit_int n}\n`); + efa_32 = (fun n -> ` .long {emit_int32 n}\n`); + efa_word = (fun n -> ` .long {emit_int n}\n`); + efa_align = emit_align; + efa_label_rel = (fun lbl ofs -> + ` .long {emit_label lbl} - . + {emit_int32 ofs}\n`); + efa_def_label = (fun l -> `{emit_label l}:\n`); + efa_string = (fun s -> + let s = s ^ "\000" in + if use_ascii_dir + then emit_string_directive " .ascii " s + else emit_bytes_directive " .byte " s) }; if macosx then emit_external_symbols () diff --git a/asmcomp/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp index b92a3cbd..6699e2f3 100644 --- a/asmcomp/i386/emit_nt.mlp +++ b/asmcomp/i386/emit_nt.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit_nt.mlp,v 1.25 2004/08/12 14:29:25 xleroy Exp $ *) +(* $Id: emit_nt.mlp,v 1.27 2007/01/29 12:10:50 xleroy Exp $ *) (* Emission of Intel 386 assembly code, MASM syntax. *) @@ -64,6 +64,8 @@ let add_used_symbol s = let emit_symbol s = emit_string "_"; Emitaux.emit_symbol '$' s +let emit_int32 n = emit_printf "0%lxh" n + (* Output a label *) let emit_label lbl = @@ -140,14 +142,7 @@ let emit_addressing addr r n = (* Record live pointers at call points *) -type frame_descr = - { fd_lbl: int; (* Return address *) - fd_frame_size: int; (* Size of stack frame *) - fd_live_offset: int list } (* Offsets/regs of live addresses *) - -let frame_descriptors = ref([] : frame_descr list) - -let record_frame_label live = +let record_frame_label live dbg = let lbl = new_label() in let live_offset = ref [] in Reg.Set.iter @@ -161,21 +156,12 @@ let record_frame_label live = frame_descriptors := { fd_lbl = lbl; fd_frame_size = frame_size(); - fd_live_offset = !live_offset } :: !frame_descriptors; + fd_live_offset = !live_offset; + fd_debuginfo = dbg } :: !frame_descriptors; lbl -let record_frame live = - let lbl = record_frame_label live in `{emit_label lbl}:\n` - -let emit_frame fd = - ` DWORD {emit_label fd.fd_lbl}\n`; - ` WORD {emit_int fd.fd_frame_size}\n`; - ` WORD {emit_int (List.length fd.fd_live_offset)}\n`; - List.iter - (fun n -> - ` WORD {emit_int n}\n`) - fd.fd_live_offset; - emit_align 4 +let record_frame live dbg = + let lbl = record_frame_label live dbg in `{emit_label lbl}:\n` (* Record calls to the GC -- we've moved them out of the way *) @@ -190,6 +176,38 @@ let emit_call_gc gc = `{emit_label gc.gc_lbl}: call _caml_call_gc\n`; `{emit_label gc.gc_frame}: jmp {emit_label gc.gc_return_lbl}\n` +(* Record calls to caml_ml_array_bound_error. + In -g mode, we maintain one call to caml_ml_array_bound_error + per bound check site. Without -g, we can share a single call. *) + +type bound_error_call = + { bd_lbl: label; (* Entry label *) + bd_frame: label } (* Label of frame descriptor *) + +let bound_error_sites = ref ([] : bound_error_call list) +let bound_error_call = ref 0 + +let bound_error_label dbg = + if !Clflags.debug then begin + let lbl_bound_error = new_label() in + let lbl_frame = record_frame_label Reg.Set.empty dbg in + bound_error_sites := + { bd_lbl = lbl_bound_error; bd_frame = lbl_frame } :: !bound_error_sites; + lbl_bound_error + end else begin + if !bound_error_call = 0 then bound_error_call := new_label(); + !bound_error_call + end + +let emit_call_bound_error bd = + `{emit_label bd.bd_lbl}: call _caml_ml_array_bound_error\n`; + `{emit_label bd.bd_frame}:\n` + +let emit_call_bound_errors () = + List.iter emit_call_bound_error !bound_error_sites; + if !bound_error_call > 0 then + `{emit_label !bound_error_call}: jmp _caml_ml_array_bound_error\n` + (* Names for instructions *) let instr_for_intop = function @@ -396,11 +414,11 @@ let emit_instr i = ` mov {emit_reg i.res.(0)}, OFFSET {emit_symbol s}\n` | Lop(Icall_ind) -> ` call {emit_reg i.arg.(0)}\n`; - record_frame i.live + record_frame i.live i.dbg | Lop(Icall_imm s) -> add_used_symbol s; ` call {emit_symbol s}\n`; - record_frame i.live + record_frame i.live i.dbg | Lop(Itailcall_ind) -> output_epilogue(); ` jmp {emit_reg i.arg.(0)}\n` @@ -417,7 +435,7 @@ let emit_instr i = if alloc then begin ` mov eax, OFFSET {emit_symbol s}\n`; ` call _caml_c_call\n`; - record_frame i.live + record_frame i.live i.dbg end else begin ` call {emit_symbol s}\n` end @@ -475,7 +493,7 @@ let emit_instr i = ` mov _caml_young_ptr, eax\n`; ` cmp eax, _caml_young_limit\n`; let lbl_call_gc = new_label() in - let lbl_frame = record_frame_label i.live in + let lbl_frame = record_frame_label i.live Debuginfo.none in ` jb {emit_label lbl_call_gc}\n`; ` lea {emit_reg i.res.(0)}, [eax+4]\n`; call_gc_sites := @@ -490,7 +508,7 @@ let emit_instr i = | _ -> ` mov eax, {emit_int n}\n`; ` call _caml_allocN\n` end; - `{record_frame i.live} lea {emit_reg i.res.(0)}, [eax+4]\n` + `{record_frame i.live Debuginfo.none} lea {emit_reg i.res.(0)}, [eax+4]\n` end | Lop(Iintop(Icomp cmp)) -> ` cmp {emit_reg i.arg.(0)},{emit_reg i.arg.(1)}\n`; @@ -503,13 +521,13 @@ let emit_instr i = ` set{emit_string b} al\n`; ` movzx {emit_reg i.res.(0)}, al\n` | Lop(Iintop Icheckbound) -> - if !range_check_trap = 0 then range_check_trap := new_label(); + let lbl = bound_error_label i.dbg in ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; - ` jbe {emit_label !range_check_trap}\n` + ` jbe {emit_label lbl}\n` | Lop(Iintop_imm(Icheckbound, n)) -> - if !range_check_trap = 0 then range_check_trap := new_label(); + let lbl = bound_error_label i.dbg in ` cmp {emit_reg i.arg.(0)}, {emit_int n}\n`; - ` jbe {emit_label !range_check_trap}\n` + ` jbe {emit_label lbl}\n` | Lop(Iintop(Idiv | Imod)) -> ` cdq\n`; ` idiv {emit_reg i.arg.(1)}\n` @@ -533,7 +551,6 @@ let emit_instr i = ` add {emit_reg i.arg.(0)}, {emit_int(n-1)}\n`; `{emit_label lbl}: sar {emit_reg i.arg.(0)}, {emit_int l}\n` | Lop(Iintop_imm(Imod, n)) -> - let l = Misc.log2 n in let lbl = new_label() in ` mov eax, {emit_reg i.arg.(0)}\n`; ` test eax, eax\n`; @@ -722,9 +739,14 @@ let emit_instr i = ` add esp, 4\n`; stack_offset := !stack_offset - 8 | Lraise -> - ` mov esp, _caml_exception_pointer\n`; - ` pop _caml_exception_pointer\n`; - ` ret\n` + if !Clflags.debug then begin + ` call _caml_raise_exn\n`; + record_frame Reg.Set.empty i.dbg + end else begin + ` mov esp, _caml_exception_pointer\n`; + ` pop _caml_exception_pointer\n`; + ` ret\n` + end let rec emit_all i = match i.desc with Lend -> () | _ -> emit_instr i; emit_all i.next @@ -760,7 +782,8 @@ let fundecl fundecl = stack_offset := 0; float_constants := []; call_gc_sites := []; - range_check_trap := 0; + bound_error_sites := []; + bound_error_call := 0; ` .CODE\n`; add_def_symbol fundecl.fun_name; emit_align 4; @@ -772,8 +795,7 @@ let fundecl fundecl = `{emit_label !tailrec_entry_point}:\n`; emit_all fundecl.fun_body; List.iter emit_call_gc !call_gc_sites; - if !range_check_trap > 0 then - `{emit_label !range_check_trap}: jmp _caml_ml_array_bound_error\n`; + emit_call_bound_errors (); begin match !float_constants with [] -> () | _ -> @@ -836,6 +858,7 @@ let begin_assembly() = ` EXTERN _caml_alloc2: PROC\n`; ` EXTERN _caml_alloc3: PROC\n`; ` EXTERN _caml_ml_array_bound_error: PROC\n`; + ` EXTERN _caml_raise_exn: PROC\n`; ` .DATA\n`; let lbl_begin = Compilenv.make_symbol (Some "data_begin") in add_def_symbol lbl_begin; @@ -861,9 +884,17 @@ let end_assembly() = let lbl = Compilenv.make_symbol (Some "frametable") in add_def_symbol lbl; ` PUBLIC {emit_symbol lbl}\n`; - `{emit_symbol lbl} DWORD {emit_int (List.length !frame_descriptors)}\n`; - List.iter emit_frame !frame_descriptors; - frame_descriptors := []; + `{emit_symbol lbl}`; + emit_frames + { efa_label = (fun l -> ` DWORD {emit_label l}\n`); + efa_16 = (fun n -> ` WORD {emit_int n}\n`); + efa_32 = (fun n -> ` DWORD {emit_int32 n}\n`); + efa_word = (fun n -> ` DWORD {emit_int n}\n`); + efa_align = emit_align; + efa_label_rel = (fun lbl ofs -> + ` DWORD {emit_label lbl} - THIS BYTE + {emit_int32 ofs}\n`); + efa_def_label = (fun l -> `{emit_label l} LABEL DWORD\n`); + efa_string = (fun s -> emit_bytes_directive " BYTE " (s ^ "\000")) }; `\n;External functions\n\n`; StringSet.iter (fun s -> diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml index 7dabd994..a27b1802 100644 --- a/asmcomp/i386/proc.ml +++ b/asmcomp/i386/proc.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: proc.ml,v 1.9.4.1 2006/07/25 08:31:56 xleroy Exp $ *) +(* $Id: proc.ml,v 1.13 2007/02/09 13:31:14 doligez Exp $ *) (* Description of the Intel 386 processor *) @@ -94,7 +94,7 @@ let word_addressed = false with negative offsets, starting at -64. Unlike arguments passed on stack, arguments passed in globals do not prevent tail-call elimination. The caller stores arguments - in these globals immediately before the call, and the first thing the + in these globals immediately before the call, and the first thing the callee does is copy them to registers or stack locations. Neither GC nor thread context switches can occur between these two times. *) @@ -124,7 +124,7 @@ let calling_conventions first_int last_int first_float last_float make_stack ofs := !ofs + size_float end done; - (loc, Misc.align stack_alignment (max 0 !ofs)) + (loc, Misc.align (max 0 !ofs) stack_alignment) let incoming ofs = Incoming ofs let outgoing ofs = Outgoing ofs diff --git a/asmcomp/i386/reload.ml b/asmcomp/i386/reload.ml index 67f8a61f..c5291249 100644 --- a/asmcomp/i386/reload.ml +++ b/asmcomp/i386/reload.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: reload.ml,v 1.5 2002/11/22 15:09:18 xleroy Exp $ *) +(* $Id: reload.ml,v 1.6 2007/01/29 12:10:50 xleroy Exp $ *) open Cmm open Arch diff --git a/asmcomp/i386/selection.ml b/asmcomp/i386/selection.ml index 2136be2b..5c2c3f05 100644 --- a/asmcomp/i386/selection.ml +++ b/asmcomp/i386/selection.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: selection.ml,v 1.13.18.1 2006/03/01 13:46:56 xleroy Exp $ *) +(* $Id: selection.ml,v 1.15 2007/01/29 12:10:50 xleroy Exp $ *) (* Instruction selection for the Intel x86 *) @@ -88,7 +88,7 @@ let rec float_needs = function let n1 = float_needs arg1 in let n2 = float_needs arg2 in if n1 = n2 then 1 + n1 else if n1 > n2 then n1 else n2 - | Cop(Cextcall(fn, ty_res, alloc), args) + | Cop(Cextcall(fn, ty_res, alloc, dbg), args) when !fast_math && List.mem fn inline_float_ops -> begin match args with [arg] -> float_needs arg @@ -161,7 +161,7 @@ method is_immediate (n : int) = true method is_simple_expr e = match e with - | Cop(Cextcall(fn, _, alloc), args) + | Cop(Cextcall(fn, _, alloc, _), args) when !fast_math && List.mem fn inline_float_ops -> (* inlined float ops are simple if their arguments are *) List.for_all self#is_simple_expr args @@ -239,7 +239,7 @@ method select_operation op args = super#select_operation op args end (* Recognize inlined floating point operations *) - | Cextcall(fn, ty_res, false) + | Cextcall(fn, ty_res, false, dbg) when !fast_math && List.mem fn inline_float_ops -> (Ispecific(Ifloatspecial fn), args) (* Default *) @@ -269,18 +269,21 @@ method select_floatarith regular_op reversed_op mem_op mem_rev_op args = (* Deal with register constraints *) -method insert_op op rs rd = +method insert_op_debug op dbg rs rd = try let (rsrc, rdst, move_res) = pseudoregs_for_operation op rs rd in self#insert_moves rs rsrc; - self#insert (Iop op) rsrc rdst; + self#insert_debug (Iop op) dbg rsrc rdst; if move_res then begin self#insert_moves rdst rd; rd end else rdst with Use_default -> - super#insert_op op rs rd + super#insert_op_debug op dbg rs rd + +method insert_op op rs rd = + self#insert_op_debug op Debuginfo.none rs rd (* Selection of push instructions for external calls *) diff --git a/asmcomp/interf.ml b/asmcomp/interf.ml index 5e0ab8a6..7276ad03 100644 --- a/asmcomp/interf.ml +++ b/asmcomp/interf.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: interf.ml,v 1.14 2004/05/08 15:04:03 xleroy Exp $ *) +(* $Id: interf.ml,v 1.15 2007/01/29 12:10:50 xleroy Exp $ *) (* Construction of the interference graph. Annotate pseudoregs with interference lists and preference lists. *) diff --git a/asmcomp/linearize.ml b/asmcomp/linearize.ml index 73d1bc6d..b3281487 100644 --- a/asmcomp/linearize.ml +++ b/asmcomp/linearize.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: linearize.ml,v 1.24 2002/01/09 19:40:48 xleroy Exp $ *) +(* $Id: linearize.ml,v 1.25 2007/01/29 12:10:50 xleroy Exp $ *) (* Transformation of Mach code into a list of pseudo-instructions. *) @@ -28,6 +28,7 @@ type instruction = mutable next: instruction; arg: Reg.t array; res: Reg.t array; + dbg: Debuginfo.t; live: Reg.Set.t } and instruction_desc = @@ -77,24 +78,28 @@ let rec end_instr = next = end_instr; arg = [||]; res = [||]; + dbg = Debuginfo.none; live = Reg.Set.empty } -(* Cons an instruction (live empty) *) +(* Cons an instruction (live, debug empty) *) let instr_cons d a r n = - { desc = d; next = n; arg = a; res = r; live = Reg.Set.empty } + { desc = d; next = n; arg = a; res = r; + dbg = Debuginfo.none; live = Reg.Set.empty } (* Cons a simple instruction (arg, res, live empty) *) let cons_instr d n = - { desc = d; next = n; arg = [||]; res = [||]; live = Reg.Set.empty } + { desc = d; next = n; arg = [||]; res = [||]; + dbg = Debuginfo.none; live = Reg.Set.empty } -(* Build an instruction with arg, res, live taken from +(* Build an instruction with arg, res, dbg, live taken from the given Mach.instruction *) let copy_instr d i n = { desc = d; next = n; - arg = i.Mach.arg; res = i.Mach.res; live = i.Mach.live } + arg = i.Mach.arg; res = i.Mach.res; + dbg = i.Mach.dbg; live = i.Mach.live } (* Label the beginning of the given instruction sequence. diff --git a/asmcomp/linearize.mli b/asmcomp/linearize.mli index 8d7d20ce..926c3fa2 100644 --- a/asmcomp/linearize.mli +++ b/asmcomp/linearize.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: linearize.mli,v 1.13 2002/01/09 19:40:48 xleroy Exp $ *) +(* $Id: linearize.mli,v 1.14 2007/01/29 12:10:50 xleroy Exp $ *) (* Transformation of Mach code into a list of pseudo-instructions. *) @@ -22,6 +22,7 @@ type instruction = mutable next: instruction; arg: Reg.t array; res: Reg.t array; + dbg: Debuginfo.t; live: Reg.Set.t } and instruction_desc = diff --git a/asmcomp/liveness.ml b/asmcomp/liveness.ml index f6bd37c1..f16fef53 100644 --- a/asmcomp/liveness.ml +++ b/asmcomp/liveness.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: liveness.ml,v 1.14 2000/08/11 19:50:52 maranget Exp $ *) +(* $Id: liveness.ml,v 1.15 2007/01/29 12:10:50 xleroy Exp $ *) (* Liveness analysis. Annotate mach code with the set of regs live at each point. *) @@ -98,7 +98,7 @@ let rec live i finally = let across_after = Reg.diff_set_array (live i.next finally) i.res in let across = match i.desc with - Iop(Icall_ind) | Iop(Icall_imm _) | Iop(Iextcall(_, _)) + Iop Icall_ind | Iop(Icall_imm _) | Iop(Iextcall _) | Iop(Iintop Icheckbound) | Iop(Iintop_imm(Icheckbound, _)) -> (* The function call may raise an exception, branching to the nearest enclosing try ... with. Similarly for bounds checks. diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml index 70f64993..67d0dc65 100644 --- a/asmcomp/mach.ml +++ b/asmcomp/mach.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: mach.ml,v 1.17 2000/08/11 19:50:52 maranget Exp $ *) +(* $Id: mach.ml,v 1.18 2007/01/29 12:10:50 xleroy Exp $ *) (* Representation of machine code by sequences of pseudoinstructions *) @@ -60,6 +60,7 @@ type instruction = next: instruction; arg: Reg.t array; res: Reg.t array; + dbg: Debuginfo.t; mutable live: Reg.Set.t } and instruction_desc = @@ -85,6 +86,7 @@ let rec dummy_instr = next = dummy_instr; arg = [||]; res = [||]; + dbg = Debuginfo.none; live = Reg.Set.empty } let end_instr () = @@ -92,13 +94,15 @@ let end_instr () = next = dummy_instr; arg = [||]; res = [||]; + dbg = Debuginfo.none; live = Reg.Set.empty } let instr_cons d a r n = - { desc = d; next = n; arg = a; res = r; live = Reg.Set.empty } + { desc = d; next = n; arg = a; res = r; + dbg = Debuginfo.none; live = Reg.Set.empty } -let instr_cons_live d a r l n = - { desc = d; next = n; arg = a; res = r; live = l } +let instr_cons_debug d a r dbg n = + { desc = d; next = n; arg = a; res = r; dbg = dbg; live = Reg.Set.empty } let rec instr_iter f i = match i.desc with diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli index ee1a3412..ad28f3a7 100644 --- a/asmcomp/mach.mli +++ b/asmcomp/mach.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: mach.mli,v 1.17 2000/08/11 19:50:53 maranget Exp $ *) +(* $Id: mach.mli,v 1.18 2007/01/29 12:10:50 xleroy Exp $ *) (* Representation of machine code by sequences of pseudoinstructions *) @@ -60,6 +60,7 @@ type instruction = next: instruction; arg: Reg.t array; res: Reg.t array; + dbg: Debuginfo.t; mutable live: Reg.Set.t } and instruction_desc = @@ -85,8 +86,8 @@ val end_instr: unit -> instruction val instr_cons: instruction_desc -> Reg.t array -> Reg.t array -> instruction -> instruction -val instr_cons_live: - instruction_desc -> Reg.t array -> Reg.t array -> Reg.Set.t -> +val instr_cons_debug: + instruction_desc -> Reg.t array -> Reg.t array -> Debuginfo.t -> instruction -> instruction val instr_iter: (instruction -> unit) -> instruction -> unit diff --git a/asmcomp/power/arch.ml b/asmcomp/power/arch.ml index 46d10816..4f5bb12c 100644 --- a/asmcomp/power/arch.ml +++ b/asmcomp/power/arch.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: arch.ml,v 1.11 2004/06/19 16:13:32 xleroy Exp $ *) +(* $Id: arch.ml,v 1.12 2006/05/31 08:16:34 xleroy Exp $ *) (* Specific operations for the PowerPC processor *) @@ -39,8 +39,11 @@ type addressing_mode = let big_endian = true -let size_addr = 4 -let size_int = 4 +let ppc64 = + match Config.model with "ppc64" -> true | _ -> false + +let size_addr = if ppc64 then 8 else 4 +let size_int = size_addr let size_float = 8 (* Operations on addressing modes *) diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp index 26096777..da8b67a0 100644 --- a/asmcomp/power/emit.mlp +++ b/asmcomp/power/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp,v 1.21 2004/06/19 17:39:34 xleroy Exp $ *) +(* $Id: emit.mlp,v 1.23 2007/01/29 12:10:50 xleroy Exp $ *) (* Emission of PowerPC assembly code *) @@ -33,19 +33,27 @@ let stack_offset = ref 0 let frame_size () = let size = !stack_offset + (* Trap frame, outgoing parameters *) - 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + (* Local variables *) - (if !contains_calls then 4 else 0) in (* The return address *) + size_int * num_stack_slots.(0) + (* Local int variables *) + size_float * num_stack_slots.(1) + (* Local float variables *) + (if !contains_calls then size_int else 0) in (* The return address *) Misc.align size 16 let slot_offset loc cls = match loc with Local n -> if cls = 0 - then !stack_offset + num_stack_slots.(1) * 8 + n * 4 - else !stack_offset + n * 8 + then !stack_offset + num_stack_slots.(1) * size_float + n * size_int + else !stack_offset + n * size_float | Incoming n -> frame_size() + n | Outgoing n -> n +(* Whether stack backtraces are supported *) + +let supports_backtraces = + match Config.system with + | "rhapsody" -> true + | _ -> false + (* Output a symbol *) let emit_symbol = @@ -85,6 +93,22 @@ let rodata_space = | "rhapsody" -> " .const\n" | _ -> assert false +(* Names of instructions that differ in 32 and 64-bit modes *) + +let lg = if ppc64 then "ld" else "lwz" +let stg = if ppc64 then "std" else "stw" +let lwa = if ppc64 then "lwa" else "lwz" +let cmpg = if ppc64 then "cmpd" else "cmpw" +let cmplg = if ppc64 then "cmpld" else "cmplw" +let datag = if ppc64 then ".quad" else ".long" +let aligng = if ppc64 then 3 else 2 +let mullg = if ppc64 then "mulld" else "mullw" +let divg = if ppc64 then "divd" else "divw" +let tglle = if ppc64 then "tdlle" else "twlle" +let sragi = if ppc64 then "sradi" else "srawi" +let slgi = if ppc64 then "sldi" else "slwi" +let fctigz = if ppc64 then "fctidz" else "fctiwz" + (* Output a pseudo-register *) let emit_reg r = @@ -127,7 +151,7 @@ let is_immediate n = n <= 32767 && n >= -32768 let is_native_immediate n = - n <= Nativeint.of_int 32767 && n >= Nativeint.of_int (-32768) + n <= 32767n && n >= -32768n (* Output a "upper 16 bits" or "lower 16 bits" operator. *) @@ -154,13 +178,16 @@ let emit_symbol_offset (s, d) = if d > 0 then `+`; if d <> 0 then emit_int d +let valid_offset instr ofs = + ofs land 3 = 0 || (instr <> "ld" && instr <> "std") + let emit_load_store instr addressing_mode addr n arg = match addressing_mode with Ibased(s, d) -> ` addis {emit_gpr 11}, 0, {emit_upper emit_symbol_offset (s,d)}\n`; ` {emit_string instr} {emit_reg arg}, {emit_lower emit_symbol_offset (s,d)}({emit_gpr 11})\n` | Iindexed ofs -> - if is_immediate ofs then + if is_immediate ofs && valid_offset instr ofs then ` {emit_string instr} {emit_reg arg}, {emit_int ofs}({emit_reg addr.(n)})\n` else begin ` lis {emit_gpr 0}, {emit_int(high ofs)}\n`; @@ -188,14 +215,7 @@ let emit_set_comp cmp res = (* Record live pointers at call points *) -type frame_descr = - { fd_lbl: int; (* Return address *) - fd_frame_size: int; (* Size of stack frame *) - fd_live_offset: int list } (* Offsets/regs of live addresses *) - -let frame_descriptors = ref([] : frame_descr list) - -let record_frame live = +let record_frame live dbg = let lbl = new_label() in let live_offset = ref [] in Reg.Set.iter @@ -209,22 +229,14 @@ let record_frame live = frame_descriptors := { fd_lbl = lbl; fd_frame_size = frame_size(); - fd_live_offset = !live_offset } :: !frame_descriptors; - `{emit_label lbl}:` - -let emit_frame fd = - ` .long {emit_label fd.fd_lbl} + 4\n`; - ` .short {emit_int fd.fd_frame_size}\n`; - ` .short {emit_int (List.length fd.fd_live_offset)}\n`; - List.iter - (fun n -> - ` .short {emit_int n}\n`) - fd.fd_live_offset; - ` .align 2\n` + fd_live_offset = !live_offset; + fd_debuginfo = dbg } :: !frame_descriptors; + `{emit_label lbl}:\n` -(* Record floating-point literals *) +(* Record floating-point and large integer literals *) let float_literals = ref ([] : (string * int) list) +let int_literals = ref ([] : (nativeint * int) list) (* Record external C functions to be called in a position-independent way (for MacOSX) *) @@ -237,7 +249,7 @@ let emit_external s = ` .non_lazy_symbol_pointer\n`; `L{emit_symbol s}$non_lazy_ptr:\n`; ` .indirect_symbol {emit_symbol s}\n`; - ` .long 0\n` + ` {emit_string datag} 0\n` (* Names for conditional branches after comparisons *) @@ -247,21 +259,21 @@ let branch_for_comparison = function | Cge -> "bge" | Clt -> "blt" let name_for_int_comparison = function - Isigned cmp -> ("cmpw", branch_for_comparison cmp) - | Iunsigned cmp -> ("cmplw", branch_for_comparison cmp) + Isigned cmp -> (cmpg, branch_for_comparison cmp) + | Iunsigned cmp -> (cmplg, branch_for_comparison cmp) (* Names for various instructions *) let name_for_intop = function Iadd -> "add" - | Imul -> "mullw" - | Idiv -> "divw" + | Imul -> if ppc64 then "mulld" else "mullw" + | Idiv -> if ppc64 then "divd" else "divw" | Iand -> "and" | Ior -> "or" | Ixor -> "xor" - | Ilsl -> "slw" - | Ilsr -> "srw" - | Iasr -> "sraw" + | Ilsl -> if ppc64 then "sld" else "slw" + | Ilsr -> if ppc64 then "srd" else "srw" + | Iasr -> if ppc64 then "srad" else "sraw" | _ -> Misc.fatal_error "Emit.Intop" let name_for_intop_imm = function @@ -270,9 +282,9 @@ let name_for_intop_imm = function | Iand -> "andi." | Ior -> "ori" | Ixor -> "xori" - | Ilsl -> "slwi" - | Ilsr -> "srwi" - | Iasr -> "srawi" + | Ilsl -> if ppc64 then "sldi" else "slwi" + | Ilsr -> if ppc64 then "srdi" else "srwi" + | Iasr -> if ppc64 then "sradi" else "srawi" | _ -> Misc.fatal_error "Emit.Intop_imm" let name_for_floatop1 = function @@ -443,11 +455,11 @@ let rec emit_instr i dslot = | {loc = Reg rs; typ = Float}, {loc = Reg rd; typ = Float} -> ` fmr {emit_reg dst}, {emit_reg src}\n` | {loc = Reg rs; typ = (Int | Addr)}, {loc = Stack sd} -> - ` stw {emit_reg src}, {emit_stack dst}\n` + ` {emit_string stg} {emit_reg src}, {emit_stack dst}\n` | {loc = Reg rs; typ = Float}, {loc = Stack sd} -> ` stfd {emit_reg src}, {emit_stack dst}\n` | {loc = Stack ss; typ = (Int | Addr)}, {loc = Reg rd} -> - ` lwz {emit_reg dst}, {emit_stack src}\n` + ` {emit_string lg} {emit_reg dst}, {emit_stack src}\n` | {loc = Stack ss; typ = Float}, {loc = Reg rd} -> ` lfd {emit_reg dst}, {emit_stack src}\n` | (_, _) -> @@ -456,10 +468,15 @@ let rec emit_instr i dslot = | Lop(Iconst_int n) -> if is_native_immediate n then ` li {emit_reg i.res.(0)}, {emit_nativeint n}\n` - else begin + else if n >= -0x8000_0000n && n <= 0x7FFF_FFFFn then begin ` lis {emit_reg i.res.(0)}, {emit_int(nativehigh n)}\n`; if nativelow n <> 0 then ` ori {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_int(nativelow n)}\n` + end else begin + let lbl = new_label() in + int_literals := (n, lbl) :: !int_literals; + ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; + ` {emit_string lg} {emit_reg i.res.(0)}, {emit_lower emit_label lbl}({emit_gpr 11})\n` end | Lop(Iconst_float s) -> let lbl = new_label() in @@ -471,16 +488,16 @@ let rec emit_instr i dslot = ` addi {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_lower emit_symbol s}\n` | Lop(Icall_ind) -> ` mtctr {emit_reg i.arg.(0)}\n`; - record_frame i.live; - ` bctrl\n` + ` bctrl\n`; + record_frame i.live i.dbg | Lop(Icall_imm s) -> - record_frame i.live; - ` bl {emit_symbol s}\n` + ` bl {emit_symbol s}\n`; + record_frame i.live i.dbg | Lop(Itailcall_ind) -> let n = frame_size() in ` mtctr {emit_reg i.arg.(0)}\n`; if !contains_calls then begin - ` lwz {emit_gpr 11}, {emit_int(n - 4)}({emit_gpr 1})\n`; + ` {emit_string lg} {emit_gpr 11}, {emit_int(n - size_addr)}({emit_gpr 1})\n`; ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n`; ` mtlr {emit_gpr 11}\n` end else begin @@ -494,7 +511,7 @@ let rec emit_instr i dslot = else begin let n = frame_size() in if !contains_calls then begin - ` lwz {emit_gpr 11}, {emit_int(n - 4)}({emit_gpr 1})\n`; + ` {emit_string lg} {emit_gpr 11}, {emit_int(n - size_addr)}({emit_gpr 1})\n`; ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int n}\n`; ` mtlr {emit_gpr 11}\n` end else begin @@ -508,18 +525,18 @@ let rec emit_instr i dslot = if pic_externals then begin external_functions := StringSet.add s !external_functions; ` addis {emit_gpr 11}, 0, ha16(L{emit_symbol s}$non_lazy_ptr)\n`; - ` lwz {emit_gpr 11}, lo16(L{emit_symbol s}$non_lazy_ptr)({emit_gpr 11})\n` + ` {emit_string lg} {emit_gpr 11}, lo16(L{emit_symbol s}$non_lazy_ptr)({emit_gpr 11})\n` end else begin ` addis {emit_gpr 11}, 0, {emit_upper emit_symbol s}\n`; ` addi {emit_gpr 11}, {emit_gpr 11}, {emit_lower emit_symbol s}\n` end; - record_frame i.live; - ` bl {emit_symbol "caml_c_call"}\n` + ` bl {emit_symbol "caml_c_call"}\n`; + record_frame i.live i.dbg end else begin if pic_externals then begin external_functions := StringSet.add s !external_functions; ` addis {emit_gpr 11}, 0, ha16(L{emit_symbol s}$non_lazy_ptr)\n`; - ` lwz {emit_gpr 11}, lo16(L{emit_symbol s}$non_lazy_ptr)({emit_gpr 11})\n`; + ` {emit_string lg} {emit_gpr 11}, lo16(L{emit_symbol s}$non_lazy_ptr)({emit_gpr 11})\n`; ` mtctr {emit_gpr 11}\n`; ` bctrl\n` end else @@ -535,9 +552,11 @@ let rec emit_instr i dslot = | Byte_signed -> "lbz" | Sixteen_unsigned -> "lhz" | Sixteen_signed -> "lha" + | Thirtytwo_unsigned -> "lwz" + | Thirtytwo_signed -> if ppc64 then "lwa" else "lwz" + | Word -> lg | Single -> "lfs" - | Double | Double_u -> "lfd" - | _ -> "lwz" in + | Double | Double_u -> "lfd" in emit_load_store loadinstr addr i.arg 0 i.res.(0); if chunk = Byte_signed then ` extsb {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` @@ -546,43 +565,46 @@ let rec emit_instr i dslot = match chunk with Byte_unsigned | Byte_signed -> "stb" | Sixteen_unsigned | Sixteen_signed -> "sth" + | Thirtytwo_unsigned | Thirtytwo_signed -> "stw" + | Word -> stg | Single -> "stfs" - | Double | Double_u -> "stfd" - | _ -> "stw" in + | Double | Double_u -> "stfd" in emit_load_store storeinstr addr i.arg 1 i.arg.(0) | Lop(Ialloc n) -> if !call_gc_label = 0 then call_gc_label := new_label(); ` addi {emit_gpr 31}, {emit_gpr 31}, {emit_int(-n)}\n`; - ` cmplw {emit_gpr 31}, {emit_gpr 30}\n`; - ` addi {emit_reg i.res.(0)}, {emit_gpr 31}, 4\n`; - record_frame i.live; - ` bltl {emit_label !call_gc_label}\n` + ` {emit_string cmplg} {emit_gpr 31}, {emit_gpr 30}\n`; + ` addi {emit_reg i.res.(0)}, {emit_gpr 31}, {emit_int size_addr}\n`; + ` bltl {emit_label !call_gc_label}\n`; + record_frame i.live Debuginfo.none | Lop(Ispecific(Ialloc_far n)) -> if !call_gc_label = 0 then call_gc_label := new_label(); let lbl = new_label() in ` addi {emit_gpr 31}, {emit_gpr 31}, {emit_int(-n)}\n`; - ` cmplw {emit_gpr 31}, {emit_gpr 30}\n`; + ` {emit_string cmplg} {emit_gpr 31}, {emit_gpr 30}\n`; ` bge {emit_label lbl}\n`; - record_frame i.live; ` bl {emit_label !call_gc_label}\n`; - `{emit_label lbl}: addi {emit_reg i.res.(0)}, {emit_gpr 31}, 4\n` + record_frame i.live Debuginfo.none; + `{emit_label lbl}: addi {emit_reg i.res.(0)}, {emit_gpr 31}, {emit_int size_addr}\n` | Lop(Iintop Isub) -> (* subfc has swapped arguments *) ` subfc {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n` | Lop(Iintop Imod) -> - ` divw {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; - ` mullw {emit_gpr 0}, {emit_gpr 0}, {emit_reg i.arg.(1)}\n`; + ` {emit_string divg} {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` {emit_string mullg} {emit_gpr 0}, {emit_gpr 0}, {emit_reg i.arg.(1)}\n`; ` subfc {emit_reg i.res.(0)}, {emit_gpr 0}, {emit_reg i.arg.(0)}\n` | Lop(Iintop(Icomp cmp)) -> begin match cmp with Isigned c -> - ` cmpw {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` {emit_string cmpg} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; emit_set_comp c i.res.(0) | Iunsigned c -> - ` cmplw {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` {emit_string cmplg} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; emit_set_comp c i.res.(0) end | Lop(Iintop Icheckbound) -> - ` twlle {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` + if !Clflags.debug && supports_backtraces then + record_frame Reg.Set.empty i.dbg; + ` {emit_string tglle} {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` | Lop(Iintop op) -> let instr = name_for_intop op in ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` @@ -590,25 +612,27 @@ let rec emit_instr i dslot = ` addi {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int(-n)}\n` | Lop(Iintop_imm(Idiv, n)) -> (* n is guaranteed to be a power of 2 *) let l = Misc.log2 n in - ` srawi {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int l}\n`; + ` {emit_string sragi} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int l}\n`; ` addze {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` | Lop(Iintop_imm(Imod, n)) -> (* n is guaranteed to be a power of 2 *) let l = Misc.log2 n in - ` srawi {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_int l}\n`; + ` {emit_string sragi} {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_int l}\n`; ` addze {emit_gpr 0}, {emit_gpr 0}\n`; - ` slwi {emit_gpr 0}, {emit_gpr 0}, {emit_int l}\n`; + ` {emit_string slgi} {emit_gpr 0}, {emit_gpr 0}, {emit_int l}\n`; ` subfc {emit_reg i.res.(0)}, {emit_gpr 0}, {emit_reg i.arg.(0)}\n` | Lop(Iintop_imm(Icomp cmp, n)) -> begin match cmp with Isigned c -> - ` cmpwi {emit_reg i.arg.(0)}, {emit_int n}\n`; + ` {emit_string cmpg}i {emit_reg i.arg.(0)}, {emit_int n}\n`; emit_set_comp c i.res.(0) | Iunsigned c -> - ` cmplwi {emit_reg i.arg.(0)}, {emit_int n}\n`; + ` {emit_string cmplg}i {emit_reg i.arg.(0)}, {emit_int n}\n`; emit_set_comp c i.res.(0) end | Lop(Iintop_imm(Icheckbound, n)) -> - ` twllei {emit_reg i.arg.(0)}, {emit_int n}\n` + if !Clflags.debug && supports_backtraces then + record_frame Reg.Set.empty i.dbg; + ` {emit_string tglle}i {emit_reg i.arg.(0)}, {emit_int n}\n` | Lop(Iintop_imm(op, n)) -> let instr = name_for_intop_imm op in ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_int n}\n` @@ -619,29 +643,37 @@ let rec emit_instr i dslot = let instr = name_for_floatop2 op in ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n` | Lop(Ifloatofint) -> - let lbl = new_label() in - float_literals := ("4.503601774854144e15", lbl) :: !float_literals; - (* That float above represents 0x4330000080000000 *) - ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; - ` lfd {emit_fpr 0}, {emit_lower emit_label lbl}({emit_gpr 11})\n`; - ` lis {emit_gpr 0}, 0x4330\n`; - ` stwu {emit_gpr 0}, -8({emit_gpr 1})\n`; - ` xoris {emit_gpr 0}, {emit_reg i.arg.(0)}, 0x8000\n`; - ` stw {emit_gpr 0}, 4({emit_gpr 1})\n`; - ` lfd {emit_reg i.res.(0)}, 0({emit_gpr 1})\n`; - ` addi {emit_gpr 1}, {emit_gpr 1}, 8\n`; - ` fsub {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_fpr 0}\n` + if ppc64 then begin + ` stdu {emit_reg i.arg.(0)}, -16({emit_gpr 1})\n`; + ` lfd {emit_reg i.res.(0)}, 0({emit_gpr 1})\n`; + ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; + ` fcfid {emit_reg i.res.(0)}, {emit_reg i.res.(0)}\n` + end else begin + let lbl = new_label() in + float_literals := ("4.503601774854144e15", lbl) :: !float_literals; + (* That float above represents 0x4330000080000000 *) + ` addis {emit_gpr 11}, 0, {emit_upper emit_label lbl}\n`; + ` lfd {emit_fpr 0}, {emit_lower emit_label lbl}({emit_gpr 11})\n`; + ` lis {emit_gpr 0}, 0x4330\n`; + ` stwu {emit_gpr 0}, -16({emit_gpr 1})\n`; + ` xoris {emit_gpr 0}, {emit_reg i.arg.(0)}, 0x8000\n`; + ` stw {emit_gpr 0}, 4({emit_gpr 1})\n`; + ` lfd {emit_reg i.res.(0)}, 0({emit_gpr 1})\n`; + ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; + ` fsub {emit_reg i.res.(0)}, {emit_reg i.res.(0)}, {emit_fpr 0}\n` + end | Lop(Iintoffloat) -> - ` fctiwz {emit_fpr 0}, {emit_reg i.arg.(0)}\n`; - ` stfdu {emit_fpr 0}, -8({emit_gpr 1})\n`; - ` lwz {emit_reg i.res.(0)}, 4({emit_gpr 1})\n`; - ` addi {emit_gpr 1}, {emit_gpr 1}, 8\n` + let ofs = if ppc64 then 0 else 4 in + ` {emit_string fctigz} {emit_fpr 0}, {emit_reg i.arg.(0)}\n`; + ` stfdu {emit_fpr 0}, -16({emit_gpr 1})\n`; + ` {emit_string lg} {emit_reg i.res.(0)}, {emit_int ofs}({emit_gpr 1})\n`; + ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n` | Lop(Ispecific sop) -> let instr = name_for_specific sop in ` {emit_string instr} {emit_reg i.res.(0)}, {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}\n` | Lreloadretaddr -> let n = frame_size() in - ` lwz {emit_gpr 11}, {emit_int(n - 4)}({emit_gpr 1})\n`; + ` {emit_string lg} {emit_gpr 11}, {emit_int(n - size_addr)}({emit_gpr 1})\n`; ` mtlr {emit_gpr 11}\n` | Lreturn -> let n = frame_size() in @@ -655,11 +687,11 @@ let rec emit_instr i dslot = | Lcondbranch(tst, lbl) -> begin match tst with Itruetest -> - ` cmpwi {emit_reg i.arg.(0)}, 0\n`; + ` {emit_string cmpg}i {emit_reg i.arg.(0)}, 0\n`; emit_delay dslot; ` bne {emit_label lbl}\n` | Ifalsetest -> - ` cmpwi {emit_reg i.arg.(0)}, 0\n`; + ` {emit_string cmpg}i {emit_reg i.arg.(0)}, 0\n`; emit_delay dslot; ` beq {emit_label lbl}\n` | Iinttest cmp -> @@ -699,7 +731,7 @@ let rec emit_instr i dslot = ` beq {emit_label lbl}\n` end | Lcondbranch3(lbl0, lbl1, lbl2) -> - ` cmpwi {emit_reg i.arg.(0)}, 1\n`; + ` {emit_string cmpg}i {emit_reg i.arg.(0)}, 1\n`; emit_delay dslot; begin match lbl0 with None -> () @@ -718,8 +750,8 @@ let rec emit_instr i dslot = ` addis {emit_gpr 11}, 0, {emit_upper emit_label !lbl_jumptbl}\n`; ` addi {emit_gpr 11}, {emit_gpr 11}, {emit_lower emit_label !lbl_jumptbl}\n`; ` addi {emit_gpr 0}, {emit_reg i.arg.(0)}, {emit_int !num_jumptbl_entries}\n`; - ` slwi {emit_gpr 0}, {emit_gpr 0}, 2\n`; - ` lwzx {emit_gpr 0}, {emit_gpr 11}, {emit_gpr 0}\n`; + ` {emit_string slgi} {emit_gpr 0}, {emit_gpr 0}, 2\n`; + ` {emit_string lwa}x {emit_gpr 0}, {emit_gpr 11}, {emit_gpr 0}\n`; ` add {emit_gpr 0}, {emit_gpr 11}, {emit_gpr 0}\n`; ` mtctr {emit_gpr 0}\n`; ` bctr\n`; @@ -732,20 +764,25 @@ let rec emit_instr i dslot = | Lpushtrap -> stack_offset := !stack_offset + 16; ` mflr {emit_gpr 0}\n`; - ` stwu {emit_gpr 0}, -16({emit_gpr 1})\n`; - ` stw {emit_gpr 29}, 4({emit_gpr 1})\n`; + ` {emit_string stg}u {emit_gpr 0}, -16({emit_gpr 1})\n`; + ` {emit_string stg} {emit_gpr 29}, {emit_int size_addr}({emit_gpr 1})\n`; ` mr {emit_gpr 29}, {emit_gpr 1}\n` | Lpoptrap -> - ` lwz {emit_gpr 29}, 4({emit_gpr 1})\n`; + ` {emit_string lg} {emit_gpr 29}, {emit_int size_addr}({emit_gpr 1})\n`; ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; stack_offset := !stack_offset - 16 | Lraise -> - ` lwz {emit_gpr 0}, 0({emit_gpr 29})\n`; - ` mr {emit_gpr 1}, {emit_gpr 29}\n`; - ` mtlr {emit_gpr 0}\n`; - ` lwz {emit_gpr 29}, 4({emit_gpr 1})\n`; - ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; - ` blr\n` + if !Clflags.debug && supports_backtraces then begin + ` bl {emit_symbol "caml_raise_exn"}\n`; + record_frame Reg.Set.empty i.dbg + end else begin + ` {emit_string lg} {emit_gpr 0}, 0({emit_gpr 29})\n`; + ` mr {emit_gpr 1}, {emit_gpr 29}\n`; + ` mtlr {emit_gpr 0}\n`; + ` {emit_string lg} {emit_gpr 29}, {emit_int size_addr}({emit_gpr 1})\n`; + ` addi {emit_gpr 1}, {emit_gpr 1}, 16\n`; + ` blr\n` + end and emit_delay = function None -> () @@ -802,6 +839,7 @@ let fundecl fundecl = stack_offset := 0; call_gc_label := 0; float_literals := []; + int_literals := []; ` .globl {emit_symbol fundecl.fun_name}\n`; begin match Config.system with | "elf" | "bsd" -> @@ -815,7 +853,7 @@ let fundecl fundecl = if !contains_calls then begin ` mflr {emit_gpr 0}\n`; ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int(-n)}\n`; - ` stw {emit_gpr 0}, {emit_int(n - 4)}({emit_gpr 1})\n` + ` {emit_string stg} {emit_gpr 0}, {emit_int(n - size_addr)}({emit_gpr 1})\n` end else begin if n > 0 then ` addi {emit_gpr 1}, {emit_gpr 1}, {emit_int(-n)}\n` @@ -828,14 +866,18 @@ let fundecl fundecl = `{emit_label !call_gc_label}:\n`; ` b {emit_symbol "caml_call_gc"}\n` end; - (* Emit the floating-point literals *) - if !float_literals <> [] then begin + (* Emit the numeric literals *) + if !float_literals <> [] || !int_literals <> [] then begin emit_string rodata_space; ` .align 3\n`; List.iter (fun (f, lbl) -> `{emit_label lbl}: .double 0d{emit_string f}\n`) - !float_literals + !float_literals; + List.iter + (fun (n, lbl) -> + `{emit_label lbl}: {emit_string datag} {emit_nativeint n}\n`) + !int_literals end (* Emission of data *) @@ -859,15 +901,15 @@ let emit_item = function | Cint32 n -> ` .long {emit_nativeint n}\n` | Cint n -> - ` .long {emit_nativeint n}\n` + ` {emit_string datag} {emit_nativeint n}\n` | Csingle f -> ` .float 0d{emit_string f}\n` | Cdouble f -> ` .double 0d{emit_string f}\n` | Csymbol_address s -> - ` .long {emit_symbol s}\n` + ` {emit_string datag} {emit_symbol s}\n` | Clabel_address lbl -> - ` .long {emit_label (lbl + 100000)}\n` + ` {emit_string datag} {emit_label (lbl + 100000)}\n` | Cstring s -> emit_bytes_directive " .byte " s | Cskip n -> @@ -915,16 +957,25 @@ let end_assembly() = let lbl_end = Compilenv.make_symbol (Some "code_end") in declare_global_data lbl_end; `{emit_symbol lbl_end}:\n`; + ` .long 0\n`; emit_string data_space; let lbl_end = Compilenv.make_symbol (Some "data_end") in declare_global_data lbl_end; `{emit_symbol lbl_end}:\n`; - ` .long 0\n`; + ` {emit_string datag} 0\n`; (* Emit the frame descriptors *) emit_string rodata_space; let lbl = Compilenv.make_symbol (Some "frametable") in declare_global_data lbl; `{emit_symbol lbl}:\n`; - ` .long {emit_int (List.length !frame_descriptors)}\n`; - List.iter emit_frame !frame_descriptors; - frame_descriptors := [] + emit_frames + { efa_label = (fun l -> ` {emit_string datag} {emit_label l}\n`); + efa_16 = (fun n -> ` .short {emit_int n}\n`); + efa_32 = (fun n -> ` .long {emit_int32 n}\n`); + efa_word = (fun n -> ` {emit_string datag} {emit_int n}\n`); + efa_align = (fun n -> ` .align {emit_int (Misc.log2 n)}\n`); + efa_label_rel = (fun lbl ofs -> + ` .long ({emit_label lbl} - .) + {emit_int32 ofs}\n`); + efa_def_label = (fun l -> `{emit_label l}:\n`); + efa_string = (fun s -> emit_bytes_directive " .byte " (s ^ "\000")) + } diff --git a/asmcomp/power/proc.ml b/asmcomp/power/proc.ml index b17c9f6e..75dea545 100644 --- a/asmcomp/power/proc.ml +++ b/asmcomp/power/proc.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: proc.ml,v 1.12 2004/06/19 17:39:35 xleroy Exp $ *) +(* $Id: proc.ml,v 1.13 2006/05/31 08:16:34 xleroy Exp $ *) (* Description of the Power PC *) @@ -145,7 +145,8 @@ let loc_results res = (* C calling conventions under PowerOpen: use GPR 3-10 and FPR 1-13 just like ML calling conventions, but always reserve stack space for all arguments. - Also, using a float register automatically reserves two int registers. + Also, using a float register automatically reserves two int registers + (in 32-bit mode) or one int register (in 64-bit mode). (If we were to call a non-prototyped C function, each float argument would have to go both in a float reg and in the matching pair of integer regs.) @@ -161,7 +162,7 @@ let poweropen_external_conventions first_int last_int let loc = Array.create (Array.length arg) Reg.dummy in let int = ref first_int in let float = ref first_float in - let ofs = ref 56 in + let ofs = ref (14 * size_addr) in for i = 0 to Array.length arg - 1 do match arg.(i).typ with Int | Addr as ty -> @@ -180,7 +181,7 @@ let poweropen_external_conventions first_int last_int loc.(i) <- stack_slot (Outgoing !ofs) Float; ofs := !ofs + size_float end; - int := !int + 2 + int := !int + (if ppc64 then 1 else 2) done; (loc, Misc.align !ofs 16) (* Keep stack 16-aligned *) @@ -238,7 +239,9 @@ let assemble_file infile outfile = match Config.system with | "elf" -> Ccomp.command ("as -u -m ppc -o " ^ outfile ^ " " ^ infile) - | "rhapsody" | "bsd" -> + | "rhapsody" -> + Ccomp.command ("as -arch " ^ Config.model ^ " -o " ^ outfile ^ " " ^ infile) + | "bsd" -> Ccomp.command ("as -o " ^ outfile ^ " " ^ infile) | _ -> assert false diff --git a/asmcomp/printcmm.ml b/asmcomp/printcmm.ml index b3e0b19c..73580836 100644 --- a/asmcomp/printcmm.ml +++ b/asmcomp/printcmm.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: printcmm.ml,v 1.24 2002/11/24 15:55:24 xleroy Exp $ *) +(* $Id: printcmm.ml,v 1.25 2007/01/29 12:10:50 xleroy Exp $ *) (* Pretty-printing of C-- code *) @@ -51,8 +51,9 @@ let chunk = function | Double_u -> "float64u" let operation = function - | Capply ty -> "app" - | Cextcall(lbl, ty, alloc) -> Printf.sprintf "extcall \"%s\"" lbl + | Capply(ty, d) -> "app" ^ Debuginfo.to_string d + | Cextcall(lbl, ty, alloc, d) -> + Printf.sprintf "extcall \"%s\"%s" lbl (Debuginfo.to_string d) | Cload Word -> "load" | Cload c -> Printf.sprintf "load %s" (chunk c) | Calloc -> "alloc" @@ -82,8 +83,8 @@ let operation = function | Cfloatofint -> "floatofint" | Cintoffloat -> "intoffloat" | Ccmpf c -> Printf.sprintf "%sf" (comparison c) - | Craise -> "raise" - | Ccheckbound -> "checkbound" + | Craise d -> "raise" ^ Debuginfo.to_string d + | Ccheckbound d -> "checkbound" ^ Debuginfo.to_string d let rec expr ppf = function | Cconst_int n -> fprintf ppf "%i" n @@ -123,8 +124,8 @@ let rec expr ppf = function fprintf ppf "@[<2>(%s" (operation op); List.iter (fun e -> fprintf ppf "@ %a" expr e) el; begin match op with - | Capply mty -> fprintf ppf "@ %a" machtype mty - | Cextcall(_, mty, _) -> fprintf ppf "@ %a" machtype mty + | Capply (mty, _) -> fprintf ppf "@ %a" machtype mty + | Cextcall(_, mty, _, _) -> fprintf ppf "@ %a" machtype mty | _ -> () end; fprintf ppf ")@]" diff --git a/asmcomp/printlinear.ml b/asmcomp/printlinear.ml index 0a33d393..24207ee2 100644 --- a/asmcomp/printlinear.ml +++ b/asmcomp/printlinear.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: printlinear.ml,v 1.12 2000/04/21 08:10:35 weis Exp $ *) +(* $Id: printlinear.ml,v 1.13 2007/01/29 12:10:50 xleroy Exp $ *) (* Pretty-printing of linearized machine code *) @@ -23,7 +23,7 @@ let label ppf l = Format.fprintf ppf "L%i" l let instr ppf i = - match i.desc with + begin match i.desc with | Lend -> () | Lop op -> begin match op with @@ -64,6 +64,9 @@ let instr ppf i = fprintf ppf "pop trap" | Lraise -> fprintf ppf "raise %a" reg i.arg.(0) + end; + if i.dbg != Debuginfo.none then + fprintf ppf " %s" (Debuginfo.to_string i.dbg) let rec all_instr ppf i = match i.desc with diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml index e13420b2..de93e380 100644 --- a/asmcomp/printmach.ml +++ b/asmcomp/printmach.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: printmach.ml,v 1.22 2000/08/11 19:50:54 maranget Exp $ *) +(* $Id: printmach.ml,v 1.23 2007/01/29 12:10:50 xleroy Exp $ *) (* Pretty-printing of pseudo machine code *) @@ -42,7 +42,7 @@ let regs ppf v = | 0 -> () | 1 -> reg ppf v.(0) | n -> reg ppf v.(0); - for i = 1 to n-1 do fprintf ppf "@ %a" reg v.(i) done + for i = 1 to n-1 do fprintf ppf " %a" reg v.(i) done let regset ppf s = let first = ref true in @@ -182,6 +182,8 @@ let rec instr ppf i = | Iraise -> fprintf ppf "raise %a" reg i.arg.(0) end; + if i.dbg != Debuginfo.none then + fprintf ppf " %s" (Debuginfo.to_string i.dbg); begin match i.next.desc with Iend -> () | _ -> fprintf ppf "@,%a" instr i.next diff --git a/asmcomp/reloadgen.ml b/asmcomp/reloadgen.ml index 1600f18f..693782d9 100644 --- a/asmcomp/reloadgen.ml +++ b/asmcomp/reloadgen.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: reloadgen.ml,v 1.5 2000/08/11 19:50:55 maranget Exp $ *) +(* $Id: reloadgen.ml,v 1.6 2007/01/29 12:10:50 xleroy Exp $ *) (* Insert load/stores for pseudoregs that got assigned to stack locations. *) @@ -94,19 +94,19 @@ method private reload i = | Iop(Itailcall_ind) -> let newarg = self#makereg1 i.arg in insert_moves i.arg newarg - (instr_cons_live i.desc newarg i.res i.live i.next) - | Iop(Icall_imm _ | Iextcall(_, _)) -> - instr_cons_live i.desc i.arg i.res i.live (self#reload i.next) + {i with arg = newarg} + | Iop(Icall_imm _ | Iextcall _) -> + {i with next = self#reload i.next} | Iop(Icall_ind) -> let newarg = self#makereg1 i.arg in insert_moves i.arg newarg - (instr_cons_live i.desc newarg i.res i.live (self#reload i.next)) + {i with arg = newarg; next = self#reload i.next} | Iop op -> let (newarg, newres) = self#reload_operation op i.arg i.res in insert_moves i.arg newarg - (instr_cons_live i.desc newarg newres i.live + {i with arg = newarg; res = newres; next = (insert_moves newres i.res - (self#reload i.next))) + (self#reload i.next))} | Iifthenelse(tst, ifso, ifnot) -> let newarg = self#reload_test tst i.arg in insert_moves i.arg newarg diff --git a/asmcomp/schedgen.ml b/asmcomp/schedgen.ml index 6f7e89e1..33f1570a 100644 --- a/asmcomp/schedgen.ml +++ b/asmcomp/schedgen.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: schedgen.ml,v 1.11 2004/11/29 14:49:22 doligez Exp $ *) +(* $Id: schedgen.ml,v 1.12 2007/01/29 12:10:50 xleroy Exp $ *) (* Instruction scheduling *) @@ -123,7 +123,7 @@ method oper_in_basic_block = function | Icall_imm _ -> false | Itailcall_ind -> false | Itailcall_imm _ -> false - | Iextcall(_, _) -> false + | Iextcall _ -> false | Istackoffset _ -> false | Ialloc _ -> false | _ -> true @@ -328,8 +328,7 @@ method schedule_fundecl f = clear_code_dag(); schedule_block [] i end else - { desc = i.desc; arg = i.arg; res = i.res; live = i.live; - next = schedule i.next } + { i with next = schedule i.next } and schedule_block ready_queue i = if self#instr_in_basic_block i then @@ -338,7 +337,7 @@ method schedule_fundecl f = let critical_outputs = match i.desc with Lop(Icall_ind | Itailcall_ind) -> [| i.arg.(0) |] - | Lop(Icall_imm _ | Itailcall_imm _ | Iextcall(_, _)) -> [||] + | Lop(Icall_imm _ | Itailcall_imm _ | Iextcall _) -> [||] | Lreturn -> [||] | _ -> i.arg in List.iter (fun x -> ignore (longest_path critical_outputs x)) ready_queue; diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml index b8507477..d170de48 100644 --- a/asmcomp/selectgen.ml +++ b/asmcomp/selectgen.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: selectgen.ml,v 1.30.18.1 2006/03/01 13:46:56 xleroy Exp $ *) +(* $Id: selectgen.ml,v 1.32 2007/01/29 12:10:50 xleroy Exp $ *) (* Selection of pseudo-instructions, assignment of pseudo-registers, sequentialization. *) @@ -25,8 +25,8 @@ type environment = (Ident.t, Reg.t array) Tbl.t (* Infer the type of the result of an operation *) let oper_result_type = function - Capply ty -> ty - | Cextcall(s, ty, alloc) -> ty + Capply(ty, _) -> ty + | Cextcall(s, ty, alloc, _) -> ty | Cload c -> begin match c with Word -> typ_addr @@ -42,8 +42,8 @@ let oper_result_type = function | Cnegf | Cabsf | Caddf | Csubf | Cmulf | Cdivf -> typ_float | Cfloatofint -> typ_float | Cintoffloat -> typ_int - | Craise -> typ_void - | Ccheckbound -> typ_void + | Craise _ -> typ_void + | Ccheckbound _ -> typ_void (* Infer the size in bytes of the result of a simple expression *) @@ -151,6 +151,14 @@ let join_array rs = done; Some res +(* Extract debug info contained in a C-- operation *) +let debuginfo_op = function + | Capply(_, dbg) -> dbg + | Cextcall(_, _, _, dbg) -> dbg + | Craise dbg -> dbg + | Ccheckbound dbg -> dbg + | _ -> Debuginfo.none + (* Registers for catch constructs *) let catch_regs = ref [] @@ -182,7 +190,7 @@ method is_simple_expr = function | Cop(op, args) -> begin match op with (* The following may have side effects *) - | Capply _ | Cextcall(_, _, _) | Calloc | Cstore _ | Craise -> false + | Capply _ | Cextcall _ | Calloc | Cstore _ | Craise _ -> false (* The remaining operations are simple if their args are *) | _ -> List.for_all self#is_simple_expr args @@ -207,9 +215,9 @@ method select_store addr arg = method select_operation op args = match (op, args) with - (Capply ty, Cconst_symbol s :: rem) -> (Icall_imm s, rem) - | (Capply ty, _) -> (Icall_ind, args) - | (Cextcall(s, ty, alloc), _) -> (Iextcall(s, alloc), args) + (Capply(ty, dbg), Cconst_symbol s :: rem) -> (Icall_imm s, rem) + | (Capply(ty, dbg), _) -> (Icall_ind, args) + | (Cextcall(s, ty, alloc, dbg), _) -> (Iextcall(s, alloc), args) | (Cload chunk, [arg]) -> let (addr, eloc) = self#select_addressing arg in (Iload(chunk, addr), [eloc]) @@ -256,7 +264,7 @@ method select_operation op args = | (Cdivf, _) -> (Idivf, args) | (Cfloatofint, _) -> (Ifloatofint, args) | (Cintoffloat, _) -> (Iintoffloat, args) - | (Ccheckbound, _) -> self#select_arith Icheckbound args + | (Ccheckbound _, _) -> self#select_arith Icheckbound args | _ -> fatal_error "Selection.select_oper" method private select_arith_comm op = function @@ -331,6 +339,9 @@ method select_condition = function val mutable instr_seq = dummy_instr +method insert_debug desc dbg arg res = + instr_seq <- instr_cons_debug desc arg res dbg instr_seq + method insert desc arg res = instr_seq <- instr_cons desc arg res instr_seq @@ -338,7 +349,7 @@ method extract = let rec extract res i = if i == dummy_instr then res - else extract (instr_cons i.desc i.arg i.res res) i.next in + else extract {i with next = res} i.next in extract (end_instr()) instr_seq (* Insert a sequence of moves from one pseudoreg set to another. *) @@ -366,6 +377,10 @@ method insert_move_results loc res stacksize = to insert moves before and after the operation, i.e. for two-address instructions, or instructions using dedicated registers. *) +method insert_op_debug op dbg rs rd = + self#insert_debug (Iop op) dbg rs rd; + rd + method insert_op op rs rd = self#insert (Iop op) rs rd; rd @@ -422,13 +437,13 @@ method emit_expr env exp = | Some(simple_list, ext_env) -> Some(self#emit_tuple ext_env simple_list) end - | Cop(Craise, [arg]) -> + | Cop(Craise dbg, [arg]) -> begin match self#emit_expr env arg with None -> None | Some r1 -> let rd = [|Proc.loc_exn_bucket|] in self#insert (Iop Imove) r1 rd; - self#insert Iraise rd [||]; + self#insert_debug Iraise dbg rd [||]; None end | Cop(Ccmpf comp, args) -> @@ -439,6 +454,7 @@ method emit_expr env exp = | Some(simple_args, env) -> let ty = oper_result_type op in let (new_op, new_args) = self#select_operation op simple_args in + let dbg = debuginfo_op op in match new_op with Icall_ind -> Proc.contains_calls := true; @@ -448,7 +464,7 @@ method emit_expr env exp = let (loc_arg, stack_ofs) = Proc.loc_arguments rarg in let loc_res = Proc.loc_results rd in self#insert_move_args rarg loc_arg stack_ofs; - self#insert (Iop Icall_ind) + self#insert_debug (Iop Icall_ind) dbg (Array.append [|r1.(0)|] loc_arg) loc_res; self#insert_move_results loc_res rd stack_ofs; Some rd @@ -459,7 +475,7 @@ method emit_expr env exp = let (loc_arg, stack_ofs) = Proc.loc_arguments r1 in let loc_res = Proc.loc_results rd in self#insert_move_args r1 loc_arg stack_ofs; - self#insert (Iop(Icall_imm lbl)) loc_arg loc_res; + self#insert_debug (Iop(Icall_imm lbl)) dbg loc_arg loc_res; self#insert_move_results loc_res rd stack_ofs; Some rd | Iextcall(lbl, alloc) -> @@ -468,7 +484,8 @@ method emit_expr env exp = self#emit_extcall_args env new_args in let rd = Reg.createv ty in let loc_res = Proc.loc_external_results rd in - self#insert (Iop(Iextcall(lbl, alloc))) loc_arg loc_res; + self#insert_debug (Iop(Iextcall(lbl, alloc))) dbg + loc_arg loc_res; self#insert_move_results loc_res rd stack_ofs; Some rd | Ialloc _ -> @@ -481,7 +498,7 @@ method emit_expr env exp = | op -> let r1 = self#emit_tuple env new_args in let rd = Reg.createv ty in - Some (self#insert_op op r1 rd) + Some (self#insert_op_debug op dbg r1 rd) end | Csequence(e1, e2) -> begin match self#emit_expr env e1 with @@ -676,7 +693,7 @@ method emit_tail env exp = None -> () | Some r1 -> self#emit_tail (self#bind_let env v r1) e2 end - | Cop(Capply ty as op, args) -> + | Cop(Capply(ty, dbg) as op, args) -> begin match self#emit_parts_list env args with None -> () | Some(simple_args, env) -> @@ -695,7 +712,7 @@ method emit_tail env exp = let rd = Reg.createv ty in let loc_res = Proc.loc_results rd in self#insert_move_args rarg loc_arg stack_ofs; - self#insert (Iop Icall_ind) + self#insert_debug (Iop Icall_ind) dbg (Array.append [|r1.(0)|] loc_arg) loc_res; self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||]; self#insert Ireturn loc_res [||] @@ -715,7 +732,7 @@ method emit_tail env exp = let rd = Reg.createv ty in let loc_res = Proc.loc_results rd in self#insert_move_args r1 loc_arg stack_ofs; - self#insert (Iop(Icall_imm lbl)) loc_arg loc_res; + self#insert_debug (Iop(Icall_imm lbl)) dbg loc_arg loc_res; self#insert(Iop(Istackoffset(-stack_ofs))) [||] [||]; self#insert Ireturn loc_res [||] end diff --git a/asmcomp/selectgen.mli b/asmcomp/selectgen.mli index 6bc53fe9..2899d1ae 100644 --- a/asmcomp/selectgen.mli +++ b/asmcomp/selectgen.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: selectgen.mli,v 1.6.18.1 2006/03/01 13:46:56 xleroy Exp $ *) +(* $Id: selectgen.mli,v 1.8 2007/01/29 12:10:50 xleroy Exp $ *) (* Selection of pseudo-instructions, assignment of pseudo-registers, sequentialization. *) @@ -43,6 +43,10 @@ class virtual selector_generic : object Mach.operation -> Reg.t array -> Reg.t array -> Reg.t array (* Can be overriden to deal with 2-address instructions or instructions with hardwired input/output registers *) + method insert_op_debug : + Mach.operation -> Debuginfo.t -> Reg.t array -> Reg.t array -> Reg.t array + (* Can be overriden to deal with 2-address instructions + or instructions with hardwired input/output registers *) method emit_extcall_args : environment -> Cmm.expression list -> Reg.t array * int (* Can be overriden to deal with stack-based calling conventions *) @@ -59,6 +63,8 @@ class virtual selector_generic : object are not always applied to "self", but ideally they should be private. *) method extract : Mach.instruction method insert : Mach.instruction_desc -> Reg.t array -> Reg.t array -> unit + method insert_debug : Mach.instruction_desc -> Debuginfo.t -> + Reg.t array -> Reg.t array -> unit method insert_move : Reg.t -> Reg.t -> unit method insert_move_args : Reg.t array -> Reg.t array -> int -> unit method insert_move_results : Reg.t array -> Reg.t array -> int -> unit diff --git a/asmcomp/sparc/emit.mlp b/asmcomp/sparc/emit.mlp index d9a895c2..cfecd1e6 100644 --- a/asmcomp/sparc/emit.mlp +++ b/asmcomp/sparc/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp,v 1.23.2.1 2006/03/29 14:49:19 doligez Exp $ *) +(* $Id: emit.mlp,v 1.24 2006/04/16 23:28:15 doligez Exp $ *) (* Emission of Sparc assembly code *) diff --git a/asmcomp/spill.ml b/asmcomp/spill.ml index eb92b196..2fba098f 100644 --- a/asmcomp/spill.ml +++ b/asmcomp/spill.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: spill.ml,v 1.18 2001/02/19 20:15:42 maranget Exp $ *) +(* $Id: spill.ml,v 1.19 2007/01/29 12:10:50 xleroy Exp $ *) (* Insertion of moves to suggest possible spilling / reloading points before register allocation. *) @@ -147,7 +147,7 @@ let rec reload i before = (* All regs live across must be spilled *) let (new_next, finally) = reload i.next i.live in (add_reloads (Reg.inter_set_array before i.arg) - (instr_cons i.desc i.arg i.res new_next), + (instr_cons_debug i.desc i.arg i.res i.dbg new_next), finally) | Iop op -> let new_before = @@ -160,7 +160,7 @@ let rec reload i before = Reg.diff_set_array (Reg.diff_set_array new_before i.arg) i.res in let (new_next, finally) = reload i.next after in (add_reloads (Reg.inter_set_array new_before i.arg) - (instr_cons i.desc i.arg i.res new_next), + (instr_cons_debug i.desc i.arg i.res i.dbg new_next), finally) | Iifthenelse(test, ifso, ifnot) -> let at_fork = Reg.diff_set_array before i.arg in @@ -292,12 +292,12 @@ let rec spill i finally = let before1 = Reg.diff_set_array after i.res in let before = match i.desc with - Iop(Icall_ind) | Iop(Icall_imm _) | Iop(Iextcall(_, _)) + Iop Icall_ind | Iop(Icall_imm _) | Iop(Iextcall _) | Iop(Iintop Icheckbound) | Iop(Iintop_imm(Icheckbound, _)) -> Reg.Set.union before1 !spill_at_raise | _ -> before1 in - (instr_cons i.desc i.arg i.res + (instr_cons_debug i.desc i.arg i.res i.dbg (add_spills (Reg.inter_set_array after i.res) new_next), before) | Iifthenelse(test, ifso, ifnot) -> diff --git a/asmcomp/split.ml b/asmcomp/split.ml index 34778e8e..74f2511c 100644 --- a/asmcomp/split.ml +++ b/asmcomp/split.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: split.ml,v 1.9 2000/08/11 19:50:59 maranget Exp $ *) +(* $Id: split.ml,v 1.10 2007/01/29 12:10:50 xleroy Exp $ *) (* Renaming of registers at reload points to split live ranges. *) @@ -140,8 +140,8 @@ let rec rename i sub = end | Iop _ -> let (new_next, sub_next) = rename i.next sub in - (instr_cons i.desc (subst_regs i.arg sub) (subst_regs i.res sub) - new_next, + (instr_cons_debug i.desc (subst_regs i.arg sub) (subst_regs i.res sub) + i.dbg new_next, sub_next) | Iifthenelse(tst, ifso, ifnot) -> let (new_ifso, sub_ifso) = rename ifso sub in @@ -187,7 +187,7 @@ let rec rename i sub = (instr_cons (Itrywith(new_body, new_handler)) [||] [||] new_next, sub_next) | Iraise -> - (instr_cons Iraise (subst_regs i.arg sub) [||] i.next, + (instr_cons_debug Iraise (subst_regs i.arg sub) [||] i.dbg i.next, None) (* Second pass: replace registers by their final representatives *) diff --git a/asmrun/.cvsignore b/asmrun/.cvsignore index ee21b359..55f30ced 100644 --- a/asmrun/.cvsignore +++ b/asmrun/.cvsignore @@ -31,3 +31,4 @@ meta.c globroots.c unix.c dynlink.c +signals.c diff --git a/asmrun/.depend b/asmrun/.depend index 639bb7b7..3176dd55 100644 --- a/asmrun/.depend +++ b/asmrun/.depend @@ -1,507 +1,1104 @@ alloc.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/minor_gc.h ../byterun/stacks.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/custom.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/stacks.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/memory.h array.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h +backtrace.o: backtrace.c ../byterun/backtrace.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h callback.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h -compact.o: compact.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/misc.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc_ctrl.h ../byterun/weak.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h +compact.o: compact.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ + ../byterun/misc.h ../byterun/weak.h ../byterun/mlvalues.h compare.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h custom.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h -dynlink.o: dynlink.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/dynlink.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/osdeps.h ../byterun/prims.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/custom.h ../byterun/mlvalues.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h +dynlink.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/dynlink.h ../byterun/misc.h \ + ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/osdeps.h ../byterun/misc.h \ + ../byterun/prims.h extern.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/reverse.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/custom.h ../byterun/mlvalues.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/intext.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/io.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/reverse.h fail.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/printexc.h ../byterun/signals.h stack.h ../byterun/roots.h -finalise.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/fail.h ../byterun/roots.h ../byterun/memory.h \ + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/io.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/memory.h ../byterun/config.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/signals.h -floats.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/reverse.h ../byterun/stacks.h -freelist.o: freelist.c ../byterun/config.h ../config/m.h ../config/s.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/printexc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/signals.h ../byterun/misc.h \ + ../byterun/mlvalues.h stack.h ../byterun/roots.h ../byterun/misc.h \ + ../byterun/memory.h +finalise.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ + ../byterun/misc.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ + ../byterun/misc.h ../byterun/mlvalues.h +floats.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/reverse.h ../byterun/stacks.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/memory.h +freelist.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/gc_ctrl.h ../byterun/misc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h gc_ctrl.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/compact.h ../byterun/custom.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc_ctrl.h ../byterun/stacks.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/compact.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/custom.h ../byterun/mlvalues.h ../byterun/finalise.h \ + ../byterun/roots.h ../byterun/misc.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/gc_ctrl.h ../byterun/misc.h ../byterun/stacks.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/memory.h globroots.o: globroots.c ../byterun/memory.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/globroots.h -hash.o: hash.c ../byterun/mlvalues.h ../byterun/config.h ../config/m.h \ - ../config/s.h ../byterun/misc.h ../byterun/custom.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/globroots.h ../byterun/mlvalues.h +hash.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/custom.h ../byterun/mlvalues.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h intern.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/reverse.h ../byterun/md5.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/custom.h ../byterun/mlvalues.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/intext.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/io.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/reverse.h ../byterun/md5.h \ + ../byterun/mlvalues.h ../byterun/io.h ints.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/int64_native.h -io.o: io.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/signals.h \ - ../byterun/sys.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/custom.h \ + ../byterun/mlvalues.h ../byterun/fail.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/intext.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/io.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h +io.o: io.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/custom.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/io.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/signals.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/sys.h ../byterun/misc.h lexing.o: lexing.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/stacks.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h -main.o: main.c ../byterun/misc.h ../byterun/config.h ../config/m.h \ - ../config/s.h ../byterun/mlvalues.h ../byterun/sys.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/stacks.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h +main.o: main.c ../byterun/misc.h ../byterun/config.h \ + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/sys.h \ + ../byterun/misc.h major_gc.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/misc.h ../byterun/custom.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc_ctrl.h ../byterun/weak.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/custom.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/finalise.h \ + ../byterun/roots.h ../byterun/misc.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/gc_ctrl.h ../byterun/misc.h ../byterun/weak.h \ + ../byterun/mlvalues.h md5.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/md5.h ../byterun/io.h ../byterun/reverse.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/md5.h \ + ../byterun/mlvalues.h ../byterun/io.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h memory.o: memory.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/freelist.h ../byterun/gc.h ../byterun/gc_ctrl.h \ - ../byterun/major_gc.h ../byterun/memory.h ../byterun/minor_gc.h \ - ../byterun/signals.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ + ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/signals.h ../byterun/misc.h ../byterun/mlvalues.h meta.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/fix_code.h ../byterun/interp.h ../byterun/intext.h \ - ../byterun/io.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/minor_gc.h \ - ../byterun/prims.h ../byterun/stacks.h -minor_gc.o: minor_gc.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/gc_ctrl.h ../byterun/signals.h -misc.o: misc.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h -obj.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/gc.h ../byterun/interp.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/memory.h ../byterun/minor_gc.h \ - ../byterun/prims.h -parsing.o: parsing.c ../byterun/config.h ../config/m.h ../config/s.h \ + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/fix_code.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/interp.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/intext.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/io.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/misc.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/alloc.h + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/prims.h \ + ../byterun/stacks.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/memory.h +minor_gc.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/fail.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/finalise.h ../byterun/roots.h \ + ../byterun/misc.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ + ../byterun/misc.h ../byterun/signals.h ../byterun/misc.h \ + ../byterun/mlvalues.h +misc.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h +obj.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/interp.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/prims.h +parsing.o: parsing.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h printexc.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/callback.h ../byterun/debugger.h ../byterun/fail.h \ - ../byterun/printexc.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/callback.h \ + ../byterun/mlvalues.h ../byterun/debugger.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/fail.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/printexc.h ../byterun/misc.h \ + ../byterun/mlvalues.h roots.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/globroots.h stack.h + ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/globroots.h ../byterun/mlvalues.h \ + stack.h signals.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/callback.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/fail.h ../byterun/osdeps.h ../byterun/signals.h \ - ../byterun/signals_machdep.h signals_osdep.h stack.h ../byterun/sys.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/callback.h ../byterun/mlvalues.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/roots.h ../byterun/misc.h ../byterun/memory.h \ + ../byterun/signals.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/signals_machdep.h ../byterun/sys.h ../byterun/misc.h +signals_asm.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/osdeps.h ../byterun/misc.h \ + ../byterun/signals.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/signals_machdep.h signals_osdep.h stack.h startup.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/osdeps.h ../byterun/printexc.h \ - ../byterun/sys.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/backtrace.h \ + ../byterun/mlvalues.h ../byterun/custom.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ + ../byterun/misc.h ../byterun/osdeps.h ../byterun/misc.h \ + ../byterun/printexc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/sys.h ../byterun/misc.h str.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h -sys.o: sys.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/debugger.h ../byterun/fail.h ../byterun/instruct.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h -terminfo.o: terminfo.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/io.h -unix.o: unix.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/osdeps.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h +sys.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/debugger.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/fail.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/instruct.h ../byterun/osdeps.h \ + ../byterun/misc.h ../byterun/signals.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/stacks.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/sys.h \ + ../byterun/misc.h +terminfo.o: terminfo.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/fail.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/io.h ../byterun/misc.h \ + ../byterun/mlvalues.h +unix.o: unix.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ + ../byterun/misc.h weak.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h alloc.d.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/minor_gc.h ../byterun/stacks.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/custom.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/stacks.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/memory.h array.d.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h +backtrace.d.o: backtrace.c ../byterun/backtrace.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h callback.d.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h -compact.d.o: compact.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/misc.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc_ctrl.h ../byterun/weak.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h +compact.d.o: compact.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ + ../byterun/misc.h ../byterun/weak.h ../byterun/mlvalues.h compare.d.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h custom.d.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h -dynlink.d.o: dynlink.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/dynlink.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/osdeps.h ../byterun/prims.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/custom.h ../byterun/mlvalues.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h +dynlink.d.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/dynlink.h ../byterun/misc.h \ + ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/osdeps.h ../byterun/misc.h \ + ../byterun/prims.h extern.d.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/reverse.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/custom.h ../byterun/mlvalues.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/intext.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/io.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/reverse.h fail.d.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/printexc.h ../byterun/signals.h stack.h ../byterun/roots.h -finalise.d.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/fail.h ../byterun/roots.h ../byterun/memory.h \ + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/io.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/memory.h ../byterun/config.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/signals.h -floats.d.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/reverse.h ../byterun/stacks.h -freelist.d.o: freelist.c ../byterun/config.h ../config/m.h ../config/s.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/printexc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/signals.h ../byterun/misc.h \ + ../byterun/mlvalues.h stack.h ../byterun/roots.h ../byterun/misc.h \ + ../byterun/memory.h +finalise.d.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ + ../byterun/misc.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ + ../byterun/misc.h ../byterun/mlvalues.h +floats.d.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/reverse.h ../byterun/stacks.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/memory.h +freelist.d.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/gc_ctrl.h ../byterun/misc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h gc_ctrl.d.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/compact.h ../byterun/custom.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc_ctrl.h ../byterun/stacks.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/compact.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/custom.h ../byterun/mlvalues.h ../byterun/finalise.h \ + ../byterun/roots.h ../byterun/misc.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/gc_ctrl.h ../byterun/misc.h ../byterun/stacks.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/memory.h globroots.d.o: globroots.c ../byterun/memory.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/globroots.h -hash.d.o: hash.c ../byterun/mlvalues.h ../byterun/config.h ../config/m.h \ - ../config/s.h ../byterun/misc.h ../byterun/custom.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/globroots.h ../byterun/mlvalues.h +hash.d.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/custom.h ../byterun/mlvalues.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h intern.d.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/reverse.h ../byterun/md5.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/custom.h ../byterun/mlvalues.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/intext.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/io.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/reverse.h ../byterun/md5.h \ + ../byterun/mlvalues.h ../byterun/io.h ints.d.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/int64_native.h -io.d.o: io.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/signals.h \ - ../byterun/sys.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/custom.h \ + ../byterun/mlvalues.h ../byterun/fail.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/intext.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/io.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h +io.d.o: io.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/custom.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/io.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/signals.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/sys.h ../byterun/misc.h lexing.d.o: lexing.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/stacks.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h -main.d.o: main.c ../byterun/misc.h ../byterun/config.h ../config/m.h \ - ../config/s.h ../byterun/mlvalues.h ../byterun/sys.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/stacks.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h +main.d.o: main.c ../byterun/misc.h ../byterun/config.h \ + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/sys.h \ + ../byterun/misc.h major_gc.d.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/misc.h ../byterun/custom.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc_ctrl.h ../byterun/weak.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/custom.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/finalise.h \ + ../byterun/roots.h ../byterun/misc.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/gc_ctrl.h ../byterun/misc.h ../byterun/weak.h \ + ../byterun/mlvalues.h md5.d.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/md5.h ../byterun/io.h ../byterun/reverse.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/md5.h \ + ../byterun/mlvalues.h ../byterun/io.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h memory.d.o: memory.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/freelist.h ../byterun/gc.h ../byterun/gc_ctrl.h \ - ../byterun/major_gc.h ../byterun/memory.h ../byterun/minor_gc.h \ - ../byterun/signals.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ + ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/signals.h ../byterun/misc.h ../byterun/mlvalues.h meta.d.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/fix_code.h ../byterun/interp.h ../byterun/intext.h \ - ../byterun/io.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/minor_gc.h \ - ../byterun/prims.h ../byterun/stacks.h -minor_gc.d.o: minor_gc.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/gc_ctrl.h ../byterun/signals.h -misc.d.o: misc.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h -obj.d.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/gc.h ../byterun/interp.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/memory.h ../byterun/minor_gc.h \ - ../byterun/prims.h -parsing.d.o: parsing.c ../byterun/config.h ../config/m.h ../config/s.h \ + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/fix_code.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/interp.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/intext.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/io.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/misc.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/alloc.h + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/prims.h \ + ../byterun/stacks.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/memory.h +minor_gc.d.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/fail.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/finalise.h ../byterun/roots.h \ + ../byterun/misc.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ + ../byterun/misc.h ../byterun/signals.h ../byterun/misc.h \ + ../byterun/mlvalues.h +misc.d.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h +obj.d.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/interp.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/prims.h +parsing.d.o: parsing.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h printexc.d.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/callback.h ../byterun/debugger.h ../byterun/fail.h \ - ../byterun/printexc.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/callback.h \ + ../byterun/mlvalues.h ../byterun/debugger.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/fail.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/printexc.h ../byterun/misc.h \ + ../byterun/mlvalues.h roots.d.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/globroots.h stack.h + ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/globroots.h ../byterun/mlvalues.h \ + stack.h signals.d.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/callback.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/fail.h ../byterun/osdeps.h ../byterun/signals.h \ - ../byterun/signals_machdep.h signals_osdep.h stack.h ../byterun/sys.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/callback.h ../byterun/mlvalues.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/roots.h ../byterun/misc.h ../byterun/memory.h \ + ../byterun/signals.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/signals_machdep.h ../byterun/sys.h ../byterun/misc.h +signals_asm.d.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/osdeps.h ../byterun/misc.h \ + ../byterun/signals.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/signals_machdep.h signals_osdep.h stack.h startup.d.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/osdeps.h ../byterun/printexc.h \ - ../byterun/sys.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/backtrace.h \ + ../byterun/mlvalues.h ../byterun/custom.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ + ../byterun/misc.h ../byterun/osdeps.h ../byterun/misc.h \ + ../byterun/printexc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/sys.h ../byterun/misc.h str.d.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h -sys.d.o: sys.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/debugger.h ../byterun/fail.h ../byterun/instruct.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h -terminfo.d.o: terminfo.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/io.h -unix.d.o: unix.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/osdeps.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h +sys.d.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/debugger.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/fail.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/instruct.h ../byterun/osdeps.h \ + ../byterun/misc.h ../byterun/signals.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/stacks.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/sys.h \ + ../byterun/misc.h +terminfo.d.o: terminfo.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/fail.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/io.h ../byterun/misc.h \ + ../byterun/mlvalues.h +unix.d.o: unix.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ + ../byterun/misc.h weak.d.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h alloc.p.o: alloc.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/minor_gc.h ../byterun/stacks.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/custom.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/stacks.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/memory.h array.p.o: array.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h +backtrace.p.o: backtrace.c ../byterun/backtrace.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h stack.h callback.p.o: callback.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h -compact.p.o: compact.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/misc.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc_ctrl.h ../byterun/weak.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h +compact.p.o: compact.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/finalise.h ../byterun/roots.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ + ../byterun/misc.h ../byterun/weak.h ../byterun/mlvalues.h compare.p.o: compare.c ../byterun/custom.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h custom.p.o: custom.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h -dynlink.p.o: dynlink.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/dynlink.h ../byterun/fail.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/osdeps.h ../byterun/prims.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/custom.h ../byterun/mlvalues.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h +dynlink.p.o: dynlink.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/dynlink.h ../byterun/misc.h \ + ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/osdeps.h ../byterun/misc.h \ + ../byterun/prims.h extern.p.o: extern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/reverse.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/custom.h ../byterun/mlvalues.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/intext.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/io.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/reverse.h fail.p.o: fail.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/io.h ../byterun/gc.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/printexc.h ../byterun/signals.h stack.h ../byterun/roots.h -finalise.p.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/fail.h ../byterun/roots.h ../byterun/memory.h \ + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/io.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/memory.h ../byterun/config.h \ ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/signals.h -floats.p.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/reverse.h ../byterun/stacks.h -freelist.p.o: freelist.c ../byterun/config.h ../config/m.h ../config/s.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/printexc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/signals.h ../byterun/misc.h \ + ../byterun/mlvalues.h stack.h ../byterun/roots.h ../byterun/misc.h \ + ../byterun/memory.h +finalise.p.o: finalise.c ../byterun/callback.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/roots.h \ + ../byterun/misc.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/gc.h ../byterun/gc_ctrl.h ../byterun/major_gc.h + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/signals.h \ + ../byterun/misc.h ../byterun/mlvalues.h +floats.p.o: floats.c ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/reverse.h ../byterun/stacks.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/memory.h +freelist.p.o: freelist.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/gc_ctrl.h ../byterun/misc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h gc_ctrl.p.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/compact.h ../byterun/custom.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc_ctrl.h ../byterun/stacks.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/compact.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/custom.h ../byterun/mlvalues.h ../byterun/finalise.h \ + ../byterun/roots.h ../byterun/misc.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/gc_ctrl.h ../byterun/misc.h ../byterun/stacks.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/memory.h globroots.p.o: globroots.c ../byterun/memory.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/globroots.h -hash.p.o: hash.c ../byterun/mlvalues.h ../byterun/config.h ../config/m.h \ - ../config/s.h ../byterun/misc.h ../byterun/custom.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/globroots.h ../byterun/mlvalues.h +hash.p.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/custom.h ../byterun/mlvalues.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h intern.p.o: intern.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \ - ../byterun/intext.h ../byterun/io.h ../byterun/memory.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/reverse.h ../byterun/md5.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/custom.h ../byterun/mlvalues.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/intext.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/io.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/reverse.h ../byterun/md5.h \ + ../byterun/mlvalues.h ../byterun/io.h ints.p.o: ints.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/custom.h \ - ../byterun/fail.h ../byterun/intext.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/int64_native.h -io.p.o: io.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/io.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/signals.h \ - ../byterun/sys.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/custom.h \ + ../byterun/mlvalues.h ../byterun/fail.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/intext.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/io.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/int64_native.h +io.p.o: io.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/custom.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/io.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/signals.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/sys.h ../byterun/misc.h lexing.p.o: lexing.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/stacks.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h -main.p.o: main.c ../byterun/misc.h ../byterun/config.h ../config/m.h \ - ../config/s.h ../byterun/mlvalues.h ../byterun/sys.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/stacks.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h +main.p.o: main.c ../byterun/misc.h ../byterun/config.h \ + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/sys.h \ + ../byterun/misc.h major_gc.p.o: major_gc.c ../byterun/compact.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/misc.h ../byterun/custom.h \ - ../byterun/mlvalues.h ../byterun/fail.h ../byterun/finalise.h \ - ../byterun/roots.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/gc_ctrl.h ../byterun/weak.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/custom.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/finalise.h \ + ../byterun/roots.h ../byterun/misc.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/gc_ctrl.h ../byterun/misc.h ../byterun/weak.h \ + ../byterun/mlvalues.h md5.p.o: md5.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/md5.h ../byterun/io.h ../byterun/reverse.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/md5.h \ + ../byterun/mlvalues.h ../byterun/io.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/reverse.h memory.p.o: memory.c ../byterun/fail.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/freelist.h ../byterun/gc.h ../byterun/gc_ctrl.h \ - ../byterun/major_gc.h ../byterun/memory.h ../byterun/minor_gc.h \ - ../byterun/signals.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ + ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/major_gc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/signals.h ../byterun/misc.h ../byterun/mlvalues.h meta.p.o: meta.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/fix_code.h ../byterun/interp.h ../byterun/intext.h \ - ../byterun/io.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/minor_gc.h \ - ../byterun/prims.h ../byterun/stacks.h -minor_gc.p.o: minor_gc.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/finalise.h ../byterun/roots.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/gc_ctrl.h ../byterun/signals.h -misc.p.o: misc.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/misc.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h -obj.p.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/gc.h ../byterun/interp.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/memory.h ../byterun/minor_gc.h \ - ../byterun/prims.h -parsing.p.o: parsing.c ../byterun/config.h ../config/m.h ../config/s.h \ + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/fix_code.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/interp.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/intext.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/io.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ ../byterun/mlvalues.h ../byterun/misc.h ../byterun/memory.h \ - ../byterun/gc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/alloc.h + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/prims.h \ + ../byterun/stacks.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/memory.h +minor_gc.p.o: minor_gc.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/fail.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/finalise.h ../byterun/roots.h \ + ../byterun/misc.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ + ../byterun/misc.h ../byterun/signals.h ../byterun/misc.h \ + ../byterun/mlvalues.h +misc.p.o: misc.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/misc.h ../byterun/config.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h +obj.p.o: obj.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/interp.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/major_gc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/prims.h +parsing.p.o: parsing.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h printexc.p.o: printexc.c ../byterun/backtrace.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/callback.h ../byterun/debugger.h ../byterun/fail.h \ - ../byterun/printexc.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/callback.h \ + ../byterun/mlvalues.h ../byterun/debugger.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/fail.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/printexc.h ../byterun/misc.h \ + ../byterun/mlvalues.h roots.p.o: roots.c ../byterun/finalise.h ../byterun/roots.h \ - ../byterun/misc.h ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/globroots.h stack.h + ../byterun/misc.h ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/globroots.h ../byterun/mlvalues.h \ + stack.h signals.p.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/mlvalues.h \ - ../byterun/callback.h ../byterun/memory.h ../byterun/gc.h \ - ../byterun/major_gc.h ../byterun/freelist.h ../byterun/minor_gc.h \ - ../byterun/fail.h ../byterun/osdeps.h ../byterun/signals.h \ - ../byterun/signals_machdep.h signals_osdep.h stack.h ../byterun/sys.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/callback.h ../byterun/mlvalues.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/mlvalues.h \ + ../byterun/major_gc.h ../byterun/freelist.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/roots.h ../byterun/misc.h ../byterun/memory.h \ + ../byterun/signals.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/signals_machdep.h ../byterun/sys.h ../byterun/misc.h +signals_asm.p.o: signals_asm.c ../byterun/fail.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/memory.h ../byterun/config.h ../byterun/gc.h \ + ../byterun/mlvalues.h ../byterun/major_gc.h ../byterun/freelist.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/misc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/osdeps.h ../byterun/misc.h \ + ../byterun/signals.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/signals_machdep.h signals_osdep.h stack.h startup.p.o: startup.c ../byterun/callback.h ../byterun/mlvalues.h \ - ../byterun/config.h ../config/m.h ../config/s.h ../byterun/misc.h \ - ../byterun/custom.h ../byterun/fail.h ../byterun/gc.h \ - ../byterun/gc_ctrl.h ../byterun/osdeps.h ../byterun/printexc.h \ - ../byterun/sys.h + ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/backtrace.h \ + ../byterun/mlvalues.h ../byterun/custom.h ../byterun/mlvalues.h \ + ../byterun/fail.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/gc_ctrl.h \ + ../byterun/misc.h ../byterun/osdeps.h ../byterun/misc.h \ + ../byterun/printexc.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/sys.h ../byterun/misc.h str.p.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h -sys.p.o: sys.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/debugger.h ../byterun/fail.h ../byterun/instruct.h \ - ../byterun/osdeps.h ../byterun/signals.h ../byterun/stacks.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h ../byterun/sys.h -terminfo.p.o: terminfo.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/alloc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/fail.h ../byterun/io.h -unix.p.o: unix.c ../byterun/config.h ../config/m.h ../config/s.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/mlvalues.h \ - ../byterun/misc.h ../byterun/major_gc.h ../byterun/freelist.h \ - ../byterun/minor_gc.h ../byterun/osdeps.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h +sys.p.o: sys.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/debugger.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/fail.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/instruct.h ../byterun/osdeps.h \ + ../byterun/misc.h ../byterun/signals.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/stacks.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/sys.h \ + ../byterun/misc.h +terminfo.p.o: terminfo.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/alloc.h ../byterun/misc.h \ + ../byterun/config.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/fail.h ../byterun/misc.h \ + ../byterun/mlvalues.h ../byterun/io.h ../byterun/misc.h \ + ../byterun/mlvalues.h +unix.p.o: unix.c ../byterun/config.h ../byterun/../config/m.h \ + ../byterun/../config/s.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/config.h \ + ../byterun/misc.h ../byterun/config.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/minor_gc.h ../byterun/misc.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/osdeps.h \ + ../byterun/misc.h weak.p.o: weak.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ - ../config/m.h ../config/s.h ../byterun/mlvalues.h ../byterun/fail.h \ - ../byterun/memory.h ../byterun/gc.h ../byterun/major_gc.h \ - ../byterun/freelist.h ../byterun/minor_gc.h + ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ + ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ + ../byterun/misc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/mlvalues.h \ + ../byterun/misc.h ../byterun/memory.h ../byterun/config.h \ + ../byterun/gc.h ../byterun/mlvalues.h ../byterun/major_gc.h \ + ../byterun/minor_gc.h ../byterun/misc.h ../byterun/misc.h \ + ../byterun/mlvalues.h diff --git a/asmrun/Makefile b/asmrun/Makefile index 629d0394..27e9a9fc 100644 --- a/asmrun/Makefile +++ b/asmrun/Makefile @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.51 2004/05/09 15:19:16 xleroy Exp $ +# $Id: Makefile,v 1.56 2007/02/23 09:29:45 xleroy Exp $ include ../config/Makefile @@ -22,11 +22,11 @@ CFLAGS=$(FLAGS) -O $(NATIVECCCOMPOPTS) DFLAGS=$(FLAGS) -g -DDEBUG $(NATIVECCCOMPOPTS) PFLAGS=$(FLAGS) -pg -O -DPROFILING $(NATIVECCPROFOPTS) -COBJS=startup.o main.o fail.o roots.o globroots.o signals.o \ +COBJS=startup.o main.o fail.o roots.o globroots.o signals.o signals_asm.o \ misc.o freelist.o major_gc.o minor_gc.o memory.o alloc.o compare.o ints.o \ floats.o str.o array.o io.o extern.o intern.o hash.o sys.o parsing.o \ gc_ctrl.o terminfo.o md5.o obj.o lexing.o printexc.o callback.o weak.o \ - compact.o finalise.o custom.o unix.o + compact.o finalise.o custom.o unix.o backtrace.o ASMOBJS=$(ARCH).o @@ -140,12 +140,14 @@ unix.c: ../byterun/unix.c ln -s ../byterun/unix.c unix.c dynlink.c: ../byterun/dynlink.c ln -s ../byterun/dynlink.c dynlink.c +signals.c: ../byterun/signals.c + ln -s ../byterun/signals.c signals.c LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \ compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \ parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c \ weak.c compact.c finalise.c meta.c custom.c main.c globroots.c unix.c \ - dynlink.c + dynlink.c signals.c clean:: rm -f $(LINKEDFILES) @@ -181,9 +183,8 @@ clean:: rm -f *.o *.a *~ depend: $(COBJS:.o=.c) ${LINKEDFILES} - gcc -MM $(FLAGS) *.c > .depend + -gcc -MM $(FLAGS) *.c > .depend gcc -MM $(FLAGS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend gcc -MM $(FLAGS) -DDEBUG *.c | sed -e 's/\.o/.p.o/' >> .depend include .depend - diff --git a/asmrun/Makefile.nt b/asmrun/Makefile.nt index 84cfc1ed..8bfce2ff 100644 --- a/asmrun/Makefile.nt +++ b/asmrun/Makefile.nt @@ -11,30 +11,31 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.20 2002/06/18 16:17:34 xleroy Exp $ +# $Id: Makefile.nt,v 1.23 2007/02/23 09:29:45 xleroy Exp $ include ../config/Makefile CC=$(NATIVECC) CFLAGS=-I../byterun -DNATIVE_CODE -DTARGET_$(ARCH) -DSYS_$(SYSTEM) $(NATIVECCCOMPOPTS) -COBJS=startup.$(O) main.$(O) fail.$(O) roots.$(O) signals.$(O) \ +COBJS=startup.$(O) main.$(O) fail.$(O) roots.$(O) signals.$(O) signals_asm.$(O) \ misc.$(O) freelist.$(O) major_gc.$(O) minor_gc.$(O) memory.$(O) alloc.$(O) \ compare.$(O) ints.$(O) floats.$(O) str.$(O) array.$(O) io.$(O) extern.$(O) \ intern.$(O) hash.$(O) sys.$(O) parsing.$(O) gc_ctrl.$(O) terminfo.$(O) \ md5.$(O) obj.$(O) lexing.$(O) win32.$(O) printexc.$(O) callback.$(O) \ - weak.$(O) compact.$(O) finalise.$(O) custom.$(O) globroots.$(O) + weak.$(O) compact.$(O) finalise.$(O) custom.$(O) globroots.$(O) \ + backtrace.$(O) LINKEDFILES=misc.c freelist.c major_gc.c minor_gc.c memory.c alloc.c array.c \ compare.c ints.c floats.c str.c io.c extern.c intern.c hash.c sys.c \ parsing.c gc_ctrl.c terminfo.c md5.c obj.c lexing.c printexc.c callback.c \ weak.c compact.c meta.c finalise.c custom.c main.c globroots.c \ - dynlink.c + dynlink.c signals.c ifeq ($(TOOLCHAIN),mingw) -ASMOBJS=i386.o +ASMOBJS=$(ARCH).o else -ASMOBJS=i386nt.obj +ASMOBJS=$(ARCH)nt.obj endif OBJS=$(COBJS) $(ASMOBJS) @@ -47,6 +48,9 @@ libasmrun.$(A): $(OBJS) i386nt.obj: i386nt.asm ml /nologo /coff /Cp /c /Foi386nt.obj i386nt.asm +amd64nt.obj: amd64nt.asm + ml64 /nologo /Cp /c /Foamd64nt.obj amd64nt.asm + i386.o: i386.S $(CC) -c -DSYS_$(SYSTEM) i386.S @@ -71,7 +75,7 @@ clean:: clean:: rm -f *.$(O) *.$(A) *~ -.depend.nt: +.depend.nt: .depend sed -e 's/\.o/.$(O)/g' .depend > .depend.nt include .depend.nt diff --git a/asmrun/amd64.S b/asmrun/amd64.S index a55c75d6..8707e9de 100644 --- a/asmrun/amd64.S +++ b/asmrun/amd64.S @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: amd64.S,v 1.9.4.1 2005/12/18 15:42:06 xleroy Exp $ */ +/* $Id: amd64.S,v 1.11 2007/01/29 12:10:52 xleroy Exp $ */ /* Asm part of the runtime system, AMD64 processor */ /* Must be preprocessed by cpp */ @@ -247,14 +247,48 @@ FUNCTION(caml_start_program) orq $2, %rax jmp .L109 +/* Raise an exception from Caml */ + +FUNCTION(caml_raise_exn) + testl $1, caml_backtrace_active(%rip) + jne .L110 + movq %r14, %rsp + popq %r14 + ret +.L110: + movq %rax, %r12 /* Save exception bucket */ + movq %rax, %rdi /* arg 1: exception bucket */ + movq 0(%rsp), %rsi /* arg 2: pc of raise */ + leaq 8(%rsp), %rdx /* arg 3: sp of raise */ + movq %r14, %rcx /* arg 4: sp of handler */ + call caml_stash_backtrace + movq %r12, %rax /* Recover exception bucket */ + movq %r14, %rsp + popq %r14 + ret + /* Raise an exception from C */ FUNCTION(caml_raise_exception) + testl $1, caml_backtrace_active(%rip) + jne .L111 movq %rdi, %rax movq caml_exception_pointer(%rip), %rsp popq %r14 /* Recover previous exception handler */ movq caml_young_ptr(%rip), %r15 /* Reload alloc ptr */ ret +.L111: + movq %rdi, %r12 /* Save exception bucket */ + /* arg 1: exception bucket */ + movq caml_last_return_address(%rip), %rsi /* arg 2: pc of raise */ + movq caml_bottom_of_stack(%rip), %rdx /* arg 3: sp of raise */ + movq caml_exception_pointer(%rip), %rcx /* arg 4: sp of handler */ + call caml_stash_backtrace + movq %r12, %rax /* Recover exception bucket */ + movq caml_exception_pointer(%rip), %rsp + popq %r14 /* Recover previous exception handler */ + movq caml_young_ptr(%rip), %r15 /* Reload alloc ptr */ + ret /* Callback from C to Caml */ @@ -307,10 +341,8 @@ FUNCTION(caml_callback3_exn) jmp .L106 FUNCTION(caml_ml_array_bound_error) - /* Make the exception handler and alloc ptr available to the C code */ - movq %r15, caml_young_ptr(%rip) - movq %r14, caml_exception_pointer(%rip) - jmp caml_array_bound_error + leaq caml_array_bound_error(%rip), %rax + jmp caml_c_call .data .globl caml_system__frametable diff --git a/asmrun/amd64nt.asm b/asmrun/amd64nt.asm new file mode 100644 index 00000000..c441a275 --- /dev/null +++ b/asmrun/amd64nt.asm @@ -0,0 +1,464 @@ +;********************************************************************* +; +; Objective Caml +; +; Xavier Leroy, projet Gallium, INRIA Rocquencourt +; +; Copyright 2006 Institut National de Recherche en Informatique et +; en Automatique. All rights reserved. This file is distributed +; under the terms of the GNU Library General Public License, with +; the special exception on linking described in file ../LICENSE. +; +;********************************************************************* + +; $Id: amd64nt.asm,v 1.5 2007/03/01 10:26:51 xleroy Exp $ + +; Asm part of the runtime system, AMD64 processor, Intel syntax + +; Notes on Win64 calling conventions: +; function arguments in RCX, RDX, R8, R9 / XMM0 - XMM3 +; caller must reserve 32 bytes of stack space +; callee must preserve RBX, RBP, RSI, RDI, R12-R15, XMM6-XMM15 + + EXTRN caml_garbage_collection: NEAR + EXTRN caml_apply2: NEAR + EXTRN caml_apply3: NEAR + EXTRN caml_program: NEAR + EXTRN caml_array_bound_error: NEAR + EXTRN caml_young_limit: QWORD + EXTRN caml_young_ptr: QWORD + EXTRN caml_bottom_of_stack: QWORD + EXTRN caml_last_return_address: QWORD + EXTRN caml_gc_regs: QWORD + EXTRN caml_exception_pointer: QWORD + EXTRN caml_backtrace_active: DWORD + EXTRN caml_stash_backtrace: NEAR + + .CODE + +; Allocation + + PUBLIC caml_call_gc + ALIGN 16 +caml_call_gc: + ; Record lowest stack address and return address + mov rax, [rsp] + mov caml_last_return_address, rax + lea rax, [rsp+8] + mov caml_bottom_of_stack, rax +L105: + ; Save caml_young_ptr, caml_exception_pointer + mov caml_young_ptr, r15 + mov caml_exception_pointer, r14 + ; Build array of registers, save it into caml_gc_regs + push r13 + push r12 + push rbp + push r11 + push r10 + push r9 + push r8 + push rcx + push rdx + push rsi + push rdi + push rbx + push rax + mov caml_gc_regs, rsp + ; Save floating-point registers + sub rsp, 16*8 + movlpd QWORD PTR [rsp + 0*8], xmm0 + movlpd QWORD PTR [rsp + 1*8], xmm1 + movlpd QWORD PTR [rsp + 2*8], xmm2 + movlpd QWORD PTR [rsp + 3*8], xmm3 + movlpd QWORD PTR [rsp + 4*8], xmm4 + movlpd QWORD PTR [rsp + 5*8], xmm5 + movlpd QWORD PTR [rsp + 6*8], xmm6 + movlpd QWORD PTR [rsp + 7*8], xmm7 + movlpd QWORD PTR [rsp + 8*8], xmm8 + movlpd QWORD PTR [rsp + 9*8], xmm9 + movlpd QWORD PTR [rsp + 10*8], xmm10 + movlpd QWORD PTR [rsp + 11*8], xmm11 + movlpd QWORD PTR [rsp + 12*8], xmm12 + movlpd QWORD PTR [rsp + 13*8], xmm13 + movlpd QWORD PTR [rsp + 14*8], xmm14 + movlpd QWORD PTR [rsp + 15*8], xmm15 + ; Call the garbage collector + call caml_garbage_collection + ; Restore all regs used by the code generator + movlpd xmm0, QWORD PTR [rsp + 0*8] + movlpd xmm1, QWORD PTR [rsp + 1*8] + movlpd xmm2, QWORD PTR [rsp + 2*8] + movlpd xmm3, QWORD PTR [rsp + 3*8] + movlpd xmm4, QWORD PTR [rsp + 4*8] + movlpd xmm5, QWORD PTR [rsp + 5*8] + movlpd xmm6, QWORD PTR [rsp + 6*8] + movlpd xmm7, QWORD PTR [rsp + 7*8] + movlpd xmm8, QWORD PTR [rsp + 8*8] + movlpd xmm9, QWORD PTR [rsp + 9*8] + movlpd xmm10, QWORD PTR [rsp + 10*8] + movlpd xmm11, QWORD PTR [rsp + 11*8] + movlpd xmm12, QWORD PTR [rsp + 12*8] + movlpd xmm13, QWORD PTR [rsp + 13*8] + movlpd xmm14, QWORD PTR [rsp + 14*8] + movlpd xmm15, QWORD PTR [rsp + 15*8] + add rsp, 16*8 + pop rax + pop rbx + pop rdi + pop rsi + pop rdx + pop rcx + pop r8 + pop r9 + pop r10 + pop r11 + pop rbp + pop r12 + pop r13 + ; Restore caml_young_ptr, caml_exception_pointer + mov r15, caml_young_ptr + mov r14, caml_exception_pointer + ; Return to caller + ret + + PUBLIC caml_alloc1 + ALIGN 16 +caml_alloc1: + sub r15, 16 + cmp r15, caml_young_limit + jb L100 + ret +L100: + mov rax, [rsp + 0] + mov caml_last_return_address, rax + lea rax, [rsp + 8] + mov caml_bottom_of_stack, rax + sub rsp, 8 + call L105 + add rsp, 8 + jmp caml_alloc1 + + PUBLIC caml_alloc2 + ALIGN 16 +caml_alloc2: + sub r15, 24 + cmp r15, caml_young_limit + jb L101 + ret +L101: + mov rax, [rsp + 0] + mov caml_last_return_address, rax + lea rax, [rsp + 8] + mov caml_bottom_of_stack, rax + sub rsp, 8 + call L105 + add rsp, 8 + jmp caml_alloc2 + + PUBLIC caml_alloc3 + ALIGN 16 +caml_alloc3: + sub r15, 32 + cmp r15, caml_young_limit + jb L102 + ret +L102: + mov rax, [rsp + 0] + mov caml_last_return_address, rax + lea rax, [rsp + 8] + mov caml_bottom_of_stack, rax + sub rsp, 8 + call L105 + add rsp, 8 + jmp caml_alloc3 + + PUBLIC caml_allocN + ALIGN 16 +caml_allocN: + sub r15, rax + cmp r15, caml_young_limit + jb L103 + ret +L103: + push rax ; save desired size + mov rax, [rsp + 8] + mov caml_last_return_address, rax + lea rax, [rsp + 16] + mov caml_bottom_of_stack, rax + call L105 + pop rax ; recover desired size + jmp caml_allocN + +; Call a C function from Caml + + PUBLIC caml_c_call + ALIGN 16 +caml_c_call: + ; Record lowest stack address and return address + pop r12 + mov caml_last_return_address, r12 + mov caml_bottom_of_stack, rsp + ; Make the exception handler and alloc ptr available to the C code + mov caml_young_ptr, r15 + mov caml_exception_pointer, r14 + ; Call the function (address in rax) + call rax + ; Reload alloc ptr + mov r15, caml_young_ptr + ; Return to caller + push r12 + ret + +; Start the Caml program + + PUBLIC caml_start_program + ALIGN 16 +caml_start_program: + ; Save callee-save registers + push rbx + push rbp + push rsi + push rdi + push r12 + push r13 + push r14 + push r15 + sub rsp, 8+10*16 ; stack 16-aligned + 10 saved xmm regs + movapd OWORD PTR [rsp + 0*16], xmm6 + movapd OWORD PTR [rsp + 1*16], xmm7 + movapd OWORD PTR [rsp + 2*16], xmm8 + movapd OWORD PTR [rsp + 3*16], xmm9 + movapd OWORD PTR [rsp + 4*16], xmm10 + movapd OWORD PTR [rsp + 5*16], xmm11 + movapd OWORD PTR [rsp + 6*16], xmm12 + movapd OWORD PTR [rsp + 7*16], xmm13 + movapd OWORD PTR [rsp + 8*16], xmm14 + movapd OWORD PTR [rsp + 9*16], xmm15 + ; Initial entry point is caml_program + lea r12, caml_program + ; Common code for caml_start_program and caml_callback* +L106: + ; Build a callback link + sub rsp, 8 ; stack 16-aligned + push caml_gc_regs + push caml_last_return_address + push caml_bottom_of_stack + ; Setup alloc ptr and exception ptr + mov r15, caml_young_ptr + mov r14, caml_exception_pointer + ; Build an exception handler + lea r13, L108 + push r13 + push r14 + mov r14, rsp + ; Call the Caml code + call r12 +L107: + ; Pop the exception handler + pop r14 + pop r12 ; dummy register +L109: + ; Update alloc ptr and exception ptr + mov caml_young_ptr, r15 + mov caml_exception_pointer, r14 + ; Pop the callback restoring, link the global variables + pop caml_bottom_of_stack + pop caml_last_return_address + pop caml_gc_regs + add rsp, 8 + ; Restore callee-save registers. + movapd xmm6, OWORD PTR [rsp + 0*16] + movapd xmm7, OWORD PTR [rsp + 1*16] + movapd xmm8, OWORD PTR [rsp + 2*16] + movapd xmm9, OWORD PTR [rsp + 3*16] + movapd xmm10, OWORD PTR [rsp + 4*16] + movapd xmm11, OWORD PTR [rsp + 5*16] + movapd xmm12, OWORD PTR [rsp + 6*16] + movapd xmm13, OWORD PTR [rsp + 7*16] + movapd xmm14, OWORD PTR [rsp + 8*16] + movapd xmm15, OWORD PTR [rsp + 9*16] + add rsp, 8+10*16 + pop r15 + pop r14 + pop r13 + pop r12 + pop rdi + pop rsi + pop rbp + pop rbx + ; Return to caller + ret +L108: + ; Exception handler + ; Mark the bucket as an exception result and return it + or rax, 2 + jmp L109 + +; Raise an exception from Caml + + PUBLIC caml_raise_exn + ALIGN 16 +caml_raise_exn: + test caml_backtrace_active, 1 + jne L110 + mov rsp, r14 ; Cut stack + pop r14 ; Recover previous exception handler + ret ; Branch to handler +L110: + mov r12, rax ; Save exception bucket in r12 + mov rcx, rax ; Arg 1: exception bucket + mov rdx, [rsp] ; Arg 2: PC of raise + lea r8, [rsp+8] ; Arg 3: SP of raise + mov r9, r14 ; Arg 4: SP of handler + sub rsp, 32 ; Reserve 32 bytes on stack + call caml_stash_backtrace + mov rax, r12 ; Recover exception bucket + mov rsp, r14 ; Cut stack + pop r14 ; Recover previous exception handler + ret ; Branch to handler + +; Raise an exception from C + + PUBLIC caml_raise_exception + ALIGN 16 +caml_raise_exception: + test caml_backtrace_active, 1 + jne L111 + mov rax, rcx ; First argument is exn bucket + mov rsp, caml_exception_pointer + pop r14 ; Recover previous exception handler + mov r15, caml_young_ptr ; Reload alloc ptr + ret +L111: + mov r12, rcx ; Save exception bucket in r12 + ; Arg 1: exception bucket + mov rdx, caml_last_return_address ; Arg 2: PC of raise + mov r8, caml_bottom_of_stack ; Arg 3: SP of raise + mov r9, caml_exception_pointer ; Arg 4: SP of handler + sub rsp, 32 ; Reserve 32 bytes on stack + call caml_stash_backtrace + mov rax, r12 ; Recover exception bucket + mov rsp, caml_exception_pointer + pop r14 ; Recover previous exception handler + mov r15, caml_young_ptr ; Reload alloc ptr + ret + +; Callback from C to Caml + + PUBLIC caml_callback_exn + ALIGN 16 +caml_callback_exn: + ; Save callee-save registers + push rbx + push rbp + push rsi + push rdi + push r12 + push r13 + push r14 + push r15 + sub rsp, 8+10*16 ; stack 16-aligned + 10 saved xmm regs + movapd OWORD PTR [rsp + 0*16], xmm6 + movapd OWORD PTR [rsp + 1*16], xmm7 + movapd OWORD PTR [rsp + 2*16], xmm8 + movapd OWORD PTR [rsp + 3*16], xmm9 + movapd OWORD PTR [rsp + 4*16], xmm10 + movapd OWORD PTR [rsp + 5*16], xmm11 + movapd OWORD PTR [rsp + 6*16], xmm12 + movapd OWORD PTR [rsp + 7*16], xmm13 + movapd OWORD PTR [rsp + 8*16], xmm14 + movapd OWORD PTR [rsp + 9*16], xmm15 + ; Initial loading of arguments + mov rbx, rcx ; closure + mov rax, rdx ; argument + mov r12, [rbx] ; code pointer + jmp L106 + + PUBLIC caml_callback2_exn + ALIGN 16 +caml_callback2_exn: + ; Save callee-save registers + push rbx + push rbp + push rsi + push rdi + push r12 + push r13 + push r14 + push r15 + sub rsp, 8+10*16 ; stack 16-aligned + 10 saved xmm regs + movapd OWORD PTR [rsp + 0*16], xmm6 + movapd OWORD PTR [rsp + 1*16], xmm7 + movapd OWORD PTR [rsp + 2*16], xmm8 + movapd OWORD PTR [rsp + 3*16], xmm9 + movapd OWORD PTR [rsp + 4*16], xmm10 + movapd OWORD PTR [rsp + 5*16], xmm11 + movapd OWORD PTR [rsp + 6*16], xmm12 + movapd OWORD PTR [rsp + 7*16], xmm13 + movapd OWORD PTR [rsp + 8*16], xmm14 + movapd OWORD PTR [rsp + 9*16], xmm15 + ; Initial loading of arguments + mov rdi, rcx ; closure + mov rax, rdx ; first argument + mov rbx, r8 ; second argument + lea r12, caml_apply2 ; code pointer + jmp L106 + + PUBLIC caml_callback3_exn + ALIGN 16 +caml_callback3_exn: + ; Save callee-save registers + push rbx + push rbp + push rsi + push rdi + push r12 + push r13 + push r14 + push r15 + sub rsp, 8+10*16 ; stack 16-aligned + 10 saved xmm regs + movapd OWORD PTR [rsp + 0*16], xmm6 + movapd OWORD PTR [rsp + 1*16], xmm7 + movapd OWORD PTR [rsp + 2*16], xmm8 + movapd OWORD PTR [rsp + 3*16], xmm9 + movapd OWORD PTR [rsp + 4*16], xmm10 + movapd OWORD PTR [rsp + 5*16], xmm11 + movapd OWORD PTR [rsp + 6*16], xmm12 + movapd OWORD PTR [rsp + 7*16], xmm13 + movapd OWORD PTR [rsp + 8*16], xmm14 + movapd OWORD PTR [rsp + 9*16], xmm15 + ; Initial loading of arguments + mov rsi, rcx ; closure + mov rax, rdx ; first argument + mov rbx, r8 ; second argument + mov rdi, r9 ; third argument + lea r12, caml_apply3 ; code pointer + jmp L106 + + PUBLIC caml_ml_array_bound_error + ALIGN 16 +caml_ml_array_bound_error: + lea rax, caml_array_bound_error + jmp caml_c_call + + .DATA + PUBLIC caml_system__frametable +caml_system__frametable LABEL QWORD + QWORD 1 ; one descriptor + QWORD L107 ; return address into callback + WORD -1 ; negative frame size => use callback link + WORD 0 ; no roots here + ALIGN 8 + + PUBLIC caml_negf_mask + ALIGN 16 +caml_negf_mask LABEL QWORD + QWORD 8000000000000000H, 0 + + PUBLIC caml_absf_mask + ALIGN 16 +caml_absf_mask LABEL QWORD + QWORD 7FFFFFFFFFFFFFFFH, 0FFFFFFFFFFFFFFFFH + + END diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c new file mode 100644 index 00000000..59ea0c1b --- /dev/null +++ b/asmrun/backtrace.c @@ -0,0 +1,149 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ +/* */ +/* Copyright 2006 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id: backtrace.c,v 1.2 2007/01/29 12:10:52 xleroy Exp $ */ + +/* Stack backtrace for uncaught exceptions */ + +#include +#include "backtrace.h" +#include "memory.h" +#include "misc.h" +#include "mlvalues.h" +#include "stack.h" + +int caml_backtrace_active = 0; +int caml_backtrace_pos = 0; +code_t * caml_backtrace_buffer = NULL; +value caml_backtrace_last_exn = Val_unit; +#define BACKTRACE_BUFFER_SIZE 1024 + +/* Initialize the backtrace machinery */ + +void caml_init_backtrace(void) +{ + caml_backtrace_active = 1; + caml_register_global_root(&caml_backtrace_last_exn); +} + +/* Store the return addresses contained in the given stack fragment + into the backtrace array */ + +void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp) +{ + frame_descr * d; + uintnat h; + + if (exn != caml_backtrace_last_exn) { + caml_backtrace_pos = 0; + caml_backtrace_last_exn = exn; + } + if (caml_backtrace_buffer == NULL) { + caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t)); + if (caml_backtrace_buffer == NULL) return; + } + if (caml_frame_descriptors == NULL) caml_init_frame_descriptors(); + + while (1) { + /* Find the descriptor corresponding to the return address */ + h = Hash_retaddr(pc); + while(1) { + d = caml_frame_descriptors[h]; + if (d->retaddr == pc) break; + if (d->retaddr == 0) return; /* should not happen */ + h = (h+1) & caml_frame_descriptors_mask; + } + /* Skip to next frame */ + if (d->frame_size != 0xFFFF) { + /* Regular frame, store its descriptor in the backtrace buffer */ + if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return; + caml_backtrace_buffer[caml_backtrace_pos++] = (code_t) d; +#ifndef Stack_grows_upwards + sp += (d->frame_size & 0xFFFC); +#else + sp -= (d->frame_size & 0xFFFC); +#endif + pc = Saved_return_address(sp); +#ifdef Mask_already_scanned + pc = Mask_already_scanned(pc); +#endif + } else { + /* Special frame marking the top of a stack chunk for an ML callback. + Skip C portion of stack and continue with next ML stack chunk. */ + struct caml_context * next_context = Callback_link(sp); + sp = next_context->bottom_of_stack; + pc = next_context->last_retaddr; + /* A null sp means no more ML stack chunks; stop here. */ + if (sp == NULL) return; + } + /* Stop when we reach the current exception handler */ +#ifndef Stack_grows_upwards + if (sp > trapsp) return; +#else + if (sp < trapsp) return; +#endif + } +} + +/* Print a backtrace */ + +static void print_location(int index, frame_descr * d) +{ + uintnat infoptr; + uint32 info1, info2, k, n, l, a, b; + char * kind; + + /* If no debugging information available, print nothing. + When everything is compiled with -g, this corresponds to + compiler-inserted re-raise operations. */ + if ((d->frame_size & 1) == 0) return; + /* Recover debugging info */ + infoptr = ((uintnat) d + + sizeof(char *) + sizeof(short) + sizeof(short) + + sizeof(short) * d->num_live + sizeof(frame_descr *) - 1) + & -sizeof(frame_descr *); + info1 = ((uint32 *)infoptr)[0]; + info2 = ((uint32 *)infoptr)[1]; + /* Format of the two info words: + llllllllllllllllllll aaaaaaaa bbbbbbbbbb nnnnnnnnnnnnnnnnnnnnnnnn kk + 44 36 26 2 0 + (32+12) (32+4) + k ( 2 bits): 0 if it's a call, 1 if it's a raise + n (24 bits): offset (in 4-byte words) of file name relative to infoptr + l (20 bits): line number + a ( 8 bits): beginning of character range + b (10 bits): end of character range */ + k = info1 & 3; + n = info1 & 0x3FFFFFC; + l = info2 >> 12; + a = (info2 >> 4) & 0xFF; + b = ((info2 & 0xF) << 6) | (info1 >> 26); + + if (index == 0) + kind = "Raised at"; + else if (k == 1) + kind = "Re-raised at"; + else + kind = "Called from"; + + fprintf(stderr, "%s file \"%s\", line %d, characters %d-%d\n", + kind, ((char *) infoptr) + n, l, a, b); +} + +void caml_print_exception_backtrace(void) +{ + int i; + + for (i = 0; i < caml_backtrace_pos; i++) + print_location(i, (frame_descr *) caml_backtrace_buffer[i]); +} diff --git a/asmrun/fail.c b/asmrun/fail.c index 4852327d..954ab667 100644 --- a/asmrun/fail.c +++ b/asmrun/fail.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: fail.c,v 1.37 2004/05/17 17:25:52 doligez Exp $ */ +/* $Id: fail.c,v 1.38 2006/11/28 15:45:24 doligez Exp $ */ /* Raising exceptions from C. */ @@ -62,7 +62,7 @@ void caml_raise(value v) #else #define PUSHED_AFTER > #endif - while (caml_local_roots != NULL && + while (caml_local_roots != NULL && (char *) caml_local_roots PUSHED_AFTER caml_exception_pointer) { caml_local_roots = caml_local_roots->next; } @@ -94,17 +94,17 @@ void caml_raise_with_arg(value tag, value arg) CAMLnoreturn; } -void caml_raise_with_string(value tag, char *msg) +void caml_raise_with_string(value tag, char const *msg) { caml_raise_with_arg(tag, caml_copy_string(msg)); } -void caml_failwith (char *msg) +void caml_failwith (char const *msg) { caml_raise_with_string((value) caml_exn_Failure, msg); } -void caml_invalid_argument (char *msg) +void caml_invalid_argument (char const *msg) { caml_raise_with_string((value) caml_exn_Invalid_argument, msg); } diff --git a/asmrun/hppa.S b/asmrun/hppa.S index 6d9a26ff..0c0a8be1 100644 --- a/asmrun/hppa.S +++ b/asmrun/hppa.S @@ -11,7 +11,7 @@ ;* * ;********************************************************************* -; $Id: hppa.S,v 1.25.8.1 2006/03/29 14:49:19 doligez Exp $ +; $Id: hppa.S,v 1.26 2006/04/16 23:28:15 doligez Exp $ ; Asm part of the runtime system for the HP PA-RISC processor. ; Must be preprocessed by cpp diff --git a/asmrun/i386.S b/asmrun/i386.S index 37b03de3..1ecdd6b0 100644 --- a/asmrun/i386.S +++ b/asmrun/i386.S @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: i386.S,v 1.43.4.3 2006/07/14 08:53:50 xleroy Exp $ */ +/* $Id: i386.S,v 1.48 2007/01/29 15:44:42 xleroy Exp $ */ /* Asm part of the runtime system, Intel 386 processor */ /* Must be preprocessed by cpp */ @@ -57,12 +57,27 @@ popl %edx; popl %ecx; popl %eax; popl %ebp #define PROFILE_C \ pushl %ebp; movl %esp, %ebp; call .mcount; popl %ebp +#elif defined(SYS_macosx) +#define PROFILE_CAML \ + pushl %ebp; movl %esp, %ebp; pushl %eax; pushl %ecx; pushl %edx; \ + call Lmcount$stub; \ + popl %edx; popl %ecx; popl %eax; popl %ebp +#define PROFILE_C \ + pushl %ebp; movl %esp, %ebp; call Lmcount$stub; popl %ebp #endif #else #define PROFILE_CAML #define PROFILE_C #endif +#ifdef SYS_macosx +#define ALIGN_STACK(amount) subl $ amount, %esp +#define UNDO_ALIGN_STACK(amount) addl $ amount, %esp +#else +#define ALIGN_STACK(amount) +#define UNDO_ALIGN_STACK(amount) +#endif + /* Allocation */ .text @@ -72,6 +87,7 @@ .globl G(caml_alloc3) .globl G(caml_allocN) + .align FUNCTION_ALIGN G(caml_call_gc): PROFILE_CAML /* Record lowest stack address and return address */ @@ -117,13 +133,9 @@ LBL(100): movl %eax, G(caml_last_return_address) leal 4(%esp), %eax movl %eax, G(caml_bottom_of_stack) -#ifdef SYS_macosx - subl $12, %esp /* 16-alignment */ -#endif + ALIGN_STACK(12) call LBL(105) -#ifdef SYS_macosx - addl $12, %esp /* undo 16-alignment */ -#endif + UNDO_ALIGN_STACK(12) jmp G(caml_alloc1) .align FUNCTION_ALIGN @@ -140,13 +152,9 @@ LBL(101): movl %eax, G(caml_last_return_address) leal 4(%esp), %eax movl %eax, G(caml_bottom_of_stack) -#ifdef SYS_macosx - subl $12, %esp /* 16-alignment */ -#endif + ALIGN_STACK(12) call LBL(105) -#ifdef SYS_macosx - addl $12, %esp /* undo 16-alignment */ -#endif + UNDO_ALIGN_STACK(12) jmp G(caml_alloc2) .align FUNCTION_ALIGN @@ -163,13 +171,9 @@ LBL(102): movl %eax, G(caml_last_return_address) leal 4(%esp), %eax movl %eax, G(caml_bottom_of_stack) -#ifdef SYS_macosx - subl $12, %esp /* 16-alignment */ -#endif + ALIGN_STACK(12) call LBL(105) -#ifdef SYS_macosx - addl $12, %esp /* undo 16-alignment */ -#endif + UNDO_ALIGN_STACK(12) jmp G(caml_alloc3) .align FUNCTION_ALIGN @@ -190,13 +194,9 @@ LBL(103): movl %eax, G(caml_last_return_address) leal 8(%esp), %eax movl %eax, G(caml_bottom_of_stack) -#ifdef SYS_macosx - subl $8, %esp /* 16-alignment */ -#endif + ALIGN_STACK(8) call LBL(105) -#ifdef SYS_macosx - addl $8, %esp /* undo 16-alignment */ -#endif + UNDO_ALIGN_STACK(8) popl %eax /* recover desired size */ jmp G(caml_allocN) @@ -236,9 +236,7 @@ LBL(106): /* Note: 16-alignment preserved on MacOSX at this point */ /* Build an exception handler */ pushl $ LBL(108) -#ifdef SYS_macosx - subl $8, %esp /* 16-alignment */ -#endif + ALIGN_STACK(8) pushl G(caml_exception_pointer) movl %esp, G(caml_exception_pointer) /* Call the Caml code */ @@ -269,18 +267,59 @@ LBL(108): orl $2, %eax jmp LBL(109) +/* Raise an exception from Caml */ + + .globl G(caml_raise_exn) + .align FUNCTION_ALIGN +G(caml_raise_exn): + testl $1, G(caml_backtrace_active) + jne LBL(110) + movl G(caml_exception_pointer), %esp + popl G(caml_exception_pointer) + UNDO_ALIGN_STACK(8) + ret +LBL(110): + movl %eax, %esi /* Save exception bucket in esi */ + movl G(caml_exception_pointer), %edi /* SP of handler */ + movl 0(%esp), %eax /* PC of raise */ + leal 4(%esp), %edx /* SP of raise */ + ALIGN_STACK(12) + pushl %edi /* arg 4: sp of handler */ + pushl %edx /* arg 3: sp of raise */ + pushl %eax /* arg 2: pc of raise */ + pushl %esi /* arg 1: exception bucket */ + call G(caml_stash_backtrace) + movl %esi, %eax /* Recover exception bucket */ + movl %edi, %esp + popl G(caml_exception_pointer) + UNDO_ALIGN_STACK(8) + ret + /* Raise an exception from C */ .globl G(caml_raise_exception) .align FUNCTION_ALIGN G(caml_raise_exception): PROFILE_C + testl $1, G(caml_backtrace_active) + jne LBL(111) movl 4(%esp), %eax movl G(caml_exception_pointer), %esp popl G(caml_exception_pointer) -#ifdef SYS_macosx - addl $8, %esp -#endif + UNDO_ALIGN_STACK(8) + ret +LBL(111): + movl 4(%esp), %esi /* Save exception bucket in esi */ + ALIGN_STACK(12) + pushl G(caml_exception_pointer) /* arg 4: sp of handler */ + pushl G(caml_bottom_of_stack) /* arg 3: sp of raise */ + pushl G(caml_last_return_address) /* arg 2: pc of raise */ + pushl %esi /* arg 1: exception bucket */ + call G(caml_stash_backtrace) + movl %esi, %eax /* Recover exception bucket */ + movl G(caml_exception_pointer), %esp + popl G(caml_exception_pointer) + UNDO_ALIGN_STACK(8) ret /* Callback from C to Caml */ @@ -346,7 +385,8 @@ G(caml_ml_array_bound_error): ffree %st(6) ffree %st(7) /* Branch to [caml_array_bound_error] */ - jmp G(caml_array_bound_error) + movl $ G(caml_array_bound_error), %eax + jmp G(caml_c_call) .data .globl G(caml_system__frametable) @@ -368,3 +408,11 @@ G(caml_extra_params): #else .zero 64 #endif + +#if defined(PROFILING) && defined(SYS_macosx) + .section __IMPORT,__jump_table,symbol_stubs,self_modifying_code+pure_instructions,5 +Lmcount$stub: + .indirect_symbol mcount + hlt ; hlt ; hlt ; hlt ; hlt + .subsections_via_symbols +#endif diff --git a/asmrun/i386nt.asm b/asmrun/i386nt.asm index d1128542..229ffc79 100644 --- a/asmrun/i386nt.asm +++ b/asmrun/i386nt.asm @@ -11,7 +11,7 @@ ; ;********************************************************************* -; $Id: i386nt.asm,v 1.19 2005/10/12 12:56:53 xleroy Exp $ +; $Id: i386nt.asm,v 1.20 2007/01/29 12:10:52 xleroy Exp $ ; Asm part of the runtime system, Intel 386 processor, Intel syntax @@ -29,6 +29,8 @@ EXTERN _caml_last_return_address: DWORD EXTERN _caml_gc_regs: DWORD EXTERN _caml_exception_pointer: DWORD + EXTERN _caml_backtrace_active: DWORD + EXTERN _caml_stash_backtrace: PROC ; Allocation @@ -194,15 +196,53 @@ L108: or eax, 2 jmp L109 +; Raise an exception for Caml + + PUBLIC _caml_raise_exn + ALIGN 4 +_caml_raise_exn: + test _caml_backtrace_active, 1 + jne L110 + mov esp, _caml_exception_pointer + pop _caml_exception_pointer + ret +L110: + mov esi, eax ; Save exception bucket in esi + mov edi, _caml_exception_pointer ; SP of handler + mov eax, [esp] ; PC of raise + lea edx, [esp+4] + push edi ; arg 4: SP of handler + push edx ; arg 3: SP of raise + push eax ; arg 2: PC of raise + push esi ; arg 1: exception bucket + call _caml_stash_backtrace + mov eax, esi ; recover exception bucket + mov esp, edi ; cut the stack + pop _caml_exception_pointer + ret + ; Raise an exception from C PUBLIC _caml_raise_exception ALIGN 4 _caml_raise_exception: + test _caml_backtrace_active, 1 + jne L111 mov eax, [esp+4] mov esp, _caml_exception_pointer pop _caml_exception_pointer ret +L111: + mov esi, [esp+4] ; Save exception bucket in esi + push _caml_exception_pointer ; arg 4: SP of handler + push _caml_bottom_of_stack ; arg 3: SP of raise + push _caml_last_return_address ; arg 2: PC of raise + push esi ; arg 1: exception bucket + call _caml_stash_backtrace + mov eax, esi ; recover exception bucket + mov esp, _caml_exception_pointer ; cut the stack + pop _caml_exception_pointer + ret ; Callback from C to Caml @@ -263,8 +303,9 @@ _caml_ml_array_bound_error: ffree st(5) ffree st(6) ffree st(7) - ; Branch to array_bound_error - jmp _caml_array_bound_error + ; Branch to caml_array_bound_error + mov eax, offset _caml_array_bound_error + jmp _caml_c_call .DATA PUBLIC _caml_system__frametable diff --git a/asmrun/power-rhapsody.S b/asmrun/power-rhapsody.S index 338010cb..b7cfab59 100644 --- a/asmrun/power-rhapsody.S +++ b/asmrun/power-rhapsody.S @@ -11,7 +11,20 @@ /* */ /*********************************************************************/ -/* $Id: power-rhapsody.S,v 1.13 2004/02/22 14:56:25 xleroy Exp $ */ +/* $Id: power-rhapsody.S,v 1.15 2007/01/29 12:10:52 xleroy Exp $ */ + +#ifdef __ppc64__ +#define X(a,b) b +#else +#define X(a,b) a +#endif + +#define WORD X(4,8) +#define lg X(lwz,ld) +#define lgu X(lwzu,ldu) +#define stg X(stw,std) +#define stgu X(stwu,stdu) +#define gdata X(.long,.quad) .macro Addrglobal /* reg, glob */ addis $0, 0, ha16($1) @@ -19,11 +32,11 @@ .endmacro .macro Loadglobal /* reg,glob,tmp */ addis $2, 0, ha16($1) - lwz $0, lo16($1)($2) + lg $0, lo16($1)($2) .endmacro .macro Storeglobal /* reg,glob,tmp */ addis $2, 0, ha16($1) - stw $0, lo16($1)($2) + stg $0, lo16($1)($2) .endmacro .text @@ -33,13 +46,13 @@ .globl _caml_call_gc _caml_call_gc: /* Set up stack frame */ - stwu r1, -0x1A0(r1) - /* 0x1A0 = 4*32 (int regs) + 8*32 (float regs) + 32 (space for C call) */ +#define FRAMESIZE (32*WORD + 32*8 + 32) + stwu r1, -FRAMESIZE(r1) /* Record return address into Caml code */ mflr r0 Storeglobal r0, _caml_last_return_address, r11 /* Record lowest stack address */ - addi r0, r1, 0x1A0 + addi r0, r1, FRAMESIZE Storeglobal r0, _caml_bottom_of_stack, r11 /* Record pointer to register array */ addi r0, r1, 8*32 + 32 @@ -49,30 +62,30 @@ _caml_call_gc: /* Save exception pointer (if e.g. a sighandler raises) */ Storeglobal r29, _caml_exception_pointer, r11 /* Save all registers used by the code generator */ - addi r11, r1, 8*32 + 32 - 4 - stwu r3, 4(r11) - stwu r4, 4(r11) - stwu r5, 4(r11) - stwu r6, 4(r11) - stwu r7, 4(r11) - stwu r8, 4(r11) - stwu r9, 4(r11) - stwu r10, 4(r11) - stwu r14, 4(r11) - stwu r15, 4(r11) - stwu r16, 4(r11) - stwu r17, 4(r11) - stwu r18, 4(r11) - stwu r19, 4(r11) - stwu r20, 4(r11) - stwu r21, 4(r11) - stwu r22, 4(r11) - stwu r23, 4(r11) - stwu r24, 4(r11) - stwu r25, 4(r11) - stwu r26, 4(r11) - stwu r27, 4(r11) - stwu r28, 4(r11) + addi r11, r1, 8*32 + 32 - WORD + stgu r3, WORD(r11) + stgu r4, WORD(r11) + stgu r5, WORD(r11) + stgu r6, WORD(r11) + stgu r7, WORD(r11) + stgu r8, WORD(r11) + stgu r9, WORD(r11) + stgu r10, WORD(r11) + stgu r14, WORD(r11) + stgu r15, WORD(r11) + stgu r16, WORD(r11) + stgu r17, WORD(r11) + stgu r18, WORD(r11) + stgu r19, WORD(r11) + stgu r20, WORD(r11) + stgu r21, WORD(r11) + stgu r22, WORD(r11) + stgu r23, WORD(r11) + stgu r24, WORD(r11) + stgu r25, WORD(r11) + stgu r26, WORD(r11) + stgu r27, WORD(r11) + stgu r28, WORD(r11) addi r11, r1, 32 - 8 stfdu f1, 8(r11) stfdu f2, 8(r11) @@ -111,30 +124,30 @@ _caml_call_gc: Loadglobal r31, _caml_young_ptr, r11 Loadglobal r30, _caml_young_limit, r11 /* Restore all regs used by the code generator */ - addi r11, r1, 8*32 + 32 - 4 - lwzu r3, 4(r11) - lwzu r4, 4(r11) - lwzu r5, 4(r11) - lwzu r6, 4(r11) - lwzu r7, 4(r11) - lwzu r8, 4(r11) - lwzu r9, 4(r11) - lwzu r10, 4(r11) - lwzu r14, 4(r11) - lwzu r15, 4(r11) - lwzu r16, 4(r11) - lwzu r17, 4(r11) - lwzu r18, 4(r11) - lwzu r19, 4(r11) - lwzu r20, 4(r11) - lwzu r21, 4(r11) - lwzu r22, 4(r11) - lwzu r23, 4(r11) - lwzu r24, 4(r11) - lwzu r25, 4(r11) - lwzu r26, 4(r11) - lwzu r27, 4(r11) - lwzu r28, 4(r11) + addi r11, r1, 8*32 + 32 - WORD + lgu r3, WORD(r11) + lgu r4, WORD(r11) + lgu r5, WORD(r11) + lgu r6, WORD(r11) + lgu r7, WORD(r11) + lgu r8, WORD(r11) + lgu r9, WORD(r11) + lgu r10, WORD(r11) + lgu r14, WORD(r11) + lgu r15, WORD(r11) + lgu r16, WORD(r11) + lgu r17, WORD(r11) + lgu r18, WORD(r11) + lgu r19, WORD(r11) + lgu r20, WORD(r11) + lgu r21, WORD(r11) + lgu r22, WORD(r11) + lgu r23, WORD(r11) + lgu r24, WORD(r11) + lgu r25, WORD(r11) + lgu r26, WORD(r11) + lgu r27, WORD(r11) + lgu r28, WORD(r11) addi r11, r1, 32 - 8 lfdu f1, 8(r11) lfdu f2, 8(r11) @@ -175,9 +188,10 @@ _caml_call_gc: li r12, 0 Storeglobal r12, _caml_last_return_address, r11 /* Deallocate stack frame */ - addi r1, r1, 0x1A0 + addi r1, r1, FRAMESIZE /* Return */ blr +#undef FRAMESIZE /* Call a C function from Caml */ @@ -206,10 +220,43 @@ _caml_c_call: /* Return to caller */ blr +/* Raise an exception from Caml */ + .globl _caml_raise_exn +_caml_raise_exn: + addis r11, 0, ha16(_caml_backtrace_active) + lwz r11, lo16(_caml_backtrace_active)(r11) + cmpwi r11, 0 + bne L110 +L111: + /* Pop trap frame */ + lg r0, 0(r29) + mr r1, r29 + mtlr r0 + lg r29, WORD(r1) + addi r1, r1, 16 + /* Branch to handler */ + blr + +L110: + mr r28, r3 /* preserve exn bucket in callee-save */ + /* arg 1: exception bucket (already in r3) */ + mflr r4 /* arg 2: PC of raise */ + mr r5, r1 /* arg 3: SP of raise */ + mr r6, r29 /* arg 4: SP of handler */ + addi r1, r1, -(16*WORD) /* reserve stack space for C call */ + bl _caml_stash_backtrace + mr r3, r28 + b L111 + /* Raise an exception from C */ .globl _caml_raise_exception _caml_raise_exception: + addis r11, 0, ha16(_caml_backtrace_active) + lwz r11, lo16(_caml_backtrace_active)(r11) + cmpwi r11, 0 + bne L112 +L113: /* Reload Caml global registers */ Loadglobal r1, _caml_exception_pointer, r11 Loadglobal r31, _caml_young_ptr, r11 @@ -218,12 +265,22 @@ _caml_raise_exception: li r0, 0 Storeglobal r0, _caml_last_return_address, r11 /* Pop trap frame */ - lwz r0, 0(r1) - lwz r29, 4(r1) + lg r0, 0(r1) + lg r29, WORD(r1) mtlr r0 addi r1, r1, 16 /* Branch to handler */ blr +L112: + mr r28, r3 /* preserve exn bucket in callee-save */ + /* arg 1: exception bucket (already in r3) */ + Loadglobal r4, _caml_last_return_address, r11 /* arg 2: PC of raise */ + Loadglobal r5, _caml_bottom_of_stack, r11 /* arg 3: SP of raise */ + Loadglobal r6, _caml_exception_pointer, r11 /* arg 4: SP of handler */ + addi r1, r1, -(16*WORD) /* reserve stack space for C call */ + bl _caml_stash_backtrace + mr r3, r28 + b L113 /* Start the Caml program */ @@ -234,32 +291,32 @@ _caml_start_program: /* Code shared between caml_start_program and caml_callback */ L102: /* Allocate and link stack frame */ - stwu r1, -256(r1) +#define FRAMESIZE (16 + 20*WORD + 18*8) + stgu r1, -FRAMESIZE(r1) /* Save return address */ mflr r0 - stw r0, 256+4(r1) + stg r0, WORD(r1) /* Save all callee-save registers */ - /* GPR 14 at sp+16 ... GPR 31 at sp+84 - FPR 14 at sp+92 ... FPR 31 at sp+228 */ - addi r11, r1, 16-4 - stwu r14, 4(r11) - stwu r15, 4(r11) - stwu r16, 4(r11) - stwu r17, 4(r11) - stwu r18, 4(r11) - stwu r19, 4(r11) - stwu r20, 4(r11) - stwu r21, 4(r11) - stwu r22, 4(r11) - stwu r23, 4(r11) - stwu r24, 4(r11) - stwu r25, 4(r11) - stwu r26, 4(r11) - stwu r27, 4(r11) - stwu r28, 4(r11) - stwu r29, 4(r11) - stwu r30, 4(r11) - stwu r31, 4(r11) + /* GPR14 ... GPR31, then FPR14 ... FPR31 starting at sp+16 */ + addi r11, r1, 16-WORD + stgu r14, WORD(r11) + stgu r15, WORD(r11) + stgu r16, WORD(r11) + stgu r17, WORD(r11) + stgu r18, WORD(r11) + stgu r19, WORD(r11) + stgu r20, WORD(r11) + stgu r21, WORD(r11) + stgu r22, WORD(r11) + stgu r23, WORD(r11) + stgu r24, WORD(r11) + stgu r25, WORD(r11) + stgu r26, WORD(r11) + stgu r27, WORD(r11) + stgu r28, WORD(r11) + stgu r29, WORD(r11) + stgu r30, WORD(r11) + stgu r31, WORD(r11) stfdu f14, 8(r11) stfdu f15, 8(r11) stfdu f16, 8(r11) @@ -279,22 +336,22 @@ L102: stfdu f30, 8(r11) stfdu f31, 8(r11) /* Set up a callback link */ - addi r1, r1, -16 + addi r1, r1, -32 Loadglobal r9, _caml_bottom_of_stack, r11 Loadglobal r10, _caml_last_return_address, r11 Loadglobal r11, _caml_gc_regs, r11 - stw r9, 0(r1) - stw r10, 4(r1) - stw r11, 8(r1) + stg r9, 0(r1) + stg r10, WORD(r1) + stg r11, 2*WORD(r1) /* Build an exception handler to catch exceptions escaping out of Caml */ bl L103 b L104 L103: addi r1, r1, -16 mflr r0 - stw r0, 0(r1) + stg r0, 0(r1) Loadglobal r11, _caml_exception_pointer, r11 - stw r11, 4(r1) + stg r11, WORD(r1) mr r29, r1 /* Reload allocation pointers */ Loadglobal r31, _caml_young_ptr, r11 @@ -307,40 +364,40 @@ L103: L105: bctrl /* Pop the trap frame, restoring caml_exception_pointer */ - lwz r9, 4(r1) + lg r9, WORD(r1) Storeglobal r9, _caml_exception_pointer, r11 addi r1, r1, 16 /* Pop the callback link, restoring the global variables */ L106: - lwz r9, 0(r1) - lwz r10, 4(r1) - lwz r11, 8(r1) + lg r9, 0(r1) + lg r10, WORD(r1) + lg r11, 2*WORD(r1) Storeglobal r9, _caml_bottom_of_stack, r12 Storeglobal r10, _caml_last_return_address, r12 Storeglobal r11, _caml_gc_regs, r12 - addi r1, r1, 16 + addi r1, r1, 32 /* Update allocation pointer */ Storeglobal r31, _caml_young_ptr, r11 /* Restore callee-save registers */ - addi r11, r1, 16-4 - lwzu r14, 4(r11) - lwzu r15, 4(r11) - lwzu r16, 4(r11) - lwzu r17, 4(r11) - lwzu r18, 4(r11) - lwzu r19, 4(r11) - lwzu r20, 4(r11) - lwzu r21, 4(r11) - lwzu r22, 4(r11) - lwzu r23, 4(r11) - lwzu r24, 4(r11) - lwzu r25, 4(r11) - lwzu r26, 4(r11) - lwzu r27, 4(r11) - lwzu r28, 4(r11) - lwzu r29, 4(r11) - lwzu r30, 4(r11) - lwzu r31, 4(r11) + addi r11, r1, 16-WORD + lgu r14, WORD(r11) + lgu r15, WORD(r11) + lgu r16, WORD(r11) + lgu r17, WORD(r11) + lgu r18, WORD(r11) + lgu r19, WORD(r11) + lgu r20, WORD(r11) + lgu r21, WORD(r11) + lgu r22, WORD(r11) + lgu r23, WORD(r11) + lgu r24, WORD(r11) + lgu r25, WORD(r11) + lgu r26, WORD(r11) + lgu r27, WORD(r11) + lgu r28, WORD(r11) + lgu r29, WORD(r11) + lgu r30, WORD(r11) + lgu r31, WORD(r11) lfdu f14, 8(r11) lfdu f15, 8(r11) lfdu f16, 8(r11) @@ -360,10 +417,10 @@ L106: lfdu f30, 8(r11) lfdu f31, 8(r11) /* Reload return address */ - lwz r0, 256+4(r1) + lg r0, WORD(r1) mtlr r0 /* Return */ - addi r1, r1, 256 + addi r1, r1, FRAMESIZE blr /* The trap handler: */ @@ -373,6 +430,7 @@ L104: /* Encode exception bucket as an exception result and return it */ ori r3, r3, 2 b L106 +#undef FRAMESIZE /* Callback from C to Caml */ @@ -382,7 +440,7 @@ _caml_callback_exn: mr r0, r3 /* Closure */ mr r3, r4 /* Argument */ mr r4, r0 - lwz r12, 0(r4) /* Code pointer */ + lg r12, 0(r4) /* Code pointer */ b L102 .globl _caml_callback2_exn @@ -409,8 +467,8 @@ _caml_callback3_exn: .const .globl _caml_system__frametable _caml_system__frametable: - .long 1 /* one descriptor */ - .long L105 + 4 /* return address into callback */ + gdata 1 /* one descriptor */ + gdata L105 + 4 /* return address into callback */ .short -1 /* negative size count => use callback link */ .short 0 /* no roots here */ - + .align X(2,3) diff --git a/asmrun/roots.c b/asmrun/roots.c index 5d5a8898..d11b85c6 100644 --- a/asmrun/roots.c +++ b/asmrun/roots.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: roots.c,v 1.38 2005/09/22 14:21:47 xleroy Exp $ */ +/* $Id: roots.c,v 1.41 2007/02/15 18:35:20 frisch Exp $ */ /* To walk the memory roots for garbage collection */ @@ -33,24 +33,15 @@ void (*caml_scan_roots_hook) (scanning_action) = NULL; /* The hashtable of frame descriptors */ -typedef struct { - uintnat retaddr; - short frame_size; - short num_live; - short live_ofs[1]; -} frame_descr; - -static frame_descr ** frame_descriptors = NULL; -static int frame_descriptors_mask; - -#define Hash_retaddr(addr) \ - (((uintnat)(addr) >> 3) & frame_descriptors_mask) +frame_descr ** caml_frame_descriptors = NULL; +int caml_frame_descriptors_mask; -static void init_frame_descriptors(void) +void caml_init_frame_descriptors(void) { intnat num_descr, tblsize, i, j, len; intnat * tbl; frame_descr * d; + uintnat nextd; uintnat h; /* Count the frame descriptors */ @@ -64,10 +55,10 @@ static void init_frame_descriptors(void) while (tblsize < 2 * num_descr) tblsize *= 2; /* Allocate the hash table */ - frame_descriptors = + caml_frame_descriptors = (frame_descr **) caml_stat_alloc(tblsize * sizeof(frame_descr *)); - for (i = 0; i < tblsize; i++) frame_descriptors[i] = NULL; - frame_descriptors_mask = tblsize - 1; + for (i = 0; i < tblsize; i++) caml_frame_descriptors[i] = NULL; + caml_frame_descriptors_mask = tblsize - 1; /* Fill the hash table */ for (i = 0; caml_frametable[i] != 0; i++) { @@ -76,15 +67,17 @@ static void init_frame_descriptors(void) d = (frame_descr *)(tbl + 1); for (j = 0; j < len; j++) { h = Hash_retaddr(d->retaddr); - while (frame_descriptors[h] != NULL) { - h = (h+1) & frame_descriptors_mask; + while (caml_frame_descriptors[h] != NULL) { + h = (h+1) & caml_frame_descriptors_mask; } - frame_descriptors[h] = d; - d = (frame_descr *) - (((uintnat)d + - sizeof(char *) + sizeof(short) + sizeof(short) + - sizeof(short) * d->num_live + sizeof(frame_descr *) - 1) - & -sizeof(frame_descr *)); + caml_frame_descriptors[h] = d; + nextd = + ((uintnat)d + + sizeof(char *) + sizeof(short) + sizeof(short) + + sizeof(short) * d->num_live + sizeof(frame_descr *) - 1) + & -sizeof(frame_descr *); + if (d->frame_size & 1) nextd += 8; + d = (frame_descr *) nextd; } } } @@ -107,7 +100,7 @@ void caml_oldify_local_roots (void) frame_descr * d; uintnat h; int i, j, n, ofs; - short * p; + unsigned short * p; value glob; value * root; struct global_root * gr; @@ -125,7 +118,7 @@ void caml_oldify_local_roots (void) caml_globals_scanned = caml_globals_inited; /* The stack and local roots */ - if (frame_descriptors == NULL) init_frame_descriptors(); + if (caml_frame_descriptors == NULL) caml_init_frame_descriptors(); sp = caml_bottom_of_stack; retaddr = caml_last_return_address; regs = caml_gc_regs; @@ -134,11 +127,11 @@ void caml_oldify_local_roots (void) /* Find the descriptor corresponding to the return address */ h = Hash_retaddr(retaddr); while(1) { - d = frame_descriptors[h]; + d = caml_frame_descriptors[h]; if (d->retaddr == retaddr) break; - h = (h+1) & frame_descriptors_mask; + h = (h+1) & caml_frame_descriptors_mask; } - if (d->frame_size >= 0) { + if (d->frame_size != 0xFFFF) { /* Scan the roots in this frame */ for (p = d->live_ofs, n = d->num_live; n > 0; n--, p++) { ofs = *p; @@ -151,9 +144,9 @@ void caml_oldify_local_roots (void) } /* Move to next frame */ #ifndef Stack_grows_upwards - sp += d->frame_size; + sp += (d->frame_size & 0xFFFC); #else - sp -= d->frame_size; + sp -= (d->frame_size & 0xFFFC); #endif retaddr = Saved_return_address(sp); #ifdef Already_scanned @@ -213,7 +206,7 @@ void caml_do_roots (scanning_action f) f (Field (glob, j), &Field (glob, j)); } /* The stack and local roots */ - if (frame_descriptors == NULL) init_frame_descriptors(); + if (caml_frame_descriptors == NULL) caml_init_frame_descriptors(); caml_do_local_roots(f, caml_bottom_of_stack, caml_last_return_address, caml_gc_regs, caml_local_roots); /* Global C roots */ @@ -236,7 +229,7 @@ void caml_do_local_roots(scanning_action f, char * bottom_of_stack, frame_descr * d; uintnat h; int i, j, n, ofs; - short * p; + unsigned short * p; value * root; struct caml__roots_block *lr; @@ -248,11 +241,11 @@ void caml_do_local_roots(scanning_action f, char * bottom_of_stack, /* Find the descriptor corresponding to the return address */ h = Hash_retaddr(retaddr); while(1) { - d = frame_descriptors[h]; + d = caml_frame_descriptors[h]; if (d->retaddr == retaddr) break; - h = (h+1) & frame_descriptors_mask; + h = (h+1) & caml_frame_descriptors_mask; } - if (d->frame_size >= 0) { + if (d->frame_size != 0xFFFF) { /* Scan the roots in this frame */ for (p = d->live_ofs, n = d->num_live; n > 0; n--, p++) { ofs = *p; @@ -265,9 +258,9 @@ void caml_do_local_roots(scanning_action f, char * bottom_of_stack, } /* Move to next frame */ #ifndef Stack_grows_upwards - sp += d->frame_size; + sp += (d->frame_size & 0xFFFC); #else - sp -= d->frame_size; + sp -= (d->frame_size & 0xFFFC); #endif retaddr = Saved_return_address(sp); #ifdef Mask_already_scanned diff --git a/asmrun/signals.c b/asmrun/signals.c deleted file mode 100644 index 44895649..00000000 --- a/asmrun/signals.c +++ /dev/null @@ -1,481 +0,0 @@ -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: signals.c,v 1.93.2.2 2006/08/01 01:02:07 xleroy Exp $ */ - -#if defined(TARGET_amd64) && defined (SYS_linux) -#define _GNU_SOURCE -#endif -#include -#include -#include "alloc.h" -#include "callback.h" -#include "memory.h" -#include "minor_gc.h" -#include "misc.h" -#include "mlvalues.h" -#include "fail.h" -#include "osdeps.h" -#include "signals.h" -#include "signals_machdep.h" -#include "signals_osdep.h" -#include "stack.h" -#include "sys.h" -#ifdef HAS_STACK_OVERFLOW_DETECTION -#include -#include -#endif - -#ifndef NSIG -#define NSIG 64 -#endif - -#ifdef _WIN32 -typedef void (*sighandler)(int sig); -extern sighandler caml_win32_signal(int sig, sighandler action); -#define signal(sig,act) caml_win32_signal(sig,act) -#endif - -extern char * caml_code_area_start, * caml_code_area_end; - -#define In_code_area(pc) \ - ((char *)(pc) >= caml_code_area_start && \ - (char *)(pc) <= caml_code_area_end) - -intnat volatile caml_signals_are_pending = 0; -volatile intnat caml_pending_signals[NSIG]; -volatile int caml_force_major_slice = 0; -value caml_signal_handlers = 0; - -static void caml_process_pending_signals(void) -{ - int i; - - if (caml_signals_are_pending) { - caml_signals_are_pending = 0; - for (i = 0; i < NSIG; i++) { - if (caml_pending_signals[i]) { - caml_pending_signals[i] = 0; - caml_execute_signal(i, 0); - } - } - } -} - -static intnat volatile caml_async_signal_mode = 0; - -static void caml_enter_blocking_section_default(void) -{ - Assert (caml_async_signal_mode == 0); - caml_async_signal_mode = 1; -} - -static void caml_leave_blocking_section_default(void) -{ - Assert (caml_async_signal_mode == 1); - caml_async_signal_mode = 0; -} - -static int caml_try_leave_blocking_section_default(void) -{ - intnat res; - Read_and_clear(res, caml_async_signal_mode); - return res; -} - -CAMLexport void (*caml_enter_blocking_section_hook)(void) = - caml_enter_blocking_section_default; -CAMLexport void (*caml_leave_blocking_section_hook)(void) = - caml_leave_blocking_section_default; -CAMLexport int (*caml_try_leave_blocking_section_hook)(void) = - caml_try_leave_blocking_section_default; - -int caml_rev_convert_signal_number(int signo); - -/* Execute a signal handler immediately. */ - -void caml_execute_signal(int signal_number, int in_signal_handler) -{ - value res; -#ifdef POSIX_SIGNALS - sigset_t sigs; - /* Block the signal before executing the handler, and record in sigs - the original signal mask */ - sigemptyset(&sigs); - sigaddset(&sigs, signal_number); - sigprocmask(SIG_BLOCK, &sigs, &sigs); -#endif - res = caml_callback_exn( - Field(caml_signal_handlers, signal_number), - Val_int(caml_rev_convert_signal_number(signal_number))); -#ifdef POSIX_SIGNALS - if (! in_signal_handler) { - /* Restore the original signal mask */ - sigprocmask(SIG_SETMASK, &sigs, NULL); - } else if (Is_exception_result(res)) { - /* Restore the original signal mask and unblock the signal itself */ - sigdelset(&sigs, signal_number); - sigprocmask(SIG_SETMASK, &sigs, NULL); - } -#endif - if (Is_exception_result(res)) caml_raise(Extract_exception(res)); -} - -/* Record the delivery of a signal and play with the allocation limit - so that the next allocation will trigger a garbage collection. */ - -void caml_record_signal(int signal_number) -{ - caml_pending_signals[signal_number] = 1; - caml_signals_are_pending = 1; - caml_young_limit = caml_young_end; -} - -/* This routine is the common entry point for garbage collection - and signal handling. It can trigger a callback to Caml code. - With system threads, this callback can cause a context switch. - Hence [caml_garbage_collection] must not be called from regular C code - (e.g. the [caml_alloc] function) because the context of the call - (e.g. [intern_val]) may not allow context switching. - Only generated assembly code can call [caml_garbage_collection], - via the caml_call_gc assembly stubs. */ - -void caml_garbage_collection(void) -{ - caml_young_limit = caml_young_start; - if (caml_young_ptr < caml_young_start || caml_force_major_slice) { - caml_minor_collection(); - } - caml_process_pending_signals(); -} - -/* Trigger a garbage collection as soon as possible */ - -void caml_urge_major_slice (void) -{ - caml_force_major_slice = 1; - caml_young_limit = caml_young_end; - /* This is only moderately effective on ports that cache [caml_young_limit] - in a register, since [caml_modify] is called directly, not through - [caml_c_call], so it may take a while before the register is reloaded - from [caml_young_limit]. */ -} - -void caml_enter_blocking_section(void) -{ - while (1){ - /* Process all pending signals now */ - caml_process_pending_signals(); - caml_enter_blocking_section_hook (); - /* Check again for pending signals. - If none, done; otherwise, try again */ - if (! caml_signals_are_pending) break; - caml_leave_blocking_section_hook (); - } -} - -CAMLexport void caml_leave_blocking_section(void) -{ - caml_leave_blocking_section_hook (); - caml_process_pending_signals(); -} - -DECLARE_SIGNAL_HANDLER(handle_signal) -{ -#if !defined(POSIX_SIGNALS) && !defined(BSD_SIGNALS) - signal(sig, handle_signal); -#endif - if (sig < 0 || sig >= NSIG) return; - if (caml_try_leave_blocking_section_hook ()) { - caml_execute_signal(sig, 1); - caml_enter_blocking_section_hook(); - } else { - caml_record_signal(sig); - /* Some ports cache [caml_young_limit] in a register. - Use the signal context to modify that register too, but only if - we are inside Caml code (not inside C code). */ -#if defined(CONTEXT_PC) && defined(CONTEXT_YOUNG_LIMIT) - if (In_code_area(CONTEXT_PC)) - CONTEXT_YOUNG_LIMIT = (context_reg) caml_young_limit; -#endif - } -} - -#ifndef SIGABRT -#define SIGABRT -1 -#endif -#ifndef SIGALRM -#define SIGALRM -1 -#endif -#ifndef SIGFPE -#define SIGFPE -1 -#endif -#ifndef SIGHUP -#define SIGHUP -1 -#endif -#ifndef SIGILL -#define SIGILL -1 -#endif -#ifndef SIGINT -#define SIGINT -1 -#endif -#ifndef SIGKILL -#define SIGKILL -1 -#endif -#ifndef SIGPIPE -#define SIGPIPE -1 -#endif -#ifndef SIGQUIT -#define SIGQUIT -1 -#endif -#ifndef SIGSEGV -#define SIGSEGV -1 -#endif -#ifndef SIGTERM -#define SIGTERM -1 -#endif -#ifndef SIGUSR1 -#define SIGUSR1 -1 -#endif -#ifndef SIGUSR2 -#define SIGUSR2 -1 -#endif -#ifndef SIGCHLD -#define SIGCHLD -1 -#endif -#ifndef SIGCONT -#define SIGCONT -1 -#endif -#ifndef SIGSTOP -#define SIGSTOP -1 -#endif -#ifndef SIGTSTP -#define SIGTSTP -1 -#endif -#ifndef SIGTTIN -#define SIGTTIN -1 -#endif -#ifndef SIGTTOU -#define SIGTTOU -1 -#endif -#ifndef SIGVTALRM -#define SIGVTALRM -1 -#endif -#ifndef SIGPROF -#define SIGPROF -1 -#endif - -static int posix_signals[] = { - SIGABRT, SIGALRM, SIGFPE, SIGHUP, SIGILL, SIGINT, SIGKILL, SIGPIPE, - SIGQUIT, SIGSEGV, SIGTERM, SIGUSR1, SIGUSR2, SIGCHLD, SIGCONT, - SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU, SIGVTALRM, SIGPROF -}; - -int caml_convert_signal_number(int signo) -{ - if (signo < 0 && signo >= -(sizeof(posix_signals) / sizeof(int))) - return posix_signals[-signo-1]; - else - return signo; -} - -int caml_rev_convert_signal_number(int signo) -{ - int i; - for (i = 0; i < sizeof(posix_signals) / sizeof(int); i++) - if (signo == posix_signals[i]) return -i - 1; - return signo; -} - -typedef void (*signal_handler)(int signo); - -value caml_install_signal_handler(value signal_number, value action) /* ML */ -{ - CAMLparam2 (signal_number, action); - int sig; - signal_handler oldact; -#ifdef POSIX_SIGNALS - struct sigaction sigact, oldsigact; -#else - signal_handler act; -#endif - CAMLlocal1 (res); - - sig = caml_convert_signal_number(Int_val(signal_number)); - if (sig < 0 || sig >= NSIG) - caml_invalid_argument("Sys.signal: unavailable signal"); -#ifdef POSIX_SIGNALS - switch(action) { - case Val_int(0): /* Signal_default */ - sigact.sa_handler = SIG_DFL; - sigact.sa_flags = 0; - break; - case Val_int(1): /* Signal_ignore */ - sigact.sa_handler = SIG_IGN; - sigact.sa_flags = 0; - break; - default: /* Signal_handle */ - SET_SIGACT(sigact, handle_signal); - break; - } - sigemptyset(&sigact.sa_mask); - if (sigaction(sig, &sigact, &oldsigact) == -1) caml_sys_error(NO_ARG); - oldact = oldsigact.sa_handler; -#else - switch(action) { - case Val_int(0): /* Signal_default */ - act = SIG_DFL; - break; - case Val_int(1): /* Signal_ignore */ - act = SIG_IGN; - break; - default: /* Signal_handle */ - act = handle_signal; - break; - } - oldact = signal(sig, act); - if (oldact == SIG_ERR) caml_sys_error(NO_ARG); -#endif - if (oldact == (signal_handler) handle_signal) { - res = caml_alloc_small(1, 0); /* Signal_handle */ - Field(res, 0) = Field(caml_signal_handlers, sig); - } - else if (oldact == SIG_IGN) - res = Val_int(1); /* Signal_ignore */ - else - res = Val_int(0); /* Signal_default */ - if (Is_block(action)) { - if (caml_signal_handlers == 0) { - caml_signal_handlers = caml_alloc(NSIG, 0); - caml_register_global_root(&caml_signal_handlers); - } - caml_modify(&Field(caml_signal_handlers, sig), Field(action, 0)); - } - caml_process_pending_signals(); - CAMLreturn (res); -} - -/* Machine- and OS-dependent handling of bound check trap */ - -#if defined(TARGET_power) || (defined(TARGET_sparc) && defined(SYS_solaris)) -DECLARE_SIGNAL_HANDLER(trap_handler) -{ -#if defined(SYS_solaris) - if (info->si_code != ILL_ILLTRP) { - /* Deactivate our exception handler and return. */ - struct sigaction act; - act.sa_handler = SIG_DFL; - act.sa_flags = 0; - sigemptyset(&act.sa_mask); - sigaction(sig, &act, NULL); - return; - } -#endif -#if defined(SYS_rhapsody) - /* Unblock SIGTRAP */ - { sigset_t mask; - sigemptyset(&mask); - sigaddset(&mask, SIGTRAP); - sigprocmask(SIG_UNBLOCK, &mask, NULL); - } -#endif - caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER; - caml_young_ptr = (char *) CONTEXT_YOUNG_PTR; - caml_array_bound_error(); -} -#endif - -/* Machine- and OS-dependent handling of stack overflow */ - -#ifdef HAS_STACK_OVERFLOW_DETECTION - -static char * system_stack_top; -static char sig_alt_stack[SIGSTKSZ]; - -DECLARE_SIGNAL_HANDLER(segv_handler) -{ - struct rlimit limit; - struct sigaction act; - char * fault_addr; - - /* Sanity checks: - - faulting address is word-aligned - - faulting address is within the stack - - we are in Caml code */ - fault_addr = CONTEXT_FAULTING_ADDRESS; - if (((uintnat) fault_addr & (sizeof(intnat) - 1)) == 0 - && getrlimit(RLIMIT_STACK, &limit) == 0 - && fault_addr < system_stack_top - && fault_addr >= system_stack_top - limit.rlim_cur - 0x2000 -#ifdef CONTEXT_PC - && In_code_area(CONTEXT_PC) -#endif - ) { - /* Turn this into a Stack_overflow exception */ -#if defined(CONTEXT_YOUNG_PTR) && defined(CONTEXT_EXCEPTION_POINTER) - caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER; - caml_young_ptr = (char *) CONTEXT_YOUNG_PTR; -#endif - caml_raise_stack_overflow(); - } - /* Otherwise, deactivate our exception handler and return, - causing fatal signal to be generated at point of error. */ - act.sa_handler = SIG_DFL; - act.sa_flags = 0; - sigemptyset(&act.sa_mask); - sigaction(SIGSEGV, &act, NULL); -} - -#endif - -/* Initialization of signal stuff */ - -void caml_init_signals(void) -{ - /* Bound-check trap handling */ -#if defined(TARGET_sparc) && defined(SYS_solaris) - { struct sigaction act; - sigemptyset(&act.sa_mask); - SET_SIGACT(act, trap_handler); - act.sa_flags |= SA_NODEFER; - sigaction(SIGILL, &act, NULL); - } -#endif - -#if defined(TARGET_power) - { struct sigaction act; - sigemptyset(&act.sa_mask); - SET_SIGACT(act, trap_handler); -#if !defined(SYS_rhapsody) - act.sa_flags |= SA_NODEFER; -#endif - sigaction(SIGTRAP, &act, NULL); - } -#endif - - /* Stack overflow handling */ -#ifdef HAS_STACK_OVERFLOW_DETECTION - { - struct sigaltstack stk; - struct sigaction act; - stk.ss_sp = sig_alt_stack; - stk.ss_size = SIGSTKSZ; - stk.ss_flags = 0; - SET_SIGACT(act, segv_handler); - act.sa_flags |= SA_ONSTACK | SA_NODEFER; - sigemptyset(&act.sa_mask); - system_stack_top = (char *) &act; - if (sigaltstack(&stk, NULL) == 0) { sigaction(SIGSEGV, &act, NULL); } - } -#endif -} diff --git a/asmrun/signals_asm.c b/asmrun/signals_asm.c new file mode 100644 index 00000000..7019e0be --- /dev/null +++ b/asmrun/signals_asm.c @@ -0,0 +1,256 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ +/* */ +/* Copyright 2007 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id: signals_asm.c,v 1.2 2007/03/01 10:27:26 xleroy Exp $ */ + +/* Signal handling, code specific to the native-code compiler */ + +#if defined(TARGET_amd64) && defined (SYS_linux) +#define _GNU_SOURCE +#endif +#include +#include +#include "fail.h" +#include "memory.h" +#include "osdeps.h" +#include "signals.h" +#include "signals_machdep.h" +#include "signals_osdep.h" +#include "stack.h" + +#ifdef HAS_STACK_OVERFLOW_DETECTION +#include +#include +#endif + +#ifndef NSIG +#define NSIG 64 +#endif + +typedef void (*signal_handler)(int signo); + +#ifdef _WIN32 +extern signal_handler caml_win32_signal(int sig, signal_handler action); +#define signal(sig,act) caml_win32_signal(sig,act) +extern void caml_win32_overflow_detection(); +#endif + +extern char * caml_code_area_start, * caml_code_area_end; + +#define In_code_area(pc) \ + ((char *)(pc) >= caml_code_area_start && \ + (char *)(pc) <= caml_code_area_end) + +/* This routine is the common entry point for garbage collection + and signal handling. It can trigger a callback to Caml code. + With system threads, this callback can cause a context switch. + Hence [caml_garbage_collection] must not be called from regular C code + (e.g. the [caml_alloc] function) because the context of the call + (e.g. [intern_val]) may not allow context switching. + Only generated assembly code can call [caml_garbage_collection], + via the caml_call_gc assembly stubs. */ + +void caml_garbage_collection(void) +{ + caml_young_limit = caml_young_start; + if (caml_young_ptr < caml_young_start || caml_force_major_slice) { + caml_minor_collection(); + } + caml_process_pending_signals(); +} + +DECLARE_SIGNAL_HANDLER(handle_signal) +{ +#if !defined(POSIX_SIGNALS) && !defined(BSD_SIGNALS) + signal(sig, handle_signal); +#endif + if (sig < 0 || sig >= NSIG) return; + if (caml_try_leave_blocking_section_hook ()) { + caml_execute_signal(sig, 1); + caml_enter_blocking_section_hook(); + } else { + caml_record_signal(sig); + /* Some ports cache [caml_young_limit] in a register. + Use the signal context to modify that register too, but only if + we are inside Caml code (not inside C code). */ +#if defined(CONTEXT_PC) && defined(CONTEXT_YOUNG_LIMIT) + if (In_code_area(CONTEXT_PC)) + CONTEXT_YOUNG_LIMIT = (context_reg) caml_young_limit; +#endif + } +} + +int caml_set_signal_action(int signo, int action) +{ + signal_handler oldact; +#ifdef POSIX_SIGNALS + struct sigaction sigact, oldsigact; +#else + signal_handler act; +#endif + +#ifdef POSIX_SIGNALS + switch(action) { + case 0: + sigact.sa_handler = SIG_DFL; + sigact.sa_flags = 0; + break; + case 1: + sigact.sa_handler = SIG_IGN; + sigact.sa_flags = 0; + break; + default: + SET_SIGACT(sigact, handle_signal); + break; + } + sigemptyset(&sigact.sa_mask); + if (sigaction(signo, &sigact, &oldsigact) == -1) return -1; + oldact = oldsigact.sa_handler; +#else + switch(action) { + case 0: act = SIG_DFL; break; + case 1: act = SIG_IGN; break; + default: act = handle_signal; break; + } + oldact = signal(signo, act); + if (oldact == SIG_ERR) return -1; +#endif + if (oldact == (signal_handler) handle_signal) + return 2; + else if (oldact == SIG_IGN) + return 1; + else + return 0; +} + +/* Machine- and OS-dependent handling of bound check trap */ + +#if defined(TARGET_power) || (defined(TARGET_sparc) && defined(SYS_solaris)) +DECLARE_SIGNAL_HANDLER(trap_handler) +{ +#if defined(SYS_solaris) + if (info->si_code != ILL_ILLTRP) { + /* Deactivate our exception handler and return. */ + struct sigaction act; + act.sa_handler = SIG_DFL; + act.sa_flags = 0; + sigemptyset(&act.sa_mask); + sigaction(sig, &act, NULL); + return; + } +#endif +#if defined(SYS_rhapsody) + /* Unblock SIGTRAP */ + { sigset_t mask; + sigemptyset(&mask); + sigaddset(&mask, SIGTRAP); + sigprocmask(SIG_UNBLOCK, &mask, NULL); + } +#endif + caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER; + caml_young_ptr = (char *) CONTEXT_YOUNG_PTR; +#if defined(SYS_rhapsody) + caml_bottom_of_stack = (char *) CONTEXT_SP; + caml_last_return_address = (uintnat) CONTEXT_PC; +#endif + caml_array_bound_error(); +} +#endif + +/* Machine- and OS-dependent handling of stack overflow */ + +#ifdef HAS_STACK_OVERFLOW_DETECTION + +static char * system_stack_top; +static char sig_alt_stack[SIGSTKSZ]; + +DECLARE_SIGNAL_HANDLER(segv_handler) +{ + struct rlimit limit; + struct sigaction act; + char * fault_addr; + + /* Sanity checks: + - faulting address is word-aligned + - faulting address is within the stack + - we are in Caml code */ + fault_addr = CONTEXT_FAULTING_ADDRESS; + if (((uintnat) fault_addr & (sizeof(intnat) - 1)) == 0 + && getrlimit(RLIMIT_STACK, &limit) == 0 + && fault_addr < system_stack_top + && fault_addr >= system_stack_top - limit.rlim_cur - 0x2000 +#ifdef CONTEXT_PC + && In_code_area(CONTEXT_PC) +#endif + ) { + /* Turn this into a Stack_overflow exception */ +#if defined(CONTEXT_YOUNG_PTR) && defined(CONTEXT_EXCEPTION_POINTER) + caml_exception_pointer = (char *) CONTEXT_EXCEPTION_POINTER; + caml_young_ptr = (char *) CONTEXT_YOUNG_PTR; +#endif + caml_raise_stack_overflow(); + } + /* Otherwise, deactivate our exception handler and return, + causing fatal signal to be generated at point of error. */ + act.sa_handler = SIG_DFL; + act.sa_flags = 0; + sigemptyset(&act.sa_mask); + sigaction(SIGSEGV, &act, NULL); +} + +#endif + +/* Initialization of signal stuff */ + +void caml_init_signals(void) +{ + /* Bound-check trap handling */ +#if defined(TARGET_sparc) && defined(SYS_solaris) + { struct sigaction act; + sigemptyset(&act.sa_mask); + SET_SIGACT(act, trap_handler); + act.sa_flags |= SA_NODEFER; + sigaction(SIGILL, &act, NULL); + } +#endif + +#if defined(TARGET_power) + { struct sigaction act; + sigemptyset(&act.sa_mask); + SET_SIGACT(act, trap_handler); +#if !defined(SYS_rhapsody) + act.sa_flags |= SA_NODEFER; +#endif + sigaction(SIGTRAP, &act, NULL); + } +#endif + + /* Stack overflow handling */ +#ifdef HAS_STACK_OVERFLOW_DETECTION + { + struct sigaltstack stk; + struct sigaction act; + stk.ss_sp = sig_alt_stack; + stk.ss_size = SIGSTKSZ; + stk.ss_flags = 0; + SET_SIGACT(act, segv_handler); + act.sa_flags |= SA_ONSTACK | SA_NODEFER; + sigemptyset(&act.sa_mask); + system_stack_top = (char *) &act; + if (sigaltstack(&stk, NULL) == 0) { sigaction(SIGSEGV, &act, NULL); } + } +#endif +#if defined(_WIN32) && !defined(_WIN64) + caml_win32_overflow_detection(); +#endif +} diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h index 0f22009e..1002bf12 100644 --- a/asmrun/signals_osdep.h +++ b/asmrun/signals_osdep.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: signals_osdep.h,v 1.3.2.1 2005/12/30 08:40:56 xleroy Exp $ */ +/* $Id: signals_osdep.h,v 1.8 2007/01/29 12:10:52 xleroy Exp $ */ /* Processor- and OS-dependent signal interface */ @@ -70,11 +70,28 @@ static void name(int sig, siginfo_t * info, void * context) #define SET_SIGACT(sigact,name) \ - sigact.sa_sigaction = (name); + sigact.sa_sigaction = (name); \ sigact.sa_flags = SA_SIGINFO #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) +/****************** I386, MacOS X */ + +#elif defined(TARGET_i386) && defined(SYS_macosx) + + #define DECLARE_SIGNAL_HANDLER(name) \ + static void name(int sig, siginfo_t * info, void * context) + + #define SET_SIGACT(sigact,name) \ + sigact.sa_sigaction = (name); \ + sigact.sa_flags = SA_SIGINFO + + #include + + #define CONTEXT_STATE (((struct ucontext *)context)->uc_mcontext->ss) + #define CONTEXT_PC (CONTEXT_STATE.eip) + #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) + /****************** MIPS, all OS */ #elif defined(TARGET_mips) @@ -96,20 +113,47 @@ #elif defined(TARGET_power) && defined(SYS_rhapsody) +#ifdef __ppc64__ + + #define DECLARE_SIGNAL_HANDLER(name) \ + static void name(int sig, siginfo_t * info, void * context) + + #define SET_SIGACT(sigact,name) \ + sigact.sa_sigaction = (name); \ + sigact.sa_flags = SA_SIGINFO | SA_64REGSET + + typedef unsigned long long context_reg; + + #include + + #define CONTEXT_STATE (((struct ucontext64 *)context)->uc_mcontext64->ss) + + #define CONTEXT_PC (CONTEXT_STATE.srr0) + #define CONTEXT_EXCEPTION_POINTER (CONTEXT_STATE.r29) + #define CONTEXT_YOUNG_LIMIT (CONTEXT_STATE.r30) + #define CONTEXT_YOUNG_PTR (CONTEXT_STATE.r31) + #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) + #define CONTEXT_SP (CONTEXT_STATE.r1) + +#else + #include #define DECLARE_SIGNAL_HANDLER(name) \ - static void name(int sig, int code, void * context) + static void name(int sig, siginfo_t * info, void * context) #define SET_SIGACT(sigact,name) \ sigact.sa_handler = (void (*)(int)) (name); \ sigact.sa_flags = SA_SIGINFO typedef unsigned long context_reg; + #define CONTEXT_PC (*context_gpr_p(context, -2)) #define CONTEXT_EXCEPTION_POINTER (*context_gpr_p(context, 29)) #define CONTEXT_YOUNG_LIMIT (*context_gpr_p(context, 30)) #define CONTEXT_YOUNG_PTR (*context_gpr_p(context, 31)) + #define CONTEXT_FAULTING_ADDRESS ((char *) info->si_addr) + #define CONTEXT_SP (*context_gpr_p(context, 1)) static int ctx_version = 0; static void init_ctx (void) @@ -168,6 +212,8 @@ } #endif +#endif + /****************** PowerPC, ELF (Linux) */ #elif defined(TARGET_power) && defined(SYS_elf) diff --git a/asmrun/stack.h b/asmrun/stack.h index ba7eb327..fca1faf2 100644 --- a/asmrun/stack.h +++ b/asmrun/stack.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: stack.h,v 1.29.2.1 2006/03/01 13:46:56 xleroy Exp $ */ +/* $Id: stack.h,v 1.34 2007/02/15 18:35:20 frisch Exp $ */ /* Machine-dependent interface with the asm code */ @@ -53,9 +53,9 @@ #endif #ifdef TARGET_power -#define Saved_return_address(sp) *((intnat *)((sp) - 4)) +#define Saved_return_address(sp) *((intnat *)((sp) - SIZEOF_PTR)) #define Already_scanned(sp, retaddr) ((retaddr) & 1) -#define Mark_scanned(sp, retaddr) (*((intnat *)((sp) - 4)) = (retaddr) | 1) +#define Mark_scanned(sp, retaddr) (*((intnat *)((sp) - SIZEOF_PTR)) = (retaddr) | 1) #define Mask_already_scanned(retaddr) ((retaddr) & ~1) #ifdef SYS_aix #define Trap_frame_size 32 @@ -96,6 +96,25 @@ struct caml_context { value * gc_regs; /* pointer to register block */ }; +/* Structure of frame descriptors */ + +typedef struct { + uintnat retaddr; + unsigned short frame_size; + unsigned short num_live; + unsigned short live_ofs[1]; +} frame_descr; + +/* Hash table of frame descriptors */ + +extern frame_descr ** caml_frame_descriptors; +extern int caml_frame_descriptors_mask; + +#define Hash_retaddr(addr) \ + (((uintnat)(addr) >> 3) & caml_frame_descriptors_mask) + +extern void caml_init_frame_descriptors(void); + /* Declaration of variables used in the asm code */ extern char * caml_bottom_of_stack; extern uintnat caml_last_return_address; diff --git a/asmrun/startup.c b/asmrun/startup.c index 5296c5be..9155b5bb 100644 --- a/asmrun/startup.c +++ b/asmrun/startup.c @@ -11,13 +11,14 @@ /* */ /***********************************************************************/ -/* $Id: startup.c,v 1.32 2005/09/22 14:21:47 xleroy Exp $ */ +/* $Id: startup.c,v 1.33 2007/01/29 12:10:52 xleroy Exp $ */ /* Start-up code */ #include #include #include "callback.h" +#include "backtrace.h" #include "custom.h" #include "fail.h" #include "gc.h" @@ -110,6 +111,7 @@ static void parse_camlrunparam(void) case 'o': scanmult (opt, &percent_free_init); break; case 'O': scanmult (opt, &max_percent_free_init); break; case 'v': scanmult (opt, &caml_verb_gc); break; + case 'b': caml_init_backtrace(); break; case 'p': caml_parser_trace = 1; break; } } diff --git a/boot/.cvsignore b/boot/.cvsignore index bc591db4..b9c6f858 100644 --- a/boot/.cvsignore +++ b/boot/.cvsignore @@ -2,3 +2,4 @@ Saved ocamlrun ocamlyacc camlheader +myocamlbuild diff --git a/boot/myocamlbuild.boot b/boot/myocamlbuild.boot new file mode 100755 index 00000000..a0aae97d Binary files /dev/null and b/boot/myocamlbuild.boot differ diff --git a/boot/ocamlc b/boot/ocamlc index 573e9fe5..74dd4482 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamldep b/boot/ocamldep new file mode 100755 index 00000000..ef85504a Binary files /dev/null and b/boot/ocamldep differ diff --git a/boot/ocamllex b/boot/ocamllex index eda81a58..57dfd4a2 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/build/boot-c-parts-windows.sh b/build/boot-c-parts-windows.sh new file mode 100755 index 00000000..c8c06d42 --- /dev/null +++ b/build/boot-c-parts-windows.sh @@ -0,0 +1,24 @@ +#!/bin/sh +cd `dirname $0`/.. +set -ex + +. config/config.sh + +(cd byterun && make -f Makefile.nt) +(cd asmrun && make -f Makefile.nt all meta.$O dynlink.$O) +(cd yacc && make -f Makefile.nt) +(cd win32caml && make) + +mkdir -p _build/boot +cp -f byterun/ocamlrun.exe \ + byterun/libcamlrun.$A \ + byterun/ocamlrun.dll \ + asmrun/libasmrun.$A \ + yacc/ocamlyacc.exe \ + boot/ocamlc \ + boot/ocamllex \ + boot/ocamldep \ + _build/boot +mkdir -p _build/byterun +cp -f byterun/ocamlrun.exe byterun/ocamlrun.dll boot +cp -f byterun/ocamlrun.$A _build/byterun diff --git a/build/boot-c-parts.sh b/build/boot-c-parts.sh new file mode 100755 index 00000000..921f595a --- /dev/null +++ b/build/boot-c-parts.sh @@ -0,0 +1,21 @@ +#!/bin/sh +cd `dirname $0`/.. +set -ex + +# Create a bunch of symlinks to _build/boot +mkdir -p _build/boot +ln -sf ../../byterun/ocamlrun \ + ../../byterun/libcamlrun.a \ + ../../asmrun/libasmrun.a \ + ../../asmrun/libasmrunp.a \ + ../../yacc/ocamlyacc \ + ../../boot/ocamlc \ + ../../boot/ocamllex \ + ../../boot/ocamldep \ + _build/boot + +[ -f boot/ocamlrun ] || ln -sf ../byterun/ocamlrun boot + +(cd byterun && make) +(cd asmrun && make all meta.o dynlink.o) +(cd yacc && make) diff --git a/build/boot.sh b/build/boot.sh new file mode 100755 index 00000000..97509646 --- /dev/null +++ b/build/boot.sh @@ -0,0 +1,12 @@ +#!/bin/sh +cd `dirname $0`/.. +set -ex +./boot/ocamlrun boot/myocamlbuild.boot boot/stdlib.cma boot/std_exit.cmo +boot/ocamlrun boot/myocamlbuild.boot -log _boot_log1 \ + ocamlbuild/ocamlbuildlightlib.cma ocamlbuild/ocamlbuildlight.byte +rm -f _build/myocamlbuild +boot/ocamlrun boot/myocamlbuild.boot \ + -just-plugin -install-lib-dir _build/ocamlbuild -byte-plugin +cp _build/myocamlbuild boot/myocamlbuild +./boot/ocamlrun boot/myocamlbuild $@ -log _boot_log2 \ + boot/camlheader ocamlc diff --git a/build/buildbot b/build/buildbot new file mode 100755 index 00000000..af9b99d7 --- /dev/null +++ b/build/buildbot @@ -0,0 +1,107 @@ +#!/bin/sh + +usage() { + echo "Usage: $0 (make|ocb|ocamlbuild) (win (mingw|msvc|msvc64) | *)" + exit 1 +} + +logfile="buildbot.log" + +finish() { + curl -s -0 -F "log=@$logfile" \ + -F "host=`hostname`" \ + -F "mode=$mode-$opt_win-$opt_win2" \ + http://weblog.feydakins.org/dropbox || : +} + +rm -f buildbot.failed +rm -f $logfile + +bad() { + touch buildbot.failed +} + +finish_if_bad() { + if [ -f buildbot.failed ]; then + finish + exit 2 + fi +} + +if figlet "test" > /dev/null 2> /dev/null; then + draw="figlet" +else + draw="echo ----------- " +fi + +if echo | tee -a tee.log > /dev/null 2> /dev/null; then + tee="tee -a $logfile" +else + tee=: +fi + +rm -f tee.log + +log() { + $draw $@ + $tee +} + +mode=$1 +shift 1 + +case "$mode" in + make|ocb|ocamlbuild) : ;; + *) usage;; +esac + +case "$1" in + win) + opt_win=win + opt_win2=$2 + shift 2 + Makefile=Makefile.nt;; + *) Makefile=Makefile;; +esac + +( [ -f config/Makefile ] && make -f $Makefile clean || : ) 2>&1 | log clean + +( ./build/distclean.sh || : ) 2>&1 | log distclean + +(cvs -q up -dP -r release310 || bad) 2>&1 | log cvs up +finish_if_bad + +case "$opt_win" in +win) + + # FIXME + sed -e 's/\(OTHERLIBRARIES=.*\) labltk/\1/' \ + < "config/Makefile.$opt_win2" > config/Makefile || bad + finish_if_bad + + cp config/m-nt.h config/m.h || bad + finish_if_bad + cp config/s-nt.h config/s.h || bad + finish_if_bad + ;; + +*) + (./configure --prefix `pwd`/_install $@ || bad) 2>&1 | log configure + finish_if_bad + ;; +esac + +case "$mode" in + make) + (make -f $Makefile world opt opt.opt install || bad) 2>&1 | log build install + finish_if_bad + ;; + ocb|ocamlbuild) + (./build/fastworld.sh || bad) 2>&1 | log build + finish_if_bad + (./build/install.sh || bad) 2>&1 | log install + finish_if_bad + ;; +esac + +finish diff --git a/build/camlp4-bootstrap.sh b/build/camlp4-bootstrap.sh new file mode 100755 index 00000000..e1458475 --- /dev/null +++ b/build/camlp4-bootstrap.sh @@ -0,0 +1,28 @@ +#!/bin/sh +set -e +cd `dirname $0`/.. + +TMPTARGETS="\ + camlp4/boot/Lexer.ml" + +TARGETS="\ + camlp4/Camlp4/Struct/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 + +if [ -x ./boot/myocamlbuild.native ]; then + OCAMLBUILD=./boot/myocamlbuild.native +else + OCAMLBUILD="./boot/ocamlrun boot/myocamlbuild" +fi +$OCAMLBUILD $TMPTARGETS $TARGETS + +for t in $TARGETS; do + echo promote $t + cp _build/$t camlp4/boot/`basename $t` +done diff --git a/build/camlp4-byte-only.sh b/build/camlp4-byte-only.sh new file mode 100755 index 00000000..ce307318 --- /dev/null +++ b/build/camlp4-byte-only.sh @@ -0,0 +1,8 @@ +#!/bin/sh +set -e +OCAMLBUILD_PARTIAL="true" +export OCAMLBUILD_PARTIAL +cd `dirname $0`/.. +. build/targets.sh +set -x +$OCAMLBUILD $@ byte_stdlib_partial_mode $OCAMLC_BYTE $OCAMLLEX_BYTE $CAMLP4_BYTE diff --git a/build/camlp4-native-only.sh b/build/camlp4-native-only.sh new file mode 100755 index 00000000..b0865b3b --- /dev/null +++ b/build/camlp4-native-only.sh @@ -0,0 +1,8 @@ +#!/bin/sh +set -e +OCAMLBUILD_PARTIAL="true" +export OCAMLBUILD_PARTIAL +cd `dirname $0`/.. +. build/targets.sh +set -x +$OCAMLBUILD $@ native_stdlib_partial_mode $OCAMLOPT_BYTE $OCAMLLEX_BYTE $CAMLP4_NATIVE diff --git a/build/camlp4-targets.sh b/build/camlp4-targets.sh new file mode 100644 index 00000000..32b55db6 --- /dev/null +++ b/build/camlp4-targets.sh @@ -0,0 +1,31 @@ +#!/bin/sh +CAMLP4_COMMON="\ + camlp4/Camlp4/Camlp4Ast.partial.ml \ + camlp4/boot/camlp4boot.byte" +CAMLP4_BYTE="$CAMLP4_COMMON \ + camlp4/Camlp4.cmo \ + camlp4/Camlp4Top.cmo \ + camlp4/camlp4prof.byte$EXE \ + camlp4/mkcamlp4.byte$EXE \ + camlp4/camlp4.byte$EXE" +CAMLP4_NATIVE="$CAMLP4_COMMON \ + camlp4/Camlp4.cmx \ + camlp4/Camlp4Top.cmx \ + camlp4/camlp4prof.native$EXE \ + camlp4/mkcamlp4.native$EXE \ + camlp4/camlp4.native$EXE" + +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" +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/distclean.sh b/build/distclean.sh new file mode 100755 index 00000000..302005c1 --- /dev/null +++ b/build/distclean.sh @@ -0,0 +1,28 @@ +#!/bin/sh +cd `dirname $0`/.. +set -ex +(cd byterun && make clean) || : +(cd asmrun && make clean) || : +(cd yacc && make clean) || : +rm -rf _build +rm -f boot/ocamlrun boot/ocamlrun.exe boot/camlheader \ + boot/myocamlbuild boot/myocamlbuild.native boot/myocamlbuild.native.exe \ + myocamlbuild_config.ml config/config.sh config/Makefile \ + config/s.h config/m.h boot/*.cm* _log _*_log* + +# from partial boot +rm -f driver/main.byte driver/optmain.byte lex/main.byte \ + tools/ocamlmklib.byte camlp4/build/location.ml \ + camlp4/build/location.mli \ + tools/myocamlbuild_config.ml camlp4/build/linenum.mli \ + camlp4/build/linenum.mll \ + camlp4/build/terminfo.mli camlp4/build/terminfo.ml + +# from ocamlbuild bootstrap +rm -f ocamlbuild/_log ocamlbuild/,ocamlbuild.byte.start \ + ocamlbuild/boot/ocamlbuild ocamlbuild/myocamlbuild_config.ml \ + ocamlbuild/myocamlbuild_config.mli +rm -rf ocamlbuild/_build ocamlbuild/_start + +# from the old build system +rm -f camlp4/build/camlp4_config.ml camlp4/**/*.cm* diff --git a/build/fastworld.sh b/build/fastworld.sh new file mode 100755 index 00000000..1aae8f6f --- /dev/null +++ b/build/fastworld.sh @@ -0,0 +1,31 @@ +#!/bin/sh +cd `dirname $0` +set -e +./mkconfig.sh +./mkmyocamlbuild_config.sh +. ../config/config.sh +if [ "x$EXE" = "x.exe" ]; then + ./boot-c-parts-windows.sh +else + ./boot-c-parts.sh +fi +./boot.sh $@ + +cd .. +. build/targets.sh +OCAMLMKLIB_BYTE="tools/ocamlmklib.byte" +set -x +$OCAMLBUILD $@ -log _boot_fast_log \ + $STDLIB_BYTE $OCAMLOPT_BYTE $STDLIB_NATIVE \ + $OCAMLOPT_NATIVE $OCAMLMKLIB_BYTE $OTHERLIBS_UNIX_NATIVE $OCAMLBUILD_NATIVE + +rm -f _build/myocamlbuild +boot/ocamlrun boot/myocamlbuild \ + -just-plugin -install-lib-dir _build/ocamlbuild \ + -ocamlopt "../_build/ocamlopt.opt -nostdlib -I boot -I stdlib -I $UNIXDIR" +cp _build/myocamlbuild boot/myocamlbuild.native + +./boot/myocamlbuild.native $@ \ + $OCAMLC_NATIVE $TOPLEVEL $OTHERLIBS_BYTE $OTHERLIBS_NATIVE $OCAMLLEX_BYTE \ + $OCAMLLEX_NATIVE $TOOLS_BYTE $TOOLS_NATIVE $DEBUGGER \ + $OCAMLDOC_BYTE $OCAMLDOC_NATIVE $OCAMLBUILD_BYTE $CAMLP4_BYTE $CAMLP4_NATIVE diff --git a/build/install.sh b/build/install.sh new file mode 100755 index 00000000..286e462e --- /dev/null +++ b/build/install.sh @@ -0,0 +1,600 @@ +#!/bin/sh +set -e + +cd `dirname $0`/.. + +. config/config.sh + +not_installed=$PWD/_build/not_installed + +rm -f "$not_installed" + +wontinstall() { + echo "$1" >> "$not_installed" +} + +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" + ranlib "$dest" + 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 +mkdir -p $LIBDIR/caml +mkdir -p $LIBDIR/camlp4 +mkdir -p $LIBDIR/vmthreads +mkdir -p $LIBDIR/threads +mkdir -p $LIBDIR/labltk +mkdir -p $LIBDIR/ocamlbuild +mkdir -p $LIBDIR/ocamldoc +mkdir -p $STUBLIBDIR +mkdir -p $MANDIR/man1 +mkdir -p $MANDIR/man3 +mkdir -p $MANDIR/man$MANEXT + +echo "Installing core libraries..." +installlibdir byterun/libcamlrun.$A byterun/libcamlrunp.$A \ + asmrun/libasmrun.$A asmrun/libasmrunp.$A \ + asmrun/libasmrunp.$A asmrun/libasmrunpp.$A \ + $LIBDIR + +PUBLIC_INCLUDES="\ + alloc.h callback.h config.h custom.h fail.h intext.h \ + memory.h misc.h mlvalues.h printexc.h signals.h compatibility.h" + +cd byterun +for i in $PUBLIC_INCLUDES; do + echo " install caml/$i" + sed -f ../tools/cleanup-header $i > $LIBDIR/caml/$i +done +cd .. + +installdir otherlibs/win32unix/unixsupport.h otherlibs/unix/unixsupport.h \ + $LIBDIR/caml + +installdir byterun/ocamlrun.dll yacc/ocamlyacc byterun/ocamlrun $BINDIR + +installdir byterun/ld.conf $LIBDIR + +installbin win32caml/ocamlwin.exe $PREFIX/OCamlWin.exe + +cd _build + +echo "Installing the toplevel and compilers..." +installbin ocaml$EXE $BINDIR/ocaml$EXE +installbin ocamlc$EXE $BINDIR/ocamlc$EXE +installbin ocamlopt$EXE $BINDIR/ocamlopt$EXE +installbin ocamlc.opt$EXE $BINDIR/ocamlc.opt$EXE +installbin ocamlopt.opt$EXE $BINDIR/ocamlopt.opt$EXE + +set=set # coloration workaround + +echo "Installing the standard library..." +installdir \ + stdlib/stdlib.cma \ + stdlib/stdlib.cmxa stdlib/stdlibp.cmxa \ + stdlib/camlheader \ + stdlib/camlheader_ur \ + stdlib/std_exit.cm[io] \ + stdlib/arg.cmi stdlib/arg.mli \ + stdlib/array.cmi stdlib/array.mli \ + stdlib/arrayLabels.cmi stdlib/arrayLabels.mli \ + stdlib/buffer.cmi stdlib/buffer.mli \ + stdlib/callback.cmi stdlib/callback.mli \ + stdlib/camlinternalMod.cmi stdlib/camlinternalMod.mli \ + stdlib/camlinternalOO.cmi stdlib/camlinternalOO.mli \ + stdlib/char.cmi stdlib/char.mli \ + stdlib/complex.cmi stdlib/complex.mli \ + stdlib/digest.cmi stdlib/digest.mli \ + stdlib/filename.cmi stdlib/filename.mli \ + stdlib/format.cmi stdlib/format.mli \ + stdlib/gc.cmi stdlib/gc.mli \ + stdlib/genlex.cmi stdlib/genlex.mli \ + stdlib/hashtbl.cmi stdlib/hashtbl.mli \ + stdlib/int32.cmi stdlib/int32.mli \ + stdlib/int64.cmi stdlib/int64.mli \ + stdlib/lazy.cmi stdlib/lazy.mli \ + stdlib/lexing.cmi stdlib/lexing.mli \ + stdlib/list.cmi stdlib/list.mli \ + stdlib/listLabels.cmi stdlib/listLabels.mli \ + stdlib/map.cmi stdlib/map.mli \ + stdlib/marshal.cmi stdlib/marshal.mli \ + stdlib/moreLabels.cmi stdlib/moreLabels.mli \ + stdlib/nativeint.cmi stdlib/nativeint.mli \ + stdlib/obj.cmi stdlib/obj.mli \ + stdlib/oo.cmi stdlib/oo.mli \ + stdlib/parsing.cmi stdlib/parsing.mli \ + stdlib/pervasives.cmi stdlib/pervasives.mli \ + stdlib/printexc.cmi stdlib/printexc.mli \ + stdlib/printf.cmi stdlib/printf.mli \ + stdlib/queue.cmi stdlib/queue.mli \ + stdlib/random.cmi stdlib/random.mli \ + stdlib/scanf.cmi stdlib/scanf.mli \ + stdlib/sort.cmi stdlib/sort.mli \ + stdlib/stack.cmi stdlib/stack.mli \ + stdlib/stdLabels.cmi stdlib/stdLabels.mli \ + stdlib/stream.cmi stdlib/stream.mli \ + stdlib/string.cmi stdlib/string.mli \ + stdlib/stringLabels.cmi stdlib/stringLabels.mli \ + stdlib/sys.cmi stdlib/sys.mli \ + stdlib/weak.cmi stdlib/weak.mli \ + stdlib/$set.cmi stdlib/$set.mli \ + stdlib/arg.cmx stdlib/argp.cmx stdlib/arg.$O stdlib/argp.$O \ + stdlib/array.cmx stdlib/arrayp.cmx stdlib/array.$O stdlib/arrayp.$O \ + stdlib/arrayLabels.cmx stdlib/arrayLabelsp.cmx stdlib/arrayLabels.$O stdlib/arrayLabelsp.$O \ + stdlib/buffer.cmx stdlib/bufferp.cmx stdlib/buffer.$O stdlib/bufferp.$O \ + stdlib/callback.cmx stdlib/callbackp.cmx stdlib/callback.$O stdlib/callbackp.$O \ + stdlib/camlinternalMod.cmx stdlib/camlinternalModp.cmx stdlib/camlinternalMod.$O stdlib/camlinternalModp.$O \ + stdlib/camlinternalOO.cmx stdlib/camlinternalOOp.cmx stdlib/camlinternalOO.$O stdlib/camlinternalOOp.$O \ + stdlib/char.cmx stdlib/charp.cmx stdlib/char.$O stdlib/charp.$O \ + stdlib/complex.cmx stdlib/complexp.cmx stdlib/complex.$O stdlib/complexp.$O \ + stdlib/digest.cmx stdlib/digestp.cmx stdlib/digest.$O stdlib/digestp.$O \ + stdlib/filename.cmx stdlib/filenamep.cmx stdlib/filename.$O stdlib/filenamep.$O \ + stdlib/format.cmx stdlib/formatp.cmx stdlib/format.$O stdlib/formatp.$O \ + stdlib/gc.cmx stdlib/gcp.cmx stdlib/gc.$O stdlib/gcp.$O \ + stdlib/genlex.cmx stdlib/genlexp.cmx stdlib/genlex.$O stdlib/genlexp.$O \ + stdlib/hashtbl.cmx stdlib/hashtblp.cmx stdlib/hashtbl.$O stdlib/hashtblp.$O \ + stdlib/int32.cmx stdlib/int32p.cmx stdlib/int32.$O stdlib/int32p.$O \ + stdlib/int64.cmx stdlib/int64p.cmx stdlib/int64.$O stdlib/int64p.$O \ + stdlib/lazy.cmx stdlib/lazyp.cmx stdlib/lazy.$O stdlib/lazyp.$O \ + stdlib/lexing.cmx stdlib/lexingp.cmx stdlib/lexing.$O stdlib/lexingp.$O \ + stdlib/list.cmx stdlib/listp.cmx stdlib/list.$O stdlib/listp.$O \ + stdlib/listLabels.cmx stdlib/listLabelsp.cmx stdlib/listLabels.$O stdlib/listLabelsp.$O \ + stdlib/map.cmx stdlib/mapp.cmx stdlib/map.$O stdlib/mapp.$O \ + stdlib/marshal.cmx stdlib/marshalp.cmx stdlib/marshal.$O stdlib/marshalp.$O \ + stdlib/moreLabels.cmx stdlib/moreLabelsp.cmx stdlib/moreLabels.$O stdlib/moreLabelsp.$O \ + stdlib/nativeint.cmx stdlib/nativeintp.cmx stdlib/nativeint.$O stdlib/nativeintp.$O \ + stdlib/obj.cmx stdlib/objp.cmx stdlib/obj.$O stdlib/objp.$O \ + stdlib/oo.cmx stdlib/oop.cmx stdlib/oo.$O stdlib/oop.$O \ + stdlib/parsing.cmx stdlib/parsingp.cmx stdlib/parsing.$O stdlib/parsingp.$O \ + stdlib/pervasives.cmx stdlib/pervasivesp.cmx stdlib/pervasives.$O stdlib/pervasivesp.$O \ + stdlib/printexc.cmx stdlib/printexcp.cmx stdlib/printexc.$O stdlib/printexcp.$O \ + stdlib/printf.cmx stdlib/printfp.cmx stdlib/printf.$O stdlib/printfp.$O \ + stdlib/queue.cmx stdlib/queuep.cmx stdlib/queue.$O stdlib/queuep.$O \ + stdlib/random.cmx stdlib/randomp.cmx stdlib/random.$O stdlib/randomp.$O \ + stdlib/scanf.cmx stdlib/scanfp.cmx stdlib/scanf.$O stdlib/scanfp.$O \ + stdlib/sort.cmx stdlib/sortp.cmx stdlib/sort.$O stdlib/sortp.$O \ + stdlib/stack.cmx stdlib/stackp.cmx stdlib/stack.$O stdlib/stackp.$O \ + stdlib/stdLabels.cmx stdlib/stdLabelsp.cmx stdlib/stdLabels.$O stdlib/stdLabelsp.$O \ + stdlib/std_exit.cmx stdlib/std_exitp.cmx stdlib/std_exit.$O stdlib/std_exitp.$O \ + stdlib/stream.cmx stdlib/streamp.cmx stdlib/stream.$O stdlib/streamp.$O \ + stdlib/string.cmx stdlib/stringp.cmx stdlib/string.$O stdlib/stringp.$O \ + stdlib/stringLabels.cmx stdlib/stringLabelsp.cmx stdlib/stringLabels.$O stdlib/stringLabelsp.$O \ + stdlib/sys.cmx stdlib/sysp.cmx stdlib/sys.$O stdlib/sysp.$O \ + stdlib/weak.cmx stdlib/weakp.cmx stdlib/weak.$O stdlib/weakp.$O \ + stdlib/$set.cmx stdlib/$setp.cmx stdlib/$set.$O stdlib/$setp.$O \ + $LIBDIR + +installlibdir \ + stdlib/stdlib.$A stdlib/stdlibp.$A \ + $LIBDIR + +echo "Installing ocamllex, ocamldebug..." +installbin lex/ocamllex$EXE $BINDIR/ocamllex$EXE +installbin debugger/ocamldebug$EXE $BINDIR/ocamldebug$EXE +installbin lex/ocamllex.opt$EXE $BINDIR/ocamllex.opt$EXE +installbin tools/ocamldep.native$EXE $BINDIR/ocamldep.opt$EXE + +echo "Installing some tools..." +installbin tools/ocamlcp.byte$EXE $BINDIR/ocamlcp$EXE +installbin tools/ocamldep.byte$EXE $BINDIR/ocamldep$EXE +installbin tools/ocamlmklib.byte$EXE $BINDIR/ocamlmklib$EXE +installbin tools/ocamlmktop.byte$EXE $BINDIR/ocamlmktop$EXE +installbin tools/ocamlprof.byte$EXE $BINDIR/ocamlprof$EXE +installbin toplevel/expunge.byte$EXE $LIBDIR/expunge$EXE +installbin tools/addlabels.byte $LIBDIR/addlabels +installbin tools/scrapelabels.byte $LIBDIR/scrapelabels +installbin otherlibs/dynlink/extract_crc.byte $LIBDIR/extract_crc +installbin otherlibs/labltk/lib/labltk$EXE $BINDIR/labltk$EXE +installbin otherlibs/labltk/compiler/tkcompiler$EXE $BINDIR/tkcompiler$EXE +installbin otherlibs/labltk/browser/ocamlbrowser$EXE $BINDIR/ocamlbrowser$EXE +installbin otherlibs/labltk/compiler/pp$EXE $LIBDIR/labltk/pp$EXE +installbin otherlibs/labltk/lib/labltktop$EXE $LIBDIR/labltk/labltktop$EXE + +echo "Installing libraries..." +installdir \ + otherlibs/bigarray/bigarray.cma \ + otherlibs/dbm/dbm.cma \ + otherlibs/dynlink/dynlink.cma \ + otherlibs/graph/graphics.cma otherlibs/win32/graph/graphics.cma \ + otherlibs/num/nums.cma \ + otherlibs/str/str.cma \ + otherlibs/unix/unix.cma otherlibs/win32unix/unix.cma \ + otherlibs/bigarray/bigarray.cmxa otherlibs/bigarray/bigarray.p.cmxa \ + otherlibs/dbm/dbm.cmxa otherlibs/dbm/dbm.p.cmxa \ + otherlibs/graph/graphics.cmxa otherlibs/graph/graphics.p.cmxa \ + otherlibs/win32/graph/graphics.cmxa otherlibs/win32graph/graphics.p.cmxa \ + otherlibs/num/nums.cmxa otherlibs/num/nums.p.cmxa \ + otherlibs/str/str.cmxa otherlibs/str/str.p.cmxa \ + otherlibs/unix/unix.cmxa otherlibs/unix/unix.p.cmxa \ + otherlibs/win32unix/unix.cmxa otherlibs/win32unix/unix.p.cmxa \ + toplevel/toplevellib.cma \ + otherlibs/systhreads/thread.mli \ + otherlibs/systhreads/mutex.mli \ + otherlibs/systhreads/condition.mli \ + otherlibs/systhreads/event.mli \ + otherlibs/systhreads/threadUnix.mli \ + $LIBDIR + +installdir \ + otherlibs/labltk/support/fileevent.mli \ + otherlibs/labltk/support/fileevent.cmi \ + otherlibs/labltk/support/fileevent.cmx \ + otherlibs/labltk/support/protocol.mli \ + otherlibs/labltk/support/protocol.cmi \ + otherlibs/labltk/support/protocol.cmx \ + otherlibs/labltk/support/textvariable.mli \ + otherlibs/labltk/support/textvariable.cmi \ + otherlibs/labltk/support/textvariable.cmx \ + otherlibs/labltk/support/timer.mli \ + otherlibs/labltk/support/timer.cmi \ + otherlibs/labltk/support/timer.cmx \ + otherlibs/labltk/support/rawwidget.mli \ + otherlibs/labltk/support/rawwidget.cmi \ + otherlibs/labltk/support/rawwidget.cmx \ + otherlibs/labltk/support/widget.mli \ + otherlibs/labltk/support/widget.cmi \ + otherlibs/labltk/support/widget.cmx \ + otherlibs/labltk/support/tkthread.mli \ + otherlibs/labltk/support/tkthread.cmi \ + otherlibs/labltk/support/tkthread.cmo \ + otherlibs/labltk/support/tkthread.$O \ + otherlibs/labltk/labltk/*.mli \ + otherlibs/labltk/labltk/*.cmi \ + otherlibs/labltk/labltk/*.cmx \ + otherlibs/labltk/camltk/*.mli \ + otherlibs/labltk/camltk/*.cmi \ + otherlibs/labltk/camltk/*.cmx \ + otherlibs/labltk/frx/frxlib.cma \ + otherlibs/labltk/frx/frxlib.cmxa \ + otherlibs/labltk/frx/*.mli \ + otherlibs/labltk/frx/*.cmi \ + otherlibs/labltk/frx/*.cmx \ + otherlibs/labltk/jpf/jpflib.cma \ + otherlibs/labltk/jpf/jpflib.cmxa \ + otherlibs/labltk/jpf/*.mli \ + otherlibs/labltk/jpf/*.cmi \ + otherlibs/labltk/jpf/*.cmx \ + otherlibs/labltk/lib/labltk.cma \ + otherlibs/labltk/lib/labltk.cmxa \ + otherlibs/labltk/tkanim/*.mli \ + otherlibs/labltk/tkanim/*.cmi \ + otherlibs/labltk/tkanim/tkanim.cma \ + otherlibs/labltk/tkanim/tkanim.cmxa \ + $LIBDIR/labltk + +installdir \ + otherlibs/systhreads/threads.cma \ + otherlibs/systhreads/threads.cmxa \ + otherlibs/systhreads/threads.p.cmxa \ + otherlibs/systhreads/thread.cmi \ + otherlibs/systhreads/mutex.cmi \ + otherlibs/systhreads/condition.cmi \ + otherlibs/systhreads/event.cmi \ + otherlibs/systhreads/threadUnix.cmi \ + $LIBDIR/threads + +installdir \ + otherlibs/bigarray/dllbigarray$EXT_DLL \ + otherlibs/dbm/dllmldbm$EXT_DLL \ + otherlibs/graph/dllgraphics$EXT_DLL \ + otherlibs/win32graph/dllgraphics$EXT_DLL \ + otherlibs/num/dllnums$EXT_DLL \ + otherlibs/str/dllstr$EXT_DLL \ + otherlibs/systhreads/dllthreads$EXT_DLL \ + otherlibs/unix/dllunix$EXT_DLL \ + otherlibs/win32unix/dllunix$EXT_DLL \ + otherlibs/threads/dllvmthreads$EXT_DLL \ + otherlibs/labltk/support/dlllabltk$EXT_DLL \ + otherlibs/labltk/tkanim/dlltkanim$EXT_DLL \ + $STUBLIBDIR + +installlibdir \ + otherlibs/threads/libvmthreads.$A \ + $LIBDIR/vmthreads + +installdir \ + otherlibs/threads/thread.cmi \ + otherlibs/threads/thread.mli \ + otherlibs/threads/mutex.cmi \ + otherlibs/threads/mutex.mli \ + otherlibs/threads/condition.cmi \ + otherlibs/threads/condition.mli \ + otherlibs/threads/event.cmi \ + otherlibs/threads/event.mli \ + otherlibs/threads/threadUnix.cmi \ + otherlibs/threads/threadUnix.mli \ + otherlibs/threads/threads.cma \ + otherlibs/threads/stdlib.cma \ + otherlibs/threads/unix.cma \ + $LIBDIR/vmthreads + +installlibdir \ + otherlibs/labltk/support/liblabltk.$A \ + otherlibs/labltk/lib/labltk.$A \ + otherlibs/labltk/jpf/jpflib.$A \ + otherlibs/labltk/tkanim/libtkanim.$A \ + otherlibs/labltk/tkanim/tkanim.$A \ + otherlibs/labltk/frx/frxlib.$A \ + $LIBDIR/labltk + +installlibdir \ + otherlibs/bigarray/libbigarray.$A otherlibs/bigarray/libbigarray.p.$A \ + otherlibs/dbm/libmldbm.$A otherlibs/dbm/libmldbm.p.$A \ + otherlibs/graph/libgraphics.$A \ + otherlibs/graph/libgraphics.p.$A \ + otherlibs/win32graph/libgraphics.$A \ + otherlibs/win32graph/libgraphics.p.$A \ + otherlibs/num/libnums.$A \ + otherlibs/num/libnums.p.$A \ + otherlibs/str/libstr.$A \ + otherlibs/str/libstr.p.$A \ + otherlibs/systhreads/libthreads.$A \ + otherlibs/systhreads/libthreads.p.$A \ + otherlibs/systhreads/libthreadsnat.$A \ + otherlibs/systhreads/libthreadsnat.p.$A \ + otherlibs/unix/libunix.$A \ + otherlibs/unix/libunix.p.$A \ + otherlibs/win32unix/libunix.$A \ + otherlibs/win32unix/libunix.p.$A \ + $LIBDIR + +echo "Installing object files and interfaces..." +installdir \ + tools/profiling.cm[oi] \ + toplevel/topstart.cmo \ + toplevel/toploop.cmi \ + toplevel/topdirs.cmi \ + toplevel/topmain.cmi \ + typing/outcometree.cmi \ + otherlibs/graph/graphicsX11.cmi \ + otherlibs/win32graph/graphicsX11.cmi \ + otherlibs/dynlink/dynlink.cmi \ + otherlibs/num/arith_status.cmi \ + otherlibs/num/big_int.cmi \ + otherlibs/num/nat.cmi \ + otherlibs/num/num.cmi \ + otherlibs/num/ratio.cmi \ + otherlibs/bigarray/bigarray.cmi \ + otherlibs/dbm/dbm.cmi \ + otherlibs/graph/graphics.cmi \ + otherlibs/win32graph/graphics.cmi \ + otherlibs/str/str.cmi \ + otherlibs/unix/unix.cmi \ + otherlibs/win32unix/unix.cmi \ + otherlibs/unix/unixLabels.cmi \ + otherlibs/win32unix/unixLabels.cmi \ + otherlibs/num/arith_flags.cmx \ + otherlibs/num/arith_flags.$O \ + otherlibs/num/arith_flags.p.cmx \ + otherlibs/num/arith_flags.p.$O \ + otherlibs/num/int_misc.cmx \ + otherlibs/num/int_misc.p.$O \ + otherlibs/num/int_misc.cmx \ + otherlibs/num/int_misc.p.$O \ + otherlibs/num/arith_status.cmx \ + otherlibs/num/arith_status.p.$O \ + otherlibs/num/arith_status.cmx \ + otherlibs/num/arith_status.p.$O \ + otherlibs/num/big_int.cmx \ + otherlibs/num/big_int.p.$O \ + otherlibs/num/big_int.cmx \ + otherlibs/num/big_int.p.$O \ + otherlibs/num/nat.cmx \ + otherlibs/num/nat.p.$O \ + otherlibs/num/nat.cmx \ + otherlibs/num/nat.p.$O \ + otherlibs/num/num.cmx \ + otherlibs/num/num.p.$O \ + otherlibs/num/num.cmx \ + otherlibs/num/num.p.$O \ + otherlibs/num/ratio.cmx \ + otherlibs/num/ratio.p.$O \ + otherlibs/num/ratio.cmx \ + otherlibs/num/ratio.p.$O \ + otherlibs/bigarray/bigarray.cmx \ + otherlibs/bigarray/bigarray.p.$O \ + otherlibs/bigarray/bigarray.cmx \ + otherlibs/bigarray/bigarray.p.$O \ + otherlibs/dbm/dbm.cmx \ + otherlibs/dbm/dbm.p.$O \ + otherlibs/dbm/dbm.cmx \ + otherlibs/dbm/dbm.p.$O \ + otherlibs/graph/graphics.cmx \ + otherlibs/graph/graphics.$O \ + otherlibs/graph/graphics.p.cmx \ + otherlibs/graph/graphics.p.$O \ + otherlibs/win32graph/graphics.cmx \ + otherlibs/win32graph/graphics.$O \ + otherlibs/win32graph/graphics.p.cmx \ + otherlibs/win32graph/graphics.p.$O \ + otherlibs/str/str.cmx \ + otherlibs/str/str.p.$O \ + otherlibs/str/str.cmx \ + otherlibs/str/str.p.$O \ + otherlibs/unix/unix.cmx \ + otherlibs/unix/unix.$O \ + otherlibs/unix/unix.p.cmx \ + otherlibs/unix/unix.p.$O \ + otherlibs/win32unix/unix.cmx \ + otherlibs/win32unix/unix.$O \ + otherlibs/win32unix/unix.p.cmx \ + otherlibs/win32unix/unix.p.$O \ + otherlibs/unix/unixLabels.cmx \ + otherlibs/unix/unixLabels.$O \ + otherlibs/unix/unixLabels.p.cmx \ + otherlibs/unix/unixLabels.p.$O \ + otherlibs/win32unix/unixLabels.cmx \ + otherlibs/win32unix/unixLabels.$O \ + otherlibs/win32unix/unixLabels.p.cmx \ + otherlibs/win32unix/unixLabels.p.$O \ + $LIBDIR + +installlibdir \ + otherlibs/bigarray/bigarray.$A \ + otherlibs/bigarray/bigarray.p.$A \ + otherlibs/dbm/dbm.$A \ + otherlibs/dbm/dbm.p.$A \ + otherlibs/graph/graphics.$A \ + otherlibs/graph/graphics.p.$A \ + otherlibs/win32graph/graphics.$A \ + otherlibs/win32graph/graphics.p.$A \ + otherlibs/num/nums.$A \ + otherlibs/num/nums.p.$A \ + otherlibs/str/str.$A \ + otherlibs/str/str.p.$A \ + otherlibs/unix/unix.$A \ + otherlibs/unix/unix.p.$A \ + otherlibs/win32unix/unix.$A \ + otherlibs/win32unix/unix.p.$A \ + stdlib/stdlib.$A \ + stdlib/stdlib.p.$A \ + $LIBDIR + +installlibdir \ + otherlibs/systhreads/threads.$A \ + otherlibs/systhreads/threads.p.$A \ + $LIBDIR/threads + +echo "Installing manuals..." +(cd ../man && make install) + +echo "Installing ocamldoc..." +installbin ocamldoc/ocamldoc$EXE $BINDIR/ocamldoc$EXE +installbin ocamldoc/ocamldoc.opt$EXE $BINDIR/ocamldoc.opt$EXE + +installdir \ + ../ocamldoc/ocamldoc.hva \ + ocamldoc/*.cmi \ + ocamldoc/odoc_info.mli ocamldoc/odoc_infor.cm[ia] ocamldoc/odoc_info.cmxa \ + ocamldoc/odoc_info.$A \ + $LIBDIR/ocamldoc + +installdir \ + ocamldoc/stdlib_man/* \ + $MANDIR/man3 + +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 \ + $dir/*.p.$O \ + $CAMLP4DIR/$dir +done +installdir \ + camlp4lib.cma camlp4lib.cmxa Camlp4.cmi \ + camlp4o.cma camlp4of.cma camlp4oof.cma \ + camlp4orf.cma camlp4r.cma camlp4rf.cma \ + Camlp4Bin.cm[iox] Camlp4Bin.$O Camlp4Bin.p.$O Camlp4Top.cm[io] \ + $CAMLP4DIR +installlibdir camlp4lib.$A camlp4lib.p.$A $CAMLP4DIR +cd .. + +echo "Installing ocamlbuild..." + +installbin ocamlbuild/ocamlbuild.byte$EXE $BINDIR/ocamlbuild.byte$EXE +installbin ocamlbuild/ocamlbuild.native$EXE $BINDIR/ocamlbuild.native$EXE +installbestbin ocamlbuild/ocamlbuild.native$EXE ocamlbuild/ocamlbuild.byte$EXE $BINDIR/ocamlbuild$EXE + +installlibdir \ + ocamlbuild/ocamlbuildlib.$A ocamlbuild/ocamlbuildlib.p.$A \ + $LIBDIR/ocamlbuild + +installdir \ + ocamlbuild/ocamlbuildlib.cmxa ocamlbuild/ocamlbuildlib.p.cmxa \ + ocamlbuild/ocamlbuildlib.cma \ + ocamlbuild/ocamlbuild_plugin.cmi \ + ocamlbuild/ocamlbuild_pack.cmi \ + ocamlbuild/ocamlbuild.cmo \ + ocamlbuild/ocamlbuild.cmx \ + ocamlbuild/ocamlbuild.$O \ + ocamlbuild/ocamlbuild.p.cmx \ + ocamlbuild/ocamlbuild.p.$O \ + $LIBDIR/ocamlbuild + +installdir \ + ../ocamlbuild/man/ocamlbuild.1 \ + $MANDIR/man1 diff --git a/build/mkconfig.sh b/build/mkconfig.sh new file mode 100755 index 00000000..7d786d8a --- /dev/null +++ b/build/mkconfig.sh @@ -0,0 +1,8 @@ +#!/bin/sh + +cd `dirname $0`/.. + +sed -e 's/\$(\([^)]*\))/${\1}/g' \ + -e 's/^\([^=]*\)=\([^"]*\)$/\1="\2"/' \ + -e 's/^\(.*\$([0-9]).*\)$/# \1/' \ + config/Makefile > config/config.sh diff --git a/build/mkmyocamlbuild_config.sh b/build/mkmyocamlbuild_config.sh new file mode 100755 index 00000000..0b8137f2 --- /dev/null +++ b/build/mkmyocamlbuild_config.sh @@ -0,0 +1,19 @@ +#!/bin/sh + +cd `dirname $0`/.. + +sed \ + -e 's/^#ml \(.*\)/\1/' \ + -e 's/^\(#.*\)$/(* \1 *)/' \ + -e 's/^\(.*\$([0-9]).*\)$/(* \1 *)/' \ + -e 's/^\([^(=]*\)=\([^"]*\)$/let <:lower<\1>> = "\2";;/' \ + -e 's/\$(\([^)]*\))/"\^<:lower<\1>>\^"/g' \ + -e 's/""\^//g' \ + -e 's/\^""//g' \ + -e 's/^let <:lower<\(MAKE\|DO\).*$//g' \ + -e 's/"true"/true/g' \ + -e 's/"false"/false/g' \ + config/Makefile | \ + sed -f build/tolower.sed | \ + sed -f build/tolower.sed | \ + sed -f build/tolower.sed > myocamlbuild_config.ml diff --git a/build/mkruntimedef.sh b/build/mkruntimedef.sh new file mode 100755 index 00000000..0324d786 --- /dev/null +++ b/build/mkruntimedef.sh @@ -0,0 +1,8 @@ +#!/bin/sh +echo 'let builtin_exceptions = [|'; \ +sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$| \1;|p' byterun/fail.h | \ +sed -e '$s/;$//'; \ +echo '|]'; \ +echo 'let builtin_primitives = [|'; \ +sed -e 's/.*/ "&";/' -e '$s/;$//' byterun/primitives; \ +echo '|]' diff --git a/build/myocamlbuild.sh b/build/myocamlbuild.sh new file mode 100755 index 00000000..2721d1b2 --- /dev/null +++ b/build/myocamlbuild.sh @@ -0,0 +1,18 @@ +#!/bin/sh +cd `dirname $0`/.. +set -xe +if [ ! -x _build/ocamlbuild/ocamlbuildlight.byte ]; then + if [ ! -x ocamlbuild/_build/ocamlbuildlight.byte ]; then + (cd ocamlbuild && make) + fi + mkdir -p _build/ocamlbuild + for i in "light.cmo" "light.byte" "lightlib.cma" "_plugin.cmi" "_pack.cmi" + do + cp ocamlbuild/_build/ocamlbuild$i _build/ocamlbuild + done +fi +rm -f ocamlbuild/myocamlbuild_config.ml ocamlbuild/myocamlbuild_config.mli +rm -rf _build/myocamlbuild boot/myocamlbuild boot/myocamlbuild.native +./boot/ocamlrun _build/ocamlbuild/ocamlbuildlight.byte -no-hygiene \ + -tag debug -install-lib-dir _build/ocamlbuild -byte-plugin -just-plugin +cp _build/myocamlbuild boot/myocamlbuild.boot diff --git a/build/new-build-system b/build/new-build-system new file mode 100644 index 00000000..b16f6deb --- /dev/null +++ b/build/new-build-system @@ -0,0 +1,41 @@ +_tags # Defines tags to setup exceptions +myocamlbuild.ml # Contains all needed rules that are differents +boot/ocamldep +myocamlbuild_config.mli +utils/config.mlbuild # Should be renamed as utils/config.ml + +# Files that just contain module names of object files. +**/*.mllib # Files that describe the contents of an OCaml library +**/*.mlpack # Files that describe the contents of an OCaml package +**/*.cilb # Files that describe the contents of an C static library +**/*.dilb # Files that describe the contents of an C dynamic library + +build/ + world.sh # Build all the OCaml world + fastworld.sh # Same as above but faster + boot-c-parts.sh # Compile byterun, ocamlyacc and asmrun with the Makefiles + boot-c-parts-windows.sh # Same as boot-c-parts.sh but for windows + boot.sh # Compile the stdlib and ocamlc + camlp4-targets.sh # Setup camlp4 targets + otherlibs-targets.sh # Setup otherlibs targets + targets.sh # All targets of the OCaml distribution + + world.byte.sh # Build the bytecode world + world.native.sh # Build the native world + world.all.sh # Build all the world the don't bootstrap + + install.sh # Install all needed files + distclean.sh # Clean all generated files + + myocamlbuild.sh # Regenerate the boot/myocamlbuild program + mkconfig.sh # Generate config/config.sh + mkmyocamlbuild_config.sh # Generate myocamlbuild_config.ml + + camlp4-bootstrap.sh + + # Partial stuffs (just camlp4 and ocamlbuild) + partial-boot.sh + camlp4-byte-only.sh + camlp4-native-only.sh + ocamlbuild-byte-only.sh + ocamlbuild-native-only.sh diff --git a/build/ocamlbuild-byte-only.sh b/build/ocamlbuild-byte-only.sh new file mode 100755 index 00000000..a389342b --- /dev/null +++ b/build/ocamlbuild-byte-only.sh @@ -0,0 +1,8 @@ +#!/bin/sh +set -e +OCAMLBUILD_PARTIAL="true" +export OCAMLBUILD_PARTIAL +cd `dirname $0`/.. +. build/targets.sh +set -x +$OCAMLBUILD $@ byte_stdlib_partial_mode $OCAMLC_BYTE $OCAMLLEX_BYTE $OCAMLBUILD_BYTE diff --git a/build/ocamlbuild-native-only.sh b/build/ocamlbuild-native-only.sh new file mode 100755 index 00000000..0a170958 --- /dev/null +++ b/build/ocamlbuild-native-only.sh @@ -0,0 +1,8 @@ +#!/bin/sh +set -e +OCAMLBUILD_PARTIAL="true" +export OCAMLBUILD_PARTIAL +cd `dirname $0`/.. +. build/targets.sh +set -x +$OCAMLBUILD $@ native_stdlib_partial_mode $OCAMLOPT_BYTE $OCAMLLEX_BYTE $OCAMLBUILD_NATIVE diff --git a/build/otherlibs-targets.sh b/build/otherlibs-targets.sh new file mode 100644 index 00000000..b71eb4b0 --- /dev/null +++ b/build/otherlibs-targets.sh @@ -0,0 +1,106 @@ +#!/bin/sh +OTHERLIBS_BYTE="" +OTHERLIBS_NATIVE="" +OTHERLIBS_UNIX_NATIVE="" +UNIXDIR="otherlibs/unix" + +add_native() { + for native_file in $@; do + OTHERLIBS_NATIVE="$OTHERLIBS_NATIVE otherlibs/$lib/$native_file" + case $lib in + unix|win32unix) + OTHERLIBS_UNIX_NATIVE="$OTHERLIBS_UNIX_NATIVE otherlibs/$lib/$native_file";; + esac + done +} + +add_byte() { + for byte_file in $@; do + OTHERLIBS_BYTE="$OTHERLIBS_BYTE otherlibs/$lib/$byte_file" + done +} + +add_file() { + add_byte $@ + add_native $@ +} + +add_bin() { + for bin_file in $@; do + add_byte $bin_file.byte$EXE + add_native $bin_file.native$EXE + done +} + +add_c_lib() { + add_file "lib$1.$A" +} + +add_ocaml_lib() { + add_native "$1.cmxa" + add_byte "$1.cma" +} + +add_dll() { + add_file "dll$1$EXT_DLL" +} + +add() { + add_c_lib $1 + add_ocaml_lib $1 + add_dll $1 +} + +THREADS_CMIS="thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi" + +for lib in $OTHERLIBRARIES; do + case $lib in + num) + add nums;; + systhreads) + add_ocaml_lib threads + add_dll threads + add_file $THREADS_CMIS + add_byte libthreads.$A + add_native libthreadsnat.$A;; + graph|win32graph) + add graphics;; + threads) + add_byte pervasives.cmi pervasives.mli \ + $THREADS_CMIS marshal.cmi marshal.mli \ + stdlib.cma unix.cma threads.cma libvmthreads.$A;; + labltk) + add_file support/camltk.h + add_byte support/byte.otarget + add_native support/native.otarget + add_file support/liblabltk.$A + add_byte compiler/tkcompiler$EXE compiler/pp$EXE + add_file labltk/tk.ml labltk/labltk.ml + add_byte labltk/byte.otarget + add_native labltk/native.otarget + add_byte camltk/byte.otarget + add_native camltk/native.otarget + add_ocaml_lib lib/labltk + add_byte lib/labltktop$EXE lib/labltk$EXE + add_ocaml_lib jpf/jpflib + add_ocaml_lib frx/frxlib + add_ocaml_lib tkanim/tkanim + add_file tkanim/libtkanim.$A + add_byte browser/ocamlbrowser$EXE + ;; + dbm) + add_ocaml_lib dbm + add_c_lib mldbm;; + dynlink) + add_byte $lib.cmi $lib.cma extract_crc;; + win32unix) + UNIXDIR="otherlibs/win32unix" + add_file unixsupport.h cst2constr.h socketaddr.h + add unix;; + unix) + add_file unixsupport.h + add unix;; + *) + add $lib + esac +done diff --git a/build/partial-boot.sh b/build/partial-boot.sh new file mode 100755 index 00000000..9600b523 --- /dev/null +++ b/build/partial-boot.sh @@ -0,0 +1,13 @@ +#!/bin/sh +set -ex +cd `dirname $0`/.. +OCAMLBUILD_PARTIAL="true" +export OCAMLBUILD_PARTIAL +mkdir -p _build +cp -rf boot _build/ +cp parsing/location.ml parsing/location.mli camlp4/build +cp parsing/linenum.mll parsing/linenum.mli camlp4/build +cp utils/terminfo.ml utils/terminfo.mli camlp4/build +./build/mkconfig.sh +./build/mkmyocamlbuild_config.sh +./build/boot.sh diff --git a/build/partial-install.sh b/build/partial-install.sh new file mode 100755 index 00000000..acd87281 --- /dev/null +++ b/build/partial-install.sh @@ -0,0 +1,164 @@ +#!/bin/sh + +###################################### +######### Copied from build/install.sh +###################################### + +set -e + +cd `dirname $0`/.. + +. config/config.sh + +not_installed=$PWD/_build/not_installed + +rm -f "$not_installed" + +wontinstall() { + echo "$1" >> "$not_installed" +} + +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" + ranlib "$dest" + 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 +mkdir -p $LIBDIR/camlp4 +mkdir -p $LIBDIR/ocamlbuild +mkdir -p $STUBLIBDIR +mkdir -p $MANDIR/man1 +mkdir -p $MANDIR/man3 +mkdir -p $MANDIR/man$MANEXT + +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 \ + $dir/*.p.$O \ + $CAMLP4DIR/$dir +done +installdir \ + camlp4lib.cma camlp4lib.cmxa Camlp4.cmi \ + camlp4o.cma \ + camlp4of.cma \ + camlp4oof.cma \ + camlp4orf.cma \ + camlp4r.cma \ + camlp4rf.cma \ + Camlp4Bin.cm[iox] Camlp4Bin.$O Camlp4Bin.p.$O Camlp4Top.cm[io] \ + $CAMLP4DIR +installlibdir camlp4lib.$A camlp4lib.p.$A $CAMLP4DIR +cd .. + +echo "Installing ocamlbuild..." + +installbin ocamlbuild/ocamlbuild.byte$EXE $BINDIR/ocamlbuild.byte$EXE +installbin ocamlbuild/ocamlbuild.native$EXE $BINDIR/ocamlbuild.native$EXE +installbestbin ocamlbuild/ocamlbuild.native$EXE ocamlbuild/ocamlbuild.byte$EXE $BINDIR/ocamlbuild$EXE + +installlibdir \ + ocamlbuild/ocamlbuildlib.$A ocamlbuild/ocamlbuildlib.p.$A \ + $LIBDIR/ocamlbuild + +installdir \ + ocamlbuild/ocamlbuildlib.cmxa ocamlbuild/ocamlbuildlibp.cmxa\ + ocamlbuild/ocamlbuildlib.cma \ + ocamlbuild/ocamlbuild_plugin.cmi \ + ocamlbuild/ocamlbuild_pack.cmi \ + ocamlbuild/ocamlbuild.cmo \ + ocamlbuild/ocamlbuild.cmx \ + ocamlbuild/ocamlbuild.$O \ + ocamlbuild/ocamlbuild.p.cmx \ + ocamlbuild/ocamlbuild.p.$O \ + $LIBDIR/ocamlbuild + +installdir \ + ../ocamlbuild/man/ocamlbuild.1 \ + $MANDIR/man1 diff --git a/build/targets.sh b/build/targets.sh new file mode 100644 index 00000000..a6ac528a --- /dev/null +++ b/build/targets.sh @@ -0,0 +1,48 @@ +. config/config.sh +. build/otherlibs-targets.sh +. build/camlp4-targets.sh + +INSTALL_BIN="$BINDIR" +export INSTALL_BIN + +STDLIB_BYTE="stdlib/libcamlrun.$A stdlib/stdlib.cma \ + stdlib/std_exit.cmo stdlib/camlheader stdlib/camlheader_ur" +OCAMLLEX_BYTE=lex/ocamllex$EXE +OCAMLC_BYTE=ocamlc$EXE +OCAMLOPT_BYTE=ocamlopt$EXE +OCAMLBUILD_BYTE="ocamlbuild/ocamlbuildlib.cma \ + ocamlbuild/ocamlbuildlightlib.cma \ + ocamlbuild/ocamlbuild.byte$EXE \ + ocamlbuild/ocamlbuildlight.byte$EXE" +TOPLEVEL=ocaml$EXE +TOOLS_BYTE="tools/ocamldep.byte$EXE tools/profiling.cmo \ + tools/ocamlprof.byte$EXE tools/ocamlcp.byte$EXE \ + tools/ocamlmktop.byte$EXE tools/ocamlmklib$EXE \ + tools/scrapelabels.byte tools/addlabels.byte \ + tools/dumpobj.byte$EXE" +if [ ! -z "$DEBUGGER" ]; then + DEBUGGER=debugger/ocamldebug$EXE +fi +OCAMLDOC_BYTE="ocamldoc/ocamldoc$EXE ocamldoc/odoc_info.cma" +STDLIB_NATIVE="stdlib/stdlib.cmxa stdlib/std_exit.cmx asmrun/libasmrun.$A" +case $PROFILING in +prof) + STDLIB_NATIVE="$STDLIB_NATIVE asmrun/libasmrunp.$A \ + stdlib/stdlib.p.cmxa stdlib/std_exit.p.cmx";; +noprof) ;; +*) echo "unexpected PROFILING value $PROFILING"; exit 1;; +esac +OCAMLC_NATIVE=ocamlc.opt$EXE +OCAMLOPT_NATIVE=ocamlopt.opt$EXE +OCAMLLEX_NATIVE=lex/ocamllex.opt$EXE +TOOLS_NATIVE=tools/ocamldep.native$EXE +OCAMLDOC_NATIVE="ocamldoc/ocamldoc.opt$EXE ocamldoc/odoc_info.cmxa ocamldoc/stdlib_man/Pervasives.3o" +OCAMLBUILD_NATIVE="ocamlbuild/ocamlbuildlib.cmxa \ + ocamlbuild/ocamlbuildlightlib.cmxa \ + ocamlbuild/ocamlbuild.native$EXE \ + ocamlbuild/ocamlbuildlight.native$EXE" +if [ -x boot/myocamlbuild.native ]; then + OCAMLBUILD=./boot/myocamlbuild.native +else + OCAMLBUILD="./boot/ocamlrun boot/myocamlbuild" +fi diff --git a/build/tolower.sed b/build/tolower.sed new file mode 100644 index 00000000..ccd55fca --- /dev/null +++ b/build/tolower.sed @@ -0,0 +1,11 @@ +# tolower.sed expands one ...<:lower>... to ...foo... per line +h +s/.*<:lower<\(.*\)>>.*/\1/ +t cont +b end +:cont +y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ +s/$/|/ +G +s/\(.*\)|\n\(.*\)<:lower<\(.*\)>>/\2\1/ +:end diff --git a/build/world.all.sh b/build/world.all.sh new file mode 100755 index 00000000..b84bf8a1 --- /dev/null +++ b/build/world.all.sh @@ -0,0 +1,11 @@ +#!/bin/sh +set -e +cd `dirname $0`/.. +. build/targets.sh +set -x +$OCAMLBUILD $@ \ + $STDLIB_BYTE $OCAMLC_BYTE $OCAMLLEX_BYTE $OCAMLOPT_BYTE $TOPLEVEL \ + $TOOLS_BYTE $OTHERLIBS_BYTE $OCAMLBUILD_BYTE $DEBUGGER $OCAMLDOC_BYTE \ + $CAMLP4_BYTE $STDLIB_NATIVE $OCAMLC_NATIVE $OCAMLOPT_NATIVE \ + $OCAMLLEX_NATIVE $TOOLS_NATIVE $OTHERLIBS_NATIVE \ + $OCAMLBUILD_NATIVE $OCAMLDOC_NATIVE $CAMLP4_NATIVE diff --git a/build/world.byte.sh b/build/world.byte.sh new file mode 100755 index 00000000..56b3de5f --- /dev/null +++ b/build/world.byte.sh @@ -0,0 +1,8 @@ +#!/bin/sh +set -e +cd `dirname $0`/.. +. build/targets.sh +set -x +$OCAMLBUILD $@ \ + $STDLIB_BYTE $OCAMLC_BYTE $OCAMLLEX_BYTE $OCAMLOPT_BYTE $TOPLEVEL $TOOLS_BYTE \ + $OTHERLIBS_BYTE $OCAMLBUILD_BYTE $DEBUGGER $OCAMLDOC_BYTE $CAMLP4_BYTE diff --git a/build/world.native.sh b/build/world.native.sh new file mode 100755 index 00000000..88f74033 --- /dev/null +++ b/build/world.native.sh @@ -0,0 +1,9 @@ +#!/bin/sh +set -e +cd `dirname $0`/.. +. build/targets.sh +set -x +$OCAMLBUILD $@ \ + $STDLIB_NATIVE $OCAMLC_NATIVE $OCAMLOPT_NATIVE \ + $OCAMLLEX_NATIVE $TOOLS_NATIVE $OTHERLIBS_NATIVE \ + $OCAMLBUILD_NATIVE $OCAMLDOC_NATIVE $CAMLP4_NATIVE diff --git a/build/world.sh b/build/world.sh new file mode 100755 index 00000000..bb0c813c --- /dev/null +++ b/build/world.sh @@ -0,0 +1,13 @@ +#!/bin/sh +cd `dirname $0` +set -ex +./mkconfig.sh +./mkmyocamlbuild_config.sh +. ../config/config.sh +if [ "x$EXE" = "x.exe" ]; then + ./boot-c-parts-windows.sh +else + ./boot-c-parts.sh +fi +./boot.sh $@ +./world.all.sh $@ diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 012b8d2e..14364a80 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: bytegen.ml,v 1.67 2005/08/25 15:35:16 doligez Exp $ *) +(* $Id: bytegen.ml,v 1.69 2007/02/09 13:31:15 doligez Exp $ *) (* bytegen.ml : translation of lambda terms to lists of instructions. *) @@ -128,15 +128,36 @@ let rec push_dummies n k = match n with type rhs_kind = | RHS_block of int + | RHS_floatblock of int | RHS_nonrec ;; + +let rec check_recordwith_updates id e = + match e with + | Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; _]), cont) + -> id2 = id && check_recordwith_updates id cont + | Lvar id2 -> id2 = id + | _ -> false +;; + let rec size_of_lambda = function | Lfunction(kind, params, body) as funct -> RHS_block (1 + IdentSet.cardinal(free_variables funct)) + | Llet (Strict, id, Lprim (Pduprecord (kind, size), _), body) + when check_recordwith_updates id body -> + begin match kind with + | Record_regular -> RHS_block size + | Record_float -> RHS_floatblock size + end | Llet(str, id, arg, body) -> size_of_lambda body | Lletrec(bindings, body) -> size_of_lambda body | Lprim(Pmakeblock(tag, mut), args) -> RHS_block (List.length args) - | Lprim(Pmakearray kind, args) -> RHS_block (List.length args) + | Lprim (Pmakearray (Paddrarray|Pintarray), args) -> + RHS_block (List.length args) + | Lprim (Pmakearray Pfloatarray, args) -> RHS_floatblock (List.length args) + | Lprim (Pmakearray Pgenarray, args) -> assert false + | Lprim (Pduprecord (Record_regular, size), args) -> RHS_block size + | Lprim (Pduprecord (Record_float, size), args) -> RHS_floatblock size | Levent (lam, _) -> size_of_lambda lam | Lsequence (lam, lam') -> size_of_lambda lam' | _ -> RHS_nonrec @@ -171,7 +192,7 @@ let merge_repr ev ev' = let merge_events ev ev' = let (maj, min) = match ev.ev_kind, ev'.ev_kind with - (* Discard pseudo-events *) + (* Discard pseudo-events *) Event_pseudo, _ -> ev', ev | _, Event_pseudo -> ev, ev' (* Keep following event, supposedly more informative *) @@ -205,7 +226,7 @@ let weaken_event ev cont = end | _ -> Kevent ev :: cont - + let add_event ev = function Kevent ev' :: cont -> weaken_event (merge_events ev ev') cont @@ -275,6 +296,7 @@ let comp_primitive p args = | Psetfield(n, ptr) -> Ksetfield n | Pfloatfield n -> Kgetfloatfield n | Psetfloatfield n -> Ksetfloatfield n + | Pduprecord _ -> Kccall("caml_obj_dup", 1) | Pccall p -> Kccall(p.prim_name, p.prim_arity) | Pnegint -> Knegint | Paddint -> Kaddint @@ -351,8 +373,8 @@ let comp_primitive p args = | Pbintcomp(bi, Cgt) -> Kccall("caml_greaterthan", 2) | Pbintcomp(bi, Cle) -> Kccall("caml_lessequal", 2) | Pbintcomp(bi, Cge) -> Kccall("caml_greaterequal", 2) - | Pbigarrayref(n, _, _) -> Kccall("bigarray_get_" ^ string_of_int n, n + 1) - | Pbigarrayset(n, _, _) -> Kccall("bigarray_set_" ^ string_of_int n, n + 2) + | Pbigarrayref(n, _, _) -> Kccall("caml_ba_get_" ^ string_of_int n, n + 1) + | Pbigarrayset(n, _, _) -> Kccall("caml_ba_set_" ^ string_of_int n, n + 2) | _ -> fatal_error "Bytegen.comp_primitive" let is_immed n = immed_min <= n && n <= immed_max @@ -472,6 +494,10 @@ let rec comp_expr env exp sz cont = List.map (fun (id, exp) -> (id, exp, size_of_lambda exp)) decl in let rec comp_init new_env sz = function | [] -> comp_nonrec new_env sz ndecl decl_size + | (id, exp, RHS_floatblock blocksize) :: rem -> + Kconst(Const_base(Const_int blocksize)) :: + Kccall("caml_alloc_dummy_float", 1) :: Kpush :: + comp_init (add_var id (sz+1) new_env) (sz+1) rem | (id, exp, RHS_block blocksize) :: rem -> Kconst(Const_base(Const_int blocksize)) :: Kccall("caml_alloc_dummy", 1) :: Kpush :: @@ -481,14 +507,14 @@ let rec comp_expr env exp sz cont = comp_init (add_var id (sz+1) new_env) (sz+1) rem and comp_nonrec new_env sz i = function | [] -> comp_rec new_env sz ndecl decl_size - | (id, exp, RHS_block blocksize) :: rem -> + | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> comp_nonrec new_env sz (i-1) rem | (id, exp, RHS_nonrec) :: rem -> comp_expr new_env exp sz (Kassign (i-1) :: comp_nonrec new_env sz (i-1) rem) and comp_rec new_env sz i = function | [] -> comp_expr new_env body sz (add_pop ndecl cont) - | (id, exp, RHS_block blocksize) :: rem -> + | (id, exp, (RHS_block _ | RHS_floatblock _)) :: rem -> comp_expr new_env exp sz (Kpush :: Kacc i :: Kccall("caml_update_dummy", 2) :: comp_rec new_env sz (i-1) rem) @@ -570,10 +596,10 @@ let rec comp_expr env exp sz cont = comp_args env args sz (comp_primitive p args :: cont) | Lprim(p, args) -> comp_args env args sz (comp_primitive p args :: cont) - | Lstaticcatch (body, (i, vars) , handler) -> + | Lstaticcatch (body, (i, vars) , handler) -> let nvars = List.length vars in let branch1, cont1 = make_branch cont in - let r = + let r = if nvars <> 1 then begin (* general case *) let lbl_handler, cont2 = label_code @@ -612,8 +638,8 @@ let rec comp_expr env exp sz cont = | Ltrywith(body, id, handler) -> let (branch1, cont1) = make_branch cont in let lbl_handler = new_label() in - Kpushtrap lbl_handler :: - comp_expr env body (sz+4) (Kpoptrap :: branch1 :: + Kpushtrap lbl_handler :: + comp_expr env body (sz+4) (Kpoptrap :: branch1 :: Klabel lbl_handler :: Kpush :: comp_expr (add_var id (sz+1) env) handler (sz+1) (add_pop 1 cont1)) | Lifthenelse(cond, ifso, ifnot) -> @@ -643,7 +669,7 @@ let rec comp_expr env exp sz cont = | Lswitch(arg, sw) -> let (branch, cont1) = make_branch cont in let c = ref (discard_dead_code cont1) in -(* Build indirection vectors *) +(* Build indirection vectors *) let store = mk_store Lambda.same in let act_consts = Array.create sw.sw_numconsts 0 and act_blocks = Array.create sw.sw_numblocks 0 in @@ -841,4 +867,3 @@ let compile_phrase expr = let init_code = comp_block empty_env expr 1 [Kreturn 1] in let fun_code = comp_remainder [] in (init_code, fun_code) - diff --git a/bytecomp/bytelibrarian.ml b/bytecomp/bytelibrarian.ml index 85d8eb92..5c5c155a 100644 --- a/bytecomp/bytelibrarian.ml +++ b/bytecomp/bytelibrarian.ml @@ -10,13 +10,13 @@ (* *) (***********************************************************************) -(* $Id: bytelibrarian.ml,v 1.18 2002/04/18 22:55:36 garrigue Exp $ *) +(* $Id: bytelibrarian.ml,v 1.19 2006/05/11 15:50:53 xleroy Exp $ *) (* Build libraries of .cmo files *) open Misc open Config -open Emitcode +open Cmo_format type error = File_not_found of string diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index b547bd13..83add82d 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: bytelink.ml,v 1.86 2005/10/13 13:32:06 xleroy Exp $ *) +(* $Id: bytelink.ml,v 1.90 2006/09/28 21:36:38 xleroy Exp $ *) (* Link a set of .cmo files and produce a bytecode executable. *) @@ -18,7 +18,7 @@ open Sys open Misc open Config open Instruct -open Emitcode +open Cmo_format type error = File_not_found of string @@ -296,7 +296,7 @@ let link_bytecode tolink exec_name standalone = (* Initialize the DLL machinery *) Dll.init_compile !Clflags.no_std_include; Dll.add_path !load_path; - try Dll.open_dlls sharedobjs + try Dll.open_dlls Dll.For_checking sharedobjs with Failure reason -> raise(Error(Cannot_open_dll reason)) end; let output_fun = output_string outchan @@ -428,13 +428,6 @@ void caml_startup(char ** argv) (* Build a custom runtime *) -let rec extract suffix l = - match l with - | [] -> [] - | h::t when Filename.check_suffix h suffix -> h :: (extract suffix t) - | h::t -> extract suffix t -;; - let build_custom_runtime prim_name exec_name = match Config.ccomp_type with "cc" -> @@ -464,12 +457,14 @@ let build_custom_runtime prim_name exec_name = (List.rev_map Ccomp.expand_libname !Clflags.ccobjs)) (Filename.quote (Ccomp.expand_libname "-lcamlrun")) Config.bytecomp_c_libraries - (String.concat " " (List.rev !Clflags.ccopts))) in + (Ccomp.make_link_options !Clflags.ccopts)) in (* C compiler doesn't clean up after itself. Note that the .obj file is created in the current working directory. *) remove_file (Filename.chop_suffix (Filename.basename prim_name) ".c" ^ ".obj"); - retcode + if retcode <> 0 + then retcode + else Ccomp.merge_manifest exec_name | _ -> assert false let append_bytecode_and_cleanup bytecode_name exec_name prim_name = diff --git a/bytecomp/bytelink.mli b/bytecomp/bytelink.mli index 244ef75a..bb59279f 100644 --- a/bytecomp/bytelink.mli +++ b/bytecomp/bytelink.mli @@ -10,13 +10,13 @@ (* *) (***********************************************************************) -(* $Id: bytelink.mli,v 1.11 2002/06/11 14:15:11 xleroy Exp $ *) +(* $Id: bytelink.mli,v 1.12 2006/05/11 15:50:53 xleroy Exp $ *) (* Link .cmo files and produce a bytecode executable. *) val link: string list -> string -> unit -val check_consistency: string -> Emitcode.compilation_unit -> unit +val check_consistency: string -> Cmo_format.compilation_unit -> unit val extract_crc_interfaces: unit -> (string * Digest.t) list diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index 853d0db5..d0712cb3 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -10,14 +10,14 @@ (* *) (***********************************************************************) -(* $Id: bytepackager.ml,v 1.4 2004/04/09 13:32:27 xleroy Exp $ *) +(* $Id: bytepackager.ml,v 1.6 2007/02/23 13:44:51 ertai Exp $ *) (* "Package" a set of .cmo files into one .cmo file having the original compilation units as sub-modules. *) open Misc open Instruct -open Emitcode +open Cmo_format type error = Forward_reference of string * Ident.t @@ -81,7 +81,7 @@ type pack_member = let read_member_info file = let name = - String.capitalize(Filename.basename(chop_extension_if_any file)) in + String.capitalize(Filename.basename(chop_extensions file)) in let kind = if Filename.check_suffix file ".cmo" then begin let ic = open_in_bin file in @@ -224,7 +224,7 @@ let package_files files targetfile = try find_in_path !Config.load_path f with Not_found -> raise(Error(File_not_found f))) files in - let prefix = chop_extension_if_any targetfile in + let prefix = chop_extensions targetfile in let targetcmi = prefix ^ ".cmi" in let targetname = String.capitalize(Filename.basename prefix) in try diff --git a/bytecomp/cmo_format.mli b/bytecomp/cmo_format.mli new file mode 100644 index 00000000..46f222c9 --- /dev/null +++ b/bytecomp/cmo_format.mli @@ -0,0 +1,61 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: cmo_format.mli,v 1.1 2006/05/11 15:50:53 xleroy Exp $ *) + +(* Symbol table information for .cmo and .cma files *) + +(* Relocation information *) + +type reloc_info = + Reloc_literal of Lambda.structured_constant (* structured constant *) + | Reloc_getglobal of Ident.t (* reference to a global *) + | Reloc_setglobal of Ident.t (* definition of a global *) + | Reloc_primitive of string (* C primitive number *) + +(* Descriptor for compilation units *) + +type compilation_unit = + { cu_name: string; (* Name of compilation unit *) + mutable cu_pos: int; (* Absolute position in file *) + cu_codesize: int; (* Size of code block *) + cu_reloc: (reloc_info * int) list; (* Relocation information *) + cu_imports: (string * Digest.t) list; (* Names and CRC of intfs imported *) + cu_primitives: string list; (* Primitives declared inside *) + mutable cu_force_link: bool; (* Must be linked even if unref'ed *) + mutable cu_debug: int; (* Position of debugging info, or 0 *) + cu_debugsize: int } (* Length of debugging info *) + +(* Format of a .cmo file: + magic number (Config.cmo_magic_number) + absolute offset of compilation unit descriptor + block of relocatable bytecode + debugging information if any + compilation unit descriptor *) + +(* Descriptor for libraries *) + +type library = + { lib_units: compilation_unit list; (* List of compilation units *) + lib_custom: bool; (* Requires custom mode linking? *) + lib_ccobjs: string list; (* C object files needed for -custom *) + lib_ccopts: string list; (* Extra opts to C compiler *) + lib_dllibs: string list } (* DLLs needed *) + +(* Format of a .cma file: + magic number (Config.cma_magic_number) + absolute offset of library descriptor + object code for first library member + ... + object code for last library member + library descriptor *) + diff --git a/bytecomp/dll.ml b/bytecomp/dll.ml index 93f0b0ae..540180f0 100644 --- a/bytecomp/dll.ml +++ b/bytecomp/dll.ml @@ -10,14 +10,15 @@ (* *) (***********************************************************************) -(* $Id: dll.ml,v 1.12 2004/01/16 15:24:02 doligez Exp $ *) +(* $Id: dll.ml,v 1.13 2006/09/28 21:36:38 xleroy Exp $ *) (* Handling of dynamically-linked libraries *) type dll_handle type dll_address +type dll_mode = For_checking | For_execution -external dll_open: string -> dll_handle = "caml_dynlink_open_lib" +external dll_open: dll_mode -> string -> dll_handle = "caml_dynlink_open_lib" external dll_close: dll_handle -> unit = "caml_dynlink_close_lib" external dll_sym: dll_handle -> string -> dll_address = "caml_dynlink_lookup_symbol" @@ -52,7 +53,7 @@ let extract_dll_name file = (* Open a list of DLLs, adding them to opened_dlls. Raise [Failure msg] in case of error. *) -let open_dll name = +let open_dll mode name = let name = name ^ Config.ext_dll in let fullname = try @@ -62,13 +63,16 @@ let open_dll name = else fullname with Not_found -> name in if not (List.mem fullname !names_of_opened_dlls) then begin - let dll = dll_open fullname in - names_of_opened_dlls := fullname :: !names_of_opened_dlls; - opened_dlls := dll :: !opened_dlls + try + let dll = dll_open mode fullname in + names_of_opened_dlls := fullname :: !names_of_opened_dlls; + opened_dlls := dll :: !opened_dlls + with Failure msg -> + failwith (fullname ^ ": " ^ msg) end -let open_dlls names = - List.iter open_dll names +let open_dlls mode names = + List.iter (open_dll mode) names (* Close all DLLs *) diff --git a/bytecomp/dll.mli b/bytecomp/dll.mli index 389e1fab..46d162fe 100644 --- a/bytecomp/dll.mli +++ b/bytecomp/dll.mli @@ -10,16 +10,22 @@ (* *) (***********************************************************************) -(* $Id: dll.mli,v 1.5 2002/07/02 16:13:12 weis Exp $ *) +(* $Id: dll.mli,v 1.6 2006/09/28 21:36:38 xleroy Exp $ *) (* Handling of dynamically-linked libraries *) (* Extract the name of a DLLs from its external name (xxx.so or -lxxx) *) val extract_dll_name: string -> string -(* Open a list of DLLs, adding them to opened_dlls. - Raise [Failure msg] in case of error. *) -val open_dlls: string list -> unit +type dll_mode = + | For_checking (* will just check existence of symbols; + no need to do full symbol resolution *) + | For_execution (* will call functions from this DLL; + must resolve symbols completely *) + +(* Open a list of DLLs. First argument indicates whether to perform + full symbol resolution. Raise [Failure msg] in case of error. *) +val open_dlls: dll_mode -> string list -> unit (* Close all DLLs *) val close_all_dlls: unit -> unit diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index 8e60088d..0201ba6a 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emitcode.ml,v 1.32 2004/05/26 11:10:50 garrigue Exp $ *) +(* $Id: emitcode.ml,v 1.33 2006/05/11 15:50:53 xleroy Exp $ *) (* Generation of bytecode + relocation information *) @@ -20,37 +20,7 @@ open Asttypes open Lambda open Instruct open Opcodes - - -(* Relocation information *) - -type reloc_info = - Reloc_literal of structured_constant (* structured constant *) - | Reloc_getglobal of Ident.t (* reference to a global *) - | Reloc_setglobal of Ident.t (* definition of a global *) - | Reloc_primitive of string (* C primitive number *) - -(* Descriptor for compilation units *) - -type compilation_unit = - { cu_name: string; (* Name of compilation unit *) - mutable cu_pos: int; (* Absolute position in file *) - cu_codesize: int; (* Size of code block *) - cu_reloc: (reloc_info * int) list; (* Relocation information *) - cu_imports: (string * Digest.t) list; (* Names and CRC of intfs imported *) - cu_primitives: string list; (* Primitives declared inside *) - mutable cu_force_link: bool; (* Must be linked even if unref'ed *) - mutable cu_debug: int; (* Position of debugging info, or 0 *) - cu_debugsize: int } (* Length of debugging info *) - -(* Descriptor for libraries *) - -type library = - { lib_units: compilation_unit list; (* List of compilation units *) - lib_custom: bool; (* Requires custom mode linking? *) - lib_ccobjs: string list; (* C object files needed for -custom *) - lib_ccopts: string list; (* Extra opts to C compiler *) - lib_dllibs: string list } (* DLLs needed *) +open Cmo_format (* Buffering of bytecode *) diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli index 72dcea4c..5a09293d 100644 --- a/bytecomp/emitcode.mli +++ b/bytecomp/emitcode.mli @@ -10,58 +10,13 @@ (* *) (***********************************************************************) -(* $Id: emitcode.mli,v 1.14 2003/03/06 15:59:54 xleroy Exp $ *) +(* $Id: emitcode.mli,v 1.15 2006/05/11 15:50:53 xleroy Exp $ *) (* Generation of bytecode for .cmo files *) -open Lambda +open Cmo_format open Instruct -(* Relocation information *) - -type reloc_info = - Reloc_literal of structured_constant (* structured constant *) - | Reloc_getglobal of Ident.t (* reference to a global *) - | Reloc_setglobal of Ident.t (* definition of a global *) - | Reloc_primitive of string (* C primitive number *) - -(* Descriptor for compilation units *) - -type compilation_unit = - { cu_name: string; (* Name of compilation unit *) - mutable cu_pos: int; (* Absolute position in file *) - cu_codesize: int; (* Size of code block *) - cu_reloc: (reloc_info * int) list; (* Relocation information *) - cu_imports: (string * Digest.t) list; (* Names and CRC of intfs imported *) - cu_primitives: string list; (* Primitives declared inside *) - mutable cu_force_link: bool; (* Must be linked even if unref'ed *) - mutable cu_debug: int; (* Position of debugging info, or 0 *) - cu_debugsize: int } (* Length of debugging info *) - -(* Format of a .cmo file: - magic number (Config.cmo_magic_number) - absolute offset of compilation unit descriptor - block of relocatable bytecode - debugging information if any - compilation unit descriptor *) - -(* Descriptor for libraries *) - -type library = - { lib_units: compilation_unit list; (* List of compilation units *) - lib_custom: bool; (* Requires custom mode linking? *) - lib_ccobjs: string list; (* C object files needed for -custom *) - lib_ccopts: string list; (* Extra opts to C compiler *) - lib_dllibs: string list } (* DLLs needed *) - -(* Format of a .cma file: - magic number (Config.cma_magic_number) - absolute offset of library descriptor - object code for first library member - ... - object code for last library member - library descriptor *) - val to_file: out_channel -> string -> instruction list -> unit (* Arguments: channel on output file diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index df6bcc81..38a86300 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: lambda.ml,v 1.44 2005/08/25 15:35:16 doligez Exp $ *) +(* $Id: lambda.ml,v 1.45 2007/02/09 13:31:15 doligez Exp $ *) open Misc open Path @@ -28,6 +28,7 @@ type primitive = | Psetfield of int * bool | Pfloatfield of int | Psetfloatfield of int + | Pduprecord of Types.record_representation * int (* External call *) | Pccall of Primitive.description (* Exceptions *) @@ -251,7 +252,7 @@ let rec iter f = function | Lprim(p, args) -> List.iter f args | Lswitch(arg, sw) -> - f arg; + f arg; List.iter (fun (key, case) -> f case) sw.sw_consts; List.iter (fun (key, case) -> f case) sw.sw_blocks; begin match sw.sw_failaction with diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index 9390ecdf..c44260dc 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: lambda.mli,v 1.42 2005/08/25 15:35:16 doligez Exp $ *) +(* $Id: lambda.mli,v 1.43 2007/02/09 13:31:15 doligez Exp $ *) (* The "lambda" intermediate code *) @@ -28,6 +28,7 @@ type primitive = | Psetfield of int * bool | Pfloatfield of int | Psetfloatfield of int + | Pduprecord of Types.record_representation * int (* External call *) | Pccall of Primitive.description (* Exceptions *) @@ -96,7 +97,7 @@ and bigarray_kind = | Pbigarray_float32 | Pbigarray_float64 | Pbigarray_sint8 | Pbigarray_uint8 | Pbigarray_sint16 | Pbigarray_uint16 - | Pbigarray_int32 | Pbigarray_int64 + | Pbigarray_int32 | Pbigarray_int64 | Pbigarray_caml_int | Pbigarray_native_int | Pbigarray_complex32 | Pbigarray_complex64 diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index ef826a64..40e0c3bf 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: printlambda.ml,v 1.51 2005/08/25 15:35:16 doligez Exp $ *) +(* $Id: printlambda.ml,v 1.52 2007/02/09 13:31:15 doligez Exp $ *) open Format open Asttypes @@ -83,6 +83,12 @@ let print_bigarray name kind ppf layout = | Pbigarray_c_layout -> "C" | Pbigarray_fortran_layout -> "Fortran") +let record_rep ppf r = + match r with + | Record_regular -> fprintf ppf "regular" + | Record_float -> fprintf ppf "float" +;; + let primitive ppf = function | Pidentity -> fprintf ppf "id" | Pignore -> fprintf ppf "ignore" @@ -96,6 +102,7 @@ let primitive ppf = function fprintf ppf "%s%i" instr n | Pfloatfield n -> fprintf ppf "floatfield %i" n | Psetfloatfield n -> fprintf ppf "setfloatfield %i" n + | Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size | Pccall p -> fprintf ppf "%s" p.prim_name | Praise -> fprintf ppf "raise" | Psequand -> fprintf ppf "&&" @@ -239,7 +246,7 @@ let rec lam ppf = function if !spc then fprintf ppf "@ " else spc := true; fprintf ppf "@[default:@ %a@]" lam l end in - + fprintf ppf "@[<1>(%s %a@ @[%a@])@]" (match sw.sw_failaction with None -> "switch*" | _ -> "switch") diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index bbaafee0..fd38b811 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -10,14 +10,14 @@ (* *) (***********************************************************************) -(* $Id: symtable.ml,v 1.38 2004/11/30 07:28:00 garrigue Exp $ *) +(* $Id: symtable.ml,v 1.39 2006/05/11 15:50:53 xleroy Exp $ *) (* To assign numbers to globals and primitives *) open Misc open Asttypes open Lambda -open Emitcode +open Cmo_format (* Functions for batch linking *) diff --git a/bytecomp/symtable.mli b/bytecomp/symtable.mli index 674b843a..5743a9b1 100644 --- a/bytecomp/symtable.mli +++ b/bytecomp/symtable.mli @@ -10,11 +10,11 @@ (* *) (***********************************************************************) -(* $Id: symtable.mli,v 1.14 2004/02/22 15:07:50 xleroy Exp $ *) +(* $Id: symtable.mli,v 1.15 2006/05/11 15:50:53 xleroy Exp $ *) (* Assign locations and numbers to globals and primitives *) -open Emitcode +open Cmo_format (* Functions for batch linking *) diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 025c73e3..f785abbe 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: translclass.ml,v 1.38.2.1 2006/03/08 02:05:42 garrigue Exp $ *) +(* $Id: translclass.ml,v 1.41 2006/07/06 07:32:28 garrigue Exp $ *) open Misc open Asttypes @@ -107,7 +107,7 @@ let create_object cl obj init = Lsequence(obj_init, if not has_init then Lvar obj' else Lapply (oo_prim "run_initializers_opt", - [obj; Lvar obj'; Lvar cl])))) + [obj; Lvar obj'; Lvar cl])))) end let rec build_object_init cl_table obj params inh_init obj_init cl = @@ -133,10 +133,10 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = (fun _ -> lambda_unit) cl in (inh_init, lsequence obj_init' obj_init, true) - | Cf_val (_, id, exp) -> + | Cf_val (_, id, Some exp, _) -> (inh_init, lsequence (set_inst_var obj id exp) obj_init, has_init) - | Cf_meth _ -> + | Cf_meth _ | Cf_val _ -> (inh_init, obj_init, has_init) | Cf_init _ -> (inh_init, obj_init, true) @@ -198,7 +198,7 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids = let ((_,inh_init), obj_init) = build_object_init cl_table obj params (envs,[]) (copy_env env) cl in let obj_init = - if ids = [] then obj_init else lfunction [self] obj_init in + if ids = [] then obj_init else lfunction [self] obj_init in (inh_init, lfunction [env] (subst_env env inh_init obj_init)) @@ -213,27 +213,17 @@ let bind_methods tbl meths vals cl_init = if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else if len = 0 && nvals < 2 then transl_vals tbl true vals cl_init else let ids = Ident.create "ids" in - let i = ref len in - let getter, names, cl_init = - match vals with [] -> "get_method_labels", [], cl_init - | (_,id0)::vals' -> - incr i; - let i = ref (List.length vals) in - "new_methods_variables", - [transl_meth_list (List.map fst vals)], - Llet(Strict, id0, lfield ids 0, - List.fold_right - (fun (name,id) rem -> - decr i; - Llet(Alias, id, Lprim(Poffsetint !i, [Lvar id0]), rem)) - vals' cl_init) + let i = ref (len + nvals) in + let getter, names = + if nvals = 0 then "get_method_labels", [] else + "new_methods_variables", [transl_meth_list (List.map fst vals)] in Llet(StrictOpt, ids, Lapply (oo_prim getter, [Lvar tbl; transl_meth_list (List.map fst methl)] @ names), List.fold_right (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam)) - methl cl_init) + (methl @ vals) cl_init) let output_methods tbl methods lam = match methods with @@ -261,11 +251,11 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = Tclass_ident path -> begin match inh_init with (obj_init, path')::inh_init -> - let lpath = transl_path path in + let lpath = transl_path path in (inh_init, - Llet (Strict, obj_init, + Llet (Strict, obj_init, Lapply(Lprim(Pfield 1, [lpath]), Lvar cla :: - if top then [Lprim(Pfield 3, [lpath])] else []), + if top then [Lprim(Pfield 3, [lpath])] else []), bind_super cla super cl_init)) | _ -> assert false @@ -283,8 +273,9 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = (vals, meths_super cla str.cl_meths meths) inh_init cl_init msubst top cl in (inh_init, cl_init, [], values) - | Cf_val (name, id, exp) -> - (inh_init, cl_init, methods, (name, id)::values) + | Cf_val (name, id, exp, over) -> + let values = if over then values else (name, id) :: values in + (inh_init, cl_init, methods, values) | Cf_meth (name, exp) -> let met_code = msubst true (transl_exp exp) in let met_code = @@ -332,42 +323,39 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in let concr_meths = Concr.elements concr_meths in let narrow_args = - [Lvar cla; + [Lvar cla; transl_meth_list vals; transl_meth_list virt_meths; transl_meth_list concr_meths] in let cl = ignore_cstrs cl in begin match cl.cl_desc, inh_init with - Tclass_ident path, (obj_init, path')::inh_init -> - assert (Path.same path path'); - let lpath = transl_path path in + Tclass_ident path, (obj_init, path')::inh_init -> + assert (Path.same path path'); + let lpath = transl_path path in let inh = Ident.create "inh" - and inh_vals = Ident.create "vals" - and inh_meths = Ident.create "meths" + and ofs = List.length vals + 1 and valids, methids = super in let cl_init = List.fold_left (fun init (nm, id, _) -> - Llet(StrictOpt, id, lfield inh_meths (index nm concr_meths), + Llet(StrictOpt, id, lfield inh (index nm concr_meths + ofs), init)) cl_init methids in let cl_init = List.fold_left (fun init (nm, id) -> - Llet(StrictOpt, id, lfield inh_vals (index nm vals), init)) + Llet(StrictOpt, id, lfield inh (index nm vals + 1), init)) cl_init valids in (inh_init, - Llet (Strict, inh, - Lapply(oo_prim "inherits", narrow_args @ - [lpath; Lconst(Const_pointer(if top then 1 else 0))]), - Llet(StrictOpt, obj_init, lfield inh 0, - Llet(Alias, inh_vals, lfield inh 1, - Llet(Alias, inh_meths, lfield inh 2, cl_init))))) + Llet (Strict, inh, + Lapply(oo_prim "inherits", narrow_args @ + [lpath; Lconst(Const_pointer(if top then 1 else 0))]), + Llet(StrictOpt, obj_init, lfield inh 0, cl_init))) | _ -> - let core cl_init = + let core cl_init = build_class_init cla true super inh_init cl_init msubst top cl - in - if cstr then core cl_init else + in + if cstr then core cl_init else let (inh_init, cl_init) = core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]), cl_init)) in @@ -397,12 +385,16 @@ let rec get_class_meths cl = XXX Il devrait etre peu couteux d'ecrire des classes : class c x y = d e f *) -let rec transl_class_rebind obj_init cl = +let rec transl_class_rebind obj_init cl vf = match cl.cl_desc with Tclass_ident path -> + if vf = Concrete then begin + try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit + with Not_found -> raise Exit + end; (path, obj_init) | Tclass_fun (pat, _, cl, partial) -> - let path, obj_init = transl_class_rebind obj_init cl in + let path, obj_init = transl_class_rebind obj_init cl vf in let build params rem = let param = name_pattern "param" [pat, ()] in Lfunction (Curried, param::params, @@ -414,14 +406,14 @@ let rec transl_class_rebind obj_init cl = Lfunction (Curried, params, rem) -> build params rem | rem -> build [] rem) | Tclass_apply (cl, oexprs) -> - let path, obj_init = transl_class_rebind obj_init cl in + let path, obj_init = transl_class_rebind obj_init cl vf in (path, transl_apply obj_init oexprs) | Tclass_let (rec_flag, defs, vals, cl) -> - let path, obj_init = transl_class_rebind obj_init cl in + let path, obj_init = transl_class_rebind obj_init cl vf in (path, Translcore.transl_let rec_flag defs obj_init) | Tclass_structure _ -> raise Exit | Tclass_constraint (cl', _, _, _) -> - let path, obj_init = transl_class_rebind obj_init cl' in + let path, obj_init = transl_class_rebind obj_init cl' vf in let rec check_constraint = function Tcty_constr(path', _, _) when Path.same path path' -> () | Tcty_fun (_, _, cty) -> check_constraint cty @@ -430,21 +422,21 @@ let rec transl_class_rebind obj_init cl = check_constraint cl.cl_type; (path, obj_init) -let rec transl_class_rebind_0 self obj_init cl = +let rec transl_class_rebind_0 self obj_init cl vf = match cl.cl_desc with Tclass_let (rec_flag, defs, vals, cl) -> - let path, obj_init = transl_class_rebind_0 self obj_init cl in + let path, obj_init = transl_class_rebind_0 self obj_init cl vf in (path, Translcore.transl_let rec_flag defs obj_init) | _ -> - let path, obj_init = transl_class_rebind obj_init cl in + let path, obj_init = transl_class_rebind obj_init cl vf in (path, lfunction [self] obj_init) -let transl_class_rebind ids cl = +let transl_class_rebind ids cl vf = try let obj_init = Ident.create "obj_init" and self = Ident.create "self" in let obj_init0 = lapply (Lvar obj_init) [Lvar self] in - let path, obj_init' = transl_class_rebind_0 self obj_init0 cl in + let path, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in if not (Translcore.check_recursive_lambda ids obj_init') then raise(Error(cl.cl_loc, Illegal_class_expr)); let id = (obj_init' = lfunction [self] obj_init0) in @@ -539,9 +531,9 @@ let rec builtin_meths self env env2 body = module M = struct open CamlinternalOO - let builtin_meths arr self env env2 body = + let builtin_meths self env env2 body = let builtin, args = builtin_meths self env env2 body in - if not arr then [Lapply(oo_prim builtin, args)] else + (* if not arr then [Lapply(oo_prim builtin, args)] else *) let tag = match builtin with "get_const" -> GetConst | "get_var" -> GetVar @@ -592,9 +584,9 @@ open M *) -let transl_class ids cl_id arity pub_meths cl = +let transl_class ids cl_id arity pub_meths cl vflag = (* First check if it is not only a rebind *) - let rebind = transl_class_rebind ids cl in + let rebind = transl_class_rebind ids cl vflag in if rebind <> lambda_unit then rebind else (* Prepare for heavy environment handling *) @@ -633,8 +625,8 @@ let transl_class ids cl_id arity pub_meths cl = begin try (* Doesn't seem to improve size for bytecode *) (* if not !Clflags.native_code then raise Not_found; *) - if !Clflags.debug then raise Not_found; - builtin_meths arr [self] env env2 (lfunction args body') + if not arr || !Clflags.debug then raise Not_found; + builtin_meths [self] env env2 (lfunction args body') with Not_found -> [lfunction (self :: args) (if not (IdentSet.mem env (free_variables body')) then body' else @@ -697,16 +689,14 @@ let transl_class ids cl_id arity pub_meths cl = (* Simplest case: an object defined at toplevel (ids=[]) *) if top && ids = [] then llets (ltable cla (ldirect obj_init)) else - let concrete = - ids = [] || - Typeclass.virtual_methods (Ctype.signature_of_class_type cl.cl_type) = [] + let concrete = (vflag = Concrete) and lclass lam = let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in Llet(Strict, class_init, cl_init, lam (free_variables cl_init)) and lbody fv = if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then Lapply (oo_prim "make_class",[transl_meth_list pub_meths; - Lvar class_init]) + Lvar class_init]) else ltable table ( Llet( @@ -714,8 +704,8 @@ let transl_class ids cl_id arity pub_meths cl = Lsequence( Lapply (oo_prim "init_class", [Lvar table]), Lprim(Pmakeblock(0, Immutable), - [Lapply(Lvar env_init, [lambda_unit]); - Lvar class_init; Lvar env_init; lambda_unit])))) + [Lapply(Lvar env_init, [lambda_unit]); + Lvar class_init; Lvar env_init; lambda_unit])))) and lbody_virt lenvs = Lprim(Pmakeblock(0, Immutable), [lambda_unit; Lfunction(Curried,[cla], cl_init); lambda_unit; lenvs]) @@ -801,11 +791,11 @@ let transl_class ids cl_id arity pub_meths cl = (* Wrapper for class compilation *) -let transl_class ids cl_id arity pub_meths cl = - oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths) cl +let transl_class ids cl_id arity pub_meths cl vf = + oo_wrap cl.cl_env false (transl_class ids cl_id arity pub_meths cl) vf let () = - transl_object := (fun id meths cl -> transl_class [] id 0 meths cl) + transl_object := (fun id meths cl -> transl_class [] id 0 meths cl Concrete) (* Error report *) diff --git a/bytecomp/translclass.mli b/bytecomp/translclass.mli index 54301cf5..ab813c10 100644 --- a/bytecomp/translclass.mli +++ b/bytecomp/translclass.mli @@ -10,13 +10,14 @@ (* *) (***********************************************************************) -(* $Id: translclass.mli,v 1.11 2004/08/12 12:55:11 xleroy Exp $ *) +(* $Id: translclass.mli,v 1.12 2006/04/05 02:28:12 garrigue Exp $ *) open Typedtree open Lambda val transl_class : - Ident.t list -> Ident.t -> int -> string list -> class_expr -> lambda;; + Ident.t list -> Ident.t -> + int -> string list -> class_expr -> Asttypes.virtual_flag -> lambda;; type error = Illegal_class_expr | Tags of string * string diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 713ad695..d1135063 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: translcore.ml,v 1.100 2005/08/25 15:35:16 doligez Exp $ *) +(* $Id: translcore.ml,v 1.102 2007/02/09 13:31:15 doligez Exp $ *) (* Translation from typed abstract syntax to lambda terms, for the core language *) @@ -250,12 +250,12 @@ let primitives_table = create_hashtable 57 [ "%int64_to_int32", Pcvtbint(Pint64, Pint32); "%int64_of_nativeint", Pcvtbint(Pnativeint, Pint64); "%int64_to_nativeint", Pcvtbint(Pint64, Pnativeint); - "%bigarray_ref_1", Pbigarrayref(1, Pbigarray_unknown, Pbigarray_c_layout); - "%bigarray_ref_2", Pbigarrayref(2, Pbigarray_unknown, Pbigarray_c_layout); - "%bigarray_ref_3", Pbigarrayref(3, Pbigarray_unknown, Pbigarray_c_layout); - "%bigarray_set_1", Pbigarrayset(1, Pbigarray_unknown, Pbigarray_c_layout); - "%bigarray_set_2", Pbigarrayset(2, Pbigarray_unknown, Pbigarray_c_layout); - "%bigarray_set_3", Pbigarrayset(3, Pbigarray_unknown, Pbigarray_c_layout) + "%caml_ba_ref_1", Pbigarrayref(1, Pbigarray_unknown, Pbigarray_c_layout); + "%caml_ba_ref_2", Pbigarrayref(2, Pbigarray_unknown, Pbigarray_c_layout); + "%caml_ba_ref_3", Pbigarrayref(3, Pbigarray_unknown, Pbigarray_c_layout); + "%caml_ba_set_1", Pbigarrayset(1, Pbigarray_unknown, Pbigarray_c_layout); + "%caml_ba_set_2", Pbigarrayset(2, Pbigarray_unknown, Pbigarray_c_layout); + "%caml_ba_set_3", Pbigarrayset(3, Pbigarray_unknown, Pbigarray_c_layout) ] let prim_makearray = @@ -368,6 +368,7 @@ let check_recursive_lambda idlist lam = List.for_all (check idlist) args | Lprim(Pmakearray(Paddrarray|Pintarray), args) -> List.for_all (check idlist) args + | Lprim (Pmakearray (Pgenarray), args) -> false | Lsequence (lam1, lam2) -> check idlist lam1 && check idlist lam2 | Levent (lam, _) -> check idlist lam | lam -> @@ -385,9 +386,10 @@ let check_recursive_lambda idlist lam = bindings idlist (* reverse-engineering the code generated by transl_record case 2 *) + (* If you change this, you probably need to change Bytegen.size_of_lambda. *) and check_recursive_recordwith idlist = function - | Llet (Strict, id1, Lprim (Pccall prim, [e1]), body) -> - prim = prim_obj_dup && check_top idlist e1 + | Llet (Strict, id1, Lprim (Pduprecord _, [e1]), body) -> + check_top idlist e1 && check_recordwith_updates idlist id1 body | _ -> false @@ -491,7 +493,7 @@ let primitive_is_ccall = function (* Determine if a primitive is a Pccall or will be turned later into a C function call that may raise an exception *) | Pccall _ | Pstringrefs | Pstringsets | Parrayrefs _ | Parraysets _ | - Pbigarrayref _ | Pbigarrayset _ -> true + Pbigarrayref _ | Pbigarrayset _ | Pduprecord _ -> true | _ -> false (* Assertions *) @@ -536,15 +538,15 @@ and transl_exp0 e = let public_send = p.prim_name = "%send" in if public_send || p.prim_name = "%sendself" then let kind = if public_send then Public else Self in - let obj = Ident.create "obj" and meth = Ident.create "meth" in - Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, [])) + let obj = Ident.create "obj" and meth = Ident.create "meth" in + Lfunction(Curried, [obj; meth], Lsend(kind, Lvar meth, Lvar obj, [])) else if p.prim_name = "%sendcache" then - let obj = Ident.create "obj" and meth = Ident.create "meth" in + let obj = Ident.create "obj" and meth = Ident.create "meth" in let cache = Ident.create "cache" and pos = Ident.create "pos" in - Lfunction(Curried, [obj; meth; cache; pos], + Lfunction(Curried, [obj; meth; cache; pos], Lsend(Cached, Lvar meth, Lvar obj, [Lvar cache; Lvar pos])) else - transl_primitive p + transl_primitive p | Texp_ident(path, {val_kind = Val_anc _}) -> raise(Error(e.exp_loc, Free_super_var)) | Texp_ident(path, {val_kind = Val_reg | Val_self _}) -> @@ -576,8 +578,8 @@ and transl_exp0 e = || not !Clflags.native_code && p.prim_name = "%sendcache"in if public_send || p.prim_name = "%sendself" then let kind = if public_send then Public else Self in - let obj = List.hd argl in - wrap (Lsend (kind, List.nth argl 1, obj, [])) + let obj = List.hd argl in + wrap (Lsend (kind, List.nth argl 1, obj, [])) else if p.prim_name = "%sendcache" then match argl with [obj; meth; cache; pos] -> wrap (Lsend(Cached, meth, obj, [cache; pos])) @@ -662,7 +664,7 @@ and transl_exp0 e = let cl = List.map extract_constant ll in let master = match kind with - | Paddrarray | Pintarray -> + | Paddrarray | Pintarray -> Lconst(Const_block(0, cl)) | Pfloatarray -> Lconst(Const_float_array(List.map extract_float cl)) @@ -694,11 +696,11 @@ and transl_exp0 e = | Texp_send(expr, met) -> let obj = transl_exp expr in let lam = - match met with + match met with Tmeth_val id -> Lsend (Self, Lvar id, obj, []) | Tmeth_name nm -> let (tag, cache) = Translobj.meth obj nm in - let kind = if cache = [] then Public else Cached in + let kind = if cache = [] then Public else Cached in Lsend (kind, tag, obj, cache) in event_after e lam @@ -856,8 +858,9 @@ and transl_setinstvar self var expr = [self; transl_path var; transl_exp expr]) and transl_record all_labels repres lbl_expr_list opt_init_expr = + let size = Array.length all_labels in (* Determine if there are "enough" new fields *) - if 3 + 2 * List.length lbl_expr_list >= Array.length all_labels + if 3 + 2 * List.length lbl_expr_list >= size then begin (* Allocate new record with given fields (and remaining fields taken from init_expr if any *) @@ -914,7 +917,7 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr = None -> assert false | Some init_expr -> Llet(Strict, copy_id, - Lprim(Pccall prim_obj_dup, [transl_exp init_expr]), + Lprim(Pduprecord (repres, size), [transl_exp init_expr]), List.fold_right update_field lbl_expr_list (Lvar copy_id)) end end diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index f5998606..eac0c639 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: translmod.ml,v 1.51 2004/08/12 12:55:11 xleroy Exp $ *) +(* $Id: translmod.ml,v 1.52 2006/04/05 02:28:12 garrigue Exp $ *) (* Translation from typed abstract syntax to lambda terms, for the module language *) @@ -317,10 +317,10 @@ and transl_structure fields cc rootpath = function | Tstr_open path :: rem -> transl_structure fields cc rootpath rem | Tstr_class cl_list :: rem -> - let ids = List.map (fun (i, _, _, _) -> i) cl_list in + let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in Lletrec(List.map - (fun (id, arity, meths, cl) -> - (id, transl_class ids id arity meths cl)) + (fun (id, arity, meths, cl, vf) -> + (id, transl_class ids id arity meths cl vf)) cl_list, transl_structure (List.rev ids @ fields) cc rootpath rem) | Tstr_cltype cl_list :: rem -> @@ -414,11 +414,11 @@ let transl_store_structure glob map prims str = | Tstr_open path :: rem -> transl_store subst rem | Tstr_class cl_list :: rem -> - let ids = List.map (fun (i, _, _, _) -> i) cl_list in + let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in let lam = Lletrec(List.map - (fun (id, arity, meths, cl) -> - (id, transl_class ids id arity meths cl)) + (fun (id, arity, meths, cl, vf) -> + (id, transl_class ids id arity meths cl vf)) cl_list, store_idents ids) in Lsequence(subst_lambda subst lam, @@ -485,7 +485,7 @@ let rec defined_idents = function | Tstr_modtype(id, decl) :: rem -> defined_idents rem | Tstr_open path :: rem -> defined_idents rem | Tstr_class cl_list :: rem -> - List.map (fun (i, _, _, _) -> i) cl_list @ defined_idents rem + List.map (fun (i, _, _, _, _) -> i) cl_list @ defined_idents rem | Tstr_cltype cl_list :: rem -> defined_idents rem | Tstr_include(modl, ids) :: rem -> ids @ defined_idents rem @@ -603,14 +603,14 @@ let transl_toplevel_item = function | Tstr_class cl_list -> (* we need to use unique names for the classes because there might be a value named identically *) - let ids = List.map (fun (i, _, _, _) -> i) cl_list in + let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in List.iter set_toplevel_unique_name ids; Lletrec(List.map - (fun (id, arity, meths, cl) -> - (id, transl_class ids id arity meths cl)) + (fun (id, arity, meths, cl, vf) -> + (id, transl_class ids id arity meths cl vf)) cl_list, make_sequence - (fun (id, _, _, _) -> toploop_setvalue_id id) + (fun (id, _, _, _, _) -> toploop_setvalue_id id) cl_list) | Tstr_cltype cl_list -> lambda_unit diff --git a/byterun/.depend b/byterun/.depend index 441b7e79..43277c13 100644 --- a/byterun/.depend +++ b/byterun/.depend @@ -77,7 +77,8 @@ major_gc.o: major_gc.c compact.h config.h ../config/m.h ../config/s.h \ compatibility.h misc.h custom.h mlvalues.h fail.h finalise.h roots.h \ memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h weak.h md5.o: md5.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h md5.h io.h reverse.h + ../config/s.h mlvalues.h fail.h md5.h io.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h reverse.h memory.o: memory.c fail.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h \ minor_gc.h signals.h @@ -107,6 +108,9 @@ signals.o: signals.c alloc.h compatibility.h misc.h config.h \ ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \ sys.h +signals_byt.o: signals_byt.c config.h ../config/m.h ../config/s.h \ + compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ + minor_gc.h osdeps.h signals.h signals_machdep.h stacks.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.h \ fail.h misc.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h @@ -127,11 +131,8 @@ unix.o: unix.c config.h ../config/m.h ../config/s.h compatibility.h \ memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ osdeps.h weak.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ + ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ minor_gc.h -win32.o: win32.c memory.h compatibility.h config.h ../config/m.h \ - ../config/s.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ - osdeps.h signals.h alloc.d.o: alloc.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h custom.h major_gc.h freelist.h memory.h gc.h \ minor_gc.h stacks.h @@ -213,7 +214,8 @@ major_gc.d.o: major_gc.c compact.h config.h ../config/m.h ../config/s.h \ compatibility.h misc.h custom.h mlvalues.h fail.h finalise.h roots.h \ memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h weak.h md5.d.o: md5.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h md5.h io.h reverse.h + ../config/s.h mlvalues.h fail.h md5.h io.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h reverse.h memory.d.o: memory.c fail.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h freelist.h gc.h gc_ctrl.h major_gc.h memory.h \ minor_gc.h signals.h @@ -243,6 +245,9 @@ signals.d.o: signals.c alloc.h compatibility.h misc.h config.h \ ../config/m.h ../config/s.h mlvalues.h callback.h fail.h memory.h gc.h \ major_gc.h freelist.h minor_gc.h roots.h signals.h signals_machdep.h \ sys.h +signals_byt.d.o: signals_byt.c config.h ../config/m.h ../config/s.h \ + compatibility.h memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h \ + minor_gc.h osdeps.h signals.h signals_machdep.h stacks.d.o: stacks.c config.h ../config/m.h ../config/s.h compatibility.h \ fail.h misc.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h @@ -263,8 +268,5 @@ unix.d.o: unix.c config.h ../config/m.h ../config/s.h compatibility.h \ memory.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ osdeps.h weak.d.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \ - ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ + ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ minor_gc.h -win32.d.o: win32.c memory.h compatibility.h config.h ../config/m.h \ - ../config/s.h gc.h mlvalues.h misc.h major_gc.h freelist.h minor_gc.h \ - osdeps.h signals.h diff --git a/byterun/Makefile b/byterun/Makefile index 882ce9b6..e76fab32 100644 --- a/byterun/Makefile +++ b/byterun/Makefile @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.52.2.1 2005/11/29 11:57:49 doligez Exp $ +# $Id: Makefile,v 1.56 2007/02/23 09:29:45 xleroy Exp $ include ../config/Makefile @@ -21,7 +21,7 @@ DFLAGS=-DCAML_NAME_SPACE -g -DDEBUG $(BYTECCCOMPOPTS) OBJS=interp.o misc.o stacks.o fix_code.o startup.o main.o \ freelist.o major_gc.o minor_gc.o memory.o alloc.o roots.o globroots.o \ - fail.o signals.o printexc.o backtrace.o \ + fail.o signals.o signals_byt.o printexc.o backtrace.o \ compare.o ints.o floats.o str.o array.o io.o extern.o intern.o \ hash.o sys.o meta.o parsing.o gc_ctrl.o terminfo.o md5.o obj.o \ lexing.o callback.o debugger.o weak.o compact.o finalise.o custom.o \ @@ -72,6 +72,7 @@ libcamlrund.a: $(DOBJS) clean: rm -f ocamlrun$(EXE) ocamlrund$(EXE) *.o lib*.a rm -f primitives prims.c opnames.h jumptbl.h ld.conf + rm -f version.h primitives : $(PRIMS) sed -n -e "s/CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p" \ @@ -100,10 +101,8 @@ jumptbl.h : instruct.h sed -n -e '/^ /s/ \([A-Z]\)/ \&\&lbl_\1/gp' \ -e '/^}/q' instruct.h > jumptbl.h -version.h : ../stdlib/sys.ml - sed -n -e 's/;;//' \ - -e '/let *ocaml_version *= */s//#define OCAML_VERSION /p' \ - <../stdlib/sys.ml >version.h +version.h : ../VERSION + echo "#define OCAML_VERSION \"`head -1 ../VERSION`\"" >version.h .SUFFIXES: .d.o @@ -114,7 +113,7 @@ version.h : ../stdlib/sys.ml @ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi depend : prims.c opnames.h jumptbl.h version.h - gcc -MM $(BYTECCCOMPOPTS) *.c > .depend - gcc -MM $(BYTECCCOMPOPTS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend + -gcc -MM $(BYTECCCOMPOPTS) *.c > .depend + -gcc -MM $(BYTECCCOMPOPTS) -DDEBUG *.c | sed -e 's/\.o/.d.o/' >> .depend include .depend diff --git a/byterun/Makefile.nt b/byterun/Makefile.nt index d316b528..3e4fcfca 100644 --- a/byterun/Makefile.nt +++ b/byterun/Makefile.nt @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.38.4.1 2005/12/30 09:58:40 xleroy Exp $ +# $Id: Makefile.nt,v 1.44 2007/02/23 09:29:45 xleroy Exp $ include ../config/Makefile @@ -19,7 +19,7 @@ CC=$(BYTECC) CFLAGS=-DIN_OCAMLRUN -DOCAML_STDLIB_DIR='"$(LIBDIR)"' COMMONOBJS=interp.o misc.o stacks.o fix_code.o startup.o \ - fail.o signals.o freelist.o major_gc.o minor_gc.o \ + fail.o signals.o signals_byt.o freelist.o major_gc.o minor_gc.o \ memory.o alloc.o roots.o compare.o ints.o floats.o \ str.o array.o io.o extern.o intern.o hash.o sys.o \ meta.o parsing.o gc_ctrl.o terminfo.o md5.o obj.o lexing.o \ @@ -28,6 +28,8 @@ COMMONOBJS=interp.o misc.o stacks.o fix_code.o startup.o \ DOBJS=$(COMMONOBJS:.o=.$(DO)) prims.$(DO) SOBJS=$(COMMONOBJS:.o=.$(SO)) main.$(SO) +DBGOBJS=$(COMMONOBJS:.o=.$(DBGO)) prims.$(DBGO) main.$(DBGO) instrtrace.$(DBGO) + PRIMS=alloc.c array.c compare.c extern.c floats.c gc_ctrl.c hash.c \ intern.c interp.c ints.c io.c lexing.c md5.c meta.c obj.c parsing.c \ @@ -40,7 +42,7 @@ PUBLIC_INCLUDES=alloc.h callback.h config.h custom.h fail.h intext.h \ all: ocamlrun.exe libcamlrun.$(A) ocamlrun.exe: ocamlrun.dll main.$(DO) - $(CC) -o ocamlrun.exe main.$(DO) ocamlrun.$(A) + $(call MKEXE,ocamlrun.exe,main.$(DO) ocamlrun.$(A)) ocamlrun.dll: $(DOBJS) $(call MKDLL,ocamlrun.dll,ocamlrun.$(A),$(DOBJS) $(BYTECCLIBS)) @@ -48,6 +50,9 @@ ocamlrun.dll: $(DOBJS) libcamlrun.$(A): $(SOBJS) $(call MKLIB,libcamlrun.$(A),$(SOBJS)) +ocamlrund.exe: opnames.h $(DBGOBJS) + $(call MKEXE,ocamlrund.exe,$(BYTECCDBGCOMPOPTS) $(DBGOBJS)) + install: cp ocamlrun.exe $(BINDIR)/ocamlrun.exe cp ocamlrun.dll $(BINDIR)/ocamlrun.dll @@ -76,26 +81,25 @@ prims.c : primitives echo ' 0 };') > prims.c opnames.h : instruct.h - sed -e "/\/\*/d" \ - -e "s\enum /char * names_of_/" \ - -e "s/{$$/[] = {/" \ - -e "s/\([A-Z][A-Z_0-9]*\)/"\1"/g" instruct.h > opnames.h + sed -e '/\/\*/d' \ + -e '/^#/d' \ + -e 's/enum /char * names_of_/' \ + -e 's/{$$/[] = {/' \ + -e 's/\([[:upper:]][[:upper:]_0-9]*\)/"\1"/g' instruct.h > opnames.h # jumptbl.h is required only if you have GCC 2.0 or later jumptbl.h : instruct.h sed -n -e "/^ /s/ \([A-Z]\)/ \&\&lbl_\1/gp" \ -e "/^}/q" instruct.h > jumptbl.h -version.h : ../stdlib/sys.ml - sed -n -e 's/;;//' \ - -e '/let *ocaml_version *= */s//#define OCAML_VERSION /p' \ - <../stdlib/sys.ml >version.h +version.h : ../VERSION + echo "#define OCAML_VERSION \"`head -1 ../VERSION`\"" >version.h main.$(DO): main.c $(CC) $(DLLCCCOMPOPTS) -c main.c mv main.$(O) main.$(DO) -.SUFFIXES: .$(DO) .$(SO) +.SUFFIXES: .$(DO) .$(SO) .$(DBGO) .c.$(DO): $(CC) $(CFLAGS) $(DLLCCCOMPOPTS) -c $< @@ -103,8 +107,11 @@ main.$(DO): main.c .c.$(SO): $(CC) $(CFLAGS) $(BYTECCCOMPOPTS) -c $< mv $*.$(O) $*.$(SO) +.c.$(DBGO): + $(CC) $(CFLAGS) $(BYTECCDBGCOMPOPTS) -c $< + mv $*.$(O) $*.$(DBGO) .depend.nt: .depend - sed -e '/\.d\.o/q' -e 's/^\(.*\)\.o:/\1.$$(DO) \1.$$(SO):/' .depend > .depend.nt + sed -e '/\.d\.o/q' -e 's/^\(.*\)\.o:/\1.$$(DO) \1.$$(SO) \1.$$(DBGO):/' .depend > .depend.nt include .depend.nt diff --git a/byterun/alloc.c b/byterun/alloc.c index cac5b072..5eb8ec5c 100644 --- a/byterun/alloc.c +++ b/byterun/alloc.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: alloc.c,v 1.28 2004/01/01 16:42:34 doligez Exp $ */ +/* $Id: alloc.c,v 1.29 2007/02/09 13:31:15 doligez Exp $ */ /* 1. Allocation functions doing the same work as the macros in the case where [Setup_for_gc] and [Restore_after_gc] are no-ops. @@ -153,13 +153,34 @@ CAMLprim value caml_alloc_dummy(value size) return caml_alloc (wosize, 0); } +CAMLprim value caml_alloc_dummy_float (value size) +{ + mlsize_t wosize = Int_val(size) * Double_wosize; + + if (wosize == 0) return Atom(0); + return caml_alloc (wosize, 0); +} + CAMLprim value caml_update_dummy(value dummy, value newval) { mlsize_t size, i; + tag_t tag; + size = Wosize_val(newval); + tag = Tag_val (newval); Assert (size == Wosize_val(dummy)); - Tag_val(dummy) = Tag_val(newval); - for (i = 0; i < size; i++) - caml_modify(&Field(dummy, i), Field(newval, i)); + Assert (tag < No_scan_tag || tag == Double_array_tag); + + Tag_val(dummy) = tag; + if (tag == Double_array_tag){ + size = Wosize_val (newval) / Double_wosize; + for (i = 0; i < size; i++){ + Store_double_field (dummy, i, Double_field (newval, i)); + } + }else{ + for (i = 0; i < size; i++){ + caml_modify (&Field(dummy, i), Field(newval, i)); + } + } return Val_unit; } diff --git a/byterun/backtrace.c b/byterun/backtrace.c index d29c659c..dd35361b 100644 --- a/byterun/backtrace.c +++ b/byterun/backtrace.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: backtrace.c,v 1.23 2005/10/25 16:22:38 doligez Exp $ */ +/* $Id: backtrace.c,v 1.24 2007/01/29 12:11:15 xleroy Exp $ */ /* Stack backtrace for uncaught exceptions */ @@ -170,7 +170,7 @@ static value event_for_location(value events, code_t pc) static void print_location(value events, int index) { - code_t pc = caml_backtrace_buffer[index]; + code_t pc = caml_backtrace_buffer[index]; char * info; value ev; diff --git a/byterun/backtrace.h b/byterun/backtrace.h index 9d267800..f962ad7b 100644 --- a/byterun/backtrace.h +++ b/byterun/backtrace.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: backtrace.h,v 1.6 2003/12/31 14:20:35 doligez Exp $ */ +/* $Id: backtrace.h,v 1.7 2007/01/29 12:11:15 xleroy Exp $ */ #ifndef CAML_BACKTRACE_H #define CAML_BACKTRACE_H @@ -24,7 +24,9 @@ CAMLextern code_t * caml_backtrace_buffer; CAMLextern value caml_backtrace_last_exn; extern void caml_init_backtrace(void); +#ifndef NATIVE_CODE extern void caml_stash_backtrace(value exn, code_t pc, value * sp); +#endif CAMLextern void caml_print_exception_backtrace(void); #endif /* CAML_BACKTRACE_H */ diff --git a/byterun/callback.c b/byterun/callback.c index 1d51ad13..2a5ea816 100644 --- a/byterun/callback.c +++ b/byterun/callback.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: callback.c,v 1.22.10.1 2005/12/30 09:57:09 xleroy Exp $ */ +/* $Id: callback.c,v 1.24 2006/09/11 12:12:24 doligez Exp $ */ /* Callbacks from C to Caml */ @@ -34,7 +34,7 @@ CAMLexport int caml_callback_depth = 0; #ifndef LOCAL_CALLBACK_BYTECODE static opcode_t callback_code[] = { ACC, 0, APPLY, 0, POP, 1, STOP }; -#endif +#endif #ifdef THREADED_CODE @@ -207,7 +207,7 @@ struct named_value { static struct named_value * named_value_table[Named_value_size] = { NULL, }; -static unsigned int hash_value_name(char *name) +static unsigned int hash_value_name(char const *name) { unsigned int h; for (h = 0; *name != 0; name++) h = h * 19 + *name; @@ -236,7 +236,7 @@ CAMLprim value caml_register_named_value(value vname, value val) return Val_unit; } -CAMLexport value * caml_named_value(char *name) +CAMLexport value * caml_named_value(char const *name) { struct named_value * nv; for (nv = named_value_table[hash_value_name(name)]; diff --git a/byterun/callback.h b/byterun/callback.h index ec03ed8e..e7339473 100644 --- a/byterun/callback.h +++ b/byterun/callback.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: callback.h,v 1.13 2004/01/05 20:25:58 doligez Exp $ */ +/* $Id: callback.h,v 1.14 2006/09/11 12:12:24 doligez Exp $ */ /* Callbacks from C to Caml */ @@ -39,7 +39,7 @@ CAMLextern value caml_callbackN_exn (value closure, int narg, value args[]); #define Is_exception_result(v) (((v) & 3) == 2) #define Extract_exception(v) ((v) & ~3) -CAMLextern value * caml_named_value (char * name); +CAMLextern value * caml_named_value (char const * name); CAMLextern void caml_main (char ** argv); CAMLextern void caml_startup (char ** argv); diff --git a/byterun/compare.c b/byterun/compare.c index 7478ad4a..9d59107b 100644 --- a/byterun/compare.c +++ b/byterun/compare.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: compare.c,v 1.34 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: compare.c,v 1.36 2007/02/09 13:31:15 doligez Exp $ */ #include #include @@ -83,7 +83,7 @@ static struct compare_item * compare_resize_stack(struct compare_item * sp) #define LESS -1 #define EQUAL 0 #define GREATER 1 -#define UNORDERED (1L << (8 * sizeof(value) - 1)) +#define UNORDERED ((intnat)1 << (8 * sizeof(value) - 1)) /* The return value of compare_val is as follows: > 0 v1 is greater than v2 @@ -199,7 +199,10 @@ static intnat compare_val(value v1, value v2, int total) case Custom_tag: { int res; int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare; - if (compare == NULL) caml_invalid_argument("equal: abstract value"); + if (compare == NULL) { + compare_free_stack(); + caml_invalid_argument("equal: abstract value"); + } caml_compare_unordered = 0; res = Custom_ops_val(v1)->compare(v1, v2); if (caml_compare_unordered && !total) return UNORDERED; diff --git a/byterun/compatibility.h b/byterun/compatibility.h index aba6751f..0eca2794 100644 --- a/byterun/compatibility.h +++ b/byterun/compatibility.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: compatibility.h,v 1.14 2005/07/29 12:11:00 xleroy Exp $ */ +/* $Id: compatibility.h,v 1.15 2006/01/27 14:33:42 doligez Exp $ */ /* definitions for compatibility with old identifiers */ @@ -305,5 +305,70 @@ /* **** asmcomp/asmlink.ml, asmcomp/cmmgen.ml, asmcomp/compilenv.ml */ +/* ************************************************************* */ + +/* **** otherlibs/bigarray */ +#define int8 caml_ba_int8 +#define uint8 caml_ba_uint8 +#define int16 caml_ba_int16 +#define uint16 caml_ba_uint16 +#define MAX_NUM_DIMS CAML_BA_MAX_NUM_DIMS +#define caml_bigarray_kind caml_ba_kind +#define BIGARRAY_FLOAT32 CAML_BA_FLOAT32 +#define BIGARRAY_FLOAT64 CAML_BA_FLOAT64 +#define BIGARRAY_SINT8 CAML_BA_SINT8 +#define BIGARRAY_UINT8 CAML_BA_UINT8 +#define BIGARRAY_SINT16 CAML_BA_SINT16 +#define BIGARRAY_UINT16 CAML_BA_UINT16 +#define BIGARRAY_INT32 CAML_BA_INT32 +#define BIGARRAY_INT64 CAML_BA_INT64 +#define BIGARRAY_CAML_INT CAML_BA_CAML_INT +#define BIGARRAY_NATIVE_INT CAML_BA_NATIVE_INT +#define BIGARRAY_COMPLEX32 CAML_BA_COMPLEX32 +#define BIGARRAY_COMPLEX64 CAML_BA_COMPLEX64 +#define BIGARRAY_KIND_MASK CAML_BA_KIND_MASK +#define caml_bigarray_layout caml_ba_layout +#define BIGARRAY_C_LAYOUT CAML_BA_C_LAYOUT +#define BIGARRAY_FORTRAN_LAYOUT CAML_BA_FORTRAN_LAYOUT +#define BIGARRAY_LAYOUT_MASK CAML_BA_LAYOUT_MASK +#define caml_bigarray_managed caml_ba_managed +#define BIGARRAY_EXTERNAL CAML_BA_EXTERNAL +#define BIGARRAY_MANAGED CAML_BA_MANAGED +#define BIGARRAY_MAPPED_FILE CAML_BA_MAPPED_FILE +#define BIGARRAY_MANAGED_MASK CAML_BA_MANAGED_MASK +#define caml_bigarray_proxy caml_ba_proxy +#define caml_bigarray caml_ba_array +#define Bigarray_val Caml_ba_array_val +#define Data_bigarray_val Caml_ba_data_val +#define alloc_bigarray caml_ba_alloc +#define alloc_bigarray_dims caml_ba_alloc_dims +#define bigarray_map_file caml_ba_map_file +#define bigarray_unmap_file caml_ba_unmap_file +#define bigarray_element_size caml_ba_element_size +#define bigarray_byte_size caml_ba_byte_size +#define bigarray_deserialize caml_ba_deserialize +#define MAX_BIGARRAY_MEMORY CAML_BA_MAX_MEMORY +#define bigarray_create caml_ba_create +#define bigarray_get_N caml_ba_get_N +#define bigarray_get_1 caml_ba_get_1 +#define bigarray_get_2 caml_ba_get_2 +#define bigarray_get_3 caml_ba_get_3 +#define bigarray_get_generic caml_ba_get_generic +#define bigarray_set_1 caml_ba_set_1 +#define bigarray_set_2 caml_ba_set_2 +#define bigarray_set_3 caml_ba_set_3 +#define bigarray_set_N caml_ba_set_N +#define bigarray_set_generic caml_ba_set_generic +#define bigarray_num_dims caml_ba_num_dims +#define bigarray_dim caml_ba_dim +#define bigarray_kind caml_ba_kind +#define bigarray_layout caml_ba_layout +#define bigarray_slice caml_ba_slice +#define bigarray_sub caml_ba_sub +#define bigarray_blit caml_ba_blit +#define bigarray_fill caml_ba_fill +#define bigarray_reshape caml_ba_reshape +#define bigarray_init caml_ba_init + #endif /* CAML_NAME_SPACE */ #endif /* CAML_COMPATIBILITY_H */ diff --git a/byterun/config.h b/byterun/config.h index 832c208b..a2a5087b 100644 --- a/byterun/config.h +++ b/byterun/config.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: config.h,v 1.39 2005/09/24 09:19:28 xleroy Exp $ */ +/* $Id: config.h,v 1.40 2006/09/19 12:40:29 xleroy Exp $ */ #ifndef CAML_CONFIG_H #define CAML_CONFIG_H @@ -117,7 +117,7 @@ typedef struct { uint32 l, h; } uint64, int64; #define Stack_threshold (256 * sizeof(value)) /* Default maximum size of the stack (words). */ -#define Max_stack_def (256 * 1024) +#define Max_stack_def (1024 * 1024) /* Maximum size of a block allocated in the young generation (words). */ diff --git a/byterun/dynlink.c b/byterun/dynlink.c index 72ddccd5..601e4cc2 100644 --- a/byterun/dynlink.c +++ b/byterun/dynlink.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: dynlink.c,v 1.15 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: dynlink.c,v 1.17 2006/10/03 11:52:15 xleroy Exp $ */ /* Dynamic loading of C primitives. */ @@ -123,7 +123,7 @@ static void open_shared_lib(char * name) realname = caml_search_dll_in_path(&caml_shared_libs_path, name); caml_gc_message(0x100, "Loading shared library %s\n", (uintnat) realname); - handle = caml_dlopen(realname); + handle = caml_dlopen(realname, 1); if (handle == NULL) caml_fatal_error_arg2("Fatal error: cannot load shared library %s\n", name, "Reason: %s\n", caml_dlerror()); @@ -194,12 +194,14 @@ void caml_build_primitive_table_builtin(void) #define Handle_val(v) (*((void **) (v))) -CAMLprim value caml_dynlink_open_lib(value filename) +CAMLprim value caml_dynlink_open_lib(value mode, value filename) { void * handle; value result; - handle = caml_dlopen(String_val(filename)); + caml_gc_message(0x100, "Opening shared library %s\n", + (uintnat) String_val(filename)); + handle = caml_dlopen(String_val(filename), Int_val(mode)); if (handle == NULL) caml_failwith(caml_dlerror()); result = caml_alloc_small(1, Abstract_tag); Handle_val(result) = handle; diff --git a/byterun/extern.c b/byterun/extern.c index 496bf606..111d04d8 100644 --- a/byterun/extern.c +++ b/byterun/extern.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: extern.c,v 1.58.2.2 2006/06/10 09:02:40 xleroy Exp $ */ +/* $Id: extern.c,v 1.61 2006/09/20 11:14:36 doligez Exp $ */ /* Structured output */ @@ -299,7 +299,7 @@ static void extern_rec(value v) } else if (n >= -(1 << 15) && n < (1 << 15)) { writecode16(CODE_INT16, n); #ifdef ARCH_SIXTYFOUR - } else if (n < -(1L << 31) || n >= (1L << 31)) { + } else if (n < -((intnat)1 << 31) || n >= ((intnat)1 << 31)) { writecode64(CODE_INT64, n); #endif } else @@ -401,7 +401,7 @@ static void extern_rec(value v) void (*serialize)(value v, uintnat * wsize_32, uintnat * wsize_64) = Custom_ops_val(v)->serialize; - if (serialize == NULL) + if (serialize == NULL) extern_invalid_argument("output_value: abstract value (Custom)"); Write(CODE_CUSTOM); writeblock(ident, strlen(ident) + 1); @@ -417,7 +417,7 @@ static void extern_rec(value v) if (tag < 16 && sz < 8) { Write(PREFIX_SMALL_BLOCK + tag + (sz << 4)); #ifdef ARCH_SIXTYFOUR - } else if (hd >= (1UL << 32)) { + } else if (hd >= ((uintnat)1 << 32)) { writecode64(CODE_BLOCK64, Whitehd_hd (hd)); #endif } else { @@ -478,8 +478,8 @@ static intnat extern_value(value v, value flags) /* Write the sizes */ res_len = extern_output_length(); #ifdef ARCH_SIXTYFOUR - if (res_len >= (1L << 32) || - size_32 >= (1L << 32) || size_64 >= (1L << 32)) { + if (res_len >= ((intnat)1 << 32) || + size_32 >= ((intnat)1 << 32) || size_64 >= ((intnat)1 << 32)) { /* The object is so big its size cannot be written in the header. Besides, some of the array lengths or string lengths or shared offsets it contains may have overflowed the 32 bits used to write them. */ @@ -707,7 +707,7 @@ CAMLexport void caml_serialize_block_float_8(void * data, intnat len) memmove(extern_ptr, data, len * 8); extern_ptr += len * 8; #elif ARCH_FLOAT_ENDIANNESS == 0x76543210 - { + { unsigned char * p; char * q; for (p = data, q = extern_ptr; len > 0; len--, p += 8, q += 8) @@ -715,7 +715,7 @@ CAMLexport void caml_serialize_block_float_8(void * data, intnat len) extern_ptr = q; } #else - { + { unsigned char * p; char * q; for (p = data, q = extern_ptr; len > 0; len--, p += 8, q += 8) diff --git a/byterun/fail.c b/byterun/fail.c index 9afc8e32..ed185760 100644 --- a/byterun/fail.c +++ b/byterun/fail.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: fail.c,v 1.30 2005/10/18 14:03:34 xleroy Exp $ */ +/* $Id: fail.c,v 1.31 2006/11/24 14:40:11 doligez Exp $ */ /* Raising exceptions from C. */ @@ -60,7 +60,7 @@ CAMLexport void caml_raise_with_arg(value tag, value arg) CAMLnoreturn; } -CAMLexport void caml_raise_with_string(value tag, char *msg) +CAMLexport void caml_raise_with_string(value tag, char const *msg) { CAMLparam1 (tag); CAMLlocal1 (vmsg); @@ -70,12 +70,12 @@ CAMLexport void caml_raise_with_string(value tag, char *msg) CAMLnoreturn; } -CAMLexport void caml_failwith (char *msg) +CAMLexport void caml_failwith (char const *msg) { caml_raise_with_string(Field(caml_global_data, FAILURE_EXN), msg); } -CAMLexport void caml_invalid_argument (char *msg) +CAMLexport void caml_invalid_argument (char const *msg) { caml_raise_with_string(Field(caml_global_data, INVALID_EXN), msg); } @@ -96,7 +96,7 @@ static struct { CAMLexport void caml_raise_out_of_memory(void) { - if (out_of_memory_bucket.exn == 0) + if (out_of_memory_bucket.exn == 0) caml_fatal_error ("Fatal error: out of memory while raising Out_of_memory\n"); caml_raise((value) &(out_of_memory_bucket.exn)); diff --git a/byterun/fail.h b/byterun/fail.h index 9cd2fad2..2cc3c3be 100644 --- a/byterun/fail.h +++ b/byterun/fail.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: fail.h,v 1.25 2004/01/02 19:23:20 doligez Exp $ */ +/* $Id: fail.h,v 1.26 2006/11/24 14:40:11 doligez Exp $ */ #ifndef CAML_FAIL_H #define CAML_FAIL_H @@ -60,9 +60,9 @@ extern value caml_exn_bucket; CAMLextern void caml_raise (value bucket) Noreturn; CAMLextern void caml_raise_constant (value tag) Noreturn; CAMLextern void caml_raise_with_arg (value tag, value arg) Noreturn; -CAMLextern void caml_raise_with_string (value tag, char * msg) Noreturn; -CAMLextern void caml_failwith (char *) Noreturn; -CAMLextern void caml_invalid_argument (char *) Noreturn; +CAMLextern void caml_raise_with_string (value tag, char const * msg) Noreturn; +CAMLextern void caml_failwith (char const *) Noreturn; +CAMLextern void caml_invalid_argument (char const *) Noreturn; CAMLextern void caml_raise_out_of_memory (void) Noreturn; CAMLextern void caml_raise_stack_overflow (void) Noreturn; CAMLextern void caml_raise_sys_error (value) Noreturn; diff --git a/byterun/interp.c b/byterun/interp.c index 66e99c9b..58d81fd6 100644 --- a/byterun/interp.c +++ b/byterun/interp.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: interp.c,v 1.95 2005/10/25 18:34:07 doligez Exp $ */ +/* $Id: interp.c,v 1.96 2006/08/18 14:51:59 xleroy Exp $ */ /* The bytecode interpreter */ #include @@ -139,7 +139,7 @@ sp is a local copy of the global variable caml_extern_sp. */ #define SP_REG asm("%edi") #define ACCU_REG #endif -#ifdef __ppc__ +#if defined(__ppc__) || defined(__ppc64__) #define PC_REG asm("26") #define SP_REG asm("27") #define ACCU_REG asm("28") diff --git a/byterun/ints.c b/byterun/ints.c index 21f1514d..063b75f0 100644 --- a/byterun/ints.c +++ b/byterun/ints.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: ints.c,v 1.48 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: ints.c,v 1.50 2006/05/05 13:50:45 xleroy Exp $ */ #include #include @@ -84,12 +84,12 @@ static intnat parse_intnat(value s, int nbits) } if (base == 10) { /* Signed representation expected, allow -2^(nbits-1) to 2^(nbits - 1) */ - if (res > 1UL << (nbits - 1)) + if (res > (uintnat)1 << (nbits - 1)) caml_failwith("int_of_string"); } else { /* Unsigned representation expected, allow 0 to 2^nbits - 1 and tolerate -(2^nbits - 1) to 0 */ - if (nbits < sizeof(uintnat) * 8 && res >= 1UL << nbits) + if (nbits < sizeof(uintnat) * 8 && res >= (uintnat)1 << nbits) caml_failwith("int_of_string"); } return sign < 0 ? -((intnat) res) : (intnat) res; @@ -176,7 +176,8 @@ CAMLprim value caml_format_int(value fmt, value arg) char conv; value res; - buffer = parse_format(fmt, "l", format_string, default_format_buffer, &conv); + buffer = parse_format(fmt, ARCH_INTNAT_PRINTF_FORMAT, + format_string, default_format_buffer, &conv); switch (conv) { case 'u': case 'x': case 'X': case 'o': sprintf(buffer, format_string, Unsigned_long_val(arg)); @@ -600,11 +601,11 @@ static uintnat nativeint_deserialize(void * dst) { switch (caml_deserialize_uint_1()) { case 1: - *((long *) dst) = caml_deserialize_sint_4(); + *((intnat *) dst) = caml_deserialize_sint_4(); break; case 2: #ifdef ARCH_SIXTYFOUR - *((long *) dst) = caml_deserialize_sint_8(); + *((intnat *) dst) = caml_deserialize_sint_8(); #else caml_deserialize_error("input_value: native integer value too large"); #endif @@ -719,7 +720,7 @@ CAMLprim value caml_nativeint_format(value fmt, value arg) buffer = parse_format(fmt, ARCH_INTNAT_PRINTF_FORMAT, format_string, default_format_buffer, &conv); - sprintf(buffer, format_string, (long) Nativeint_val(arg)); + sprintf(buffer, format_string, Nativeint_val(arg)); res = caml_copy_string(buffer); if (buffer != default_format_buffer) caml_stat_free(buffer); return res; diff --git a/byterun/io.c b/byterun/io.c index 4139a7ee..04b97461 100644 --- a/byterun/io.c +++ b/byterun/io.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: io.c,v 1.72.2.2 2006/06/08 14:57:59 xleroy Exp $ */ +/* $Id: io.c,v 1.77 2007/02/25 12:38:36 xleroy Exp $ */ /* Buffered input/output. */ @@ -69,6 +69,7 @@ CAMLexport struct channel * caml_open_descriptor_in(int fd) channel->revealed = 0; channel->old_revealed = 0; channel->refcount = 0; + channel->flags = 0; channel->next = caml_all_opened_channels; channel->prev = NULL; if (caml_all_opened_channels != NULL) @@ -162,7 +163,7 @@ again: n = 1; goto again; } } - if (retcode == -1) caml_sys_error(NO_ARG); + if (retcode == -1) caml_sys_io_error(NO_ARG); return retcode; } @@ -265,7 +266,7 @@ CAMLexport int caml_do_read(int fd, char *p, unsigned int n) retcode = read(fd, p, n); caml_leave_blocking_section(); } while (retcode == -1 && errno == EINTR); - if (retcode == -1) caml_sys_error(NO_ARG); + if (retcode == -1) caml_sys_io_error(NO_ARG); return retcode; } @@ -534,7 +535,7 @@ CAMLprim value caml_ml_flush_partial(value vchannel) struct channel * channel = Channel(vchannel); int res; - if (channel->fd == -1) CAMLreturn (Val_true); + if (channel->fd == -1) CAMLreturn(Val_true); Lock(channel); res = caml_flush_partial(channel); Unlock(channel); @@ -546,7 +547,7 @@ CAMLprim value caml_ml_flush(value vchannel) CAMLparam1 (vchannel); struct channel * channel = Channel(vchannel); - if (channel->fd == -1) CAMLreturn (Val_unit); + if (channel->fd == -1) CAMLreturn(Val_unit); Lock(channel); caml_flush(channel); Unlock(channel); diff --git a/byterun/io.h b/byterun/io.h index 97efb22b..d67ceb4f 100644 --- a/byterun/io.h +++ b/byterun/io.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: io.h,v 1.29 2005/09/24 16:14:41 xleroy Exp $ */ +/* $Id: io.h,v 1.30 2006/09/20 17:37:08 xleroy Exp $ */ /* Buffered input/output */ @@ -47,9 +47,14 @@ struct channel { int revealed; /* For Cash only */ int old_revealed; /* For Cash only */ int refcount; /* For flush_all and for Cash */ + int flags; /* Bitfield */ char buff[IO_BUFFER_SIZE]; /* The buffer itself */ }; +enum { + CHANNEL_FLAG_FROM_SOCKET = 1, /* For Windows */ +}; + /* For an output channel: [offset] is the absolute position of the beginning of the buffer [buff]. For an input channel: @@ -73,6 +78,7 @@ CAMLextern struct channel * caml_open_descriptor_in (int); CAMLextern struct channel * caml_open_descriptor_out (int); CAMLextern void caml_close_channel (struct channel *); CAMLextern int caml_channel_binary_mode (struct channel *); +CAMLextern value caml_alloc_channel(struct channel *chan); CAMLextern int caml_flush_partial (struct channel *); CAMLextern void caml_flush (struct channel *); diff --git a/byterun/md5.c b/byterun/md5.c index 8c3b5219..700b765b 100644 --- a/byterun/md5.c +++ b/byterun/md5.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: md5.c,v 1.19.2.1 2006/03/22 12:59:58 doligez Exp $ */ +/* $Id: md5.c,v 1.20 2006/04/16 23:28:21 doligez Exp $ */ #include #include "alloc.h" diff --git a/byterun/memory.h b/byterun/memory.h index 9a65e39e..3723d04f 100644 --- a/byterun/memory.h +++ b/byterun/memory.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: memory.h,v 1.54.2.3 2006/07/25 09:13:16 doligez Exp $ */ +/* $Id: memory.h,v 1.56 2007/02/09 13:31:15 doligez Exp $ */ /* Allocation macros and functions */ @@ -277,12 +277,14 @@ CAMLextern struct caml__roots_block *caml_local_roots; /* defined in roots.c */ return; \ }while (0) -#define CAMLreturn(result) do{ \ - value caml__temp_result = (result); \ +#define CAMLreturnT(type, result) do{ \ + type caml__temp_result = (result); \ caml_local_roots = caml__frame; \ return (caml__temp_result); \ }while(0) +#define CAMLreturn(result) CAMLreturnT(value, result) + #define CAMLnoreturn ((void) caml__frame) diff --git a/byterun/meta.c b/byterun/meta.c index 477e4a03..c0e38efd 100644 --- a/byterun/meta.c +++ b/byterun/meta.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: meta.c,v 1.31 2004/04/26 14:09:01 basile Exp $ */ +/* $Id: meta.c,v 1.32 2007/01/29 12:11:15 xleroy Exp $ */ /* Primitives for the toplevel */ @@ -160,14 +160,9 @@ value * caml_stack_high; value * caml_stack_threshold; value * caml_extern_sp; value * caml_trapsp; -int caml_backtrace_active; -int caml_backtrace_pos; -code_t * caml_backtrace_buffer; -value caml_backtrace_last_exn; int caml_callback_depth; int volatile caml_something_to_do; void (* volatile caml_async_action_hook)(void); -void caml_print_exception_backtrace(void) { } struct longjmp_buffer * caml_external_raise; #endif diff --git a/byterun/mlvalues.h b/byterun/mlvalues.h index f09bb70c..f25e85e7 100644 --- a/byterun/mlvalues.h +++ b/byterun/mlvalues.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: mlvalues.h,v 1.51 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: mlvalues.h,v 1.53 2007/02/09 13:31:15 doligez Exp $ */ #ifndef CAML_MLVALUES_H #define CAML_MLVALUES_H @@ -68,8 +68,8 @@ typedef uintnat mark_t; /* Example: Val_long as in "Val from long" or "Val of long". */ #define Val_long(x) (((intnat)(x) << 1) + 1) #define Long_val(x) ((x) >> 1) -#define Max_long ((1L << (8 * sizeof(value) - 2)) - 1) -#define Min_long (-(1L << (8 * sizeof(value) - 2))) +#define Max_long (((intnat)1 << (8 * sizeof(value) - 2)) - 1) +#define Min_long (-((intnat)1 << (8 * sizeof(value) - 2))) #define Val_int(x) Val_long(x) #define Int_val(x) ((int) Long_val(x)) #define Unsigned_long_val(x) ((uintnat)(x) >> 1) @@ -109,7 +109,7 @@ bits 63 10 9 8 7 0 #define Num_tags (1 << 8) #ifdef ARCH_SIXTYFOUR -#define Max_wosize ((1L << 54) - 1) +#define Max_wosize (((intnat)1 << 54) - 1) #else #define Max_wosize ((1 << 22) - 1) #endif @@ -239,7 +239,7 @@ CAMLextern void caml_Store_double_val (value,double); #define Store_double_field(v,i,d) do{ \ mlsize_t caml__temp_i = (i); \ double caml__temp_d = (d); \ - Store_double_val((value)((double *) v + caml__temp_i), caml__temp_d); \ + Store_double_val((value)((double *) (v) + caml__temp_i), caml__temp_d); \ }while(0) /* Custom blocks. They contain a pointer to a "method suite" diff --git a/byterun/osdeps.h b/byterun/osdeps.h index 12c608c0..2357f195 100644 --- a/byterun/osdeps.h +++ b/byterun/osdeps.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: osdeps.h,v 1.9 2004/01/02 19:23:25 doligez Exp $ */ +/* $Id: osdeps.h,v 1.10 2006/09/28 21:36:38 xleroy Exp $ */ /* Operating system - specific stuff */ @@ -36,8 +36,13 @@ CAMLextern char * caml_search_exe_in_path(char * name); extern char * caml_search_dll_in_path(struct ext_table * path, char * name); /* Open a shared library and return a handle on it. + If [for_execution] is true, perform full symbol resolution and + execute initialization code so that functions from the shared library + can be called. If [for_execution] is false, functions from this + shared library will not be called, but just checked for presence, + so symbol resolution can be skipped. Return [NULL] on error. */ -extern void * caml_dlopen(char * libname); +extern void * caml_dlopen(char * libname, int for_execution); /* Close a shared library handle */ extern void caml_dlclose(void * handle); diff --git a/byterun/printexc.c b/byterun/printexc.c index 90811534..b0003f1c 100644 --- a/byterun/printexc.c +++ b/byterun/printexc.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: printexc.c,v 1.16 2004/01/08 22:28:48 doligez Exp $ */ +/* $Id: printexc.c,v 1.17 2007/01/29 12:11:15 xleroy Exp $ */ /* Print an uncaught exception and abort */ @@ -97,33 +97,30 @@ void caml_fatal_uncaught_exception(value exn) { char * msg; value * at_exit; -#ifndef NATIVE_CODE int saved_backtrace_active, saved_backtrace_pos; -#endif + /* Build a string representation of the exception */ msg = caml_format_exception(exn); /* Perform "at_exit" processing, ignoring all exceptions that may be triggered by this */ -#ifndef NATIVE_CODE saved_backtrace_active = caml_backtrace_active; saved_backtrace_pos = caml_backtrace_pos; caml_backtrace_active = 0; -#endif at_exit = caml_named_value("Pervasives.do_at_exit"); if (at_exit != NULL) caml_callback_exn(*at_exit, Val_unit); -#ifndef NATIVE_CODE caml_backtrace_active = saved_backtrace_active; caml_backtrace_pos = saved_backtrace_pos; -#endif /* Display the uncaught exception */ fprintf(stderr, "Fatal error: exception %s\n", msg); free(msg); /* Display the backtrace if available */ + if (caml_backtrace_active #ifndef NATIVE_CODE - if (caml_backtrace_active && !caml_debugger_in_use){ + && !caml_debugger_in_use +#endif + ) { caml_print_exception_backtrace(); } -#endif /* Terminate the process */ exit(2); } diff --git a/byterun/signals.c b/byterun/signals.c index eaa5a965..a7236218 100644 --- a/byterun/signals.c +++ b/byterun/signals.c @@ -11,7 +11,9 @@ /* */ /***********************************************************************/ -/* $Id: signals.c,v 1.51.2.1 2006/03/22 13:13:45 xleroy Exp $ */ +/* $Id: signals.c,v 1.53 2007/02/23 09:29:45 xleroy Exp $ */ + +/* Signal handling, code common to the bytecode and native systems */ #include #include "alloc.h" @@ -30,20 +32,14 @@ #define NSIG 64 #endif -#ifdef _WIN32 -typedef void (*sighandler)(int sig); -extern sighandler caml_win32_signal(int sig, sighandler action); -#define signal(sig,act) caml_win32_signal(sig,act) -#endif +/* The set of pending signals (received but not yet processed) */ CAMLexport intnat volatile caml_signals_are_pending = 0; CAMLexport intnat volatile caml_pending_signals[NSIG]; -CAMLexport int volatile caml_something_to_do = 0; -int volatile caml_force_major_slice = 0; -value caml_signal_handlers = 0; -CAMLexport void (* volatile caml_async_action_hook)(void) = NULL; -static void caml_process_pending_signals(void) +/* Execute all pending signals */ + +void caml_process_pending_signals(void) { int i; @@ -58,20 +54,26 @@ static void caml_process_pending_signals(void) } } -void caml_process_event(void) -{ - void (*async_action)(void); +/* Record the delivery of a signal, and arrange for it to be processed + as soon as possible: + - in bytecode: via caml_something_to_do, processed in caml_process_event + - in native-code: by playing with the allocation limit, processed + in caml_garbage_collection +*/ - if (caml_force_major_slice) caml_minor_collection (); - /* FIXME should be [caml_check_urgent_gc] */ - caml_process_pending_signals(); - async_action = caml_async_action_hook; - if (async_action != NULL) { - caml_async_action_hook = NULL; - (*async_action)(); - } +void caml_record_signal(int signal_number) +{ + caml_pending_signals[signal_number] = 1; + caml_signals_are_pending = 1; +#ifndef NATIVE_CODE + caml_something_to_do = 1; +#else + caml_young_limit = caml_young_end; +#endif } +/* Management of blocking sections. */ + static intnat volatile caml_async_signal_mode = 0; static void caml_enter_blocking_section_default(void) @@ -100,10 +102,29 @@ CAMLexport void (*caml_leave_blocking_section_hook)(void) = CAMLexport int (*caml_try_leave_blocking_section_hook)(void) = caml_try_leave_blocking_section_default; -CAMLexport int caml_rev_convert_signal_number(int signo); +CAMLexport void caml_enter_blocking_section(void) +{ + while (1){ + /* Process all pending signals now */ + caml_process_pending_signals(); + caml_enter_blocking_section_hook (); + /* Check again for pending signals. + If none, done; otherwise, try again */ + if (! caml_signals_are_pending) break; + caml_leave_blocking_section_hook (); + } +} + +CAMLexport void caml_leave_blocking_section(void) +{ + caml_leave_blocking_section_hook (); + caml_process_pending_signals(); +} /* Execute a signal handler immediately */ +static value caml_signal_handlers = 0; + void caml_execute_signal(int signal_number, int in_signal_handler) { value res; @@ -131,54 +152,25 @@ void caml_execute_signal(int signal_number, int in_signal_handler) if (Is_exception_result(res)) caml_raise(Extract_exception(res)); } -/* Record the delivery of a signal, and arrange so that caml_process_event - is called as soon as possible. */ +/* Arrange for a garbage collection to be performed as soon as possible */ -void caml_record_signal(int signal_number) -{ - caml_pending_signals[signal_number] = 1; - caml_signals_are_pending = 1; - caml_something_to_do = 1; -} - -static void handle_signal(int signal_number) -{ -#if !defined(POSIX_SIGNALS) && !defined(BSD_SIGNALS) - signal(signal_number, handle_signal); -#endif - if (signal_number < 0 || signal_number >= NSIG) return; - if (caml_try_leave_blocking_section_hook()) { - caml_execute_signal(signal_number, 1); - caml_enter_blocking_section_hook(); - }else{ - caml_record_signal(signal_number); - } -} +int volatile caml_force_major_slice = 0; void caml_urge_major_slice (void) { caml_force_major_slice = 1; +#ifndef NATIVE_CODE caml_something_to_do = 1; +#else + caml_young_limit = caml_young_end; + /* This is only moderately effective on ports that cache [caml_young_limit] + in a register, since [caml_modify] is called directly, not through + [caml_c_call], so it may take a while before the register is reloaded + from [caml_young_limit]. */ +#endif } -CAMLexport void caml_enter_blocking_section(void) -{ - while (1){ - /* Process all pending signals now */ - caml_process_pending_signals(); - caml_enter_blocking_section_hook (); - /* Check again for pending signals. - If none, done; otherwise, try again */ - if (! caml_signals_are_pending) break; - caml_leave_blocking_section_hook (); - } -} - -CAMLexport void caml_leave_blocking_section(void) -{ - caml_leave_blocking_section_hook (); - caml_process_pending_signals(); -} +/* OS-independent numbering of signals */ #ifndef SIGABRT #define SIGABRT -1 @@ -266,48 +258,43 @@ CAMLexport int caml_rev_convert_signal_number(int signo) return signo; } +/* Installation of a signal handler (as per [Sys.signal]) */ + CAMLprim value caml_install_signal_handler(value signal_number, value action) { CAMLparam2 (signal_number, action); - int sig; - void (*act)(int signo), (*oldact)(int signo); -#ifdef POSIX_SIGNALS - struct sigaction sigact, oldsigact; -#endif CAMLlocal1 (res); + int sig, act, oldact; sig = caml_convert_signal_number(Int_val(signal_number)); if (sig < 0 || sig >= NSIG) caml_invalid_argument("Sys.signal: unavailable signal"); switch(action) { case Val_int(0): /* Signal_default */ - act = SIG_DFL; + act = 0; break; case Val_int(1): /* Signal_ignore */ - act = SIG_IGN; + act = 1; break; default: /* Signal_handle */ - act = handle_signal; + act = 2; break; } -#ifdef POSIX_SIGNALS - sigact.sa_handler = act; - sigemptyset(&sigact.sa_mask); - sigact.sa_flags = 0; - if (sigaction(sig, &sigact, &oldsigact) == -1) caml_sys_error(NO_ARG); - oldact = oldsigact.sa_handler; -#else - oldact = signal(sig, act); - if (oldact == SIG_ERR) caml_sys_error(NO_ARG); -#endif - if (oldact == handle_signal) { - res = caml_alloc_small (1, 0); /* Signal_handle */ + oldact = caml_set_signal_action(sig, act); + switch (oldact) { + case 0: /* was Signal_default */ + res = Val_int(0); + break; + case 1: /* was Signal_ignore */ + res = Val_int(1); + break; + case 2: /* was Signal_handle */ + res = caml_alloc_small (1, 0); Field(res, 0) = Field(caml_signal_handlers, sig); + break; + default: /* error in caml_set_signal_action */ + caml_sys_error(NO_ARG); } - else if (oldact == SIG_IGN) - res = Val_int(1); /* Signal_ignore */ - else - res = Val_int(0); /* Signal_default */ if (Is_block(action)) { if (caml_signal_handlers == 0) { caml_signal_handlers = caml_alloc(NSIG, 0); diff --git a/byterun/signals.h b/byterun/signals.h index 9662f261..ba6b7dcf 100644 --- a/byterun/signals.h +++ b/byterun/signals.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: signals.h,v 1.25.2.1 2006/03/22 13:13:45 xleroy Exp $ */ +/* $Id: signals.h,v 1.27 2007/02/23 09:29:45 xleroy Exp $ */ #ifndef CAML_SIGNALS_H #define CAML_SIGNALS_H @@ -23,7 +23,6 @@ #include "mlvalues.h" /* */ -extern value caml_signal_handlers; CAMLextern intnat volatile caml_signals_are_pending; CAMLextern intnat volatile caml_pending_signals[]; CAMLextern int volatile caml_something_to_do; @@ -39,7 +38,9 @@ CAMLextern int caml_convert_signal_number (int); CAMLextern int caml_rev_convert_signal_number (int); void caml_execute_signal(int signal_number, int in_signal_handler); void caml_record_signal(int signal_number); +void caml_process_pending_signals(void); void caml_process_event(void); +int caml_set_signal_action(int signo, int action); CAMLextern void (*caml_enter_blocking_section_hook)(void); CAMLextern void (*caml_leave_blocking_section_hook)(void); diff --git a/byterun/signals_byt.c b/byterun/signals_byt.c new file mode 100644 index 00000000..44adbeaf --- /dev/null +++ b/byterun/signals_byt.c @@ -0,0 +1,95 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ +/* */ +/* Copyright 2007 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id: signals_byt.c,v 1.1 2007/02/23 09:29:45 xleroy Exp $ */ + +/* Signal handling, code specific to the bytecode interpreter */ + +#include +#include "config.h" +#include "memory.h" +#include "osdeps.h" +#include "signals.h" +#include "signals_machdep.h" + +#ifndef NSIG +#define NSIG 64 +#endif + +#ifdef _WIN32 +typedef void (*sighandler)(int sig); +extern sighandler caml_win32_signal(int sig, sighandler action); +#define signal(sig,act) caml_win32_signal(sig,act) +#endif + +CAMLexport int volatile caml_something_to_do = 0; +CAMLexport void (* volatile caml_async_action_hook)(void) = NULL; + +void caml_process_event(void) +{ + void (*async_action)(void); + + if (caml_force_major_slice) caml_minor_collection (); + /* FIXME should be [caml_check_urgent_gc] */ + caml_process_pending_signals(); + async_action = caml_async_action_hook; + if (async_action != NULL) { + caml_async_action_hook = NULL; + (*async_action)(); + } +} + +static void handle_signal(int signal_number) +{ +#if !defined(POSIX_SIGNALS) && !defined(BSD_SIGNALS) + signal(signal_number, handle_signal); +#endif + if (signal_number < 0 || signal_number >= NSIG) return; + if (caml_try_leave_blocking_section_hook()) { + caml_execute_signal(signal_number, 1); + caml_enter_blocking_section_hook(); + }else{ + caml_record_signal(signal_number); + } +} + +int caml_set_signal_action(int signo, int action) +{ + void (*act)(int signo), (*oldact)(int signo); +#ifdef POSIX_SIGNALS + struct sigaction sigact, oldsigact; +#endif + + switch (action) { + case 0: act = SIG_DFL; break; + case 1: act = SIG_IGN; break; + default: act = handle_signal; break; + } + +#ifdef POSIX_SIGNALS + sigact.sa_handler = act; + sigemptyset(&sigact.sa_mask); + sigact.sa_flags = 0; + if (sigaction(signo, &sigact, &oldsigact) == -1) return -1; + oldact = oldsigact.sa_handler; +#else + oldact = signal(signo, act); + if (oldact == SIG_ERR) return -1; +#endif + if (oldact == handle_signal) + return 2; + else if (oldact == SIG_IGN) + return 1; + else + return 0; +} diff --git a/byterun/signals_machdep.h b/byterun/signals_machdep.h index d4226f97..7980c6b4 100644 --- a/byterun/signals_machdep.h +++ b/byterun/signals_machdep.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: signals_machdep.h,v 1.2 2005/07/29 12:47:45 doligez Exp $ */ +/* $Id: signals_machdep.h,v 1.3 2007/02/23 09:43:14 xleroy Exp $ */ /* Processor-specific operation: atomic "read and clear" */ @@ -42,6 +42,16 @@ : "r" (&(src)), "r" (0) \ : "cr0", "memory") +#elif defined(__GNUC__) && defined(__ppc64__) + +#define Read_and_clear(dst,src) \ + asm("0: ldarx %0, 0, %1\n\t" \ + "stdcx. %2, 0, %1\n\t" \ + "bne- 0b" \ + : "=&r" (dst) \ + : "r" (&(src)), "r" (0) \ + : "cr0", "memory") + #else /* Default, non-atomic implementation */ diff --git a/byterun/str.c b/byterun/str.c index 4ec70b62..eda1db5b 100644 --- a/byterun/str.c +++ b/byterun/str.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: str.c,v 1.27 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: str.c,v 1.28 2007/01/30 09:52:08 xleroy Exp $ */ /* Operations on strings */ @@ -67,9 +67,12 @@ CAMLprim value caml_string_set(value str, value index, value newval) CAMLprim value caml_string_equal(value s1, value s2) { - mlsize_t sz1 = Wosize_val(s1); - mlsize_t sz2 = Wosize_val(s2); + mlsize_t sz1, sz2; value * p1, * p2; + + if (s1 == s2) return Val_true; + sz1 = Wosize_val(s1); + sz2 = Wosize_val(s2); if (sz1 != sz2) return Val_false; for(p1 = Op_val(s1), p2 = Op_val(s2); sz1 > 0; sz1--, p1++, p2++) if (*p1 != *p2) return Val_false; @@ -86,6 +89,7 @@ CAMLprim value caml_string_compare(value s1, value s2) mlsize_t len1, len2; int res; + if (s1 == s2) return Val_int(0); len1 = caml_string_length(s1); len2 = caml_string_length(s2); res = memcmp(String_val(s1), String_val(s2), len1 <= len2 ? len1 : len2); diff --git a/byterun/sys.c b/byterun/sys.c index db84665a..446d54f9 100644 --- a/byterun/sys.c +++ b/byterun/sys.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: sys.c,v 1.78.2.2 2006/08/30 09:37:57 doligez Exp $ */ +/* $Id: sys.c,v 1.83 2007/03/01 13:37:39 xleroy Exp $ */ /* Basic system calls */ @@ -72,24 +72,29 @@ CAMLexport void caml_sys_error(value arg) CAMLparam1 (arg); char * err; CAMLlocal1 (str); - + + err = error_message(); + if (arg == NO_ARG) { + str = caml_copy_string(err); + } else { + int err_len = strlen(err); + int arg_len = caml_string_length(arg); + str = caml_alloc_string(arg_len + 2 + err_len); + memmove(&Byte(str, 0), String_val(arg), arg_len); + memmove(&Byte(str, arg_len), ": ", 2); + memmove(&Byte(str, arg_len + 2), err, err_len); + } + caml_raise_sys_error(str); + CAMLnoreturn; +} + +CAMLexport void caml_sys_io_error(value arg) +{ if (errno == EAGAIN || errno == EWOULDBLOCK) { caml_raise_sys_blocked_io(); } else { - err = error_message(); - if (arg == NO_ARG) { - str = caml_copy_string(err); - } else { - int err_len = strlen(err); - int arg_len = caml_string_length(arg); - str = caml_alloc_string(arg_len + 2 + err_len); - memmove(&Byte(str, 0), String_val(arg), arg_len); - memmove(&Byte(str, arg_len), ": ", 2); - memmove(&Byte(str, arg_len + 2), err, err_len); - } - caml_raise_sys_error(str); + caml_sys_error(arg); } - CAMLnoreturn; } CAMLprim value caml_sys_exit(value retcode) @@ -154,6 +159,17 @@ CAMLprim value caml_sys_file_exists(value name) return Val_bool(stat(String_val(name), &st) == 0); } +CAMLprim value caml_sys_is_directory(value name) +{ + struct stat st; + if (stat(String_val(name), &st) == -1) caml_sys_error(name); +#ifdef S_ISDIR + return Val_bool(S_ISDIR(st.st_mode)); +#else + return Val_bool(st.st_mode & S_IFDIR); +#endif +} + CAMLprim value caml_sys_remove(value name) { int ret; @@ -233,7 +249,7 @@ CAMLprim value caml_sys_system_command(value command) int status, retcode; char *buf; intnat len; - + len = caml_string_length (command); buf = caml_stat_alloc (len + 1); memmove (buf, String_val (command), len + 1); @@ -276,8 +292,15 @@ CAMLprim value caml_sys_time(value unit) #endif } +#ifdef _WIN32 +extern intnat caml_win32_random_seed (void); +#endif + CAMLprim value caml_sys_random_seed (value unit) { +#ifdef _WIN32 + return Val_long(caml_win32_random_seed()); +#else intnat seed; #ifdef HAS_GETTIMEOFDAY struct timeval tv; @@ -287,9 +310,10 @@ CAMLprim value caml_sys_random_seed (value unit) seed = time (NULL); #endif #ifdef HAS_UNISTD - seed ^= getppid() << 16 | getpid(); + seed ^= (getppid() << 16) ^ getpid(); #endif return Val_long(seed); +#endif } CAMLprim value caml_sys_get_config(value unit) diff --git a/byterun/sys.h b/byterun/sys.h index 86702369..1c7e2c80 100644 --- a/byterun/sys.h +++ b/byterun/sys.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: sys.h,v 1.15 2003/12/16 18:09:43 doligez Exp $ */ +/* $Id: sys.h,v 1.16 2007/02/25 12:38:36 xleroy Exp $ */ #ifndef CAML_SYS_H #define CAML_SYS_H @@ -21,6 +21,7 @@ #define NO_ARG Val_int(0) CAMLextern void caml_sys_error (value); +CAMLextern void caml_sys_io_error (value); extern void caml_sys_init (char * exe_name, char ** argv); CAMLextern value caml_sys_exit (value); diff --git a/byterun/unix.c b/byterun/unix.c index bb3548ae..1198d4e0 100644 --- a/byterun/unix.c +++ b/byterun/unix.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: unix.c,v 1.25 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: unix.c,v 1.28 2007/02/12 07:57:25 weis Exp $ */ /* Unix-specific stuff */ @@ -199,7 +199,7 @@ entry_t *caml_lookup_bundle(const char *name) return current; } -void * caml_dlopen(char * libname) +void * caml_dlopen(char * libname, int for_execution) { NSObjectFileImage image; entry_t *bentry = caml_lookup_bundle(libname); @@ -283,9 +283,10 @@ char * caml_dlerror(void) #define RTLD_NODELETE 0 #endif -void * caml_dlopen(char * libname) +void * caml_dlopen(char * libname, int for_execution) { - return dlopen(libname, RTLD_NOW|RTLD_GLOBAL|RTLD_NODELETE); + return dlopen(libname, RTLD_NOW | RTLD_GLOBAL | RTLD_NODELETE); + /* Could use RTLD_LAZY if for_execution == 0, but needs testing */ } void caml_dlclose(void * handle) @@ -311,7 +312,7 @@ char * caml_dlerror(void) #endif #else -void * caml_dlopen(char * libname) +void * caml_dlopen(char * libname, int for_execution) { return NULL; } diff --git a/byterun/weak.c b/byterun/weak.c index 07113fb1..8f4377a9 100644 --- a/byterun/weak.c +++ b/byterun/weak.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: weak.c,v 1.24.12.1 2005/12/05 13:37:43 doligez Exp $ */ +/* $Id: weak.c,v 1.25 2006/01/04 16:55:49 doligez Exp $ */ /* Operations on weak arrays */ diff --git a/byterun/win32.c b/byterun/win32.c index 076378cc..acfbbd12 100644 --- a/byterun/win32.c +++ b/byterun/win32.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: win32.c,v 1.26 2005/10/12 12:33:47 xleroy Exp $ */ +/* $Id: win32.c,v 1.33 2007/03/01 13:37:39 xleroy Exp $ */ /* Win32-specific stuff */ @@ -26,6 +26,7 @@ #include #include #include +#include "fail.h" #include "memory.h" #include "misc.h" #include "osdeps.h" @@ -120,9 +121,15 @@ char * caml_search_dll_in_path(struct ext_table * path, char * name) return res; } -void * caml_dlopen(char * libname) +void * caml_dlopen(char * libname, int for_execution) { - return (void *) LoadLibrary(libname); + HMODULE m; + m = LoadLibraryEx(libname, NULL, + for_execution ? 0 : DONT_RESOLVE_DLL_REFERENCES); + /* Under Win 95/98/ME, LoadLibraryEx can fail in cases where LoadLibrary + would succeed. Just try again with LoadLibrary for good measure. */ + if (m == NULL) m = LoadLibrary(libname); + return (void *) m; } void caml_dlclose(void * handle) @@ -336,14 +343,25 @@ CAMLexport void caml_expand_command_line(int * argcp, char *** argvp) int caml_read_directory(char * dirname, struct ext_table * contents) { + int dirnamelen; char * template; +#if _MSC_VER <= 1200 + int h; +#else intptr_t h; +#endif struct _finddata_t fileinfo; char * p; - template = caml_stat_alloc(strlen(dirname) + 5); + dirnamelen = strlen(dirname); + template = caml_stat_alloc(dirnamelen + 5); strcpy(template, dirname); - strcat(template, "\\*.*"); + switch (dirname[dirnamelen - 1]) { + case '/': case '\\': case ':': + strcat(template, "*.*"); break; + default: + strcat(template, "\\*.*"); + } h = _findfirst(template, &fileinfo); caml_stat_free(template); if (h == -1) return errno == ENOENT ? 0 : -1; @@ -387,3 +405,141 @@ void caml_signal_thread(void * lpParam) } #endif /* NATIVE_CODE */ + +#if defined(NATIVE_CODE) && !defined(_WIN64) + +/* Handling of system stack overflow. + * Based on code provided by Olivier Andrieu. + + * An EXCEPTION_STACK_OVERFLOW is signaled when the guard page at the + * end of the stack has been accessed. Windows clears the PAGE_GUARD + * protection (making it a regular PAGE_READWRITE) and then calls our + * exception handler. This means that although we're handling an "out + * of stack" condition, there is a bit of stack available to call + * functions and allocate temporaries. + * + * PAGE_GUARD is a one-shot access protection mechanism: we need to + * restore the PAGE_GUARD protection on this page otherwise the next + * stack overflow won't be detected and the program will abruptly exit + * with STATUS_ACCESS_VIOLATION. + * + * Visual Studio 2003 and later (_MSC_VER >= 1300) have a + * _resetstkoflw() function that resets this protection. + * Unfortunately, it cannot work when called directly from the + * exception handler because at this point we are using the page that + * is to be protected. + * + * A solution is to used an alternate stack when restoring the + * protection. However it's not possible to use _resetstkoflw() then + * since it determines the stack pointer by calling alloca(): it would + * try to protect the alternate stack. + * + * Finally, we call caml_raise_stack_overflow; it will either call + * caml_raise_exception which switches back to the normal stack, or + * call caml_fatal_uncaught_exception which terminates the program + * quickly. + * + * NB: The PAGE_GUARD protection is only available on WinNT, not + * Win9x. There is an equivalent mechanism on Win9x with + * PAGE_NOACCESS. + * + * Currently, does not work under Win64. + */ + +static uintnat win32_alt_stack[0x80]; + +static void caml_reset_stack (void *faulting_address) +{ + OSVERSIONINFO osi; + SYSTEM_INFO si; + DWORD page_size; + MEMORY_BASIC_INFORMATION mbi; + DWORD oldprot; + + /* get the os version (Win9x or WinNT ?) */ + osi.dwOSVersionInfoSize = sizeof osi; + if (! GetVersionEx (&osi)) + goto failed; + + /* get the system's page size. */ + GetSystemInfo (&si); + page_size = si.dwPageSize; + + /* get some information on the page the fault occurred */ + if (! VirtualQuery (faulting_address, &mbi, sizeof mbi)) + goto failed; + + /* restore the PAGE_GUARD protection on this page */ + switch (osi.dwPlatformId) { + case VER_PLATFORM_WIN32_NT: + VirtualProtect (mbi.BaseAddress, page_size, + mbi.Protect | PAGE_GUARD, &oldprot); + break; + case VER_PLATFORM_WIN32_WINDOWS: + VirtualProtect (mbi.BaseAddress, page_size, + PAGE_NOACCESS, &oldprot); + break; + } + + failed: + caml_raise_stack_overflow(); +} + +extern char * caml_code_area_start, * caml_code_area_end; + +#define In_code_area(pc) \ + ((char *)(pc) >= caml_code_area_start && \ + (char *)(pc) <= caml_code_area_end) + +static LONG CALLBACK + caml_UnhandledExceptionFilter (EXCEPTION_POINTERS* exn_info) +{ + DWORD code = exn_info->ExceptionRecord->ExceptionCode; + CONTEXT *ctx = exn_info->ContextRecord; + DWORD *ctx_ip = &(ctx->Eip); + DWORD *ctx_sp = &(ctx->Esp); + + if (code == EXCEPTION_STACK_OVERFLOW && In_code_area (*ctx_ip)) + { + uintnat faulting_address; + uintnat * alt_esp; + + /* grab the address that caused the fault */ + faulting_address = exn_info->ExceptionRecord->ExceptionInformation[1]; + + /* call caml_reset_stack(faulting_address) using the alternate stack */ + alt_esp = win32_alt_stack + sizeof(win32_alt_stack) / sizeof(uintnat); + *--alt_esp = faulting_address; + *ctx_sp = (uintnat) (alt_esp - 1); + *ctx_ip = (uintnat) &caml_reset_stack; + + return EXCEPTION_CONTINUE_EXECUTION; + } + + return EXCEPTION_CONTINUE_SEARCH; +} + +void caml_win32_overflow_detection() +{ + SetUnhandledExceptionFilter (caml_UnhandledExceptionFilter); +} + +#endif + +/* Seeding of pseudo-random number generators */ + +intnat caml_win32_random_seed (void) +{ + intnat seed; + SYSTEMTIME t; + + GetLocalTime(&t); + seed = t.wMonth; + seed = (seed << 5) ^ t.wDay; + seed = (seed << 4) ^ t.wHour; + seed = (seed << 5) ^ t.wMinute; + seed = (seed << 5) ^ t.wSecond; + seed = (seed << 9) ^ t.wMilliseconds; + seed ^= GetCurrentProcessId(); + return seed; +} diff --git a/camlp4/.cvsignore b/camlp4/.cvsignore new file mode 100644 index 00000000..493096e2 --- /dev/null +++ b/camlp4/.cvsignore @@ -0,0 +1,3 @@ +*.cm* +.cache-status +*.tmp.ml diff --git a/camlp4/.vcs b/camlp4/.vcs new file mode 100644 index 00000000..70f42110 --- /dev/null +++ b/camlp4/.vcs @@ -0,0 +1,4 @@ +--- +exclude: + - !re boot/camlp4boot\.save\..* + - build/camlp4_config.ml diff --git a/camlp4/CHANGES b/camlp4/CHANGES index 2ffd2beb..571894b9 100644 --- a/camlp4/CHANGES +++ b/camlp4/CHANGES @@ -1,3 +1,7 @@ +- [...] + 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) diff --git a/camlp4/Camlp4.mlpack b/camlp4/Camlp4.mlpack new file mode 100644 index 00000000..cc38b119 --- /dev/null +++ b/camlp4/Camlp4.mlpack @@ -0,0 +1,9 @@ +Debug +ErrorHandler +OCamlInitSyntax +Options +PreCast +Printers +Register +Sig +Struct diff --git a/camlp4/Camlp4/.cvsignore b/camlp4/Camlp4/.cvsignore new file mode 100644 index 00000000..e69de29b diff --git a/camlp4/Camlp4/Camlp4Ast.partial.ml b/camlp4/Camlp4/Camlp4Ast.partial.ml new file mode 100644 index 00000000..d9356c8e --- /dev/null +++ b/camlp4/Camlp4/Camlp4Ast.partial.ml @@ -0,0 +1,341 @@ + + type meta_bool = + [ BTrue + | BFalse + | BAnt of string ]; + type meta_option 'a = + [ ONone + | OSome of 'a + | OAnt of string ]; + type meta_list 'a = + [ LNil + | LCons of 'a and meta_list 'a + | LAnt of string ]; + type ident = + [ IdAcc of Loc.t and ident and ident (* i . i *) + | IdApp of Loc.t and ident and ident (* i i *) + | IdLid of Loc.t and string (* foo *) + | IdUid of Loc.t and string (* Bar *) + | IdAnt of Loc.t and string (* $s$ *) ]; + type ctyp = + [ TyNil of Loc.t + | TyAli of Loc.t and ctyp and ctyp (* t as t *) (* list 'a as 'a *) + | TyAny of Loc.t (* _ *) + | TyApp of Loc.t and ctyp and ctyp (* t t *) (* list 'a *) + | TyArr of Loc.t and ctyp and ctyp (* t -> t *) (* int -> string *) + | TyCls of Loc.t and ident (* #i *) (* #point *) + | TyLab of Loc.t and string and ctyp (* ~s *) + | TyId of Loc.t and ident (* i *) (* Lazy.t *) + | TyMan of Loc.t 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.t and string and list ctyp and ctyp and list (ctyp * ctyp) + (* < (t)? (..)? > *) (* < move : int -> 'a .. > as 'a *) + | TyObj of Loc.t and ctyp and meta_bool + | TyOlb of Loc.t and string and ctyp (* ?s *) + | TyPol of Loc.t and ctyp and ctyp (* ! t . t *) (* ! 'a . list 'a -> 'a *) + | TyQuo of Loc.t and string (* 's *) + | TyQuP of Loc.t and string (* +'s *) + | TyQuM of Loc.t and string (* -'s *) + | TyVrn of Loc.t and string (* `s *) + | TyRec of Loc.t and ctyp (* { t } *) (* { foo : int ; bar : mutable string } *) + | TyCol of Loc.t and ctyp and ctyp (* t : t *) + | TySem of Loc.t and ctyp and ctyp (* t; t *) + | TyCom of Loc.t and ctyp and ctyp (* t, t *) + | TySum of Loc.t and ctyp (* [ t ] *) (* [ A of int and string | B ] *) + | TyOf of Loc.t and ctyp and ctyp (* t of t *) (* A of int *) + | TyAnd of Loc.t and ctyp and ctyp (* t and t *) + | TyOr of Loc.t and ctyp and ctyp (* t | t *) + | TyPrv of Loc.t and ctyp (* private t *) + | TyMut of Loc.t and ctyp (* mutable t *) + | TyTup of Loc.t and ctyp (* ( t ) *) (* (int * string) *) + | TySta of Loc.t and ctyp and ctyp (* t * t *) + | TyVrnEq of Loc.t and ctyp (* [ = t ] *) + | TyVrnSup of Loc.t and ctyp (* [ > t ] *) + | TyVrnInf of Loc.t and ctyp (* [ < t ] *) + | TyVrnInfSup of Loc.t and ctyp and ctyp (* [ < t > t ] *) + | TyAmp of Loc.t and ctyp and ctyp (* t & t *) + | TyOfAmp of Loc.t and ctyp and ctyp (* t of & t *) + | TyAnt of Loc.t and string (* $s$ *) + ] + ; + type patt = + [ PaNil of Loc.t + | PaId of Loc.t and ident (* i *) + | PaAli of Loc.t and patt and patt (* p as p *) (* (Node x y as n) *) + | PaAnt of Loc.t and string (* $s$ *) + | PaAny of Loc.t (* _ *) + | PaApp of Loc.t and patt and patt (* p p *) (* fun x y -> *) + | PaArr of Loc.t and patt (* [| p |] *) + | PaCom of Loc.t and patt and patt (* p, p *) + | PaSem of Loc.t and patt and patt (* p; p *) + | PaChr of Loc.t and string (* c *) (* 'x' *) + | PaInt of Loc.t and string + | PaInt32 of Loc.t and string + | PaInt64 of Loc.t and string + | PaNativeInt of Loc.t and string + | PaFlo of Loc.t and string + | PaLab of Loc.t and string and patt (* ~s or ~s:(p) *) + (* ?s or ?s:(p = e) or ?(p = e) *) + (* | PaOlb of Loc.t and string and meta_option(*FIXME*) (patt * meta_option(*FIXME*) expr) *) + (* ?s or ?s:(p) *) + | PaOlb of Loc.t and string and patt + (* ?s:(p = e) or ?(p = e) *) + | PaOlbi of Loc.t and string and patt and expr + | PaOrp of Loc.t and patt and patt (* p | p *) + | PaRng of Loc.t and patt and patt (* p .. p *) + | PaRec of Loc.t and patt (* { p } *) + | PaEq of Loc.t and patt and patt (* p = p *) + | PaStr of Loc.t and string (* s *) + | PaTup of Loc.t and patt (* ( p ) *) + | PaTyc of Loc.t and patt and ctyp (* (p : t) *) + | PaTyp of Loc.t and ident (* #i *) + | PaVrn of Loc.t and string (* `s *) ] + and expr = + [ ExNil of Loc.t + | ExId of Loc.t and ident (* i *) + | ExAcc of Loc.t and expr and expr (* e.e *) + | ExAnt of Loc.t and string (* $s$ *) + | ExApp of Loc.t and expr and expr (* e e *) + | ExAre of Loc.t and expr and expr (* e.(e) *) + | ExArr of Loc.t and expr (* [| e |] *) + | ExSem of Loc.t and expr and expr (* e; e *) + | ExAsf of Loc.t (* assert False *) + | ExAsr of Loc.t and expr (* assert e *) + | ExAss of Loc.t and expr and expr (* e := e *) + | ExChr of Loc.t and string (* 'c' *) + | ExCoe of Loc.t and expr and ctyp and ctyp (* (e : t) or (e : t :> t) *) + | ExFlo of Loc.t and string (* 3.14 *) + (* for s = e to/downto e do { e } *) + | ExFor of Loc.t and string and expr and expr and meta_bool and expr + | ExFun of Loc.t and match_case (* fun [ a ] *) + | ExIfe of Loc.t and expr and expr and expr (* if e then e else e *) + | ExInt of Loc.t and string (* 42 *) + | ExInt32 of Loc.t and string + | ExInt64 of Loc.t and string + | ExNativeInt of Loc.t and string + | ExLab of Loc.t and string and expr (* ~s or ~s:e *) + | ExLaz of Loc.t and expr (* lazy e *) + (* let b in e or let rec b in e *) + | ExLet of Loc.t and meta_bool and binding and expr + (* let module s = me in e *) + | ExLmd of Loc.t and string and module_expr and expr + (* match e with [ a ] *) + | ExMat of Loc.t and expr and match_case + (* new i *) + | ExNew of Loc.t and ident + (* object ((p))? (cst)? end *) + | ExObj of Loc.t and patt and class_str_item + (* ?s or ?s:e *) + | ExOlb of Loc.t and string and expr + (* {< b >} *) + | ExOvr of Loc.t and binding + (* { b } or { (e) with b } *) + | ExRec of Loc.t and binding and expr + (* do { e } *) + | ExSeq of Loc.t and expr + (* e#s *) + | ExSnd of Loc.t and expr and string + (* e.[e] *) + | ExSte of Loc.t and expr and expr + (* s *) (* "foo" *) + | ExStr of Loc.t and string + (* try e with [ a ] *) + | ExTry of Loc.t and expr and match_case + (* (e) *) + | ExTup of Loc.t and expr + (* e, e *) + | ExCom of Loc.t and expr and expr + (* (e : t) *) + | ExTyc of Loc.t and expr and ctyp + (* `s *) + | ExVrn of Loc.t and string + (* while e do { e } *) + | ExWhi of Loc.t and expr and expr ] + and module_type = + (* i *) (* A.B.C *) + [ MtId of Loc.t and ident + (* functor (s : mt) -> mt *) + | MtFun of Loc.t and string and module_type and module_type + (* 's *) + | MtQuo of Loc.t and string + (* sig (sg)? end *) + | MtSig of Loc.t and sig_item + (* mt with wc *) + | MtWit of Loc.t and module_type and with_constr + | MtAnt of Loc.t and string (* $s$ *) ] + and sig_item = + [ SgNil of Loc.t + (* class cict *) + | SgCls of Loc.t and class_type + (* class type cict *) + | SgClt of Loc.t and class_type + (* sg ; sg *) + | SgSem of Loc.t and sig_item and sig_item + (* # s or # s e *) + | SgDir of Loc.t and string and expr + (* exception t *) + | SgExc of Loc.t and ctyp + (* external s : t = s ... s *) + | SgExt of Loc.t and string and ctyp and meta_list string + (* include mt *) + | SgInc of Loc.t and module_type + (* module s : mt *) + | SgMod of Loc.t and string and module_type + (* module rec mb *) + | SgRecMod of Loc.t and module_binding + (* module type s = mt *) + | SgMty of Loc.t and string and module_type + (* open i *) + | SgOpn of Loc.t and ident + (* type t *) + | SgTyp of Loc.t and ctyp + (* value s : t *) + | SgVal of Loc.t and string and ctyp + | SgAnt of Loc.t and string (* $s$ *) ] + and with_constr = + [ WcNil of Loc.t + (* type t = t *) + | WcTyp of Loc.t and ctyp and ctyp + (* module i = i *) + | WcMod of Loc.t and ident and ident + (* wc and wc *) + | WcAnd of Loc.t and with_constr and with_constr + | WcAnt of Loc.t and string (* $s$ *) ] + and binding = + [ BiNil of Loc.t + (* b and b *) (* let a = 42 and c = 43 *) + | BiAnd of Loc.t and binding and binding + (* b ; b *) + | BiSem of Loc.t and binding and binding + (* p = e *) (* let patt = expr *) + | BiEq of Loc.t and patt and expr + | BiAnt of Loc.t and string (* $s$ *) ] + and module_binding = + [ MbNil of Loc.t + (* mb and mb *) (* module rec (s : mt) = me and (s : mt) = me *) + | MbAnd of Loc.t and module_binding and module_binding + (* s : mt = me *) + | MbColEq of Loc.t and string and module_type and module_expr + (* s : mt *) + | MbCol of Loc.t and string and module_type + | MbAnt of Loc.t and string (* $s$ *) ] + and match_case = + [ McNil of Loc.t + (* a | a *) + | McOr of Loc.t and match_case and match_case + (* p (when e)? -> e *) + | McArr of Loc.t and patt and expr and expr + | McAnt of Loc.t and string (* $s$ *) ] + and module_expr = + (* i *) + [ MeId of Loc.t and ident + (* me me *) + | MeApp of Loc.t and module_expr and module_expr + (* functor (s : mt) -> me *) + | MeFun of Loc.t and string and module_type and module_expr + (* struct (st)? end *) + | MeStr of Loc.t and str_item + (* (me : mt) *) + | MeTyc of Loc.t and module_expr and module_type + | MeAnt of Loc.t and string (* $s$ *) ] + and str_item = + [ StNil of Loc.t + (* class cice *) + | StCls of Loc.t and class_expr + (* class type cict *) + | StClt of Loc.t and class_type + (* st ; st *) + | StSem of Loc.t and str_item and str_item + (* # s or # s e *) + | StDir of Loc.t and string and expr + (* exception t or exception t = i *) + | StExc of Loc.t and ctyp and meta_option(*FIXME*) ident + (* e *) + | StExp of Loc.t and expr + (* external s : t = s ... s *) + | StExt of Loc.t and string and ctyp and meta_list string + (* include me *) + | StInc of Loc.t and module_expr + (* module s = me *) + | StMod of Loc.t and string and module_expr + (* module rec mb *) + | StRecMod of Loc.t and module_binding + (* module type s = mt *) + | StMty of Loc.t and string and module_type + (* open i *) + | StOpn of Loc.t and ident + (* type t *) + | StTyp of Loc.t and ctyp + (* value b or value rec b *) + | StVal of Loc.t and meta_bool and binding + | StAnt of Loc.t and string (* $s$ *) ] + and class_type = + [ CtNil of Loc.t + (* (virtual)? i ([ t ])? *) + | CtCon of Loc.t and meta_bool and ident and ctyp + (* [t] -> ct *) + | CtFun of Loc.t and ctyp and class_type + (* object ((t))? (csg)? end *) + | CtSig of Loc.t and ctyp and class_sig_item + (* ct and ct *) + | CtAnd of Loc.t and class_type and class_type + (* ct : ct *) + | CtCol of Loc.t and class_type and class_type + (* ct = ct *) + | CtEq of Loc.t and class_type and class_type + (* $s$ *) + | CtAnt of Loc.t and string ] + and class_sig_item = + [ CgNil of Loc.t + (* type t = t *) + | CgCtr of Loc.t and ctyp and ctyp + (* csg ; csg *) + | CgSem of Loc.t and class_sig_item and class_sig_item + (* inherit ct *) + | CgInh of Loc.t and class_type + (* method s : t or method private s : t *) + | CgMth of Loc.t and string and meta_bool and ctyp + (* value (virtual)? (mutable)? s : t *) + | CgVal of Loc.t and string and meta_bool and meta_bool and ctyp + (* method virtual (mutable)? s : t *) + | CgVir of Loc.t and string and meta_bool and ctyp + | CgAnt of Loc.t and string (* $s$ *) ] + and class_expr = + [ CeNil of Loc.t + (* ce e *) + | CeApp of Loc.t and class_expr and expr + (* (virtual)? i ([ t ])? *) + | CeCon of Loc.t and meta_bool and ident and ctyp + (* fun p -> ce *) + | CeFun of Loc.t and patt and class_expr + (* let (rec)? b in ce *) + | CeLet of Loc.t and meta_bool and binding and class_expr + (* object ((p))? (cst)? end *) + | CeStr of Loc.t and patt and class_str_item + (* ce : ct *) + | CeTyc of Loc.t and class_expr and class_type + (* ce and ce *) + | CeAnd of Loc.t and class_expr and class_expr + (* ce = ce *) + | CeEq of Loc.t and class_expr and class_expr + (* $s$ *) + | CeAnt of Loc.t and string ] + and class_str_item = + [ CrNil of Loc.t + (* cst ; cst *) + | CrSem of Loc.t and class_str_item and class_str_item + (* type t = t *) + | CrCtr of Loc.t and ctyp and ctyp + (* inherit ce or inherit ce as s *) + | CrInh of Loc.t and class_expr and string + (* initializer e *) + | CrIni of Loc.t and expr + (* method (private)? s : t = e or method (private)? s = e *) + | CrMth of Loc.t and string and meta_bool and expr and ctyp + (* value (mutable)? s = e *) + | CrVal of Loc.t and string and meta_bool and expr + (* method virtual (private)? s : t *) + | CrVir of Loc.t and string and meta_bool and ctyp + (* value virtual (private)? s : t *) + | CrVvr of Loc.t and string and meta_bool and ctyp + | CrAnt of Loc.t and string (* $s$ *) ]; diff --git a/camlp4/Camlp4/Debug.ml b/camlp4/Camlp4/Debug.ml new file mode 100644 index 00000000..e99ec9e1 --- /dev/null +++ b/camlp4/Camlp4/Debug.ml @@ -0,0 +1,73 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 -> 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 normal s = + let rec self from accu = + try + let i = String.index_from s from '\n' + in self (i + 1) [String.sub s from (i - from + 1) :: accu] + with + [ Not_found -> [ String.sub s from (String.length s - from) :: accu ] ] + in String.concat header (List.rev (self 0 [])) in + let after_new_line str = header ^ normal str in + let f = ref after_new_line in + let output str chr = do { + output_string out_channel (f.val str); + output_char out_channel chr; + f.val := if chr = '\n' then after_new_line else normal; + } in + (make_formatter + (fun buf pos len -> + let p = pred len in output (String.sub buf pos p) buf.[pos + p]) + (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 00000000..13af7733 --- /dev/null +++ b/camlp4/Camlp4/Debug.mli @@ -0,0 +1,22 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 00000000..7c68bd4f --- /dev/null +++ b/camlp4/Camlp4/ErrorHandler.ml @@ -0,0 +1,171 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 -> + string_of_float (Obj.magic r : float) + | x when x = Obj.abstract_tag -> + opaque "abstract" + | x when x = Obj.custom_tag -> + opaque "custom" + | x when x = Obj.final_tag -> + opaque "final" + | _ -> + 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; + 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); + }; + 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 = + let buf = Buffer.create 128 in + let () = bprintf buf "%a" print exn in + Buffer.contents buf; + +value try_to_string exn = + let buf = Buffer.create 128 in + let () = bprintf buf "%a" try_print exn in + Buffer.contents buf; diff --git a/camlp4/Camlp4/ErrorHandler.mli b/camlp4/Camlp4/ErrorHandler.mli new file mode 100644 index 00000000..67481145 --- /dev/null +++ b/camlp4/Camlp4/ErrorHandler.mli @@ -0,0 +1,36 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 00000000..b28c40e0 --- /dev/null +++ b/camlp4/Camlp4/OCamlInitSyntax.ml @@ -0,0 +1,245 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +module Make (Warning : Sig.Warning) + (Ast : Sig.Camlp4Ast with module Loc = Warning.Loc) + (Gram : Sig.Grammar.Static with module Loc = Warning.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 AntiquotSyntax.Ast = Sig.Camlp4AstToAst Ast + and module Quotation = Quotation += struct + + module Warning = Warning; + module Loc = Ast.Loc; + module Ast = Ast; + module Gram = Gram; + module Token = Gram.Token; + open Sig; + + 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_LIDENT_or_operator = Gram.Entry.mk "a_LIDENT_or_operator"; + 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 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 = Gram.Entry.mk "field"; + value field_expr = Gram.Entry.mk "field_expr"; + 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_expr = Gram.Entry.mk "label_expr"; + value label_ipatt = Gram.Entry.mk "label_ipatt"; + value label_longident = Gram.Entry.mk "label_longident"; + value label_patt = Gram.Entry.mk "label_patt"; + 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 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 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 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 opt_polyt = Gram.Entry.mk "opt_polyt"; + value opt_private = Gram.Entry.mk "opt_private"; + value opt_rec = Gram.Entry.mk "opt_rec"; + 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 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 pipe_ctyp = Gram.Entry.mk "pipe_ctyp"; + value poly_type = Gram.Entry.mk "poly_type"; + value row_field = Gram.Entry.mk "row_field"; + value sem_ctyp = Gram.Entry.mk "sem_ctyp"; + 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 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 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"; + + + 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; + + module Parser = struct + module Ast = Ast; + 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$ >>; + end; + + module Printer = Struct.EmptyPrinter.Make Ast; + +end; diff --git a/camlp4/Camlp4/Options.ml b/camlp4/Camlp4/Options.ml new file mode 100644 index 00000000..e9979bee --- /dev/null +++ b/camlp4/Camlp4/Options.ml @@ -0,0 +1,191 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 "bool_of_string" -> None ] + | [] -> None ] + else + try do { f (bool_of_string s); Some sl } with + [ Invalid_argument "bool_of_string" -> 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 "int_of_string" -> None ] + | [] -> None ] + else + try do { f (int_of_string s); Some sl } with + [ Failure "int_of_string" -> 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 "int_of_string" -> None ] + | [] -> None ] + else + try do { r.val := (int_of_string s); Some sl } with + [ Failure "int_of_string" -> 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 = Sort.list (fun (k1, _, _) (k2, _, _) -> k1 >= k2) 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 00000000..caffd8c2 --- /dev/null +++ b/camlp4/Camlp4/Options.mli @@ -0,0 +1,26 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 00000000..ebb52e14 --- /dev/null +++ b/camlp4/Camlp4/PreCast.ml @@ -0,0 +1,69 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Id = struct + value name = "Camlp4.PreCast"; + value version = "$Id: PreCast.ml,v 1.4 2007/02/07 10:09:21 ertai Exp $"; +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 Warning = Struct.Warning.Make 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 Warning 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 00000000..fd64e6d1 --- /dev/null +++ b/camlp4/Camlp4/PreCast.mli @@ -0,0 +1,79 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 Warning : Sig.Warning with module Loc = 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 Warning = Warning + and module Token = Token + and module Ast = Ast + and module Gram = Gram + and module Quotation = Quotation; + +module Printers : sig + module OCaml : Sig.Printer with module Ast = Sig.Camlp4AstToAst Ast; + module OCamlr : Sig.Printer with module Ast = Sig.Camlp4AstToAst Ast; + (* module OCamlrr : Sig.Printer with module Ast = Sig.Camlp4AstToAst Ast; *) + module DumpOCamlAst : Sig.Printer with module Ast = Sig.Camlp4AstToAst Ast; + module DumpCamlp4Ast : Sig.Printer with module Ast = Sig.Camlp4AstToAst Ast; + module Null : Sig.Printer with module Ast = Sig.Camlp4AstToAst Ast; +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 00000000..9e593a75 --- /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 00000000..8fcd6ab0 --- /dev/null +++ b/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml @@ -0,0 +1,50 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Id = struct + value name = "Camlp4Printers.DumpCamlp4Ast"; + value version = "$Id: DumpCamlp4Ast.ml,v 1.5 2007/02/07 10:09:21 ertai Exp $"; +end; + +module Make (Syntax : Sig.Syntax) +: Sig.Printer with module Ast = Syntax.Ast += struct + include Syntax; + + value with_open_out_file x f = + match x with + [ Some file -> do { let oc = open_out_bin file in 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 00000000..0af1fa1a --- /dev/null +++ b/camlp4/Camlp4/Printers/DumpCamlp4Ast.mli @@ -0,0 +1,22 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +module Id : Sig.Id; + +module Make (Syntax : Sig.Syntax) : Sig.Printer + with module Ast = Syntax.Ast; diff --git a/camlp4/Camlp4/Printers/DumpOCamlAst.ml b/camlp4/Camlp4/Printers/DumpOCamlAst.ml new file mode 100644 index 00000000..52ec2d76 --- /dev/null +++ b/camlp4/Camlp4/Printers/DumpOCamlAst.ml @@ -0,0 +1,52 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Id : Sig.Id = struct + value name = "Camlp4Printers.DumpOCamlAst"; + value version = "$Id: DumpOCamlAst.ml,v 1.5 2007/02/07 10:09:21 ertai Exp $"; +end; + +module Make (Syntax : Sig.Camlp4Syntax) +: Sig.Printer with module Ast = Syntax.Ast += 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 in 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 00000000..b97898b1 --- /dev/null +++ b/camlp4/Camlp4/Printers/DumpOCamlAst.mli @@ -0,0 +1,22 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +module Id : Sig.Id; + +module Make (Syntax : Sig.Camlp4Syntax) : Sig.Printer + with module Ast = Syntax.Ast; diff --git a/camlp4/Camlp4/Printers/Null.ml b/camlp4/Camlp4/Printers/Null.ml new file mode 100644 index 00000000..2b009302 --- /dev/null +++ b/camlp4/Camlp4/Printers/Null.ml @@ -0,0 +1,30 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Id = struct + value name = "Camlp4.Printers.Null"; + value version = "$Id: Null.ml,v 1.2 2007/02/07 10:09:21 ertai Exp $"; +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 00000000..562c2c02 --- /dev/null +++ b/camlp4/Camlp4/Printers/Null.mli @@ -0,0 +1,22 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Id : Sig.Id; + +module Make (Syntax : Sig.Syntax) : Sig.Printer with module Ast = Syntax.Ast; diff --git a/camlp4/Camlp4/Printers/OCaml.ml b/camlp4/Camlp4/Printers/OCaml.ml new file mode 100644 index 00000000..08507539 --- /dev/null +++ b/camlp4/Camlp4/Printers/OCaml.ml @@ -0,0 +1,1061 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +open Format; + +module Id = struct + value name = "Camlp4.Printers.OCaml"; + value version = "$Id: OCaml.ml,v 1.21 2007/02/26 16:32:46 ertai Exp $"; +end; + +module Make (Syntax : Sig.Camlp4Syntax) = struct + include Syntax; + + 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 x -> 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 is_infix = + let infixes = + List.fold_right StringSet.add +(* "**."; "=."; "<>."; "<."; ">."; "<=."; ">=."; "~-"; "~-." *) + ["=="; "!="; "+"; "-"; "+."; "-."; "*"; "*."; "/"; "/."; "**"; + "="; "<>"; "<"; ">"; "<="; ">="; "^"; "^^"; "@"; "&&"; "||"; + "asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or" ] StringSet.empty + in fun s -> StringSet.mem s infixes; + + value is_keyword = + let keywords = + List.fold_right StringSet.add + ["and"; "as"; "assert"; "asr"; "begin"; "class"; "constraint"; "do"; + "done"; "downto"; "else"; "end"; "exception"; "external"; "false"; + "for"; "fun"; "function"; "functor"; "if"; "in"; "include"; + "inherit"; "initializer"; "land"; "lazy"; "let"; "lor"; "lsl"; "lsr"; + "lxor"; "match"; "method"; "mod"; "module"; "mutable"; "new"; + "object"; "of"; "open"; "or"; "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 -> + 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)) ]; + + value ocaml_char = + fun + [ "'" -> "\\'" + | c -> c ]; + + 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 + ([p :: pl], e) + else ([], ge) + | 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 = ";;"; + value andsep : format unit formatter unit = "@]@ @[<2>and@ "; + value value_val = "val"; + value value_let = "let"; + value mode = if comments then `comments else `no_comments; + value curry_constr = init_curry_constr; + value var_conversion = False; + + 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 + | 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 mutable_flag f b = o#flag f b "mutable"; + method rec_flag f b = o#flag f b "rec"; + method virtual_flag f b = o#flag f b "virtual"; + method private_flag f b = o#flag f b "private"; + method flag f b n = + match b with + [ Ast.BTrue -> do { pp_print_string f n; pp f "@ " } + | Ast.BFalse -> () + | Ast.BAnt 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 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 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#simple_patt "@ ") [p::pl] o#ctyp t o#expr e + | _ -> pp f "%a @[<0>%a=@]@ %a" o#simple_patt + p (list' o#simple_patt "" "@ ") pl o#expr e ] + | <:binding< $_$ ; $_$ >> -> assert False + | <:binding< $anti:s$ >> -> o#anti f s ]; + + method record_binding f bi = + let () = o#node f bi Ast.loc_of_binding in + match bi with + [ <:binding<>> -> () + | <:binding< $p$ = $e$ >> -> + pp f "@ @[<2>%a =@ %a@];" o#simple_patt p o#expr e + | <:binding< $b1$ ; $b2$ >> -> + do { o#under_semi#record_binding f b1; + o#under_semi#record_binding f b2 } + | <:binding< $_$ and $_$ >> -> assert False + | <:binding< $anti:s$ >> -> o#anti f s ]; + + method object_dup f = + list (fun f (s, e) -> pp f "@[<2>%a =@ %a@]" o#var s o#expr e) ";@ " f; + + 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#expr e + | el -> pp f "@[<2>[ %a@] ]" (list o#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#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#patt "@ ") [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#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 = do { + (* FIXME pp_print_if_newline f (); *) + pp_print_string f "| "; + o#ctyp f t; + }; + method string f = pp f "%s"; + method quoted_string f = pp f "%S"; + + method intlike f s = if s.[0] = '-' then pp f "(%s)" s else pp f "%s" s; + + 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) = + pp f "@[<2>(%a :@ %a)@]" o#var s o#module_type mt; + + 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 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$ >> -> + pp f "@[<2>-@,%a@]" o#expr x + | <:expr< -. $x$ >> -> + pp f "@[<2>-.@,%a@]" o#expr x + | <: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#dot_expr x n o#dot_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#dot_expr x o#expr y + | [_] -> pp f "@[<2>%a@ %a@]" o#dot_expr x o#dot_expr y + | al -> + pp f "@[<2>%a@ (%a)@]" o#dot_expr a + (list o#under_pipe#expr ",@ ") al ] + else pp f "@[<2>%a@]" (list o#dot_expr "@ ") [a::al] + | <:expr< $e1$.val := $e2$ >> -> + pp f "@[<2>%a :=@ %a@]" o#expr e1 o#expr e2 + | <:expr< $e1$ := $e2$ >> -> + pp f "@[<2>%a@ <-@ %a@]" o#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 (p, 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 ] + | <: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#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#expr e + | 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 $s$ = $e1$ $to:df$ $e2$ do { $e3$ } >> -> + pp f "@[@[@[<2>for %a =@ %a@ %a@ %a@ do@]@ %a@]@ done@]" + o#var s o#expr e1 o#direction_flag df o#expr e2 o#seq e3 + | <:expr< $int:s$ >> -> pp f "%a" o#intlike s + | <:expr< $nativeint:s$ >> -> pp f "%an" o#intlike s + | <:expr< $int64:s$ >> -> pp f "%aL" o#intlike s + | <:expr< $int32:s$ >> -> pp f "%al" o#intlike s + | <:expr< $flo:s$ >> -> pp f "%s" s + | <:expr< $chr:s$ >> -> pp f "'%s'" (ocaml_char s) + | <:expr< $id:i$ >> -> o#var_ident f i + | <:expr< { $b$ } >> -> + pp f "@[@[{@ %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< 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 + | <:expr< new $i$ >> -> pp f "@[<2>new@ %a@]" o#ident i + | <: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< $_$ $_$ >> | <:expr< $_$ . $_$ >> | <:expr< $_$ . ( $_$ ) >> | + <:expr< $_$ . [ $_$ ] >> | <:expr< $_$ := $_$ >> | + <:expr< $_$ # $_$ >> | + <:expr< fun [ $_$ ] >> | <:expr< match $_$ with [ $_$ ] >> | + <:expr< try $_$ with [ $_$ ] >> | + <:expr< if $_$ then $_$ else $_$ >> | + <:expr< let $rec:_$ $_$ in $_$ >> | + <:expr< let module $_$ = $_$ in $_$ >> | + (* Note: `new' is treated differently in pa_o and in pa_r, + and should not occur at this level *) + <:expr< assert $_$ >> | <:expr< assert False >> | <:expr< lazy $_$ >> -> + pp f "(%a)" o#reset#expr e ]; + + method direction_flag f b = + match b with + [ Ast.BTrue -> pp_print_string f "to" + | Ast.BFalse -> pp_print_string f "downto" + | Ast.BAnt 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< $p1$ = $p2$ >> -> pp f "@[<2>%a =@ %a@]" o#patt p1 o#patt p2 + | <: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< $x$ $y$ >> -> + let (a, al) = get_patt_args x [y] in + if (not curry_constr) && Ast.is_patt_constructor a then + 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 ] + else + pp f "@[<2>%a@]" (list o#simple_patt "@ ") [a::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< ( $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$ >> -> pp f "%an" o#intlike s + | <:patt< $int64:s$ >> -> pp f "%aL" o#intlike s + | <:patt< $int32:s$ >> -> pp f "%al" o#intlike s + | <:patt< $int:s$ >> -> pp f "%a" o#intlike s + | <:patt< $flo:s$ >> -> pp f "%s" s + | <:patt< $chr:s$ >> -> pp f "'%s'" (ocaml_char s) + | <:patt< ~ $s$ >> -> pp f "~%s" s + | <:patt< ` $uid:s$ >> -> pp f "`%a" o#var s + | <:patt< # $i$ >> -> pp f "@[<2>#%a@]" o#ident i + | <: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 p + | <:patt< ? $s$ : ($p$) >> -> + pp f "@[<2>?%s:@,@[<1>(%a)@]@]" s o#patt p + | <:patt< ?($p$ = $e$) >> -> + pp f "@[<2>?(%a =@ %a)@]" o#patt p o#expr e + | <:patt< ? $s$ : ($p$ = $e$) >> -> + pp f "@[<2>?%s:@,@[<1>(%a =@ %a)@]@]" s o#patt p o#expr e + | <:patt< $_$ $_$ >> | <:patt< ($_$ as $_$) >> | <:patt< $_$ | $_$ >> | + <:patt< $_$ .. $_$ >> | <:patt< $_$, $_$ >> | + <:patt< $_$; $_$ >> | <:patt< $_$ = $_$ >> as p -> + pp f "@[<1>(%a)@]" o#patt 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 "_" + | <: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< [ = $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< # $i$ >> -> pp f "@[<2>#%a@]" o#ident i + | <:ctyp< $t1$ == $t2$ >> -> + pp f "@[<2>%a =@ %a@]" o#simple_ctyp t1 o#simple_ctyp t2 + | <:ctyp< `$s$ >> -> pp f "`%a" o#var s + | <:ctyp< $t1$ * $t2$ >> -> pp f "%a *@ %a" o#simple_ctyp t1 o#simple_ctyp t2 + | 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 + | Ast.TyDcl _ tn tp te cl -> do { + pp f "@[<2>%a%a@]" o#type_params tp o#var tn; + match te with + [ <:ctyp< '$s$ >> + when not (List.exists (fun [ <:ctyp< '$s'$ >> -> s = s' + | _ -> False ]) tp) -> () + | _ -> pp f " =@ %a" o#ctyp te ]; + if cl <> [] then pp f "@ %a" (list o#constrain "@ ") cl else (); + } + | 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 + | <: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%s@]" o#ctyp t semisep + | <:sig_item< external $s$ : $t$ = $sl$ >> -> + pp f "@[<2>external@ %a :@ %a =@ %a%s@]" + o#var s o#ctyp t (meta_list o#quoted_string "@ ") sl semisep + | <: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%s@]" + o#var s1 o#functor_args al o#module_type mt semisep + | <:sig_item< module $s$ : $mt$ >> -> + pp f "@[<2>module %a :@ %a%s@]" + o#var s o#module_type mt semisep + | <:sig_item< module type $s$ = $mt$ >> -> + pp f "@[<2>module type %a =@ %a%s@]" + o#var s o#module_type mt semisep + | <:sig_item< open $sl$ >> -> + pp f "@[<2>open@ %a%s@]" o#ident sl semisep + | <:sig_item< type $t$ >> -> + pp f "@[@[type %a@]%s@]" o#ctyp t semisep + | <:sig_item< value $s$ : $t$ >> -> + pp f "@[<2>%s %a :@ %a%s@]" + value_val o#var s o#ctyp t semisep + | <:sig_item< include $mt$ >> -> + pp f "@[<2>include@ %a%s@]" o#module_type mt semisep + | <:sig_item< class type $ct$ >> -> + pp f "@[<2>class type %a%s@]" o#class_type ct semisep + | <:sig_item< class $ce$ >> -> + pp f "@[<2>class %a%s@]" o#class_type ce semisep + | <:sig_item< module rec $mb$ >> -> + pp f "@[<2>module rec %a%s@]" + o#module_rec_binding mb semisep + | <:sig_item< # $_$ $_$ >> -> () + | <:sig_item< $anti:s$ >> -> + pp f "%a%s" 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%s@]" o#ctyp t semisep + | <:str_item< exception $t$ = $sl$ >> -> + pp f "@[<2>exception@ %a =@ %a%s@]" o#ctyp t o#ident sl semisep + | <:str_item< external $s$ : $t$ = $sl$ >> -> + pp f "@[<2>external@ %a :@ %a =@ %a%s@]" + 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%s@]" + 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%s@]" + 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%s@]" + o#var s o#module_type mt o#module_expr me semisep + | <:str_item< module $s$ = $me$ >> -> + pp f "@[<2>module %a =@ %a%s@]" o#var s o#module_expr me semisep + | <:str_item< module type $s$ = $mt$ >> -> + pp f "@[<2>module type %a =@ %a%s@]" + o#var s o#module_type mt semisep + | <:str_item< open $sl$ >> -> + pp f "@[<2>open@ %a%s@]" o#ident sl semisep + | <:str_item< type $t$ >> -> + pp f "@[@[type %a@]%s@]" o#ctyp t semisep + | <:str_item< value $rec:r$ $bi$ >> -> + pp f "@[<2>%s %a%a%s@]" value_let o#rec_flag r o#binding bi semisep + | <:str_item< $exp:e$ >> -> + pp f "@[<2>let _ =@ %a%s@]" o#expr e semisep + | <:str_item< include $me$ >> -> + pp f "@[<2>include@ %a%s@]" o#module_expr me semisep + | <:str_item< class type $ct$ >> -> + pp f "@[<2>class type %a%s@]" o#class_type ct semisep + | <:str_item< class $ce$ >> -> + pp f "@[class %a%s@]" o#class_declaration ce semisep + | <:str_item< module rec $mb$ >> -> + pp f "@[<2>module rec %a%s@]" o#module_rec_binding mb semisep + | <:str_item< # $_$ $_$ >> -> () + | <:str_item< $anti:s$ >> -> pp f "%a%s" 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< $id:i$ >> -> o#ident f i + | <:module_type< $anti:s$ >> -> o#anti f s + | <: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 + | <:module_type< $mt$ with $wc$ >> -> + pp f "@[<2>%a@ with@ %a@]" o#module_type mt o#with_constraint wc ]; + + 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< $wc1$ and $wc2$ >> -> + do { o#with_constraint f wc1; pp f 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< $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 + | <: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< ( struct $st$ end : sig $sg$ end ) >> -> + pp f "@[<2>@[struct@ %a@]@ end :@ @[sig@ %a@]@ end@]" + o#str_item st o#sig_item sg + | <:module_expr< ( $me$ : $mt$ ) >> -> + pp f "@[<1>(%a :@ %a)@]" o#module_expr me o#module_type mt ]; + + 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#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 $id:i$ >> -> *) + | Ast.CeCon _ Ast.BTrue i <:ctyp<>> -> + pp f "@[<2>virtual@ %a@]" o#ident i + | Ast.CeCon _ Ast.BTrue i t -> + (* | <:class_expr< virtual $id:i$ [ $t$ ] >> -> *) + pp f "@[<2>virtual@ @[<1>[%a]@]@ %a@]" o#class_params t o#ident i + | <:class_expr< fun $p$ -> $ce$ >> -> + pp f "@[<2>fun@ %a@ ->@ %a@]" o#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 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 + | _ -> 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 $id:i$ >> -> *) + | Ast.CtCon _ Ast.BTrue i <:ctyp<>> -> + pp f "@[<2>virtual@ %a@]" o#ident i + (* | <:class_type< virtual $id:i$ [ $t$ ] >> -> *) + | Ast.CtCon _ Ast.BTrue i t -> + pp f "@[<2>virtual@ [@,%a@]@,]@ %a" o#class_params t o#ident 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 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 + | _ -> 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< type $t1$ = $t2$ >> -> + pp f "@[<2>type@ %a =@ %a%s@]" o#ctyp t1 o#ctyp t2 semisep + | <:class_sig_item< inherit $ct$ >> -> + pp f "@[<2>inherit@ %a%s@]" o#class_type ct semisep + | <:class_sig_item< method $private:pr$ $s$ : $t$ >> -> + pp f "@[<2>method %a%a :@ %a%s@]" o#private_flag pr o#var s + o#ctyp t semisep + | <:class_sig_item< method virtual $private:pr$ $s$ : $t$ >> -> + pp f "@[<2>method virtual %a%a :@ %a%s@]" + o#private_flag pr o#var s o#ctyp t semisep + | <:class_sig_item< value $mutable:mu$ $virtual:vi$ $s$ : $t$ >> -> + pp f "@[<2>%s %a%a%a :@ %a%s@]" + value_val o#mutable_flag mu o#virtual_flag vi o#var s o#ctyp t + semisep + | <:class_sig_item< $anti:s$ >> -> + pp f "%a%s" o#anti s 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< type $t1$ = $t2$ >> -> + pp f "@[<2>type %a =@ %a%s@]" o#ctyp t1 o#ctyp t2 semisep + | <:class_str_item< inherit $ce$ >> -> + pp f "@[<2>inherit@ %a%s@]" o#class_expr ce semisep + | <:class_str_item< inherit $ce$ as $lid:s$ >> -> + pp f "@[<2>inherit@ %a as@ %a%s@]" o#class_expr ce o#var s semisep + | <:class_str_item< initializer $e$ >> -> + pp f "@[<2>initializer@ %a%s@]" o#expr e semisep + | <:class_str_item< method $private:pr$ $s$ = $e$ >> -> + pp f "@[<2>method %a%a =@ %a%s@]" + o#private_flag pr o#var s o#expr e semisep + | <:class_str_item< method $private:pr$ $s$ : $t$ = $e$ >> -> + pp f "@[<2>method %a%a :@ %a =@ %a%s@]" + o#private_flag pr o#var s o#ctyp t o#expr e semisep + | <:class_str_item< method virtual $private:pr$ $s$ : $t$ >> -> + pp f "@[<2>method virtual@ %a%a :@ %a%s@]" + o#private_flag pr o#var s o#ctyp t semisep + | <:class_str_item< value virtual $mutable:mu$ $s$ : $t$ >> -> + pp f "@[<2>%s virtual %a%a :@ %a%s@]" + value_val o#mutable_flag mu o#var s o#ctyp t semisep + | <:class_str_item< value $mutable:mu$ $s$ = $e$ >> -> + pp f "@[<2>%s %a%a =@ %a%s@]" + value_val o#mutable_flag mu o#var s o#expr e semisep + | <:class_str_item< $anti:s$ >> -> + pp f "%a%s" o#anti s semisep ]; + + method implem f st = + match st with + [ <:str_item< $exp:e$ >> -> pp f "@[<0>%a%s@]@." 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 with module Ast = Syntax.Ast += struct + + include Make Syntax; + + value semisep = ref False; + 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 = if semisep.val then o#set_semisep ";;" else o#set_semisep "" 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 "-ss" (Arg.Set semisep) "Print double semicolons."; + + Options.add "-curry-constr" (Arg.Set curry_constr) "Use currified constructors."; + + Options.add "-no_ss" (Arg.Clear semisep) + "Do not print double semicolons (default)."; + + 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 00000000..ba930cf9 --- /dev/null +++ b/camlp4/Camlp4/Printers/OCaml.mli @@ -0,0 +1,168 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 Warning = Syntax.Warning + and module Token = Syntax.Token + and module Ast = Syntax.Ast + and module Gram = Syntax.Gram; + + 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 Ast.patt * 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 : string; + value value_val : string; + value value_let : string; + 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 expr : formatter -> Ast.expr -> unit; + method expr_list : formatter -> list Ast.expr -> unit; + method expr_list_cons : bool -> formatter -> Ast.expr -> 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 intlike : formatter -> string -> unit; + method binding : formatter -> Ast.binding -> unit; + method record_binding : formatter -> Ast.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 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 mutable_flag : formatter -> Ast.meta_bool -> unit; + method direction_flag : formatter -> Ast.meta_bool -> unit; + method rec_flag : formatter -> Ast.meta_bool -> unit; + method flag : formatter -> Ast.meta_bool -> string -> unit; + method node : formatter -> 'b -> ('b -> Loc.t) -> unit; + method object_dup : + formatter -> list (string * Ast.expr) -> 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_expr_fun_args : + formatter -> (Ast.patt * 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.meta_bool -> unit; + method virtual_flag : formatter -> Ast.meta_bool -> unit; + method quoted_string : formatter -> string -> unit; + method raise_match_failure : formatter -> Loc.t -> unit; + method reset : 'a; + method reset_semi : 'a; + method semisep : string; + method set_comments : bool -> 'a; + method set_curry_constr : bool -> 'a; + method set_loc_and_comments : 'a; + method set_semisep : string -> '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; + + 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; + +module MakeMore (Syntax : Sig.Camlp4Syntax) +: Sig.Printer with module Ast = Syntax.Ast; diff --git a/camlp4/Camlp4/Printers/OCamlr.ml b/camlp4/Camlp4/Printers/OCamlr.ml new file mode 100644 index 00000000..cf2df598 --- /dev/null +++ b/camlp4/Camlp4/Printers/OCamlr.ml @@ -0,0 +1,316 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +open Format; + +module Id = struct + value name = "Camlp4.Printers.OCamlr"; + value version = "$Id: OCamlr.ml,v 1.17 2007/02/07 10:09:21 ertai Exp $"; +end; + +module Make (Syntax : Sig.Camlp4Syntax) = struct + include Syntax; + open Sig; + + module PP_o = OCaml.Make Syntax; + + open PP_o; + + value pp = fprintf; + + 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 = ";"; + value andsep : format unit formatter unit = "@]@ @[<2>and@ "; + value value_val = "value"; + value value_let = "value"; + value mode = if comments then `comments else `no_comments; + value curry_constr = init_curry_constr; + value first_match_case = True; + + 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 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#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 (p, 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 simple_expr f e = + let () = o#node f e Ast.loc_of_expr in + match e with + [ <:expr< for $s$ = $e1$ to $e2$ do { $e3$ } >> -> + pp f "@[@[@[<2>for %a@ =@ %a@ to@ %a@ do {@]@ %a@]@ }@]" + o#var s o#expr e1 o#expr e2 o#seq e3 + | <:expr< for $s$ = $e1$ downto $e2$ do { $e3$ } >> -> + pp f "@[@[@[<2>for %a@ =@ %a@ downto@ %a@ do {@]@ %a@]@ }@]" + o#var s o#expr e1 o#expr e2 o#seq e3 + | <:expr< while $e1$ do { $e2$ } >> -> + pp f "@[<2>while@ %a@ do {@ %a@ }@]" o#expr e1 o#seq e2 + | <:expr< do { $e$ } >> -> + pp f "@[@[do {@ %a@]@ }@]" o#seq e + | e -> super#simple_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< '$s$ >> + when not (List.exists (fun [ <:ctyp< '$s'$ >> -> s = s' + | _ -> False ]) tp) -> () + | _ -> 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 + | 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%s@]" 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#module_expr me2 + | me -> super#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 $id:i$ >> -> *) + | Ast.CtCon _ Ast.BTrue i <:ctyp<>> -> + pp f "@[<2>virtual@ %a@]" o#ident i + (* | <:class_type< virtual $id:i$ [ $t$ ] >> -> *) + | Ast.CtCon _ Ast.BTrue i t -> + pp f "@[<2>virtual@ %a@ [@,%a@]@,]" o#ident 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 $id:i$ >> -> *) + | Ast.CeCon _ Ast.BTrue i <:ctyp<>> -> + pp f "@[<2>virtual@ %a@]" o#ident i + | Ast.CeCon _ Ast.BTrue i t -> + (* | <:class_expr< virtual $id:i$ [ $t$ ] >> -> *) + pp f "@[<2>virtual@ %a@ @[<1>[%a]@]@]" o#ident i o#ctyp t + | ce -> super#class_expr f ce ]; + end; + + value with_outfile = with_outfile; + value print = print; + value print_interf = print_interf; + value print_implem = print_implem; + +end; + +module MakeMore (Syntax : Sig.Camlp4Syntax) +: Sig.Printer with module Ast = Syntax.Ast += 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 00000000..c09bf6eb --- /dev/null +++ b/camlp4/Camlp4/Printers/OCamlr.mli @@ -0,0 +1,55 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 Warning = Syntax.Warning + 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; + + 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; + +module MakeMore (Syntax : Sig.Camlp4Syntax) +: Sig.Printer with module Ast = Syntax.Ast; diff --git a/camlp4/Camlp4/Register.ml b/camlp4/Camlp4/Register.ml new file mode 100644 index 00000000..e491f4c1 --- /dev/null +++ b/camlp4/Camlp4/Register.ml @@ -0,0 +1,167 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 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 = + (* let () = Format.eprintf "declare_dyn_module: %s@." m in *) + Queue.add (m, f) callbacks; + +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 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 }; + +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 with module Ast = Syn.Ast) = +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 with module Ast = Syn.Ast) = +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 with module Ast = PreCast.Ast) = +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 with module Ast = Ast) = +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 with module Ast = Ast) = +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 with module Ast = PreCast.Ast) = +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; + +let module M = Syntax.Parser in do { + sig_item_parser.val := M.parse_interf; + str_item_parser.val := M.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 00000000..337ca55d --- /dev/null +++ b/camlp4/Camlp4/Register.mli @@ -0,0 +1,93 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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; + +module Parser + (Id : Sig.Id) (Maker : functor (Ast : Sig.Ast) -> Sig.Parser with module Ast = Ast) : sig end; + +module OCamlParser + (Id : Sig.Id) (Maker : functor (Ast : Sig.Camlp4Ast) -> Sig.Parser with module Ast = Ast) : sig end; + +module OCamlPreCastParser + (Id : Sig.Id) (Parser : Sig.Parser with module Ast = PreCast.Ast) : 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; + +module Printer + (Id : Sig.Id) + (Maker : functor (Syn : Sig.Syntax) -> Sig.Printer with module Ast = Syn.Ast) : + sig end; + +module OCamlPrinter + (Id : Sig.Id) + (Maker : functor (Syn : Sig.Camlp4Syntax) -> Sig.Printer with module Ast = Syn.Ast) : + sig end; + +module OCamlPreCastPrinter + (Id : Sig.Id) (Printer : Sig.Printer with module Ast = PreCast.Ast) : + 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; + +module CurrentParser : Sig.Parser with module Ast = PreCast.Ast; +module CurrentPrinter : Sig.Printer with module Ast = PreCast.Ast; + +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 00000000..a3f80057 --- /dev/null +++ b/camlp4/Camlp4/Sig.ml @@ -0,0 +1,1302 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module type Type = sig + type t = 'abstract; +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 = 'abstract; + 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: Sig.ml,v 1.2 2007/02/26 16:32:46 ertai Exp $ with a versionning system. *) + value version : string; + +end; + +module type Loc = sig + + type t = 'a; + + (** 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; + + (** 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 file + to the begining of the line of location's begining. *) + value start_bol : t -> int; + + (** Returns the number of characters from the begining of the file + to the begining of the line of location's ending. *) + value stop_bol : t -> int; + + (** Returns the number of characters from the begining of the file + of the begining of this location. *) + value start_off : t -> int; + + (** Return the number of characters from the begining of the file + 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; + +module type Warning = sig + module Loc : Loc; + type t = Loc.t -> string -> unit; + value default : t; + value current : ref t; + value print : t; +end; + +(** Base class for map traversal, it includes some builtin types. *) +class mapper : object + method string : string -> string; + method int : int -> int; + method float : float -> float; + method bool : bool -> bool; + method list : ! 'a 'b . ('a -> 'b) -> list 'a -> list 'b; + method option : ! 'a 'b . ('a -> 'b) -> option 'a -> option 'b; + method array : ! 'a 'b . ('a -> 'b) -> array 'a -> array 'b; + method ref : ! 'a 'b . ('a -> 'b) -> ref 'a -> ref 'b; +end = object + method string x : string = x; + method int x : int = x; + method float x : float = x; + method bool x : bool = x; + method list : ! 'a 'b . ('a -> 'b) -> list 'a -> list 'b = + List.map; + method option : ! 'a 'b . ('a -> 'b) -> option 'a -> option 'b = + fun f -> fun [ None -> None | Some x -> Some (f x) ]; + method array : ! 'a 'b . ('a -> 'b) -> array 'a -> array 'b = + Array.map; + method ref : ! 'a 'b . ('a -> 'b) -> ref 'a -> ref 'b = + fun f { val = x } -> { val = f x }; +end; + +(** Abstract syntax tree minimal signature. + Types of this signature are abstract. + See the {!Camlp4Ast} signature for a concrete definition. *) +module type Ast = sig + + module Loc : Loc; + + type meta_bool = 'abstract; + type meta_option 'a = 'abstract; + type meta_list 'a = 'abstract; + type ctyp = 'abstract; + type patt = 'abstract; + type expr = 'abstract; + type module_type = 'abstract; + type sig_item = 'abstract; + type with_constr = 'abstract; + type module_expr = 'abstract; + type str_item = 'abstract; + type class_type = 'abstract; + type class_sig_item = 'abstract; + type class_expr = 'abstract; + type class_str_item = 'abstract; + type match_case = 'abstract; + type ident = 'abstract; + type binding = 'abstract; + type module_binding = 'abstract; + + value loc_of_ctyp : ctyp -> Loc.t; + value loc_of_patt : patt -> Loc.t; + value loc_of_expr : expr -> Loc.t; + value loc_of_module_type : module_type -> Loc.t; + value loc_of_module_expr : module_expr -> Loc.t; + value loc_of_sig_item : sig_item -> Loc.t; + value loc_of_str_item : str_item -> Loc.t; + value loc_of_class_type : class_type -> Loc.t; + value loc_of_class_sig_item : class_sig_item -> Loc.t; + value loc_of_class_expr : class_expr -> Loc.t; + value loc_of_class_str_item : class_str_item -> Loc.t; + value loc_of_with_constr : with_constr -> Loc.t; + value loc_of_binding : binding -> Loc.t; + value loc_of_module_binding : module_binding -> Loc.t; + value loc_of_match_case : match_case -> Loc.t; + value loc_of_ident : ident -> Loc.t; + + (** 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 + inherit mapper; + method meta_bool : meta_bool -> meta_bool; + method meta_option : ! 'a 'b . ('a -> 'b) -> meta_option 'a -> meta_option 'b; + method meta_list : ! 'a 'b . ('a -> 'b) -> meta_list 'a -> meta_list 'b; + method _Loc_t : Loc.t -> Loc.t; + 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 module_binding : module_binding -> module_binding; + method match_case : match_case -> match_case; + method ident : ident -> ident; + end; + + class fold : object ('self_type) + method string : string -> 'self_type; + method int : int -> 'self_type; + method float : float -> 'self_type; + method bool : bool -> 'self_type; + method list : ! 'a . ('self_type -> 'a -> 'self_type) -> list 'a -> 'self_type; + method option : ! 'a . ('self_type -> 'a -> 'self_type) -> option 'a -> 'self_type; + method array : ! 'a . ('self_type -> 'a -> 'self_type) -> array 'a -> 'self_type; + method ref : ! 'a . ('self_type -> 'a -> 'self_type) -> ref '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_t : Loc.t -> '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 module_binding : module_binding -> 'self_type; + method match_case : match_case -> 'self_type; + method ident : ident -> 'self_type; + end; + +end; + + +(** The AntiquotSyntax signature describe the minimal interface needed + for antiquotation handling. *) +module type AntiquotSyntax = sig + module Ast : Ast; + + (** The parse function for expressions. + The underlying expression grammar entry is generally "expr; EOI". *) + value parse_expr : Ast.Loc.t -> string -> Ast.expr; + + (** The parse function for patterns. + The underlying pattern grammar entry is generally "patt; EOI". *) + value parse_patt : Ast.Loc.t -> string -> Ast.patt; +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. *) +module type Camlp4Ast = sig + + module Loc : Loc; + + INCLUDE "camlp4/Camlp4/Camlp4Ast.partial.ml"; + + value loc_of_ctyp : ctyp -> Loc.t; + value loc_of_patt : patt -> Loc.t; + value loc_of_expr : expr -> Loc.t; + value loc_of_module_type : module_type -> Loc.t; + value loc_of_module_expr : module_expr -> Loc.t; + value loc_of_sig_item : sig_item -> Loc.t; + value loc_of_str_item : str_item -> Loc.t; + value loc_of_class_type : class_type -> Loc.t; + value loc_of_class_sig_item : class_sig_item -> Loc.t; + value loc_of_class_expr : class_expr -> Loc.t; + value loc_of_class_str_item : class_str_item -> Loc.t; + value loc_of_with_constr : with_constr -> Loc.t; + value loc_of_binding : binding -> Loc.t; + value loc_of_module_binding : module_binding -> Loc.t; + value loc_of_match_case : match_case -> Loc.t; + value loc_of_ident : ident -> Loc.t; + + 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.t -> Loc.t -> 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 -> expr; + end; + module MetaLoc : sig + value meta_loc_patt : Loc.t -> Loc.t -> patt; + value meta_loc_expr : Loc.t -> Loc.t -> expr; + end; + module MetaGhostLoc : sig + value meta_loc_patt : Loc.t -> 'a -> patt; + value meta_loc_expr : Loc.t -> 'a -> expr; + end; + module MetaLocVar : sig + value meta_loc_patt : Loc.t -> 'a -> patt; + value meta_loc_expr : Loc.t -> 'a -> expr; + end; + module Make (MetaLoc : META_LOC) : sig + module Expr : sig + value meta_string : Loc.t -> string -> expr; + value meta_int : Loc.t -> string -> expr; + value meta_float : Loc.t -> string -> expr; + value meta_char : Loc.t -> string -> expr; + value meta_bool : Loc.t -> bool -> expr; + value meta_list : (Loc.t -> 'a -> expr) -> Loc.t -> list 'a -> expr; + value meta_binding : Loc.t -> binding -> expr; + value meta_class_expr : Loc.t -> class_expr -> expr; + value meta_class_sig_item : Loc.t -> class_sig_item -> expr; + value meta_class_str_item : Loc.t -> class_str_item -> expr; + value meta_class_type : Loc.t -> class_type -> expr; + value meta_ctyp : Loc.t -> ctyp -> expr; + value meta_expr : Loc.t -> expr -> expr; + value meta_ident : Loc.t -> ident -> expr; + value meta_match_case : Loc.t -> match_case -> expr; + value meta_module_binding : Loc.t -> module_binding -> expr; + value meta_module_expr : Loc.t -> module_expr -> expr; + value meta_module_type : Loc.t -> module_type -> expr; + value meta_patt : Loc.t -> patt -> expr; + value meta_sig_item : Loc.t -> sig_item -> expr; + value meta_str_item : Loc.t -> str_item -> expr; + value meta_with_constr : Loc.t -> with_constr -> expr; + end; + module Patt : sig + value meta_string : Loc.t -> string -> patt; + value meta_int : Loc.t -> string -> patt; + value meta_float : Loc.t -> string -> patt; + value meta_char : Loc.t -> string -> patt; + value meta_bool : Loc.t -> bool -> patt; + value meta_list : (Loc.t -> 'a -> patt) -> Loc.t -> list 'a -> patt; + value meta_binding : Loc.t -> binding -> patt; + value meta_class_expr : Loc.t -> class_expr -> patt; + value meta_class_sig_item : Loc.t -> class_sig_item -> patt; + value meta_class_str_item : Loc.t -> class_str_item -> patt; + value meta_class_type : Loc.t -> class_type -> patt; + value meta_ctyp : Loc.t -> ctyp -> patt; + value meta_expr : Loc.t -> expr -> patt; + value meta_ident : Loc.t -> ident -> patt; + value meta_match_case : Loc.t -> match_case -> patt; + value meta_module_binding : Loc.t -> module_binding -> patt; + value meta_module_expr : Loc.t -> module_expr -> patt; + value meta_module_type : Loc.t -> module_type -> patt; + value meta_patt : Loc.t -> patt -> patt; + value meta_sig_item : Loc.t -> sig_item -> patt; + value meta_str_item : Loc.t -> str_item -> patt; + value meta_with_constr : Loc.t -> with_constr -> patt; + end; + end; + end; + + (** See {!Ast.map}. *) + class map : object + inherit mapper; + method meta_bool : meta_bool -> meta_bool; + method meta_option : ! 'a 'b . ('a -> 'b) -> meta_option 'a -> meta_option 'b; + method meta_list : ! 'a 'b . ('a -> 'b) -> meta_list 'a -> meta_list 'b; + method _Loc_t : Loc.t -> Loc.t; + 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 module_binding : module_binding -> module_binding; + method match_case : match_case -> match_case; + method ident : ident -> ident; + end; + + (** See {!Ast.fold}. *) + class fold : object ('self_type) + method string : string -> 'self_type; + method int : int -> 'self_type; + method float : float -> 'self_type; + method bool : bool -> 'self_type; + method list : ! 'a . ('self_type -> 'a -> 'self_type) -> list 'a -> 'self_type; + method option : ! 'a . ('self_type -> 'a -> 'self_type) -> option 'a -> 'self_type; + method array : ! 'a . ('self_type -> 'a -> 'self_type) -> array 'a -> 'self_type; + method ref : ! 'a . ('self_type -> 'a -> 'self_type) -> ref '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_t : Loc.t -> '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 module_binding : module_binding -> 'self_type; + method match_case : match_case -> 'self_type; + method ident : ident -> 'self_type; + end; + + (** See {!Ast.remove_antiquots}. *) + (* class remove_antiquots : object inherit map; end; *) + + class c_expr : [expr -> expr] -> object inherit map; end; + class c_patt : [patt -> patt] -> object inherit map; end; + class c_ctyp : [ctyp -> ctyp] -> object inherit map; end; + class c_str_item : [str_item -> str_item] -> object inherit map; end; + class c_sig_item : [sig_item -> sig_item] -> object inherit map; end; + class c_loc : [Loc.t -> Loc.t] -> object inherit map; end; + + value map_expr : (expr -> expr) -> expr -> expr; + value map_patt : (patt -> patt) -> patt -> patt; + value map_ctyp : (ctyp -> ctyp) -> ctyp -> ctyp; + value map_str_item : (str_item -> str_item) -> str_item -> str_item; + value map_sig_item : (sig_item -> sig_item) -> sig_item -> sig_item; + value map_loc : (Loc.t -> Loc.t) -> Loc.t -> Loc.t; + + value ident_of_expr : expr -> ident; + value ident_of_ctyp : ctyp -> ident; + + value biAnd_of_list : list binding -> binding; + value biSem_of_list : list binding -> 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 tySem_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_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 module 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 module_binding = M.module_binding + and type match_case = M.match_case + and type ident = M.ident += M; + +(** 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; + +(** 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; + + (** {6 Filters} *) + + 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 fold_interf_filters : ('a -> filter Ast.sig_item -> 'a) -> 'a -> 'a; + value fold_implem_filters : ('a -> filter Ast.str_item -> 'a) -> 'a -> 'a; + +end; + +(** Quotation operations. *) + +type quotation = + { q_name : string ; + q_loc : string ; + q_shift : int ; + q_contents : string }; + +module type Quotation = sig + module Ast : Ast; + open Ast; + + (** The Loc.t 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.t -> option string -> string -> 'a; + + (** The type for quotation expanders kind: + - [ExStr exp] for an expander [exp] returning a string which + can be parsed to create a syntax tree. Its boolean parameter + tells whether the quotation is in position of an expression + (True) or in position of a pattern (False). Quotations expanders + created with this way may work for some particular language syntax, + and not for another one (e.g. may work when used with Revised + syntax and not when used with Ocaml syntax, and conversely). + - [ExAst (expr_exp, patt_exp)] for expanders returning directly + syntax trees, therefore not necessiting to be parsed afterwards. + The function [expr_exp] is called when the quotation is in + position of an expression, and [patt_exp] when the quotation is + in position of a pattern. Quotation expanders created with this + way are independant from the language syntax. *) + type expander = + [ ExStr of bool -> expand_fun string + | ExAst of (expand_fun Ast.expr) and (expand_fun Ast.patt) ]; + + (** [add name exp] adds the quotation [name] associated with the + expander [exp]. *) + value add : string -> expander -> unit; + + (** [find name] returns the expander of the given quotation name. *) + value find : string -> expander; + + (** [default] holds the default quotation name. *) + value default : ref string; + + (** function translating quotation names; default = identity *) + value translate : ref (string -> string); + + value expand_expr : (Loc.t -> string -> Ast.expr) -> Loc.t -> quotation -> Ast.expr; + value expand_patt : (Loc.t -> string -> Ast.patt) -> Loc.t -> quotation -> Ast.patt; + + (** [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; + +type stream_filter 'a 'loc = Stream.t ('a * 'loc) -> Stream.t ('a * 'loc); + +module type Token = sig + + module Loc : Loc; + + type t = 'abstract; + + 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 = 'abstract; + + (** 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 Objective Caml 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]) + is 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 ]; + +module type Camlp4Token = Token with type t = camlp4_token; + +module type DynLoader = sig + type t = 'abstract; + 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; +end; + +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 = 'abstract; + + 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 = 'abstract; + type internal_entry = 'abstract; + type tree = 'abstract; + + type token_pattern = ((Token.t -> bool) * string); + + 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 + | 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 = 'abstract; + + (** 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 -> (Stream.t (Token.t * Loc.t) -> 'a) -> t 'a; + + (** Clear the entry and setup this parser instead. *) + value setup_parser : + t 'a -> (Stream.t (Token.t * Loc.t) -> '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 = 'abstract; + + (** 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)) + -> Stream.t (Token.t * Loc.t); + + (** 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 -> Stream.t (Token.t * Loc.t) -> '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 = 'abstract; + + (** 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 -> (Stream.t (Token.t * Loc.t) -> 'a) -> t 'a; + + (** Clear the entry and setup this parser instead. *) + value setup_parser : + t 'a -> (Stream.t (Token.t * Loc.t) -> '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 = 'abstract; + + (** 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)) + -> Stream.t (Token.t * Loc.t); + + (** 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 -> Stream.t (Token.t * Loc.t) -> 'a; + + end; + +end; + +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; + + +(** {6 Parser} *) +module type Parser = sig + + module Ast : Ast; + open Ast; + + (** 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:(str_item -> option str_item) -> + Loc.t -> Stream.t char -> Ast.str_item; + + (** Same as {!parse_implem} but for interface (mli file). *) + value parse_interf : ?directive_handler:(sig_item -> option sig_item) -> + Loc.t -> Stream.t char -> Ast.sig_item; + +end; + +(** {6 Printer} *) + +module type Printer = sig + + module Ast : Ast; + + 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; + +(** 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 Warning : Warning with module Loc = Loc; + module Ast : Ast with module Loc = Loc; + module Token : Token with module Loc = Loc; + module Gram : Grammar.Static with module Loc = Loc and module Token = Token; + module AntiquotSyntax : AntiquotSyntax with module Ast = Ast; + (* Gram is not constrained here for flexibility *) + module Quotation : Quotation with module Ast = Ast; + module Parser : Parser with module Ast = Ast; + module Printer : Printer with module Ast = Ast; +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 Warning : Warning with 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 AntiquotSyntax : AntiquotSyntax with module Ast = Camlp4AstToAst Ast; + (* Gram is not constrained here for flexibility *) + module Quotation : Quotation with module Ast = Camlp4AstToAst Ast; + module Parser : Parser with module Ast = Camlp4AstToAst Ast; + module Printer : Printer with module Ast = Camlp4AstToAst Ast; + + 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_LIDENT_or_operator : 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 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.meta_bool; + 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 : Gram.Entry.t Ast.ctyp; + value field_expr : Gram.Entry.t Ast.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_expr : Gram.Entry.t Ast.binding; + value label_ipatt : Gram.Entry.t Ast.patt; + value label_longident : Gram.Entry.t Ast.ident; + value label_patt : 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; + 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 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.meta_bool; + value opt_eq_ctyp : Gram.Entry.t (list Ast.ctyp -> 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.meta_bool; + value opt_polyt : Gram.Entry.t Ast.ctyp; + value opt_private : Gram.Entry.t Ast.meta_bool; + value opt_rec : Gram.Entry.t Ast.meta_bool; + value opt_virtual : Gram.Entry.t Ast.meta_bool; + 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 pipe_ctyp : Gram.Entry.t Ast.ctyp; + value poly_type : Gram.Entry.t Ast.ctyp; + value row_field : Gram.Entry.t Ast.ctyp; + value sem_ctyp : 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 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 (string * 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; +end; + +module type SyntaxExtension = functor (Syn : Syntax) + -> (Syntax with module Loc = Syn.Loc + and module Warning = Syn.Warning + and module Ast = Syn.Ast + and module Token = Syn.Token + and module Gram = Syn.Gram + and module AntiquotSyntax = Syn.AntiquotSyntax + and module Quotation = Syn.Quotation); + diff --git a/camlp4/Camlp4/Struct.mlpack b/camlp4/Camlp4/Struct.mlpack new file mode 100644 index 00000000..bd8c40a1 --- /dev/null +++ b/camlp4/Camlp4/Struct.mlpack @@ -0,0 +1,15 @@ +AstFilters +Camlp4Ast +Camlp4Ast2OCamlAst +CleanAst +CommentFilter +DynLoader +EmptyError +EmptyPrinter +FreeVars +Lexer +Loc +Quotation +Token +Warning +Grammar diff --git a/camlp4/Camlp4/Struct/.cvsignore b/camlp4/Camlp4/Struct/.cvsignore new file mode 100644 index 00000000..262784db --- /dev/null +++ b/camlp4/Camlp4/Struct/.cvsignore @@ -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 00000000..9962d8a1 --- /dev/null +++ b/camlp4/Camlp4/Struct/AstFilters.ml @@ -0,0 +1,34 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 register_sig_item_filter f = Queue.add f interf_filters; + value register_str_item_filter f = Queue.add f implem_filters; +end; diff --git a/camlp4/Camlp4/Struct/Camlp4Ast.mlast b/camlp4/Camlp4/Struct/Camlp4Ast.mlast new file mode 100644 index 00000000..95bccdb5 --- /dev/null +++ b/camlp4/Camlp4/Struct/Camlp4Ast.mlast @@ -0,0 +1,501 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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_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"; + + 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_acc_Loc_t = meta_loc_expr; + module Expr = Camlp4Filters.MetaGeneratorExpr Ast; + value meta_acc_Loc_t = meta_loc_patt; + module Patt = Camlp4Filters.MetaGeneratorPatt Ast; + end; + + end; + + class map = Camlp4Filters.GenerateMap.generated; + + class fold = Camlp4Filters.GenerateFold.generated; + + class c_expr f = object + inherit map as super; + method expr x = f (super#expr x); + end; + class c_patt f = object + inherit map as super; + method patt x = f (super#patt x); + end; + class c_ctyp f = object + inherit map as super; + method ctyp x = f (super#ctyp x); + end; + class c_str_item f = object + inherit map as super; + method str_item x = f (super#str_item x); + end; + class c_sig_item f = object + inherit map as super; + method sig_item x = f (super#sig_item x); + end; + class c_loc f = object + inherit map as super; + method _Loc_t x = f (super#_Loc_t x); + end; + value map_patt f ast = (new c_patt f)#patt ast; + value map_loc f ast = (new c_loc f)#_Loc_t ast; + value map_sig_item f ast = (new c_sig_item f)#sig_item ast; + value map_str_item f ast = (new c_str_item f)#str_item ast; + value map_ctyp f ast = (new c_ctyp f)#ctyp ast; + value map_expr f ast = (new c_expr f)#expr ast; + 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 rec is_irrefut_patt = + fun + [ <:patt< $lid:_$ >> -> True + | <:patt< () >> -> True + | <:patt< _ >> -> True + | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y + | <:patt< { $p$ } >> -> is_irrefut_patt p + | <:patt< $lid:_$ = $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< ($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 + | _ -> 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 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 () + | <:expr< $_$ >> -> 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 () + | <:ctyp< $_$ >> -> error () ] in + fun + [ <:ctyp< $id:i$ >> -> i + | t -> self t ]; + + 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 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 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 biSem_of_list = + fun + [ [] -> <:binding@ghost<>> + | [x] -> x + | [x::xs] -> + let _loc = loc_of_binding x in + <:binding< $x$; $biSem_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)] + | <:binding< $b1$ ; $b2$ >> -> pel_of_binding b1 @ pel_of_binding b2 + | _ -> assert False ]; + + value rec list_of_binding x acc = + match x with + [ <:binding< $b1$ and $b2$ >> | <:binding< $b1$; $b2$ >> -> + list_of_binding b1 (list_of_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] ]; + +end; + +module Camlp4Trash = struct +(* #use "camlp4/Camlp4/Camlp4Ast.partial.ml"; *) + INCLUDE "camlp4/Camlp4/Camlp4Ast.partial.ml"; +end; diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml new file mode 100644 index 00000000..9957beba --- /dev/null +++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml @@ -0,0 +1,1030 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2002-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +(* $Id: Camlp4Ast2OCamlAst.ml,v 1.15 2007/02/26 16:32:46 ertai Exp $ *) + +module Make (Ast : Sig.Camlp4Ast) = struct + open Format; + open Parsetree; + open Longident; + open Asttypes; + open Ast; + + value constructors_arity () = + debug ast2pt "constructors_arity: %b@." Camlp4_config.constructors_arity.val in + Camlp4_config.constructors_arity.val; + + 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 mkloc = Loc.to_ocaml_location; + value mkghloc loc = Loc.to_ocaml_location (Loc.ghostify loc); + + value mktyp loc d = {ptyp_desc = d; ptyp_loc = mkloc loc}; + value mkpat loc d = {ppat_desc = d; ppat_loc = mkloc loc}; + value mkghpat loc d = {ppat_desc = d; ppat_loc = mkghloc loc}; + value mkexp loc d = {pexp_desc = d; pexp_loc = mkloc loc}; + value mkmty loc d = {pmty_desc = d; pmty_loc = mkloc loc}; + value mksig loc d = {psig_desc = d; psig_loc = mkloc loc}; + value mkmod loc d = {pmod_desc = d; pmod_loc = mkloc loc}; + value mkstr loc d = {pstr_desc = d; pstr_loc = mkloc loc}; + value mkfield loc d = {pfield_desc = d; pfield_loc = mkloc loc}; + value mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc}; + value mkpcl loc d = {pcl_desc = d; pcl_loc = mkloc loc}; + value mkpolytype t = + match t.ptyp_desc with + [ Ptyp_poly _ _ -> t + | _ -> { (t) with ptyp_desc = Ptyp_poly [] t } ] + ; + + value mb2b = + fun + [ Ast.BTrue -> True + | Ast.BFalse -> False + | Ast.BAnt _ -> assert False ]; + + value mkvirtual m = if mb2b m then Virtual else Concrete; + + value lident s = Lident s; + 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 str name = + ldot (lident str) (if Camlp4_config.unsafe.val then "unsafe_" ^ name else name) + ; + + value mkrf = + fun + [ Ast.BTrue -> Recursive + | Ast.BFalse -> Nonrecursive + | Ast.BAnt _ -> assert False ]; + + value mkli s = + loop (fun s -> lident s) where rec loop f = + fun + [ [i :: il] -> loop (fun s -> ldot (f i) s) 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 ?conv_lid i = fst (ident_tag ?conv_lid i); + + value long_lident msg i = + match ident_tag i with + [ (i, `lident) -> i + | _ -> error (loc_of_ident i) msg ] + ; + + value long_type_ident = long_lident "invalid long identifier type"; + value long_class_ident = long_lident "invalid class name"; + + value long_uident ?(conv_con = fun x -> x) i = + 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 rec ctyp_long_id_prefix t = + match t with + [ <:ctyp< $id:i$ >> -> ident 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< '$s$ >> -> [s] + | _ -> assert False ]; + + 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 lab (ctyp t1) (ctyp t2)) + | TyArr loc (TyOlb loc1 lab t1) t2 -> + let t1 = TyApp loc1 <:ctyp@loc1< option >> t1 in + mktyp loc (Ptyp_arrow ("?" ^ lab) (ctyp t1) (ctyp t2)) + | TyArr loc t1 t2 -> mktyp loc (Ptyp_arrow "" (ctyp t1) (ctyp t2)) + | <:ctyp@loc< < > >> -> mktyp loc (Ptyp_object []) + | <:ctyp@loc< < .. > >> -> mktyp loc (Ptyp_object [mkfield loc Pfield_var]) + | <:ctyp@loc< < $fl$ > >> -> mktyp loc (Ptyp_object (meth_list fl [])) + | <:ctyp@loc< < $fl$ .. > >> -> + mktyp loc (Ptyp_object (meth_list fl [mkfield loc Pfield_var])) + | TyCls loc id -> + mktyp loc (Ptyp_class (ident id) [] []) + | 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" + | <: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) True None) + | <:ctyp@loc< [ > $t$ ] >> -> mktyp loc (Ptyp_variant (row_field t) False None) + | <:ctyp@loc< [ < $t$ ] >> -> mktyp loc (Ptyp_variant (row_field t) True (Some [])) + | <:ctyp@loc< [ < $t$ > $t'$ ] >> -> + mktyp loc (Ptyp_variant (row_field t) True (Some (name_tags t'))) + | TyAnt loc _ -> error loc "antiquotation not allowed here" + | TyOfAmp _ _ _ |TyAmp _ _ _ |TySta _ _ _ | + TyCom _ _ _ |TyVrn _ _ |TyQuM _ _ |TyQuP _ _ |TyDcl _ _ _ _ _ | + TyObj _ _ (BAnt _) | TyNil _ | TyTup _ _ -> + assert False ] + and row_field = fun + [ <:ctyp< `$i$ >> -> [Rtag i True []] + | <:ctyp< `$i$ of & $t$ >> -> [Rtag i True (List.map ctyp (list_of_ctyp t []))] + | <:ctyp< `$i$ of $t$ >> -> [Rtag i 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< $t1$; $t2$ >> -> meth_list t1 (meth_list t2 acc) + | <:ctyp@loc< $lid:lab$ : $t$ >> -> + [mkfield loc (Pfield lab (mkpolytype (ctyp t))) :: acc] + | _ -> assert False ] + ; + + value mktype loc tl cl tk tm = + let (params, variance) = List.split tl in + {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk; + ptype_manifest = tm; ptype_loc = mkloc loc; ptype_variance = variance} + ; + value mkprivate' m = if m then Private else Public; + value mkprivate m = mkprivate' (mb2b m); + value mktrecord = + fun + [ <:ctyp@loc< $lid:s$ : mutable $t$ >> -> + (s, Mutable, mkpolytype (ctyp t), mkloc loc) + | <:ctyp@loc< $lid:s$ : $t$ >> -> + (s, Immutable, mkpolytype (ctyp t), mkloc loc) + | _ -> assert False (*FIXME*) ]; + value mkvariant = + fun + [ <:ctyp@loc< $uid:s$ >> -> (conv_con s, [], mkloc loc) + | <:ctyp@loc< $uid:s$ of $t$ >> -> + (conv_con s, List.map ctyp (list_of_ctyp t []), mkloc loc) + | _ -> assert False (*FIXME*) ]; + value rec type_decl tl cl loc m pflag = + fun + [ TyMan _ t1 t2 -> + type_decl tl cl loc (Some (ctyp t1)) pflag t2 + | TyPrv _ t -> + type_decl tl cl loc m True t + | TyRec _ t -> + mktype loc tl cl + (Ptype_record (List.map mktrecord (list_of_ctyp t [])) (mkprivate' pflag)) m + | TySum _ t -> + mktype loc tl cl + (Ptype_variant (List.map mkvariant (list_of_ctyp t [])) (mkprivate' pflag)) m + | t -> + if m <> None then + error loc "only one manifest type allowed by definition" else + let m = + match t with + [ TyQuo _ s -> if List.mem_assoc s tl then Some (ctyp t) else None + | _ -> Some (ctyp t) ] + in + let k = if pflag then Ptype_private else Ptype_abstract in + mktype loc tl cl k m ] + ; + + value type_decl tl cl t = type_decl tl cl (loc_of_ctyp t) None False t; + + value mkvalue_desc t p = {pval_type = ctyp t; pval_prim = p}; + + 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 m = if mb2b m then Mutable else Immutable; + + 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_private, ctyp t) + | t -> (Ptype_abstract, ctyp t) ]; + + value rec type_parameters t acc = + match t with + [ <:ctyp< $t1$ $t2$ >> -> type_parameters t1 (type_parameters t2 acc) + | <:ctyp< +'$s$ >> -> [(s, (True, False)) :: acc] + | <:ctyp< -'$s$ >> -> [(s, (False, True)) :: acc] + | <:ctyp< '$s$ >> -> [(s, (False, False)) :: acc] + | _ -> assert False ]; + + value rec class_parameters t acc = + match t with + [ <:ctyp< $t1$, $t2$ >> -> class_parameters t1 (class_parameters t2 acc) + | <:ctyp< +'$s$ >> -> [(s, (True, False)) :: acc] + | <:ctyp< -'$s$ >> -> [(s, (False, True)) :: acc] + | <:ctyp< '$s$ >> -> [(s, (False, False)) :: acc] + | _ -> assert False ]; + + value rec type_parameters_and_type_name t acc = + match t with + [ <:ctyp< $t1$ $t2$ >> -> + type_parameters_and_type_name t1 + (type_parameters t2 acc) + | <:ctyp< $id:i$ >> -> (ident i, acc) + | _ -> assert False ]; + + value rec mkwithc wc acc = + match wc with + [ WcNil _ -> acc + | WcTyp loc id_tpl ct -> + let (id, tpl) = type_parameters_and_type_name id_tpl [] in + let (params, variance) = List.split tpl in + let (kind, ct) = opt_private_ctyp ct in + [(id, + Pwith_type + {ptype_params = params; ptype_cstrs = []; + ptype_kind = kind; + ptype_manifest = Some ct; + ptype_loc = mkloc loc; ptype_variance = variance}) :: acc] + | WcMod _ i1 i2 -> + [(long_uident i1, Pwith_module (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 (Const_char c1)) + else + mkghpat loc + (Ppat_or (mkghpat loc (Ppat_constant (Const_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 (Const_char c1)) + else + mkpat loc + (Ppat_or (mkghpat loc (Ppat_constant (Const_char c1))) + (deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2)) + ; + + value rec patt = + fun + [ <:patt@loc< $lid:s$ >> -> mkpat loc (Ppat_var s) + | <:patt@loc< $id:i$ >> -> + let p = Ppat_construct (long_uident ~conv_con i) + None (constructors_arity ()) + in mkpat loc p + | PaAli loc p1 p2 -> + let (p, i) = + match (p1, p2) with + [ (p, <:patt< $lid:s$ >>) -> (p, s) + | (<:patt< $lid:s$ >>, p) -> (p, s) + | _ -> error loc "invalid alias pattern" ] + in + mkpat loc (Ppat_alias (patt p) i) + | PaAnt loc _ -> error loc "antiquotation not allowed here" + | PaAny loc -> mkpat loc Ppat_any + | <:patt@loc< $uid:s$ ($tup:<:patt@loc_any< _ >>$) >> -> + mkpat loc (Ppat_construct (lident (conv_con s)) + (Some (mkpat loc_any Ppat_any)) False) + | 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 _ -> + if constructors_arity () then + mkpat loc (Ppat_construct li (Some (mkpat loc (Ppat_tuple al))) True) + else + let a = + match al with + [ [a] -> a + | _ -> mkpat loc (Ppat_tuple al) ] + in + mkpat loc (Ppat_construct li (Some a) False) + | Ppat_variant s None -> + let a = + if constructors_arity () then + mkpat loc (Ppat_tuple al) + else + 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 (Const_char (char_of_char_token loc s))) + | PaInt loc s -> + let i = try int_of_string s with [ + Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int" + ] in mkpat loc (Ppat_constant (Const_int i)) + | PaInt32 loc s -> + let i32 = try Int32.of_string s with [ + Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int32" + ] in mkpat loc (Ppat_constant (Const_int32 i32)) + | PaInt64 loc s -> + let i64 = try Int64.of_string s with [ + Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int64" + ] in mkpat loc (Ppat_constant (Const_int64 i64)) + | PaNativeInt loc s -> + let nati = try Nativeint.of_string s with [ + Failure _ -> error loc "Integer literal exceeds the range of representable integers of type nativeint" + ] in mkpat loc (Ppat_constant (Const_nativeint nati)) + | PaFlo loc s -> mkpat loc (Ppat_constant (Const_float s)) + | 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 -> + mkpat loc (Ppat_record (List.map mklabpat (list_of_patt p []))) + | PaStr loc s -> + mkpat loc (Ppat_constant (Const_string (string_of_string_token loc s))) + | <: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 s None) + | PaEq _ _ _ | PaSem _ _ _ | PaCom _ _ _ | PaNil _ as p -> + error (loc_of_patt p) "invalid pattern" ] + and mklabpat = + fun + [ <:patt< $id: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 list_of_opt_ctyp ot acc = + match ot with + [ <:ctyp<>> -> acc + | t -> list_of_ctyp t acc ]; + + value rec expr = + fun + [ <:expr@loc< $x$.val >> -> + mkexp loc + (Pexp_apply (mkexp loc (Pexp_ident (Lident "!"))) [("", 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] -> + let ca = constructors_arity () in + (mkexp loc (Pexp_construct (mkli s ml) None ca), l) + | [(loc, ml, <:expr< $lid:s$ >>) :: l] -> + (mkexp loc (Pexp_ident (mkli 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< $lid:s$ >> -> + let loc = Loc.merge loc_bp loc_ep + in (loc, mkexp loc (Pexp_field e1 (mkli (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 + if constructors_arity () then + mkexp loc (Pexp_construct li (Some (mkexp loc (Pexp_tuple al))) True) + else + let a = + match al with + [ [a] -> a + | _ -> mkexp loc (Pexp_tuple al) ] + in + mkexp loc (Pexp_construct li (Some a) False) + | Pexp_variant s None -> + let al = List.map snd al in + let a = + if constructors_arity () then + mkexp loc (Pexp_tuple al) + else + 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 "Array" "get"))) + [("", expr e1); ("", expr e2)]) + | ExArr loc e -> mkexp loc (Pexp_array (List.map expr (list_of_expr e []))) + | ExAsf loc -> mkexp loc Pexp_assertfalse + | ExAss loc e v -> + let e = + match e with + [ <:expr@loc< $x$.val >> -> + Pexp_apply (mkexp loc (Pexp_ident (Lident ":="))) + [("", expr x); ("", expr v)] + | ExAcc loc _ _ -> + match (expr e).pexp_desc with + [ Pexp_field e lab -> Pexp_setfield e lab (expr v) + | _ -> error loc "bad record access" ] + | ExAre _ e1 e2 -> + Pexp_apply (mkexp loc (Pexp_ident (array_function "Array" "set"))) + [("", expr e1); ("", expr e2); ("", expr v)] + | <:expr< $lid:lab$ >> -> Pexp_setinstvar lab (expr v) + | ExSte _ e1 e2 -> + Pexp_apply + (mkexp loc (Pexp_ident (array_function "String" "set"))) + [("", expr e1); ("", expr e2); ("", 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 (Const_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_constraint (expr e) t1 (Some (ctyp t2))) + | ExFlo loc s -> mkexp loc (Pexp_constant (Const_float s)) + | ExFor loc i e1 e2 df el -> + let e3 = ExSeq loc el in + let df = if mb2b df then Upto else Downto in + mkexp loc (Pexp_for i (expr e1) (expr e2) df (expr e3)) + | <:expr@loc< fun [ $PaLab _ lab po$ when $w$ -> $e$ ] >> -> + mkexp loc + (Pexp_function lab None + [(patt_of_lab loc lab po, when_expr e w)]) + | <:expr@loc< fun [ $PaOlbi _ lab p e1$ when $w$ -> $e2$ ] >> -> + let lab = paolab lab p in + mkexp loc + (Pexp_function ("?" ^ lab) (Some (expr e1)) [(patt p, when_expr e2 w)]) + | <:expr@loc< fun [ $PaOlb _ lab p$ when $w$ -> $e$ ] >> -> + let lab = paolab lab p in + mkexp loc + (Pexp_function ("?" ^ lab) None [(patt_of_lab loc lab p, when_expr e w)]) + | ExFun loc a -> mkexp loc (Pexp_function "" None (match_case a [])) + | ExIfe loc e1 e2 e3 -> + mkexp loc (Pexp_ifthenelse (expr e1) (expr e2) (Some (expr e3))) + | ExInt loc s -> + let i = try int_of_string s with [ + Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int" + ] in mkexp loc (Pexp_constant (Const_int i)) + | ExInt32 loc s -> + let i32 = try Int32.of_string s with [ + Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int32" + ] in mkexp loc (Pexp_constant (Const_int32 i32)) + | ExInt64 loc s -> + let i64 = try Int64.of_string s with [ + Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int64" + ] in mkexp loc (Pexp_constant (Const_int64 i64)) + | ExNativeInt loc s -> + let nati = try Nativeint.of_string s with [ + Failure _ -> error loc "Integer literal exceeds the range of representable integers of type nativeint" + ] in mkexp loc (Pexp_constant (Const_nativeint nati)) + | ExLab loc _ _ -> error loc "labeled expression not allowed here" + | ExLaz loc e -> mkexp loc (Pexp_lazy (expr e)) + | ExLet loc rf bi e -> + mkexp loc (Pexp_let (mkrf rf) (binding bi []) (expr e)) + | ExLmd loc i me e -> mkexp loc (Pexp_letmodule i (module_expr me) (expr e)) + | 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 (patt p, 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 + [ <: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) s) + | ExSte loc e1 e2 -> + mkexp loc + (Pexp_apply (mkexp loc (Pexp_ident (array_function "String" "get"))) + [("", expr e1); ("", expr e2)]) + | ExStr loc s -> + mkexp loc (Pexp_constant (Const_string (string_of_string_token loc s))) + | 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) (Some (ctyp t)) None) + | <:expr@loc< () >> -> + mkexp loc (Pexp_construct (lident "()") None True) + | <:expr@loc< $lid:s$ >> -> + mkexp loc (Pexp_ident (lident s)) + | <:expr@loc< $uid:s$ >> -> + (* let ca = constructors_arity () in *) + mkexp loc (Pexp_construct (lident (conv_con s)) None True) + | ExVrn loc s -> mkexp loc (Pexp_variant s None) + | ExWhi loc e1 el -> + let e2 = ExSeq loc el in + mkexp loc (Pexp_while (expr e1) (expr e2)) + | <:expr@loc< $_$,$_$ >> -> error loc "expr, expr: not allowed here" + | <:expr@loc< $_$;$_$ >> -> + error loc "expr; expr: not allowed here, use do {...} or [|...|] to surround them" + | 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 -> (lab, expr_of_lab loc lab eo) + | ExOlb loc lab eo -> ("?" ^ lab, expr_of_lab loc lab eo) + | e -> ("", expr e) ] + and binding x acc = + match x with + [ <:binding< $x$ and $y$ >> | <:binding< $x$; $y$ >> -> + binding x (binding y acc) + | <:binding< $p$ = $e$ >> -> [(patt p, expr e) :: 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$ >> -> + [(patt p, when_expr e w) :: acc] + | <:match_case<>> -> acc + | _ -> assert False ] + and when_expr e w = + match w with + [ <:expr<>> -> expr e + | w -> mkexp (loc_of_expr w) (Pexp_when (expr w) (expr e)) ] + and mklabexp x acc = + match x with + [ <:binding< $x$ and $y$ >> | <:binding< $x$; $y$ >> -> + mklabexp x (mklabexp y acc) + | <:binding< $id:i$ = $e$ >> -> [(ident ~conv_lid:conv_lab i, expr e) :: acc] + | _ -> assert False ] + and mkideexp x acc = + match x with + [ <:binding< $x$ and $y$ >> | <:binding< $x$; $y$ >> -> + mkideexp x (mkideexp y acc) + | <:binding< $lid:s$ = $e$ >> -> [(s, expr e) :: acc] + | _ -> assert False ] + and mktype_decl x acc = + match x with + [ <:ctyp< $x$ and $y$ >> -> + mktype_decl x (mktype_decl y acc) + | Ast.TyDcl _ 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 + [(c, type_decl (List.fold_right type_parameters tl []) cl td) :: acc] + | _ -> assert False ] + and module_type = + fun + [ MtId loc i -> mkmty loc (Pmty_ident (long_uident i)) + | MtFun loc n nt mt -> + mkmty loc (Pmty_functor n (module_type nt) (module_type mt)) + | MtQuo loc _ -> error loc "abstract module type not allowed here" + | MtSig loc sl -> + mkmty loc (Pmty_signature (sig_item sl [])) + | MtWit loc mt wc -> + mkmty loc (Pmty_with (module_type mt) (mkwithc wc [])) + | <: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 (conv_con s) []) :: l] + | <:sig_item@loc< exception $uid:s$ of $t$ >> -> + [mksig loc (Psig_exception (conv_con s) + (List.map ctyp (list_of_ctyp t []))) :: l] + | SgExc _ _ -> assert False (*FIXME*) + | SgExt loc n t sl -> [mksig loc (Psig_value n (mkvalue_desc t (list_of_meta_list sl))) :: l] + | SgInc loc mt -> [mksig loc (Psig_include (module_type mt)) :: l] + | SgMod loc n mt -> [mksig loc (Psig_module n (module_type mt)) :: l] + | SgRecMod loc mb -> + [mksig loc (Psig_recmodule (module_sig_binding mb [])) :: l] + | SgMty loc n mt -> + let si = + match mt with + [ MtQuo _ _ -> Pmodtype_abstract + | _ -> Pmodtype_manifest (module_type mt) ] + in + [mksig loc (Psig_modtype n si) :: l] + | SgOpn loc id -> + [mksig loc (Psig_open (long_uident id)) :: l] + | SgTyp loc tdl -> [mksig loc (Psig_type (mktype_decl tdl [])) :: l] + | SgVal loc n t -> [mksig loc (Psig_value n (mkvalue_desc t [])) :: l] + | <:sig_item@loc< $anti:_$ >> -> error loc "antiquotation in sig_item" ] + and module_sig_binding x acc = + match x with + [ <:module_binding< $x$ and $y$ >> -> + module_sig_binding x (module_sig_binding y acc) + | <:module_binding< $s$ : $mt$ >> -> + [(s, module_type mt) :: acc] + | _ -> assert False ] + and module_str_binding x acc = + match x with + [ <:module_binding< $x$ and $y$ >> -> + module_str_binding x (module_str_binding y acc) + | <:module_binding< $s$ : $mt$ = $me$ >> -> + [(s, module_type mt, module_expr me) :: acc] + | _ -> assert False ] + and module_expr = + fun + [ MeId loc i -> mkmod loc (Pmod_ident (long_uident i)) + | MeApp loc me1 me2 -> + mkmod loc (Pmod_apply (module_expr me1) (module_expr me2)) + | MeFun loc n mt me -> + mkmod loc (Pmod_functor n (module_type mt) (module_expr me)) + | MeStr loc sl -> + mkmod loc (Pmod_structure (str_item sl [])) + | MeTyc loc me mt -> + mkmod loc (Pmod_constraint (module_expr me) (module_type mt)) + | <: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 (conv_con s) []) :: l ] + | <:str_item@loc< exception $uid:s$ of $t$ >> -> + [mkstr loc (Pstr_exception (conv_con s) + (List.map ctyp (list_of_ctyp t []))) :: l ] + | <:str_item@loc< exception $uid:s$ = $i$ >> -> + [mkstr loc (Pstr_exn_rebind (conv_con s) (ident i)) :: l ] + | StExc _ _ _ -> assert False (*FIXME*) + | StExp loc e -> [mkstr loc (Pstr_eval (expr e)) :: l] + | StExt loc n t sl -> [mkstr loc (Pstr_primitive n (mkvalue_desc t (list_of_meta_list sl))) :: l] + | StInc loc me -> [mkstr loc (Pstr_include (module_expr me)) :: l] + | StMod loc n me -> [mkstr loc (Pstr_module n (module_expr me)) :: l] + | StRecMod loc mb -> + [mkstr loc (Pstr_recmodule (module_str_binding mb [])) :: l] + | StMty loc n mt -> [mkstr loc (Pstr_modtype n (module_type mt)) :: l] + | StOpn loc id -> + [mkstr loc (Pstr_open (long_uident id)) :: l] + | StTyp loc tdl -> [mkstr loc (Pstr_type (mktype_decl tdl [])) :: l] + | StVal loc rf bi -> + [mkstr loc (Pstr_value (mkrf rf) (binding bi [])) :: l] + | <:str_item@loc< $anti:_$ >> -> error loc "antiquotation in str_item" ] + and class_type = + fun + [ CtCon loc Ast.BFalse 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_fun lab (ctyp t) (class_type ct)) + | CtFun loc (TyOlb loc1 lab t) ct -> + let t = TyApp loc1 <:ctyp@loc1< option >> t in + mkcty loc (Pcty_fun ("?" ^ lab) (ctyp t) (class_type ct)) + | CtFun loc t ct -> mkcty loc (Pcty_fun "" (ctyp t) (class_type ct)) + | CtSig loc t_o ctfl -> + let t = + match t_o with + [ <:ctyp<>> -> <:ctyp@loc< _ >> + | t -> t ] + in + let cil = class_sig_item ctfl [] in + mkcty loc (Pcty_signature (ctyp t, cil)) + | CtCon loc _ _ _ -> + error loc "invalid virtual class inside a class type" + | CtAnt _ _ | CtEq _ _ _ | CtCol _ _ _ | CtAnd _ _ _ | CtNil _ -> + assert False ] + + and class_info_class_expr ci = + match ci with + [ CeEq _ (CeCon loc vir (IdLid _ name) params) ce -> + let (loc_params, (params, variance)) = + match params with + [ <:ctyp<>> -> (loc, ([], [])) + | t -> (loc_of_ctyp t, List.split (class_parameters t [])) ] + in + {pci_virt = if mb2b vir then Virtual else Concrete; + pci_params = (params, mkloc loc_params); + pci_name = name; + pci_expr = class_expr ce; + pci_loc = mkloc loc; + pci_variance = variance} + | ce -> error (loc_of_class_expr ce) "bad class definition" ] + and class_info_class_type ci = + match ci with + [ CtEq _ (CtCon loc vir (IdLid _ name) params) ct | + CtCol _ (CtCon loc vir (IdLid _ name) params) ct -> + let (loc_params, (params, variance)) = + match params with + [ <:ctyp<>> -> (loc, ([], [])) + | t -> (loc_of_ctyp t, List.split (class_parameters t [])) ] + in + {pci_virt = if mb2b vir then Virtual else Concrete; + pci_params = (params, mkloc loc_params); + pci_name = name; + pci_expr = class_type ct; + pci_loc = mkloc loc; + pci_variance = variance} + | 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 -> [Pctf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l] + | <:class_sig_item< $csg1$; $csg2$ >> -> + class_sig_item csg1 (class_sig_item csg2 l) + | CgInh _ ct -> [Pctf_inher (class_type ct) :: l] + | CgMth loc s pf t -> + [Pctf_meth (s, mkprivate pf, mkpolytype (ctyp t), mkloc loc) :: l] + | CgVal loc s b v t -> + [Pctf_val (s, mkmutable b, mkvirtual v, ctyp t, mkloc loc) :: l] + | CgVir loc s b t -> + [Pctf_virt (s, mkprivate b, mkpolytype (ctyp t), mkloc loc) :: l] + | CgAnt _ _ -> assert False ] + and class_expr = + fun + [ CeApp loc _ _ as c -> + let (ce, el) = class_expr_fa [] c in + let el = List.map label_expr el in + mkpcl loc (Pcl_apply (class_expr ce) el) + | CeCon loc Ast.BFalse id tl -> + mkpcl loc + (Pcl_constr (long_class_ident id) (List.map ctyp (list_of_opt_ctyp tl []))) + | CeFun loc (PaLab _ lab po) ce -> + mkpcl loc + (Pcl_fun lab None (patt_of_lab loc lab po) (class_expr ce)) + | CeFun loc (PaOlbi _ lab p e) ce -> + let lab = paolab lab p in + mkpcl loc (Pcl_fun ("?" ^ lab) (Some (expr e)) (patt p) (class_expr ce)) + | CeFun loc (PaOlb _ lab p) ce -> + let lab = paolab lab p in + mkpcl loc + (Pcl_fun ("?" ^ lab) None (patt_of_lab loc lab p) (class_expr ce)) + | CeFun loc p ce -> mkpcl loc (Pcl_fun "" None (patt p) (class_expr ce)) + | CeLet loc rf bi ce -> + mkpcl 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 + mkpcl loc (Pcl_structure (patt p, cil)) + | CeTyc loc ce ct -> + mkpcl loc (Pcl_constraint (class_expr ce) (class_type ct)) + | CeCon loc _ _ _ -> + error loc "invalid virtual class inside a class expression" + | CeAnt _ _ | CeEq _ _ _ | CeAnd _ _ _ | CeNil _ -> assert False ] + and class_str_item c l = + match c with + [ CrNil _ -> l + | CrCtr loc t1 t2 -> [Pcf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l] + | <:class_str_item< $cst1$; $cst2$ >> -> + class_str_item cst1 (class_str_item cst2 l) + | CrInh _ ce "" -> [Pcf_inher (class_expr ce) None :: l] + | CrInh _ ce pb -> [Pcf_inher (class_expr ce) (Some pb) :: l] + | CrIni _ e -> [Pcf_init (expr e) :: l] + | CrMth loc s b e t -> + let t = + match t with + [ <:ctyp<>> -> None + | t -> Some (mkpolytype (ctyp t)) ] in + let e = mkexp loc (Pexp_poly (expr e) t) in + [Pcf_meth (s, mkprivate b, e, mkloc loc) :: l] + | CrVal loc s b e -> [Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l] + | CrVir loc s b t -> + [Pcf_virt (s, mkprivate b, mkpolytype (ctyp t), mkloc loc) :: l] + | CrVvr loc s b t -> + [Pcf_valvirt (s, mkmutable b, ctyp t, mkloc loc) :: l] + | CrAnt _ _ -> assert False ]; + + value sig_item ast = sig_item ast []; + value str_item ast = str_item ast []; + + value directive = + fun + [ <:expr<>> -> Pdir_none + | ExStr _ s -> Pdir_string s + | ExInt _ i -> Pdir_int (int_of_string i) + | <:expr< True >> -> Pdir_bool True + | <:expr< False >> -> Pdir_bool False + | e -> Pdir_ident (ident (ident_of_expr e)) ] + ; + + value phrase = + fun + [ StDir _ d dp -> Ptop_dir d (directive dp) + | si -> Ptop_def (str_item si) ] + ; +end; diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli new file mode 100644 index 00000000..2ebcf43d --- /dev/null +++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli @@ -0,0 +1,33 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2002-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + + +(* $Id: Camlp4Ast2OCamlAst.mli,v 1.3 2007/02/07 10:09:21 ertai Exp $ *) + +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 00000000..0374ae28 --- /dev/null +++ b/camlp4/Camlp4/Struct/CleanAst.ml @@ -0,0 +1,127 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +(** This module is suppose to contain nils elimination. *) +module Make (Ast : Sig.Camlp4Ast) = struct + + class clean_ast = object (self) + + inherit Ast.map as super; + + method with_constr = fun + [ <:with_constr< $ <:with_constr<>> $ and $wc$ >> | + <:with_constr< $wc$ and $ <:with_constr<>> $ >> -> self#with_constr wc + | wc -> super#with_constr wc ]; + + method expr = fun + [ <:expr< let $rec:_$ $ <:binding<>> $ in $e$ >> | + <:expr< { ($e$) with $ <:binding<>> $ } >> | + <:expr< $ <:expr<>> $, $e$ >> | + <:expr< $e$, $ <:expr<>> $ >> | + <:expr< $ <:expr<>> $; $e$ >> | + <:expr< $e$; $ <:expr<>> $ >> -> self#expr e + | e -> super#expr e ]; + + method patt = fun + [ <:patt< ( $p$ as $ <:patt<>> $ ) >> | + <:patt< $ <:patt<>> $ | $p$ >> | + <:patt< $p$ | $ <:patt<>> $ >> | + <:patt< $ <:patt<>> $, $p$ >> | + <:patt< $p$, $ <:patt<>> $ >> | + <:patt< $ <:patt<>> $; $p$ >> | + <:patt< $p$; $ <:patt<>> $ >> -> self#patt p + | p -> super#patt p ]; + + method match_case = fun + [ <:match_case< $ <:match_case<>> $ | $mc$ >> | + <:match_case< $mc$ | $ <:match_case<>> $ >> -> self#match_case mc + | mc -> super#match_case mc ]; + + method binding = fun + [ <:binding< $ <:binding<>> $ and $bi$ >> | + <:binding< $bi$ and $ <:binding<>> $ >> | + <:binding< $ <:binding<>> $ ; $bi$ >> | + <:binding< $bi$ ; $ <:binding<>> $ >> -> self#binding bi + | bi -> super#binding bi ]; + + method module_binding = fun + [ <:module_binding< $ <:module_binding<>> $ and $mb$ >> | + <:module_binding< $mb$ and $ <:module_binding<>> $ >> -> + self#module_binding mb + | mb -> super#module_binding mb ]; + + method ctyp = fun + [ <: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<>> $ >> -> self#ctyp t + | t -> super#ctyp t ]; + + method sig_item = fun + [ <:sig_item< $ <:sig_item<>> $; $sg$ >> | + <:sig_item< $sg$; $ <:sig_item<>> $ >> -> self#sig_item sg + | sg -> super#sig_item sg ]; + + method str_item = fun + [ <:str_item< $ <:str_item<>> $; $st$ >> | + <:str_item< $st$; $ <:str_item<>> $ >> -> self#str_item st + | st -> super#str_item st ]; + + method module_type = fun + [ <:module_type< $mt$ with $ <:with_constr<>> $ >> -> self#module_type mt + | mt -> super#module_type mt ]; + + method class_expr = fun + [ <:class_expr< $ <:class_expr<>> $ and $ce$ >> | + <:class_expr< $ce$ and $ <:class_expr<>> $ >> -> self#class_expr ce + | ce -> super#class_expr ce ]; + + method class_type = fun + [ <:class_type< $ <:class_type<>> $ and $ct$ >> | + <:class_type< $ct$ and $ <:class_type<>> $ >> -> self#class_type ct + | ct -> super#class_type ct ]; + + method class_sig_item = fun + [ <:class_sig_item< $ <:class_sig_item<>> $; $csg$ >> | + <:class_sig_item< $csg$; $ <:class_sig_item<>> $ >> -> + self#class_sig_item csg + | csg -> super#class_sig_item csg ]; + + method class_str_item = fun + [ <:class_str_item< $ <:class_str_item<>> $; $cst$ >> | + <:class_str_item< $cst$; $ <:class_str_item<>> $ >> -> + self#class_str_item cst + | cst -> super#class_str_item cst ]; + + end; + +end; diff --git a/camlp4/Camlp4/Struct/CommentFilter.ml b/camlp4/Camlp4/Struct/CommentFilter.ml new file mode 100644 index 00000000..5867df40 --- /dev/null +++ b/camlp4/Camlp4/Struct/CommentFilter.ml @@ -0,0 +1,56 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 00000000..c1789c6c --- /dev/null +++ b/camlp4/Camlp4/Struct/CommentFilter.mli @@ -0,0 +1,33 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) +module Make (Token : Sig.Camlp4Token) : sig + open Token; + + type t = 'abstract; + + 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/DynLoader.ml b/camlp4/Camlp4/Struct/DynLoader.ml new file mode 100644 index 00000000..5975dede --- /dev/null +++ b/camlp4/Camlp4/Struct/DynLoader.ml @@ -0,0 +1,84 @@ +(* camlp4r pa_macro.cmo *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2001-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + + +(* $Id: DynLoader.ml,v 1.3 2007/02/07 10:09:21 ertai Exp $ *) + +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 -> + IFDEF OPT THEN + raise (Error file "native-code program cannot do a dynamic load") + ELSE 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)) ] + } + END; diff --git a/camlp4/Camlp4/Struct/DynLoader.mli b/camlp4/Camlp4/Struct/DynLoader.mli new file mode 100644 index 00000000..292b705b --- /dev/null +++ b/camlp4/Camlp4/Struct/DynLoader.mli @@ -0,0 +1,20 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 00000000..1acb2251 --- /dev/null +++ b/camlp4/Camlp4/Struct/EmptyError.ml @@ -0,0 +1,22 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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; \ No newline at end of file diff --git a/camlp4/Camlp4/Struct/EmptyError.mli b/camlp4/Camlp4/Struct/EmptyError.mli new file mode 100644 index 00000000..9d216623 --- /dev/null +++ b/camlp4/Camlp4/Struct/EmptyError.mli @@ -0,0 +1,19 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) +include Sig.Error; \ No newline at end of file diff --git a/camlp4/Camlp4/Struct/EmptyPrinter.ml b/camlp4/Camlp4/Struct/EmptyPrinter.ml new file mode 100644 index 00000000..2cde4dde --- /dev/null +++ b/camlp4/Camlp4/Struct/EmptyPrinter.ml @@ -0,0 +1,24 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +module Make (Ast : Sig.Ast) = struct + module Ast = Ast; + + 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 00000000..186d9301 --- /dev/null +++ b/camlp4/Camlp4/Struct/EmptyPrinter.mli @@ -0,0 +1,19 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +module Make (Ast : Sig.Ast) : Sig.Printer with module Ast = Ast; diff --git a/camlp4/Camlp4/Struct/FreeVars.ml b/camlp4/Camlp4/Struct/FreeVars.ml new file mode 100644 index 00000000..ffeae02f --- /dev/null +++ b/camlp4/Camlp4/Struct/FreeVars.ml @@ -0,0 +1,128 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +module Make (Ast : Sig.Camlp4Ast) = struct + + module S = Set.Make String; + + value rec fold_binding_vars f bi acc = + match bi with + [ <:binding< $bi1$ and $bi2$ >> | <:binding< $bi1$; $bi2$ >> -> + fold_binding_vars f bi1 (fold_binding_vars f bi2 acc) + | <:binding< $lid:i$ = $_$ >> -> f i acc + | _ -> assert False ]; + + class c_fold_pattern_vars ['accu] f init = + object (o) + 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 >} + | <:patt< $lid:_$ = $p$ >> -> o#patt p + | p -> super#patt p ]; + end; + + value fold_pattern_vars f p init = ((new c_fold_pattern_vars f init)#patt p)#acc; + + 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 $s$ = $e1$ $to:_$ $e2$ do { $e3$ } >> -> + ((((o#expr e1)#expr e2)#add_atom s)#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 $_$ >> as cst -> super#class_str_item cst + | <:class_str_item< inherit $ce$ as $s$ >> -> + (o#class_expr ce)#add_atom s + | <:class_str_item< value $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 00000000..aac72db0 --- /dev/null +++ b/camlp4/Camlp4/Struct/FreeVars.mli @@ -0,0 +1,48 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 00000000..23c34294 --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar.mlpack @@ -0,0 +1,14 @@ +Context +Delete +Dynamic +Entry +Failed +Find +Fold +Insert +Parser +Print +Search +Static +Structure +Tools diff --git a/camlp4/Camlp4/Struct/Grammar/Context.ml b/camlp4/Camlp4/Struct/Grammar/Context.ml new file mode 100644 index 00000000..fbd24134 --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Context.ml @@ -0,0 +1,90 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module type S = sig + module Token : Sig.Token; + open Token; + type t = 'abstract; + value call_with_ctx : Stream.t (Token.t * Loc.t) -> (t -> 'a) -> 'a; + value loc_bp : t -> Loc.t; + value loc_ep : t -> Loc.t; + value stream : t -> Stream.t (Token.t * Loc.t); + value peek_nth : t -> int -> option (Token.t * Loc.t); + value njunk : t -> int -> unit; + value junk : Stream.t (Token.t * Loc.t) -> unit; + value bp : Stream.t (Token.t * Loc.t) -> Loc.t; +end; + +module Make (Token : Sig.Token) : S with module Token = Token = struct + module Token = Token; + open Token; + + type t = { strm : mutable Stream.t (Token.t * Loc.t); + loc : mutable Loc.t }; + + value loc_bp c = + match Stream.peek c.strm with + [ None -> Loc.ghost + | Some (_, loc) -> loc ]; + + value loc_ep c = c.loc; + + value set_loc c = + match Stream.peek c.strm with + [ Some (_, loc) -> c.loc := loc + | None -> () ]; + + value mk strm = + match Stream.peek strm with + [ Some (_, loc) -> { strm = strm; loc = loc } + | None -> { strm = strm ; loc = Loc.ghost } ]; + + value stream c = c.strm; + + value peek_nth c n = + let list = Stream.npeek n c.strm in + let rec loop list n = + match (list, n) with + [ ([((_, loc) as x) :: _], 1) -> do { c.loc := loc; Some x } + | ([_ :: l], n) -> loop l (n - 1) + | ([], _) -> None ] + in + loop list n; + + value njunk c n = + do { for i = 1 to n do { Stream.junk c.strm }; + set_loc c }; + + value streams = ref []; + value mk strm = + let c = mk strm in + let () = streams.val := [(strm, c) :: streams.val] in c; + value junk strm = + do { set_loc (List.assq strm streams.val); Stream.junk strm }; + value bp strm = loc_bp (List.assq strm streams.val); + + value call_with_ctx strm f = + let streams_v = streams.val in + let r = + try f (mk strm) with exc -> do { streams.val := streams_v; raise exc } + in + do { streams.val := streams_v; r } + ; + +end; diff --git a/camlp4/Camlp4/Struct/Grammar/Delete.ml b/camlp4/Camlp4/Struct/Grammar/Delete.ml new file mode 100644 index 00000000..49a45002 --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Delete.ml @@ -0,0 +1,163 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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; + +(* 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 -> decr_keyw_use gram s + | Slist1 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 } + | Sopt s -> decr_keyw_use gram s + | 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 Not_found ] +; + +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 Not_found ] +; + +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 c strm -> + let f = Parser.start_parser_of_entry entry in + do { entry.estart := f; f lev c strm }; + entry.econtinue := + fun lev bp a c strm -> + let f = Parser.continue_parser_of_entry entry in + do { entry.econtinue := f; f lev bp a c strm } + } + | Dparser _ -> () ] +; + +end; diff --git a/camlp4/Camlp4/Struct/Grammar/Dynamic.ml b/camlp4/Camlp4/Struct/Grammar/Dynamic.ml new file mode 100644 index 00000000..09b43970 --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Dynamic.ml @@ -0,0 +1,72 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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; + 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 = 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 00000000..8402672b --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Entry.ml @@ -0,0 +1,91 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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; + + 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 = Tools.empty_entry n; + econtinue _ _ _ _ = parser []; + edesc = Dlevels [] }; + + value action_parse entry ts : Action.t = + Context.call_with_ctx ts + (fun c -> + try entry.estart 0 c (Context.stream c) with + [ Stream.Failure -> + Loc.raise (Context.loc_ep c) + (Stream.Error ("illegal begin of " ^ entry.ename)) + | Loc.Exc_located _ _ as exc -> raise exc + | exc -> Loc.raise (Context.loc_ep c) 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 = 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 * Loc.t) -> 'a) : t 'a = + { egram = g; + ename = n; + estart _ _ ts = Action.mk (p ts); + econtinue _ _ _ _ = parser []; + edesc = Dparser (fun ts -> Action.mk (p ts)) }; + + value setup_parser e (p : Stream.t (Token.t * Loc.t) -> '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 00000000..907d3378 --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Failed.ml @@ -0,0 +1,134 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 -> name_of_symbol_failed entry s + | Slist0sep s _ -> name_of_symbol_failed entry s + | Slist1 s -> name_of_symbol_failed entry s + | Slist1sep s _ -> name_of_symbol_failed entry s + | Sopt 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" ] + | 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 in + let ppf = err_formatter in + 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 00000000..9e7774d1 --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Find.ml @@ -0,0 +1,68 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 00000000..c6fa82a5 --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Fold.ml @@ -0,0 +1,94 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* $Id: Fold.ml,v 1.3 2007/02/07 10:09:21 ertai Exp $ *) + +(* 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; + + module Stream = struct + include Stream; + value junk strm = Context.junk strm; + value count strm = Context.bp strm; + 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 00000000..d5ae0448 --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Fold.mli @@ -0,0 +1,30 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* $Id: Fold.mli,v 1.2 2006/07/08 17:21:32 pouillar Exp $ *) + +(* 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 00000000..62d8a972 --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Insert.ml @@ -0,0 +1,328 @@ +(* -*- camlp4r -*- *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 _ -> True + | Slist0sep _ _ -> True + | Sopt _ -> True + | Stree t -> tree_derive_eps t + | Smeta _ _ _ | Slist1 _ | Slist1sep _ _ | Snterm _ | Snterml _ _ | Snext | + Sself | Stoken _ | Skeyword _ -> 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 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 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 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 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 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 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 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 -> check_gram entry s + | Slist1 s -> check_gram entry s + | Sopt 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 -> insert s + | Slist1 s -> insert s + | Slist0sep s t -> do { insert s; insert t } + | Slist1sep s t -> do { insert s; insert t } + | Sopt s -> insert s + | 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 ] + and insert_new = + fun + [ [s :: sl] -> Node {node = s; son = insert_new sl; brother = DeadEnd} + | [] -> LocAct action [] ] + 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 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 in + 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 c strm -> + let f = Parser.start_parser_of_entry entry in + do { entry.estart := f; f lev c strm }; + entry.econtinue := + fun lev bp a c strm -> + let f = Parser.continue_parser_of_entry entry in + do { entry.econtinue := f; f lev bp a c strm } + }; + + end; diff --git a/camlp4/Camlp4/Struct/Grammar/Parser.ml b/camlp4/Camlp4/Struct/Grammar/Parser.ml new file mode 100644 index 00000000..1934dc69 --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Parser.ml @@ -0,0 +1,379 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 Stream = struct + include Stream; + value junk strm = Context.junk strm; + value count strm = Context.bp strm; + end; + + value add_loc c bp parse_fun strm = + let x = parse_fun c strm in + let ep = Context.loc_ep c in + let loc = Loc.merge bp ep in + (x, loc); + + 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 c son p1 = + parser + [: a = (entry_of_symb entry s).econtinue 0 loc a c; + act = p1 ?? Failed.tree_failed entry a s son :] -> + Action.mk (fun _ -> Action.getf act a) + ; + + value skip_if_empty c bp p strm = + (* if Stream.count strm == bp then Action.mk (fun _ -> p strm) *) + if Context.loc_ep c == bp then Action.mk (fun _ -> p strm) + else raise Stream.Failure + ; + + value do_recover parser_of_tree entry nlevn alevn loc a s c son = + parser + [ [: a = parser_of_tree entry nlevn alevn (top_tree entry son) c :] -> a + | [: a = skip_if_empty c loc (parser []) :] -> a + | [: a = + continue entry loc a s c son + (parser_of_tree entry nlevn alevn son c) :] -> + a ] + ; + + + value recover parser_of_tree entry nlevn alevn loc a s c 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 + do { + 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; + } else () in + do_recover parser_of_tree entry nlevn alevn loc a s c son strm + ; + + value rec parser_of_tree entry nlevn alevn = + fun + [ DeadEnd -> fun _ -> parser [] + | LocAct act _ -> fun _ -> parser [: :] -> act + | Node {node = Sself; son = LocAct act _; brother = DeadEnd} -> + fun c -> + parser [: a = entry.estart alevn c :] -> Action.getf act a + | Node {node = Sself; son = LocAct act _; brother = bro} -> + let p2 = parser_of_tree entry nlevn alevn bro in + fun c -> + parser + [ [: a = entry.estart alevn c :] -> Action.getf act a + | [: a = p2 c :] -> 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 c -> + parser bp [: a = ps c; act = p1 c 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 c -> + parser bp + [ [: a = ps c; act = p1 c bp a :] -> Action.getf act a + | [: a = p2 c :] -> 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 + fun c -> + parser + [ [: a = p1 c :] -> a + | [: a = p2 c :] -> a ] ] ] + and parser_cont p1 entry nlevn alevn s son c loc a = + parser + [ [: a = p1 c :] -> a + | [: a = recover parser_of_tree entry nlevn alevn loc a s c 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 c _ = + match Context.peek_nth c n with + [ Some (tok, _) when tematch tok -> do { Context.njunk c n; Action.mk tok } + | _ -> raise Stream.Failure ] + in + fun c -> + parser bp [: a = ps c; act = p1 c bp a :] -> Action.getf act a + | _ -> + let ps c _ = + match Context.peek_nth c n with + [ Some (tok, _) when tematch tok -> tok + | _ -> raise Stream.Failure ] + in + let p1 = loop (n + 1) tokl in + fun c -> + parser [: tok = ps c; s :] -> + let act = p1 c s in Action.getf act tok ] + | [Skeyword kwd :: tokl] -> + match tokl with + [ [] -> + let ps c _ = + match Context.peek_nth c n with + [ Some (tok, _) when Token.match_keyword kwd tok -> + do { Context.njunk c n; Action.mk tok } + | _ -> raise Stream.Failure ] + in + fun c -> + parser bp [: a = ps c; act = p1 c bp a :] -> Action.getf act a + | _ -> + let ps c _ = + match Context.peek_nth c n with + [ Some (tok, _) when Token.match_keyword kwd tok -> tok + | _ -> raise Stream.Failure ] + in + let p1 = loop (n + 1) tokl in + fun c -> + parser [: tok = ps c; s :] -> + let act = p1 c 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 + fun c -> + Obj.magic (List.fold_left (fun act p -> Obj.magic act (p c)) act pl) + | Slist0 s -> + let ps = parser_of_symbol entry nlevn s in + let rec loop c al = + parser + [ [: a = ps c; s :] -> loop c [a :: al] s + | [: :] -> al ] + in + fun c -> parser [: a = loop c [] :] -> 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 c al = + parser + [ [: v = pt c; a = ps c ?? Failed.symb_failed entry v sep symb; + s :] -> + kont c [a :: al] s + | [: :] -> al ] + in + fun c -> + parser + [ [: a = ps c; s :] -> Action.mk (List.rev (kont c [a] s)) + | [: :] -> Action.mk [] ] + | Slist1 s -> + let ps = parser_of_symbol entry nlevn s in + let rec loop c al = + parser + [ [: a = ps c; s :] -> loop c [a :: al] s + | [: :] -> al ] + in + fun c -> + parser [: a = ps c; s :] -> Action.mk (List.rev (loop c [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 c al = + parser + [ [: v = pt c; + a = + parser + [ [: a = ps c :] -> a + | [: a = parse_top_symb' entry symb c :] -> a + | [: :] -> + raise (Stream.Error (Failed.symb_failed entry v sep symb)) ]; + s :] -> + kont c [a :: al] s + | [: :] -> al ] + in + fun c -> + parser [: a = ps c; s :] -> Action.mk (List.rev (kont c [a] s)) + | Sopt s -> + let ps = parser_of_symbol entry nlevn s in + fun c -> + parser + [ [: a = ps c :] -> Action.mk (Some a) + | [: :] -> Action.mk None ] + | Stree t -> + let pt = parser_of_tree entry 1 0 t in + fun c -> + parser bp [: (act, loc) = add_loc c bp pt :] -> + Action.getf act loc + | Snterm e -> fun c -> parser [: a = e.estart 0 c :] -> a + | Snterml e l -> + fun c -> parser [: a = e.estart (level_number e l) c :] -> a + | Sself -> fun c -> parser [: a = entry.estart 0 c :] -> a + | Snext -> fun c -> parser [: a = entry.estart nlevn c :] -> a + | Skeyword kwd -> + fun _ -> + parser + [: `(tok, _) when Token.match_keyword kwd tok :] -> Action.mk tok + | Stoken (f, _) -> + fun _ -> parser [: `(tok, _) when f tok :] -> Action.mk tok ] + and parse_top_symb' entry symb c = + parser_of_symbol entry 0 (top_symb entry symb) c + and parse_top_symb entry symb = + fun strm -> + Context.call_with_ctx strm + (fun c -> parse_top_symb' entry symb c (Context.stream c)); + + 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 c -> + parser bp + [: (act, loc) = add_loc c bp p2; strm :] -> + let a = Action.getf act loc in + entry.econtinue levn loc a c strm + | _ -> + fun levn c strm -> + if levn > clevn then p1 levn c strm + else + match strm with parser bp + [ [: (act, loc) = add_loc c bp p2 :] -> + let a = Action.getf act loc in + entry.econtinue levn loc a c strm + | [: act = p1 levn c :] -> 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 _ _ strm -> p strm ] + ; + 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 c levn bp a strm -> + if levn > clevn then p1 c levn bp a strm + else + match strm with parser bp + [ [: act = p1 c levn bp a :] -> act + | [: (act, loc) = add_loc c bp p2 :] -> + let a = Action.getf2 act a loc in + entry.econtinue levn loc a c 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 c -> + parser + [ [: a = p c levn bp a :] -> a + | [: :] -> a ] + | Dparser _ -> fun _ _ _ _ -> parser [] ] + ; + +end; diff --git a/camlp4/Camlp4/Struct/Grammar/Print.ml b/camlp4/Camlp4/Struct/Grammar/Print.ml new file mode 100644 index 00000000..dadf4aed --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Print.ml @@ -0,0 +1,268 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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} -> + List.map (fun l -> [n :: 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 + | 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 _ 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 = + List.map (fun t -> [Sself :: 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 + | 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 _ 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 00000000..9acc836d --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Print.mli @@ -0,0 +1,47 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 00000000..870a6f7f --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Search.ml @@ -0,0 +1,91 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 _ | 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 ] + | 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 00000000..b20eed77 --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Static.ml @@ -0,0 +1,84 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring +*) +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; + 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 = 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 = + 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/Structure.ml b/camlp4/Camlp4/Struct/Grammar/Structure.ml new file mode 100644 index 00000000..12023b7d --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Structure.ml @@ -0,0 +1,280 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 Context : Context.S with 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 efun = Context.t -> Stream.t (Token.t * Loc.t) -> 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 Stream.t (Token.t * Loc.t) -> 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 + | 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 }; + + module Context = Context.Make Token; + + type efun = Context.t -> Stream.t (Token.t * Loc.t) -> 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 Stream.t (Token.t * Loc.t) -> 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 + | 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; + + 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 -> 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 -> 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 00000000..bcb933b8 --- /dev/null +++ b/camlp4/Camlp4/Struct/Grammar/Tools.ml @@ -0,0 +1,89 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) +module Make (Structure : Structure.S) = struct + open Structure; + + value empty_entry ename _ _ _ = + raise (Stream.Error ("entry [" ^ ename ^ "] is empty")); + + 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) -> eq_symbols s1 s2 + | (Slist0sep s1 sep1, Slist0sep s2 sep2) -> + eq_symbols s1 s2 && eq_symbols sep1 sep2 + | (Slist1 s1, Slist1 s2) -> eq_symbols s1 s2 + | (Slist1sep s1 sep1, Slist1sep s2 sep2) -> + eq_symbols s1 s2 && eq_symbols sep1 sep2 + | (Sopt s1, Sopt s2) -> eq_symbols s1 s2 + | (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) -> eq_symbol s1 s2 + | (Slist0sep s1 sep1, Slist0sep s2 sep2) -> + eq_symbol s1 s2 && eq_symbol sep1 sep2 + | (Slist1 s1, Slist1 s2) -> eq_symbol s1 s2 + | (Slist1sep s1 sep1, Slist1sep s2 sep2) -> + eq_symbol s1 s2 && eq_symbol sep1 sep2 + | (Sopt s1, Sopt s2) -> eq_symbol s1 s2 + | (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 00000000..0a471b3f --- /dev/null +++ b/camlp4/Camlp4/Struct/Lexer.mll @@ -0,0 +1,432 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + + +(* $Id: Lexer.mll,v 1.6 2007/02/07 10:09:21 ertai Exp $ *) + +(* 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 + + 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" + + 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? (antiquotations are lexed if + * quotations are). + * If quotations is false it's a SYMBOL token. + *) + + type context = + { loc : Loc.t ; + in_comment : bool ; + quotations : bool ; + lexbuf : lexbuf ; + buffer : Buffer.t } + + let default_context lb = + { loc = Loc.ghost ; + in_comment = false ; + quotations = true ; + 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 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 = + let p = c.lexbuf.lex_start_p in + c.lexbuf.lex_start_p <- { (p) with pos_cnum = p.pos_cnum + shift } + + let with_curr_loc f c = f { (c) with loc = Loc.of_lexbuf c.lexbuf } 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 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; + } + + 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 symbolchar = + ['$' '!' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] + 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' '_']*)? + + 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(int_of_string 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(Int32.of_string i, i) + with Failure _ -> err (Literal_overflow "int32") (Loc.of_lexbuf lexbuf) } + | (int_literal as i) "L" + { try INT64(Int64.of_string i, i) + with Failure _ -> err (Literal_overflow "int64") (Loc.of_lexbuf lexbuf) } + | (int_literal as i) "n" + { try NATIVEINT(Nativeint.of_string i, i) + with Failure _ -> err (Literal_overflow "nativeint") (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) ; + move_start_p (-1) c; SYMBOL "*" } + | "<<" + { if quotations c + then mk_quotation quotation c "" "" 2 + else parse (symbolchar_star "<<") 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) } + | ( "#" | "`" | "'" | "(" | ")" | "," | "." | ".." | ":" | "::" + | ":=" | ":>" | ":]" | ";" | ";;" | "[" | "[|" | "[<" | "[:" + | "]" | "{" | "{<" | "|]" | ">]" | "}" | ">}" | "_" ) as x { SYMBOL x } + + | '$' { if quotations c + then with_curr_loc dollar (shift 1 c) + else parse (symbolchar_star "$") c } + | ['~' '?' '!' '=' '<' '>' '|' '&' '@' '^' '+' '-' '*' '/' '%'] symbolchar * + as x { SYMBOL x } + | '\\' ((symbolchar | identchar)+ as x) { ESCAPED_IDENT 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 } + | '<' (':' ident)? ('@' ident)? '<' + { 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 (3 + String.length loc) } + | symbolchar* as tok { SYMBOL("<@" ^ tok) } + + and maybe_quotation_colon c = parse + | (ident as name) '<' + { mk_quotation quotation c name "" (3 + String.length name) } + | (ident as name) '@' (ident as loc) '<' + { mk_quotation quotation c name loc + (4 + String.length loc + String.length name) } + | symbolchar* as tok { SYMBOL("<:" ^ tok) } + + and quotation c = parse + | '<' (':' ident)? ('@' ident)? '<' { 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("", "") } + (* Removed because it breaks escapings like: <:expr< $str: "\n"$ >> + * | '\\' _ { istore_char c 1; parse (antiquot "") c } *) + | ('`'? (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) } + (* Idem: | '\\' _ { istore_char c 1; parse (antiquot name) c } *) + | eof { err Unterminated_antiquot (loc c) } + | newline + { update_loc c None 1 false 0; store_parse (antiquot name) c } + | '<' (':' ident)? ('@' ident)? '<' + { 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; + 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 00000000..49fa71e0 --- /dev/null +++ b/camlp4/Camlp4/Struct/Loc.ml @@ -0,0 +1,308 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 x = + let (a, b) = (x.Location.loc_start, x.Location.loc_end) in + 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 = x.Location.loc_ghost } 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 00000000..e9016193 --- /dev/null +++ b/camlp4/Camlp4/Struct/Loc.mli @@ -0,0 +1,19 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 00000000..ea461a98 --- /dev/null +++ b/camlp4/Camlp4/Struct/Quotation.ml @@ -0,0 +1,160 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2002-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + + +(* $Id: Quotation.ml,v 1.4 2007/02/07 10:09:21 ertai Exp $ *) + +module Make (Ast : Sig.Ast) +: Sig.Quotation with module Ast = Ast += struct + module Ast = Ast; + module Loc = Ast.Loc; + open Format; + open Sig; + + type expand_fun 'a = Loc.t -> option string -> string -> 'a; + + type expander = + [ ExStr of bool -> expand_fun string + | ExAst of (expand_fun Ast.expr) and (expand_fun Ast.patt) ]; + + value expanders_table = ref []; + + 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 = List.assoc (expander_name name) expanders_table.val; + + value add name f = expanders_table.val := [(name, f) :: 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 * error * exn); + exception E of t; + + value print ppf (name, ctx, exn) = + let name = if name = "" then default.val else name in + let pp x = fprintf ppf "@?@[<2>While %s %S:" x name in + let () = + match ctx with + [ Finding -> do { + pp "finding quotation"; + fprintf ppf " available quotations are:\n@[<2>"; + List.iter (fun (s,_) -> fprintf ppf "%s@ " s) expanders_table.val; + fprintf ppf "@]" + } + | 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 + do { + 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); + } + 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 = + 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; + + value expand_quotation loc expander 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, Expanding, exc) in + raise (Loc.Exc_located iloc exc1) + | exc -> + let exc1 = Error.E (quot.q_name, Expanding, exc) in + raise (Loc.Exc_located loc exc1) ]; + + value parse_quotation_result parse loc quot str = + try parse loc str with + [ Loc.Exc_located iloc (Error.E (n, Expanding, exc)) -> + let ctx = ParsingResult iloc quot.q_contents in + let exc1 = Error.E (n, 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, ctx, exc) in + raise (Loc.Exc_located iloc exc1) ]; + + value handle_quotation loc proj in_expr parse quotation = + let name = quotation.q_name in + debug quot "handle_quotation: name: %s, str: %S@." name quotation.q_contents in + let expander = + try find name + with + [ Loc.Exc_located _ (Error.E _) as exc -> raise exc + | Loc.Exc_located qloc exc -> + raise (Loc.Exc_located qloc (Error.E (name, Finding, exc))) + | exc -> + raise (Loc.Exc_located loc (Error.E (name, Finding, exc))) ] + in + let loc = Loc.join (Loc.move `start quotation.q_shift loc) in + match expander with + [ ExStr f -> + let new_str = expand_quotation loc (f in_expr) quotation in + parse_quotation_result parse loc quotation new_str + | ExAst fe fp -> + expand_quotation loc (proj (fe, fp)) quotation ]; + + value expand_expr parse loc x = + handle_quotation loc fst True parse x; + + value expand_patt parse loc x = + handle_quotation loc snd False parse x; + +end; diff --git a/camlp4/Camlp4/Struct/Token.ml b/camlp4/Camlp4/Struct/Token.ml new file mode 100644 index 00000000..7037888a --- /dev/null +++ b/camlp4/Camlp4/Struct/Token.ml @@ -0,0 +1,241 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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 a 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 = + let b = Buffer.create 50 in + let () = bprintf b "%a" print x in Buffer.contents b; + 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 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) :] -> + Char.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) :] -> + Char.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 00000000..812df0e0 --- /dev/null +++ b/camlp4/Camlp4/Struct/Token.mli @@ -0,0 +1,35 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* 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/Struct/Warning.ml b/camlp4/Camlp4/Struct/Warning.ml new file mode 100644 index 00000000..dbb04008 --- /dev/null +++ b/camlp4/Camlp4/Struct/Warning.ml @@ -0,0 +1,26 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) +module Make (Loc : Sig.Loc) : Sig.Warning with module Loc = Loc = struct + module Loc = Loc; + open Format; + type t = Loc.t -> string -> unit; + value default loc txt = eprintf " %a: %s@." Loc.print loc txt; + value current = ref default; + value print loc txt = current.val loc txt; +end; diff --git a/camlp4/Camlp4Bin.ml b/camlp4/Camlp4Bin.ml new file mode 100644 index 00000000..12fb0e2e --- /dev/null +++ b/camlp4/Camlp4Bin.ml @@ -0,0 +1,317 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +(* $Id: Camlp4Bin.ml,v 1.14 2007/02/27 15:48:22 pouillar Exp $ *) + +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 = "Camlp4OCamlrrParser"; *) +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"; + +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 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 (fun n -> + if SSet.mem n loaded_modules.val then () + else do { + add_to_loaded_modules n; + DynLoader.load dyn_loader (n ^ ".cmo"); + }) in + do { + match (n, String.lowercase x) with + [ ("Parsers"|"", "pa_r.cmo" | "r" | "ocamlr" | "ocamlrevised" | "camlp4ocamlrevisedparser.cmo") -> load [pa_r] + (* | ("Parsers"|"", "rr" | "OCamlrr") -> load [pa_r; 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_o; 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_r; pa_g] + | ("Parsers"|"", "pa_macro.cmo" | "m" | "macro" | "camlp4macroparser.cmo") -> load [pa_r; pa_m] + | ("Parsers"|"", "q" | "camlp4quotationexpander.cmo") -> load [pa_r; pa_qb; pa_q] + | ("Parsers"|"", "q_MLast.cmo" | "rq" | "camlp4ocamlrevisedquotationexpander.cmo") -> load [pa_r; 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_rq; 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"] + | ("Filters"|"", "map" | "camlp4mapgenerator.cmo") -> load ["Camlp4MapGenerator"] + | ("Filters"|"", "fold" | "camlp4foldgenerator.cmo") -> load ["Camlp4FoldGenerator"] + | ("Filters"|"", "meta" | "camlp4metagenerator.cmo") -> load ["Camlp4MetaGenerator"] + | ("Filters"|"", "trash" | "camlp4trashremover.cmo") -> load ["Camlp4TrashRemover"] + | ("Filters"|"", "striploc" | "camlp4locationstripper.cmo") -> load ["Camlp4LocationStripper"] + | ("Filters"|"", "tracer" | "camlp4tracer.cmo") -> load ["Camlp4Tracer"] + | ("Printers"|"", "pr_r.cmo" | "r" | "ocamlr" | "camlp4ocamlrevisedprinter.cmo") -> + Register.enable_ocamlr_printer () + (* | ("Printers"|"", "rr" | "OCamlrr" | "Camlp4Printers/OCamlrr.cmo") -> *) + (* Register.enable_ocamlrr_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^".cmo" 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 { + Warning.current.val := print_warning; + let ic = if name = "-" then stdin else open_in_bin name in + let cs = Stream.of_channel ic in + let clear () = if name = "-" then () else close_in ic in + let phr = + try pa ?directive_handler loc cs + with x -> do { clear (); raise x } + in + 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 + [ <:sig_item@loc< # $n$ $str:s$ >> -> Some (loc, n, s) + | _ -> None ]; + +value gimd = + fun + [ <:str_item@loc< # $n$ $str:s$ >> -> Some (loc, n, s) + | _ -> None ]; + +open Register; + +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] +Options: +.ml Parse this implementation file +.mli Parse this interface file +.(cmo|cma) Load this module inside the Camlp4 core@."; + 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 +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 -> do { + let (f, o) = Filename.open_temp_file "from_string" ".ml"; + output_string o s; + close_out o; + task (process_impl dyn_loader) f; + } + | ModuleImpl file_name -> rewrite_and_load "" file_name + | IncludeDir dir -> DynLoader.include_dir dyn_loader dir ]; + rcall_callback.val (); + }; + +value initial_spec_list = + [("-I", Arg.String (fun x -> input_file (IncludeDir 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."); + ("-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/.cmo"); + ("-printer", Arg.String (rewrite_and_load "Printers"), + " Load the printer Camlp4Printers/.cmo"); + ("-filter", Arg.String (rewrite_and_load "Filters"), + " Load the filter Camlp4Filters/.cmo"); + ("-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 ".cmo" then ModuleImpl name + else if Filename.check_suffix name ".cma" 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 00000000..f3a0bbfd --- /dev/null +++ b/camlp4/Camlp4Filters/Camlp4AstLifter.ml @@ -0,0 +1,44 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + + +open Camlp4; + +module Id = struct + value name = "Camlp4AstLifter"; + value version = "$Id: Camlp4AstLifter.ml,v 1.1 2007/02/07 10:09:22 ertai Exp $"; +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 00000000..faccf97b --- /dev/null +++ b/camlp4/Camlp4Filters/Camlp4ExceptionTracer.ml @@ -0,0 +1,68 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + + +open Camlp4; + +module Id = struct + value name = "Camlp4ExceptionTracer"; + value version = "$Id: Camlp4ExceptionTracer.ml,v 1.1 2007/02/07 10:09:22 ertai Exp $"; +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 00000000..573e42f5 --- /dev/null +++ b/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml @@ -0,0 +1,322 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + + +open Camlp4; + +module Id = struct + value name = "Camlp4FoldGenerator"; + value version = "$Id: Camlp4FoldGenerator.ml,v 1.1 2007/02/07 10:09:22 ertai Exp $"; +end; + +module Make (AstFilters : Camlp4.Sig.AstFilters) = struct + open AstFilters; + module StringMap = Map.Make String; + open Ast; + + value _loc = Loc.ghost; + + value xi i = "_x" ^ string_of_int i; + + value xs s = "_x_" ^ s; + + 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 list_mapi f = + let rec self i = + fun + [ [] -> [] + | [ x :: xs ] -> [ f i x :: self (succ i) xs ] ] + in self 0; + + value list_init f n = + let rec self m = + if m = n then [] + else [f m :: self (succ m)] + in self 0; + + (* Yes this is a poor fresh function *) + value fresh = + let count = ref 0 in + fun basename -> + let res = basename ^ (string_of_int count.val) + in do { incr count; res }; + + value mk_tuple self t = + let tl = Ast.list_of_ctyp t [] in + let n = List.length tl in + let exi i = <:expr< $lid:xi i$ >> in + let pxi i = <:patt< $lid:xi i$ >> in + let (e, _) = + List.fold_left + (fun (acc, i) t -> (self ?obj:(Some acc) (Some (exi i)) t, succ i)) + (<:expr>, 0) tl in + <:expr< fun ($tup:Ast.paCom_of_list (list_init pxi n)$) -> $e$ >>; + + value builtins = + <:class_str_item< + method string (_ : string) : 'self_type = o; + method int (_ : int) : 'self_type = o; + method float (_ : float) : 'self_type = o; + method bool (_ : bool) : 'self_type = o; + method list : ! 'a . ('self_type -> 'a -> 'self_type) -> list 'a -> 'self_type = + fun f -> List.fold_left f o; + method option : ! 'a . ('self_type -> 'a -> 'self_type) -> option 'a -> 'self_type = + fun f -> fun [ None -> o | Some x -> f o x ]; + method array : ! 'a . ('self_type -> 'a -> 'self_type) -> array 'a -> 'self_type = + fun f -> Array.fold_left f o; + method ref : ! 'a . ('self_type -> 'a -> 'self_type) -> ref 'a -> 'self_type = + fun f { val = x } -> f o x; + >>; + + 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); + + value (unknown_type, fold_unknown_types) = + let set = ref StringMap.empty in + let add id1 id2 ty = set.val := StringMap.add id1 (id1, id2, [], ty) set.val + and fold f = StringMap.fold f set.val in (add, fold); + + value rec expr_of_ty ?obj x ty = + let rec self ?(obj = <:expr>) ox = + fun + [ <:ctyp< $lid:id$ >> -> + match ox with + [ Some x -> <:expr< $obj$#$id$ $x$ >> + | _ -> <:expr< $obj$#$id$ >> ] + | <:ctyp< $t1$ $t2$ >> -> + let e = <:expr< $self ~obj None t1$ (fun o -> $self None t2$) >> in + match ox with + [ Some x -> <:expr< $e$ $x$ >> + | _ -> e ] + | <:ctyp< $t1$ -> $t2$ >> -> + let mk_fun x = + let y = fresh "y" in + let py = <:expr< $lid:y$ >> in + let e = <:expr< $x$ $self (Some py) t1$ >> + in <:expr< fun $lid:y$ -> $self ~obj (Some e) t2$ >> in + match ox with + [ Some x -> mk_fun x + | _ -> + let z = fresh "z" in + let pz = <:expr< $lid:z$ >> in + <:expr< fun $lid:z$ -> $mk_fun pz$ >> ] + | <:ctyp< ( $tup:t$ ) >> -> + let e = mk_tuple self t in + match ox with + [ Some x -> <:expr< $e$ $x$ >> + | _ -> e ] + | <:ctyp< '$s$ >> -> + let id = "_f_" ^ s in + match ox with + [ Some x -> <:expr< $lid:id$ o $x$ >> + | _ -> <:expr< $lid:id$ o >> ] + | <:ctyp< $id:i$ >> -> + let id1 = "_" ^ lid_of_ident "_" i in + let ty = <:ctyp< $lid:id1$ >> in + let () = unknown_type id1 i ty in + self ox ty + | _ -> + match ox with + [ Some x -> <:expr< $x$ >> + | _ -> <:expr< fun _ -> o >> ] ] + in self ?obj x ty + + and expr_of_constructor t (i, acc) = + match t with + [ <:ctyp< $t1$ and $t2$ >> -> + expr_of_constructor t2 (expr_of_constructor t1 (i, acc)) + | _ -> (succ i, <:expr< $expr_of_ty ~obj:acc (Some <:expr< $lid:xi i$ >>) t$ >>) ] + +(* and expr_of_constructor_for_fold t (i, acc) = + match t with + [ <:ctyp< $t1$ and $t2$ >> -> + expr_of_constructor_for_fold t2 (expr_of_constructor_for_fold t1 (i, acc)) + | _ -> (succ i, <:expr< $acc$ $expr_of_ty (Some <:expr< $lid:xi i$ >>) t$ >>) ] + *) + and patt_of_constructor t (i, acc) = + match t with + [ <:ctyp< $t1$ and $t2$ >> -> + patt_of_constructor t2 (patt_of_constructor t1 (i, acc)) + | _ -> (succ i, <:patt< $acc$ $lid:xi i$ >>) ] + + and match_case_of_sum_type = + fun + [ <:ctyp< $t1$ | $t2$ >> -> + <:match_case< $match_case_of_sum_type t1$ | $match_case_of_sum_type t2$ >> + | <:ctyp< $uid:s$ of $t$ >> -> + <:match_case< $pat:snd (patt_of_constructor t (0, <:patt< $uid:s$ >>))$ + -> $snd (expr_of_constructor t (0, <:expr< o >>))$ >> + | <:ctyp< $uid:s$ >> -> + <:match_case< $uid:s$ -> o >> + | _ -> assert False ] + + and record_patt_of_type = + fun + [ <:ctyp< $lid:s$ : $_$ >> -> + <:patt< $lid:s$ = $lid:xs s$ >> + | <:ctyp< $t1$ ; $t2$ >> -> + <:patt< $record_patt_of_type t1$; $record_patt_of_type t2$ >> + | _ -> assert False ] + + and record_binding_of_type = + fun + [ <:ctyp< $lid:s$ : mutable $t$ >> | <:ctyp< $lid:s$ : $t$ >> -> + <:binding< $lid:s$ = $expr_of_ty (Some <:expr< $lid:xs s$ >>) t$ >> + | <:ctyp< $t1$ ; $t2$ >> -> + <:binding< $record_binding_of_type t1$; $record_binding_of_type t2$ >> + | _ -> assert False ] + + and fun_of_ctyp = + fun + [ <:ctyp< [ $t$ ] >> -> + <:expr< fun [ $match_case_of_sum_type t$ ] >> + | <:ctyp< { $t$ } >> -> + <:expr< fun { $record_patt_of_type t$ } -> { $record_binding_of_type t$ } >> + | <:ctyp< ( $tup:t$ ) >> -> mk_tuple expr_of_ty t + | _ -> <:expr< fun _ -> o >> ] + + and string_of_type_param t = + match t with + [ <:ctyp< '$s$ >> | <:ctyp< +'$s$ >> | <:ctyp< -'$s$ >> -> s + | _ -> assert False ] + + and method_of_type_decl ((id1, _, params, ctyp) as type_decl) = + let rec lambda acc = + fun + [ [] -> acc + | [ x :: xs ] -> lambda <:expr< fun $lid:"_f_" ^ x$ -> $acc$ >> xs ] in + let params' = List.map string_of_type_param params in + let funs = lambda (fun_of_ctyp ctyp) params' in + let ty = method_type_of_type_decl type_decl in + <:class_str_item< method $lid:id1$ : $ty$ = $funs$ >> + + and ctyp_name_of_name_params name params = + apply_ctyp <:ctyp< $id:name$ >> params + + and method_type_of_type_decl (_, name, params, _) = + let t = ctyp_name_of_name_params name [] (* FIXME params *) in + match List.length params with + [ 1 -> <:ctyp< ! 'a . ('self_type -> 'a -> 'self_type) -> $t$ 'a -> 'self_type >> + | 0 -> <:ctyp< $t$ -> 'self_type >> + | _ -> failwith "FIXME not implemented" ] + + and class_sig_item_of_type_decl _ ((name, _, _, _) as type_decl) acc = + <:class_sig_item< + method $lid:name$ : $method_type_of_type_decl type_decl$; + $acc$ >> + + and tyMap_of_type_decls t acc = + match t with + [ <:ctyp< $t1$ and $t2$ >> -> + tyMap_of_type_decls t1 (tyMap_of_type_decls t2 acc) + | Ast.TyDcl _ name tl tk _ -> + StringMap.add name (name, <:ident< $lid:name$ >>, tl, tk) acc + | _ -> assert False ] + + and fold_types_in_str_item f = + fun + [ <:str_item< type $t$ >> -> f t + | <:str_item< $st1$; $st2$ >> -> fun acc -> + fold_types_in_str_item f st1 (fold_types_in_str_item f st2 acc) + | <:str_item< module $_$ = struct $st$ end >> | + <:str_item< module $_$ ($_$:$_$) = struct $st$ end >> -> + fold_types_in_str_item f st + | _ -> fun x -> x ] + + and fold_types_in_sig_item f = + fun + [ <:sig_item< type $t$ >> -> f t + | <:sig_item< $sg1$; $sg2$ >> -> fun acc -> + fold_types_in_sig_item f sg1 (fold_types_in_sig_item f sg2 acc) + | <:sig_item< module $_$ : sig $sg$ end >> | + <:sig_item< module $_$ ($_$:$_$) : sig $sg$ end >> -> + fold_types_in_sig_item f sg + | _ -> fun x -> x ] + + and collect_types_in_str_item str_item = + fold_types_in_str_item tyMap_of_type_decls str_item StringMap.empty + + and collect_types_in_sig_item sig_item = + fold_types_in_sig_item tyMap_of_type_decls sig_item StringMap.empty + + and generate_structure tyMap = + let f x acc = <:class_str_item< $method_of_type_decl x$; $acc$ >> in + let g _ ty = f ty in + fold_unknown_types g (StringMap.fold g tyMap <:class_str_item<>>) + + and generate_signature tyMap = + StringMap.fold class_sig_item_of_type_decl tyMap <:class_sig_item<>> + + and inject_structure_drop_trash generated = + Ast.map_str_item + (fun + [ <:str_item@_loc< class $lid:c$ = Camlp4Filters.GenerateFold.generated >> -> + (* FIXME <:str_item< class $lid:c$ = object (o) $builtins$; $generated$ end >> *) + let x = <:class_str_item< $builtins$; $generated$ >> in + <:str_item< class $lid:c$ = object (o : 'self_type) $x$ end >> + | s -> s ]) + + and inject_signature generated = + Ast.map_sig_item + (fun + [ <:sig_item@_loc< class $lid:c$ : Camlp4Filters.GenerateFold.generated >> -> + <:sig_item< class $lid:c$ : object $generated$ end >> + | s -> s ]) + + and process_str_item str_item = + let tyMap = collect_types_in_str_item str_item in + let generated = generate_structure tyMap in + inject_structure_drop_trash generated str_item + + and process_sig_item sig_item = + let tyMap = collect_types_in_sig_item sig_item in + let generated = generate_signature tyMap in + inject_signature generated sig_item; + + register_str_item_filter process_str_item; + register_sig_item_filter process_sig_item; + +end; + +let module M = Camlp4.Register.AstFilter Id Make in (); diff --git a/camlp4/Camlp4Filters/Camlp4LocationStripper.ml b/camlp4/Camlp4Filters/Camlp4LocationStripper.ml new file mode 100644 index 00000000..7c7ce772 --- /dev/null +++ b/camlp4/Camlp4Filters/Camlp4LocationStripper.ml @@ -0,0 +1,36 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + + +open Camlp4; + +module Id = struct + value name = "Camlp4LocationStripper"; + value version = "$Id: Camlp4LocationStripper.ml,v 1.1 2007/02/07 10:09:22 ertai Exp $"; +end; + +module Make (AstFilters : Camlp4.Sig.AstFilters) = struct + open AstFilters; + open Ast; + + register_str_item_filter (new Ast.c_loc (fun _ -> Loc.ghost))#str_item; + +end; + +let module M = Camlp4.Register.AstFilter Id Make in (); diff --git a/camlp4/Camlp4Filters/Camlp4MapGenerator.ml b/camlp4/Camlp4Filters/Camlp4MapGenerator.ml new file mode 100644 index 00000000..0c391dd6 --- /dev/null +++ b/camlp4/Camlp4Filters/Camlp4MapGenerator.ml @@ -0,0 +1,327 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + + +open Camlp4; + +module Id = struct + value name = "Camlp4MapGenerator"; + value version = "$Id: Camlp4MapGenerator.ml,v 1.1 2007/02/07 10:09:22 ertai Exp $"; +end; + +module Make (AstFilters : Camlp4.Sig.AstFilters) = struct + open AstFilters; + module StringMap = Map.Make String; + open Ast; + + value _loc = Loc.ghost; + + value xi i = "_x" ^ string_of_int i; + + value xs s = "_x_" ^ s; + + 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 list_mapi f = + let rec self i = + fun + [ [] -> [] + | [ x :: xs ] -> [ f i x :: self (succ i) xs ] ] + in self 0; + + value list_init f n = + let rec self m = + if m = n then [] + else [f m :: self (succ m)] + in self 0; + + (* Yes this is a poor fresh function *) + value fresh = + let count = ref 0 in + fun basename -> + let res = basename ^ (string_of_int count.val) + in do { incr count; res }; + + value mk_tuple self t = + let tl = Ast.list_of_ctyp t [] in + let n = List.length tl in + let exi i = <:expr< $lid:xi i$ >> in + let pxi i = <:patt< $lid:xi i$ >> in + let el = list_mapi (fun i -> self (Some (exi i))) tl in + <:expr< fun ($tup:Ast.paCom_of_list (list_init pxi n)$) + -> ($tup:Ast.exCom_of_list el$) >>; + + value builtins = + <:class_str_item< + method string x : string = x; + method int x : int = x; + method float x : float = x; + method bool x : bool = x; + method list : ! 'a 'b . ('a -> 'b) -> list 'a -> list 'b = + List.map; + method option : ! 'a 'b . ('a -> 'b) -> option 'a -> option 'b = + fun f -> fun [ None -> None | Some x -> Some (f x) ]; + method array : ! 'a 'b . ('a -> 'b) -> array 'a -> array 'b = + Array.map; + method ref : ! 'a 'b . ('a -> 'b) -> ref 'a -> ref 'b = + fun f { val = x } -> { val = f x }; + >>; + + (* FIXME UNUSED *) + value builtins_sig = + <:sig_item< + value string : string -> string; + value int : int -> int; + value float : float -> float; + value bool : bool -> bool; + value list : ('a -> 'b) -> list 'a -> list 'b; + value array : ('a -> 'b) -> array 'a -> array 'b; + value option : ('a -> 'b) -> option 'a -> option 'b; + value ref : ('a -> 'b) -> ref 'a -> ref 'b; + >>; + + 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); + + value (unknown_type, fold_unknown_types) = + let set = ref StringMap.empty in + let add id1 id2 ty = set.val := StringMap.add id1 (id1, id2, [], ty) set.val + and fold f = StringMap.fold f set.val in (add, fold); + + value rec expr_of_ty x ty = + let rec self ox = + fun + [ <:ctyp< $lid:id$ >> -> + match ox with + [ Some x -> <:expr< o#$id$ $x$ >> + | _ -> <:expr< o#$id$ >> ] + | <:ctyp< $t1$ $t2$ >> -> + let e = <:expr< $self None t1$ $self None t2$ >> in + match ox with + [ Some x -> <:expr< $e$ $x$ >> + | _ -> e ] + | <:ctyp< $t1$ -> $t2$ >> -> + let mk_fun x = + let y = fresh "y" in + let py = <:expr< $lid:y$ >> in + let e = <:expr< $x$ $self (Some py) t1$ >> + in <:expr< fun $lid:y$ -> $self (Some e) t2$ >> in + match ox with + [ Some x -> mk_fun x + | _ -> + let z = fresh "z" in + let pz = <:expr< $lid:z$ >> in + <:expr< fun $lid:z$ -> $mk_fun pz$ >> ] + | <:ctyp< ( $tup:t$ ) >> -> + let e = mk_tuple self t in + match ox with + [ Some x -> <:expr< $e$ $x$ >> + | _ -> e ] + | <:ctyp< '$s$ >> -> + let id = "_f_" ^ s in + match ox with + [ Some x -> <:expr< $lid:id$ $x$ >> + | _ -> <:expr< $lid:id$ >> ] + | <:ctyp< $id:i$ >> -> + let id1 = "_" ^ lid_of_ident "_" i in + let ty = <:ctyp< $lid:id1$ >> in + let () = unknown_type id1 i ty in + self ox ty + | _ -> + match ox with + [ Some x -> <:expr< $x$ >> + | _ -> <:expr< fun x -> x >> ] ] + in self x ty + + and expr_of_constructor t (i, acc) = + match t with + [ <:ctyp< $t1$ and $t2$ >> -> + expr_of_constructor t2 (expr_of_constructor t1 (i, acc)) + | _ -> (succ i, <:expr< $acc$ $expr_of_ty (Some <:expr< $lid:xi i$ >>) t$ >>) ] + + and patt_of_constructor t (i, acc) = + match t with + [ <:ctyp< $t1$ and $t2$ >> -> + patt_of_constructor t2 (patt_of_constructor t1 (i, acc)) + | _ -> (succ i, <:patt< $acc$ $lid:xi i$ >>) ] + + and match_case_of_sum_type = + fun + [ <:ctyp< $t1$ | $t2$ >> -> + <:match_case< $match_case_of_sum_type t1$ | $match_case_of_sum_type t2$ >> + | <:ctyp< $uid:s$ of $t$ >> -> + <:match_case< $pat:snd (patt_of_constructor t (0, <:patt< $uid:s$ >>))$ + -> $snd (expr_of_constructor t (0, <:expr< $uid:s$ >>))$ >> + | <:ctyp< $uid:s$ >> -> + <:match_case< $uid:s$ -> $uid:s$ >> + | _ -> assert False ] + + and record_patt_of_type = + fun + [ <:ctyp< $lid:s$ : $_$ >> -> + <:patt< $lid:s$ = $lid:xs s$ >> + | <:ctyp< $t1$ ; $t2$ >> -> + <:patt< $record_patt_of_type t1$; $record_patt_of_type t2$ >> + | _ -> assert False ] + + and record_binding_of_type = + fun + [ <:ctyp< $lid:s$ : mutable $t$ >> | <:ctyp< $lid:s$ : $t$ >> -> + <:binding< $lid:s$ = $expr_of_ty (Some <:expr< $lid:xs s$ >>) t$ >> + | <:ctyp< $t1$ ; $t2$ >> -> + <:binding< $record_binding_of_type t1$; $record_binding_of_type t2$ >> + | _ -> assert False ] + + and fun_of_ctyp = + fun + [ <:ctyp< [ $t$ ] >> -> + <:expr< fun [ $match_case_of_sum_type t$ ] >> + | <:ctyp< { $t$ } >> -> + <:expr< fun { $record_patt_of_type t$ } -> { $record_binding_of_type t$ } >> + | <:ctyp< ( $tup:t$ ) >> -> mk_tuple expr_of_ty t + | _ -> <:expr< fun x -> x >> ] + + and string_of_type_param t = + match t with + [ <:ctyp< '$s$ >> | <:ctyp< +'$s$ >> | <:ctyp< -'$s$ >> -> s + | _ -> assert False ] + + and method_of_type_decl ((id1, _, params, ctyp) as type_decl) = + let rec lambda acc = + fun + [ [] -> acc + | [ x :: xs ] -> lambda <:expr< fun $lid:"_f_" ^ x$ -> $acc$ >> xs ] in + let params' = List.map string_of_type_param params in + let funs = lambda (fun_of_ctyp ctyp) params' in + let ty = method_type_of_type_decl type_decl in + <:class_str_item< method $lid:id1$ : $ty$ = $funs$ >> + + and ctyp_name_of_name_params name params = + apply_ctyp <:ctyp< $id:name$ >> params + + and method_type_of_type_decl (_, name, params, _) = + let t = ctyp_name_of_name_params name [] (* FIXME params *) in + match List.length params with + [ 1 -> <:ctyp< ! 'a 'b . ('a -> 'b) -> $t$ 'a -> $t$ 'b >> + | 0 -> <:ctyp< $t$ -> $t$ >> + | _ -> failwith "FIXME not implemented" ] + + and class_sig_item_of_type_decl _ ((name, _, _, _) as type_decl) acc = + <:class_sig_item< + method $lid:name$ : $method_type_of_type_decl type_decl$; + $acc$ >> + + and tyMap_of_type_decls t acc = + match t with + [ <:ctyp< $t1$ and $t2$ >> -> + tyMap_of_type_decls t1 (tyMap_of_type_decls t2 acc) + | Ast.TyDcl _ name tl tk _ -> + StringMap.add name (name, <:ident< $lid:name$ >>, tl, tk) acc + | _ -> assert False ] + + and fold_types_in_str_item f = + fun + [ <:str_item< type $t$ >> -> f t + | <:str_item< $st1$; $st2$ >> -> fun acc -> + fold_types_in_str_item f st1 (fold_types_in_str_item f st2 acc) + | <:str_item< module $_$ = struct $st$ end >> | + <:str_item< module $_$ ($_$:$_$) = struct $st$ end >> -> + fold_types_in_str_item f st + | _ -> fun x -> x ] + + and fold_types_in_sig_item f = + fun + [ <:sig_item< type $t$ >> -> f t + | <:sig_item< $sg1$; $sg2$ >> -> fun acc -> + fold_types_in_sig_item f sg1 (fold_types_in_sig_item f sg2 acc) + | <:sig_item< module $_$ : sig $sg$ end >> | + <:sig_item< module $_$ ($_$:$_$) : sig $sg$ end >> -> + fold_types_in_sig_item f sg + | _ -> fun x -> x ] + + and collect_types_in_str_item str_item = + fold_types_in_str_item tyMap_of_type_decls str_item StringMap.empty + + and collect_types_in_sig_item sig_item = + fold_types_in_sig_item tyMap_of_type_decls sig_item StringMap.empty + + and generate_structure tyMap = + let f x acc = <:class_str_item< $method_of_type_decl x$; $acc$ >> in + let g _ ty = f ty in + fold_unknown_types g (StringMap.fold g tyMap <:class_str_item<>>) + + and generate_signature tyMap = + StringMap.fold class_sig_item_of_type_decl tyMap <:class_sig_item<>> + + and inject_structure_drop_trash generated = + Ast.map_str_item + (fun + [ <:str_item@_loc< class $lid:c$ = Camlp4Filters.GenerateMap.generated >> -> + (* FIXME <:str_item< class $lid:c$ = object (o) $builtins$; $generated$ end >> *) + let x = <:class_str_item< $builtins$; $generated$ >> in + <:str_item< class $lid:c$ = object (o) $x$ end >> + | s -> s ]) + + and inject_signature generated = + Ast.map_sig_item + (fun + [ <:sig_item@_loc< class $lid:c$ : Camlp4Filters.GenerateMap.generated >> -> + <:sig_item< class $lid:c$ : object $generated$ end >> + | s -> s ]) + + and process_str_item str_item = + let tyMap = collect_types_in_str_item str_item in + let generated = generate_structure tyMap in + inject_structure_drop_trash generated str_item + + and process_sig_item sig_item = + let tyMap = collect_types_in_sig_item sig_item in + let generated = generate_signature tyMap in + inject_signature generated sig_item; + + register_str_item_filter process_str_item; + register_sig_item_filter process_sig_item; + +end; + +let module M = Camlp4.Register.AstFilter Id Make in (); diff --git a/camlp4/Camlp4Filters/Camlp4MetaGenerator.ml b/camlp4/Camlp4Filters/Camlp4MetaGenerator.ml new file mode 100644 index 00000000..1a62e84d --- /dev/null +++ b/camlp4/Camlp4Filters/Camlp4MetaGenerator.ml @@ -0,0 +1,195 @@ +open Camlp4; +open PreCast; +module MapTy = Map.Make String; + +type t = + { name : Ast.ident; + type_decls : MapTy.t Ast.ctyp; + acc : Ast.expr; + app : Ast.expr; + id : Ast.expr; + tup : Ast.expr; + com : Ast.expr; + str : Ast.expr; + int : Ast.expr; + flo : Ast.expr; + chr : Ast.expr; + ant : Ast.ident; + }; + +value _loc = Loc.ghost; + +value x i = <:ident< $lid:"x"^string_of_int i$ >>; + +value meta_ s = <:ident< $lid:"meta_"^s$ >>; + +value mf_ s = "mf_" ^ s; + +value rec string_of_ident = + fun + [ <:ident< $lid:s$ >> -> s + | <:ident< $uid:s$ >> -> s + | <:ident< $i1$.$i2$ >> -> "acc_" ^ (string_of_ident i1) ^ "_" ^ (string_of_ident i2) + | <:ident< $i1$ $i2$ >> -> "app_" ^ (string_of_ident i1) ^ "_" ^ (string_of_ident i2) + | <:ident< $anti:_$ >> -> assert False ]; + +value fold_args ty f init = + let (_, res) = + List.fold_left (fun (i, acc) ty -> (succ i, f ty i acc) + ) (0, init) ty + in res; + +value fold_data_ctors ty f init = + let rec loop acc t = + match t with + [ <:ctyp< $uid:cons$ of $ty$ >> -> f cons (Ast.list_of_ctyp ty []) acc + | <:ctyp< $uid:cons$ >> -> f cons [] acc + | <:ctyp< $t1$ | $t2$ >> -> loop (loop acc t1) t2 + | <:ctyp<>> -> acc + | _ -> assert False ] in + loop init ty; + +value fold_type_decls m f init = + MapTy.fold f m.type_decls init; + +value patt_of_data_ctor_decl cons tyargs = + fold_args tyargs (fun _ i acc -> + <:patt< $acc$ $id:x i$ >> + ) <:patt< $id:cons$ >>; + +value expr_of_data_ctor_decl cons tyargs = + fold_args tyargs (fun _ i acc -> + <:expr< $acc$ $id:x i$ >> + ) <:expr< $id:cons$ >>; + +value is_antiquot_data_ctor s = + let ls = String.length s in + ls > 3 && String.sub s (ls - 3) 3 = "Ant"; + +value rec meta_ident m = + fun + [ <:ident< $i1$.$i2$ >> -> <:expr< Ast.IdAcc _loc $meta_ident m i1$ $meta_ident m i2$ >> + | <:ident< $i1$ $i2$ >> -> <:expr< Ast.IdApp _loc $meta_ident m i1$ $meta_ident m i2$ >> + | <:ident< $anti:s$ >> -> <:expr< $anti:s$ >> + | <:ident< $lid:s$ >> -> <:expr< Ast.IdLid _loc $str:s$ >> + | <:ident< $uid:s$ >> -> <:expr< Ast.IdUid _loc $str:s$ >> ]; +value m_app m x y = <:expr< $m.app$ _loc $x$ $y$ >>; +value m_id m i = <:expr< $m.id$ _loc $i$ >>; +value m_uid m s = m_id m (meta_ident m <:ident< $uid:s$ >>); + +value failure = <:expr< raise (Failure "MetaGenerator: cannot handle that kind of types") >>; + +value mk_meta m = + let m_name_uid x = <:ident< $m.name$.$uid:x$ >> in + fold_type_decls m (fun tyname tydcl acc -> + let funct = + match tydcl with + [ Ast.TyDcl _ _ tyvars <:ctyp< [$ty$] >> _ -> + let match_case = + fold_data_ctors ty (fun cons tyargs acc -> + let m_name_cons = m_name_uid cons in + let init = m_id m (meta_ident m m_name_cons) in + let p = patt_of_data_ctor_decl m_name_cons tyargs in + let e = + if cons = "BAnt" || cons = "OAnt" || cons = "LAnt" then + <:expr< $id:m.ant$ _loc x0 >> + else if is_antiquot_data_ctor cons then + expr_of_data_ctor_decl m.ant tyargs + else + fold_args tyargs (fun ty i acc -> + let rec fcall_of_ctyp ty = + match ty with + [ <:ctyp< $id:id$ >> -> + <:expr< $id:meta_ (string_of_ident id)$ >> + | <:ctyp< ($t1$ * $t2$) >> -> + <:expr< (fun _loc (x1, x2) -> + $m.tup$ _loc + ($m.com$ _loc + ($fcall_of_ctyp t1$ _loc x1) + ($fcall_of_ctyp t2$ _loc x2))) >> + | <:ctyp< $t1$ $t2$ >> -> + <:expr< $fcall_of_ctyp t1$ $fcall_of_ctyp t2$ >> + | <:ctyp< '$s$ >> -> <:expr< $lid:mf_ s$ >> + | _ -> failure ] + in m_app m acc <:expr< $fcall_of_ctyp ty$ _loc $id:x i$ >> + ) init + in <:match_case< $p$ -> $e$ | $acc$ >> + ) <:match_case<>> in + List.fold_right (fun tyvar acc -> + match tyvar with + [ <:ctyp< +'$s$ >> | <:ctyp< -'$s$ >> | <:ctyp< '$s$ >> -> + <:expr< fun $lid:mf_ s$ -> $acc$ >> + | _ -> assert False ]) + tyvars <:expr< fun _loc -> fun [ $match_case$ ] >> + | Ast.TyDcl _ _ _ _ _ -> <:expr< fun _ -> $failure$ >> + | _ -> assert False ] + in <:binding< $acc$ and $lid:"meta_"^tyname$ = $funct$ >>) <:binding<>>; + +value find_type_decls = object + inherit Ast.fold as super; + value accu = MapTy.empty; + method get = accu; + method ctyp = + fun + [ Ast.TyDcl _ name _ _ _ as t -> {< accu = MapTy.add name t accu >} + | t -> super#ctyp t ]; +end; + +value filter st = + let type_decls = lazy (find_type_decls#str_item st)#get in + object + inherit Ast.map as super; + method module_expr me = + let mk_meta_module m = + let bi = mk_meta m in + <:module_expr< + struct + value meta_string _loc s = $m.str$ _loc s; + value meta_int _loc s = $m.int$ _loc s; + value meta_float _loc s = $m.flo$ _loc s; + value meta_char _loc s = $m.chr$ _loc s; + value meta_bool _loc = + fun + [ False -> $m_uid m "False"$ + | True -> $m_uid m "True"$ ]; + value rec meta_list mf_a _loc = + fun + [ [] -> $m_uid m "[]"$ + | [x :: xs] -> $m_app m (m_app m (m_uid m "::") <:expr< mf_a _loc x >>) <:expr< meta_list mf_a _loc xs >>$ ]; + value rec $bi$; + end >> in + match super#module_expr me with + [ <:module_expr< Camlp4Filters.MetaGeneratorExpr $id:i$ >> -> + mk_meta_module + { name = i; + type_decls = Lazy.force type_decls; + app = <:expr< Ast.ExApp >>; + acc = <:expr< Ast.ExAcc >>; + id = <:expr< Ast.ExId >>; + tup = <:expr< Ast.ExTup >>; + com = <:expr< Ast.ExCom >>; + str = <:expr< Ast.ExStr >>; + int = <:expr< Ast.ExInt >>; + flo = <:expr< Ast.ExFlo >>; + chr = <:expr< Ast.ExChr >>; + ant = <:ident< Ast.ExAnt >> + } + | <:module_expr< Camlp4Filters.MetaGeneratorPatt $id:i$ >> -> + mk_meta_module + { name = i; + type_decls = Lazy.force type_decls; + app = <:expr< Ast.PaApp >>; + acc = <:expr< Ast.PaAcc >>; + id = <:expr< Ast.PaId >>; + tup = <:expr< Ast.PaTup >>; + com = <:expr< Ast.PaCom >>; + str = <:expr< Ast.PaStr >>; + int = <:expr< Ast.PaInt >>; + flo = <:expr< Ast.PaFlo >>; + chr = <:expr< Ast.PaChr >>; + ant = <:ident< Ast.PaAnt >> + } + | me -> me ]; + end#str_item st; + +AstFilters.register_str_item_filter filter; diff --git a/camlp4/Camlp4Filters/Camlp4Profiler.ml b/camlp4/Camlp4Filters/Camlp4Profiler.ml new file mode 100644 index 00000000..d00e3612 --- /dev/null +++ b/camlp4/Camlp4Filters/Camlp4Profiler.ml @@ -0,0 +1,77 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +open Camlp4; + +module Id = struct + value name = "Camlp4Profiler"; + value version = "$Id: Camlp4Profiler.ml,v 1.1 2007/02/07 10:09:22 ertai Exp $"; +end; + +module Make (AstFilters : Camlp4.Sig.AstFilters) = struct + open AstFilters; + open Ast; + + value decorate_binding decorate_fun = object + inherit Ast.map as super; + method binding = + fun + [ <:binding@_loc< $lid:id$ = $(<:expr< fun [ $_$ ] >> as e)$ >> -> + <:binding< $lid:id$ = $decorate_fun id e$ >> + | b -> super#binding b ]; + end#binding; + + value decorate decorate_fun = object (o) + inherit Ast.map as super; + method str_item = + fun + [ <:str_item@_loc< value $rec:r$ $b$ >> -> + <:str_item< value $rec:r$ $decorate_binding decorate_fun b$ >> + | st -> super#str_item st ]; + method expr = + fun + [ <:expr@_loc< let $rec:r$ $b$ in $e$ >> -> + <:expr< let $rec:r$ $decorate_binding decorate_fun b$ in $o#expr e$ >> + | <:expr@_loc< fun [ $_$ ] >> as e -> decorate_fun "" e + | e -> super#expr e ]; + end; + + value decorate_this_expr e id = + let buf = Buffer.create 42 in + let _loc = Ast.loc_of_expr e in + let () = Format.bprintf buf "%s @@ %a@?" id Loc.dump _loc in + let s = Buffer.contents buf in + <:expr< let () = Camlp4prof.count $`str:s$ in $e$ >>; + + value rec decorate_fun id = + let decorate = decorate decorate_fun in + let decorate_expr = decorate#expr in + let decorate_match_case = decorate#match_case in + fun + [ <:expr@_loc< fun $p$ -> $e$ >> -> + <:expr< fun $p$ -> $decorate_fun id e$ >> + | <:expr@_loc< fun [ $m$ ] >> -> + decorate_this_expr <:expr< fun [ $decorate_match_case m$ ] >> id + | e -> decorate_this_expr (decorate_expr e) id ]; + + register_str_item_filter (decorate decorate_fun)#str_item; + +end; + +let module M = Camlp4.Register.AstFilter Id Make in (); diff --git a/camlp4/Camlp4Filters/Camlp4Tracer.ml b/camlp4/Camlp4Filters/Camlp4Tracer.ml new file mode 100644 index 00000000..9a24b4c0 --- /dev/null +++ b/camlp4/Camlp4Filters/Camlp4Tracer.ml @@ -0,0 +1,58 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + + +open Camlp4; + +module Id = struct + value name = "Camlp4Tracer"; + value version = "$Id: Camlp4Tracer.ml,v 1.1 2007/02/07 10:09:22 ertai Exp $"; +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: tracer: %s at " ^ Loc.to_string _loc ^ "@." in + <:expr< do { if Debug.mode "tracer" then + Format.eprintf $`str:msg$ (Printexc.to_string exc) + else (); + $e$ } >>; + + 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 ] + + and map_expr = + fun + [ <:expr@_loc< fun [ $m$ ] >> -> <:expr< fun [ $map_match_case m$ ] >> + | x -> x ]; + + register_str_item_filter (new Ast.c_expr map_expr)#str_item; + +end; + +let module M = Camlp4.Register.AstFilter Id Make in (); diff --git a/camlp4/Camlp4Filters/Camlp4TrashRemover.ml b/camlp4/Camlp4Filters/Camlp4TrashRemover.ml new file mode 100644 index 00000000..207143a8 --- /dev/null +++ b/camlp4/Camlp4Filters/Camlp4TrashRemover.ml @@ -0,0 +1,41 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + + +open Camlp4; + +module Id = struct + value name = "Camlp4TrashRemover"; + value version = "$Id: Camlp4TrashRemover.ml,v 1.1 2007/02/07 10:09:22 ertai Exp $"; +end; + +module Make (AstFilters : Camlp4.Sig.AstFilters) = struct + open AstFilters; + open Ast; + + register_str_item_filter + (new Ast.c_str_item + (fun + [ <:str_item@_loc< module Camlp4Trash = $_$ >> -> + <:str_item<>> + | st -> st ]))#str_item; + +end; + +let module M = Camlp4.Register.AstFilter Id Make in (); diff --git a/camlp4/Camlp4Parsers/Camlp4AstLoader.ml b/camlp4/Camlp4Parsers/Camlp4AstLoader.ml new file mode 100644 index 00000000..d5fd144a --- /dev/null +++ b/camlp4/Camlp4Parsers/Camlp4AstLoader.ml @@ -0,0 +1,49 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) +open Camlp4; (* -*- camlp4r -*- *) + +module Id = struct + value name = "Camlp4AstLoader"; + value version = "$Id: Camlp4AstLoader.ml,v 1.1 2007/02/07 10:09:22 ertai Exp $"; +end; + +module Make (Ast : Camlp4.Sig.Ast) = struct + module Ast = Ast; + + value parse ast_magic ?directive_handler:(_) _loc strm = + let str = + let buf = Buffer.create 2047 in + let () = Stream.iter (Buffer.add_char buf) strm + in Buffer.contents buf in + let magic_len = String.length ast_magic in + let buffer = String.create magic_len in + do { + String.blit str 0 buffer 0 magic_len; + if buffer = ast_magic then () + else failwith (Format.sprintf "Bad magic: %S vs %S" buffer ast_magic); + Marshal.from_string str magic_len; + }; + + open Camlp4.PreCast; + value parse_implem = parse Camlp4_config.camlp4_ast_impl_magic_number; + value parse_interf = parse Camlp4_config.camlp4_ast_intf_magic_number; + +end; + +let module M = Camlp4.Register.Parser Id Make in (); diff --git a/camlp4/Camlp4Parsers/Camlp4DebugParser.ml b/camlp4/Camlp4Parsers/Camlp4DebugParser.ml new file mode 100644 index 00000000..8331e5eb --- /dev/null +++ b/camlp4/Camlp4Parsers/Camlp4DebugParser.ml @@ -0,0 +1,83 @@ +open Camlp4; (* -*- camlp4r -*- *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +module Id = struct + value name = "Camlp4DebugParser"; + value version = "$Id: Camlp4DebugParser.ml,v 1.1 2007/02/07 10:09:22 ertai Exp $"; +end; + +module Make (Syntax : Sig.Camlp4Syntax) = struct + open Sig; + include Syntax; + + module StringSet = Set.Make String; + + value debug_mode = + try + let str = Sys.getenv "STATIC_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 rec apply accu = + fun + [ [] -> accu + | [x :: xs] -> + let _loc = Ast.loc_of_expr x + in apply <:expr< $accu$ $x$ >> xs ]; + + value mk_debug_mode _loc = fun [ None -> <:expr< Debug.mode >> + | Some m -> <:expr< $uid:m$.Debug.mode >> ]; + + value mk_debug _loc m fmt section args = + let call = apply <:expr< Debug.printf $str:section$ $str:fmt$ >> args in + <:expr< if $mk_debug_mode _loc m$ $str:section$ then $call$ else () >>; + + EXTEND Gram + GLOBAL: expr; + expr: + [ [ m = start_debug; section = LIDENT; fmt = STRING; + args = LIST0 expr LEVEL "."; x = end_or_in -> + match (x, debug_mode section) with + [ (None, False) -> <:expr< () >> + | (Some e, False) -> e + | (None, _) -> mk_debug _loc m fmt section args + | (Some e, _) -> <:expr< let () = $mk_debug _loc m fmt section args$ in $e$ >> ] + ] ]; + end_or_in: + [ [ "end" -> None + | "in"; e = expr -> Some e + ] ]; + start_debug: + [ [ LIDENT "debug" -> None + | LIDENT "camlp4_debug" -> Some "Camlp4" + ] ]; + END; + +end; + +let module M = Register.OCamlSyntaxExtension Id Make in (); diff --git a/camlp4/Camlp4Parsers/Camlp4GrammarParser.ml b/camlp4/Camlp4Parsers/Camlp4GrammarParser.ml new file mode 100644 index 00000000..f5382967 --- /dev/null +++ b/camlp4/Camlp4Parsers/Camlp4GrammarParser.ml @@ -0,0 +1,890 @@ +open Camlp4; (* -*- camlp4r -*- *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2002-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + + +module Id = struct + value name = "Camlp4GrammarParser"; + value version = "$Id: Camlp4GrammarParser.ml,v 1.1 2007/02/07 10:09:22 ertai Exp $"; +end; + +module Make (Syntax : Sig.Camlp4Syntax) = struct + open Sig; + include Syntax; + + module MetaLoc = Ast.Meta.MetaGhostLoc; + module MetaAst = Ast.Meta.Make MetaLoc; + module PP = Camlp4.Printers.OCaml.Make Syntax; + value pp = new PP.printer ~comments:False (); + + value string_of_patt patt = + let buf = Buffer.create 42 in + let () = Format.bprintf buf "%a@?" pp#patt patt in + let str = Buffer.contents buf in + if str = "" then assert False else str; + + value split_ext = ref False; + + type loc = Loc.t; + + type name 'e = { expr : 'e; tvar : string; loc : loc }; + + type styp = + [ STlid of loc and string + | STapp of loc and styp and styp + | STquo of loc and string + | STself of loc and string + | STtok of loc + | STstring_tok of loc + | STany of loc + | STtyp of Ast.ctyp ] + ; + + type text 'e 'p = + [ TXmeta of loc and string and list (text 'e 'p) and 'e and styp + | TXlist of loc and bool and symbol 'e 'p and option (symbol 'e 'p) + | TXnext of loc + | TXnterm of loc and name 'e and option string + | TXopt of loc and text 'e 'p + | TXrules of loc and list (list (text 'e 'p) * 'e) + | TXself of loc + | TXkwd of loc and string + | TXtok of loc and 'e and string + (** The first is the match function expr, + the second is the string description. + The description string will be used for + grammar insertion and left factoring. + Keep this string normalized and well comparable. *) ] + and entry 'e 'p = + { name : name 'e; pos : option 'e; levels : list (level 'e 'p) } + and level 'e 'p = + { label : option string; assoc : option 'e; rules : list (rule 'e 'p) } + and rule 'e 'p = { prod : list (symbol 'e 'p); action : option 'e } + and symbol 'e 'p = { used : list string; text : text 'e 'p; + styp : styp; pattern : option 'p } + ; + + type used = [ Unused | UsedScanned | UsedNotScanned ]; + + value _loc = Loc.ghost; + value gm = "Camlp4Grammar__"; + + value mark_used modif ht n = + try + let rll = Hashtbl.find_all ht n in + List.iter + (fun (r, _) -> + if r.val == Unused then do { + r.val := UsedNotScanned; modif.val := True; + } + else ()) + rll + with + [ Not_found -> () ] + ; + + value rec mark_symbol modif ht symb = + List.iter (fun e -> mark_used modif ht e) symb.used + ; + + value check_use nl el = + let ht = Hashtbl.create 301 in + let modif = ref False in + do { + List.iter + (fun e -> + let u = + match e.name.expr with + [ <:expr< $lid:_$ >> -> Unused + | _ -> UsedNotScanned ] + in + Hashtbl.add ht e.name.tvar (ref u, e)) + el; + List.iter + (fun n -> + try + let rll = Hashtbl.find_all ht n.tvar in + List.iter (fun (r, _) -> r.val := UsedNotScanned) rll + with _ -> + ()) + nl; + modif.val := True; + while modif.val do { + modif.val := False; + Hashtbl.iter + (fun _ (r, e) -> + if r.val = UsedNotScanned then do { + r.val := UsedScanned; + List.iter + (fun level -> + let rules = level.rules in + List.iter + (fun rule -> + List.iter (fun s -> mark_symbol modif ht s) + rule.prod) + rules) + e.levels + } + else ()) + ht + }; + Hashtbl.iter + (fun s (r, e) -> + if r.val = Unused then + Warning.print e.name.loc ("Unused local entry \"" ^ s ^ "\"") + else ()) + ht; + } + ; + + value new_type_var = + let i = ref 0 in fun () -> do { incr i; "e__" ^ string_of_int i.val } + ; + + value used_of_rule_list rl = + List.fold_left + (fun nl r -> List.fold_left (fun nl s -> s.used @ nl) nl r.prod) [] + rl + ; + + value retype_rule_list_without_patterns _loc rl = + try + List.map + (fun + (* ...; [ "foo" ]; ... ==> ...; (x = [ "foo" ] -> Token.extract_string x); ... *) + [ {prod = [({pattern = None; styp = STtok _} as s)]; action = None} -> + {prod = [{ (s) with pattern = Some <:patt< x >> }]; + action = Some <:expr< Token.extract_string x >>} + (* ...; [ symb ]; ... ==> ...; (x = [ symb ] -> x); ... *) + | {prod = [({pattern = None} as s)]; action = None} -> + {prod = [{ (s) with pattern = Some <:patt< x >> }]; + action = Some <:expr< x >>} + (* ...; ([] -> a); ... *) + | {prod = []; action = Some _} as r -> r + | _ -> raise Exit ]) + rl + with + [ Exit -> rl ] + ; + + value meta_action = ref False; + + value mklistexp _loc = + loop True where rec loop top = + fun + [ [] -> <:expr< [] >> + | [e1 :: el] -> + let _loc = + if top then _loc else Loc.merge (Ast.loc_of_expr e1) _loc + in + <:expr< [$e1$ :: $loop False el$] >> ] + ; + + value mklistpat _loc = + loop True where rec loop top = + fun + [ [] -> <:patt< [] >> + | [p1 :: pl] -> + let _loc = + if top then _loc else Loc.merge (Ast.loc_of_patt p1) _loc + in + <:patt< [$p1$ :: $loop False pl$] >> ] + ; + + value rec expr_fa al = + fun + [ <:expr< $f$ $a$ >> -> expr_fa [a :: al] f + | f -> (f, al) ] + ; + + value rec make_ctyp styp tvar = + match styp with + [ STlid _loc s -> <:ctyp< $lid:s$ >> + | STapp _loc t1 t2 -> <:ctyp< $make_ctyp t1 tvar$ $make_ctyp t2 tvar$ >> + | STquo _loc s -> <:ctyp< '$s$ >> + | STself _loc x -> + if tvar = "" then + Loc.raise _loc + (Stream.Error ("'" ^ x ^ "' illegal in anonymous entry level")) + else <:ctyp< '$tvar$ >> + | STany _loc -> <:ctyp< _ >> + | STtok _loc -> <:ctyp< $uid:gm$.Token.t >> + | STstring_tok _loc -> <:ctyp< string >> + | STtyp t -> t ] + ; + + value make_ctyp_patt styp tvar patt = + let styp = match styp with [ STstring_tok _loc -> STtok _loc | t -> t ] in + match make_ctyp styp tvar with + [ <:ctyp< _ >> -> patt + | t -> let _loc = Ast.loc_of_patt patt in <:patt< ($patt$ : $t$) >> ]; + + value make_ctyp_expr styp tvar expr = + match make_ctyp styp tvar with + [ <:ctyp< _ >> -> expr + | t -> let _loc = Ast.loc_of_expr expr in <:expr< ($expr$ : $t$) >> ]; + + value text_of_action _loc psl rtvar act tvar = + let locid = <:patt< $lid:Loc.name.val$ >> in + let act = + match act with + [ Some act -> act + | None -> <:expr< () >> ] + in + let (tok_match_pl, act, _) = + List.fold_left + (fun ((tok_match_pl, act, i) as accu) -> + fun + [ { pattern = None } -> accu + | { pattern = Some p } when Ast.is_irrefut_patt p -> accu + | { pattern = Some <:patt< ($_$ ($tup:<:patt< _ >>$) as $lid:s$) >> } -> + (tok_match_pl, + <:expr< let $lid:s$ = $uid:gm$.Token.extract_string $lid:s$ + in $act$ >>, i) + | { pattern = Some p; text=TXtok _ _ _ } -> + let id = "__camlp4_"^string_of_int i in + (Some (match (tok_match_pl) with + [ None -> (<:expr< $lid:id$ >>, p) + | Some (tok_pl, match_pl) -> + (<:expr< $lid:id$, $tok_pl$ >>, <:patt< $p$, $match_pl$ >>)]), + act, succ i) + | _ -> accu ]) + (None, act, 0) psl + in + let e = + let e1 = <:expr< ($act$ : '$rtvar$) >> in + let e2 = + match (tok_match_pl) with + [ None -> e1 + | Some (<:expr< $t1$, $t2$ >>, <:patt< $p1$, $p2$ >>) -> + <:expr< match ($t1$, $t2$) with + [ ($p1$, $p2$) -> $e1$ + | _ -> assert False ] >> + | Some (tok, match_) -> + <:expr< match $tok$ with + [ $pat:match_$ -> $e1$ + | _ -> assert False ] >> ] in + <:expr< fun ($locid$ : Loc.t) -> $e2$ >> in + let (txt, _) = + List.fold_left + (fun (txt, i) s -> + match s.pattern with + [ None | Some <:patt< _ >> -> (<:expr< fun _ -> $txt$ >>, i) + | Some <:patt< ($_$ ($tup:<:patt< _ >>$) as $p$) >> -> + let p = make_ctyp_patt s.styp tvar p in + (<:expr< fun $p$ -> $txt$ >>, i) + | Some p when Ast.is_irrefut_patt p -> + let p = make_ctyp_patt s.styp tvar p in + (<:expr< fun $p$ -> $txt$ >>, i) + | Some _ -> + let p = make_ctyp_patt s.styp tvar + <:patt< $lid:"__camlp4_"^string_of_int i$ >> in + (<:expr< fun $p$ -> $txt$ >>, succ i) ]) + (e, 0) psl + in + let txt = + if meta_action.val then + <:expr< Obj.magic $MetaAst.Expr.meta_expr _loc txt$ >> + else txt + in + <:expr< $uid:gm$.Action.mk $txt$ >> + ; + + value srules loc t rl tvar = + List.map + (fun r -> + let sl = List.map (fun s -> s.text) r.prod in + let ac = text_of_action loc r.prod t r.action tvar in + (sl, ac)) + rl + ; + + value rec make_expr entry tvar = + fun + [ TXmeta _loc n tl e t -> + let el = + List.fold_right + (fun t el -> <:expr< [$make_expr entry "" t$ :: $el$] >>) + tl <:expr< [] >> + in + <:expr< + $uid:gm$.Smeta $str:n$ $el$ ($uid:gm$.Action.mk ($make_ctyp_expr t tvar e$)) >> + | TXlist _loc min t ts -> + let txt = make_expr entry "" t.text in + match (min, ts) with + [ (False, None) -> <:expr< $uid:gm$.Slist0 $txt$ >> + | (True, None) -> <:expr< $uid:gm$.Slist1 $txt$ >> + | (False, Some s) -> + let x = make_expr entry tvar s.text in + <:expr< $uid:gm$.Slist0sep $txt$ $x$ >> + | (True, Some s) -> + let x = make_expr entry tvar s.text in + <:expr< $uid:gm$.Slist1sep $txt$ $x$ >> ] + | TXnext _loc -> <:expr< $uid:gm$.Snext >> + | TXnterm _loc n lev -> + match lev with + [ Some lab -> + <:expr< + $uid:gm$.Snterml + ($uid:gm$.Entry.obj ($n.expr$ : $uid:gm$.Entry.t '$n.tvar$)) + $str:lab$ >> + | None -> + if n.tvar = tvar then <:expr< $uid:gm$.Sself >> + else + <:expr< + $uid:gm$.Snterm + ($uid:gm$.Entry.obj ($n.expr$ : $uid:gm$.Entry.t '$n.tvar$)) >> ] + | TXopt _loc t -> <:expr< $uid:gm$.Sopt $make_expr entry "" t$ >> + | TXrules _loc rl -> + <:expr< $uid:gm$.srules $entry.expr$ $make_expr_rules _loc entry rl ""$ >> + | TXself _loc -> <:expr< $uid:gm$.Sself >> + | TXkwd _loc kwd -> <:expr< $uid:gm$.Skeyword $str:kwd$ >> + | TXtok _loc match_fun descr -> + <:expr< $uid:gm$.Stoken ($match_fun$, $`str:descr$) >> ] + + and make_expr_rules _loc n rl tvar = + List.fold_left + (fun txt (sl, ac) -> + let sl = + List.fold_right + (fun t txt -> + let x = make_expr n tvar t in + <:expr< [$x$ :: $txt$] >>) + sl <:expr< [] >> + in + <:expr< [($sl$, $ac$) :: $txt$] >>) + <:expr< [] >> rl + ; + + value expr_of_delete_rule _loc n sl = + let sl = + List.fold_right + (fun s e -> <:expr< [$make_expr n "" s.text$ :: $e$] >>) sl + <:expr< [] >> + in + (<:expr< $n.expr$ >>, sl) + ; + + value rec tvar_of_ident = + fun + [ <:ident< $lid:x$ >> | <:ident< $uid:x$ >> -> x + | <:ident< $uid:x$.$xs$ >> -> x ^ "__" ^ tvar_of_ident xs + | _ -> failwith "internal error in the Grammar extension" ] + ; + + value mk_name _loc i = + {expr = <:expr< $id:i$ >>; tvar = tvar_of_ident i; loc = _loc}; + + value slist loc min sep symb = + TXlist loc min symb sep + ; + + value sstoken _loc s = + let n = mk_name _loc <:ident< $lid:"a_" ^ s$ >> in + TXnterm _loc n None + ; + + value mk_symbol p s t = + {used = []; text = s; styp = t; pattern=Some p}; + + value sslist _loc min sep s = + let rl = + let r1 = + let prod = + let n = mk_name _loc <:ident< a_list >> in + [mk_symbol <:patt< a >> (TXnterm _loc n None) (STquo _loc "a_list")] + in + let act = <:expr< a >> in + {prod = prod; action = Some act} + in + let r2 = + let prod = + [mk_symbol <:patt< a >> (slist _loc min sep s) + (STapp _loc (STlid _loc "list") s.styp)] + in + let act = <:expr< Qast.List a >> in + {prod = prod; action = Some act} + in + [r1; r2] + in + let used = + match sep with + [ Some symb -> symb.used @ s.used + | None -> s.used ] + in + let used = ["a_list" :: used] in + let text = TXrules _loc (srules _loc "a_list" rl "") in + let styp = STquo _loc "a_list" in + {used = used; text = text; styp = styp; pattern = None} + ; + + value ssopt _loc s = + let rl = + let r1 = + let prod = + let n = mk_name _loc <:ident< a_opt >> in + [mk_symbol <:patt< a >> (TXnterm _loc n None) (STquo _loc "a_opt")] + in + let act = <:expr< a >> in + {prod = prod; action = Some act} + in + let r2 = + let s = + match s.text with + [ TXkwd _loc _ | TXtok _loc _ _ -> + let rl = + [{prod = [{ (s) with pattern = Some <:patt< x >> }]; + action = Some <:expr< Qast.Str (Token.extract_string x) >>}] + in + let t = new_type_var () in + {used = []; text = TXrules _loc (srules _loc t rl ""); + styp = STquo _loc t; pattern = None} + | _ -> s ] + in + let prod = + [mk_symbol <:patt< a >> (TXopt _loc s.text) + (STapp _loc (STlid _loc "option") s.styp)] + in + let act = <:expr< Qast.Option a >> in + {prod = prod; action = Some act} + in + [r1; r2] + in + let used = ["a_opt" :: s.used] in + let text = TXrules _loc (srules _loc "a_opt" rl "") in + let styp = STquo _loc "a_opt" in + {used = used; text = text; styp = styp; pattern = None} + ; + + value text_of_entry _loc e = + let ent = + let x = e.name in + let _loc = e.name.loc in + <:expr< ($x.expr$ : $uid:gm$.Entry.t '$x.tvar$) >> + in + let pos = + match e.pos with + [ Some pos -> <:expr< Some $pos$ >> + | None -> <:expr< None >> ] + in + let txt = + List.fold_right + (fun level txt -> + let lab = + match level.label with + [ Some lab -> <:expr< Some $str:lab$ >> + | None -> <:expr< None >> ] + in + let ass = + match level.assoc with + [ Some ass -> <:expr< Some $ass$ >> + | None -> <:expr< None >> ] + in + let txt = + let rl = srules _loc e.name.tvar level.rules e.name.tvar in + let e = make_expr_rules _loc e.name rl e.name.tvar in + <:expr< [($lab$, $ass$, $e$) :: $txt$] >> + in + txt) + e.levels <:expr< [] >> + in + (ent, pos, txt) + ; + + value let_in_of_extend _loc gram gl el args = + match gl with + [ None -> args + | Some nl -> + do { + check_use nl el; + let ll = + let same_tvar e n = e.name.tvar = n.tvar in + List.fold_right + (fun e ll -> + match e.name.expr with + [ <:expr< $lid:_$ >> -> + if List.exists (same_tvar e) nl then ll + else if List.exists (same_tvar e) ll then ll + else [e.name :: ll] + | _ -> ll ]) + el [] + in + let local_binding_of_name {expr = e; tvar = x; loc = _loc} = + let i = + match e with + [ <:expr< $lid:i$ >> -> i + | _ -> failwith "internal error in the Grammar extension" ] + in <:binding< $lid:i$ = + (grammar_entry_create $str:i$ : $uid:gm$.Entry.t '$x$) >> in + let expr_of_name {expr = e; tvar = x; loc = _loc} = + <:expr< ($e$ : $uid:gm$.Entry.t '$x$) >> in + let e = + match ll with + [ [] -> args + | [x::xs] -> + let locals = + List.fold_right + (fun name acc -> + <:binding< $acc$ and $local_binding_of_name name$ >>) + xs (local_binding_of_name x) + in + let entry_mk = + match gram with + [ Some g -> <:expr< $uid:gm$.Entry.mk $id:g$ >> + | None -> <:expr< $uid:gm$.Entry.mk >> ] + in <:expr< + let grammar_entry_create = $entry_mk$ in + let $locals$ in $args$ >> ] + in + match nl with + [ [] -> e + | [x::xs] -> + let globals = + List.fold_right + (fun name acc -> + <:binding< $acc$ and _ = $expr_of_name name$ >>) + xs <:binding< _ = $expr_of_name x$ >> + in <:expr< let $globals$ in $e$ >> ] + } ] + ; + + class subst gmod = + object + inherit Ast.map as super; + method ident = + fun + [ <:ident< $uid:x$ >> when x = gm -> gmod + | x -> super#ident x ]; + end; + + value subst_gmod ast gmod = (new subst gmod)#expr ast; + + value text_of_functorial_extend _loc gmod gram gl el = + let args = + let el = + List.map + (fun e -> + let (ent, pos, txt) = text_of_entry e.name.loc e in + let e = <:expr< $uid:gm$.extend $ent$ ((fun () -> ($pos$, $txt$)) ()) >> in + if split_ext.val then <:expr< let aux () = $e$ in aux () >> else e) + el + in + match el with + [ [] -> <:expr< () >> + | [e] -> e + | [e::el] -> + <:expr< do { $List.fold_left + (fun acc x -> <:expr< $acc$; $x$ >>) e el$ } >> ] + in + subst_gmod (let_in_of_extend _loc gram gl el args) gmod; + + value wildcarder = object (self) + inherit Ast.map as super; + method patt = + fun + [ <:patt@_loc< $lid:_$ >> -> <:patt< _ >> + | <:patt< ($p$ as $_$) >> -> self#patt p + | <:patt@_loc< $p1$ = $p2$ >> -> <:patt@_loc< $p1$ = $self#patt p2$ >> + | p -> super#patt p ]; + end; + + value mk_tok _loc p t = + let p' = wildcarder#patt p in + let match_fun = + if Ast.is_irrefut_patt p' then + <:expr< fun [ $pat:p'$ -> True ] >> + else + <:expr< fun [ $pat:p'$ -> True | _ -> False ] >> in + let descr = string_of_patt p' in + let text = TXtok _loc match_fun descr in + {used = []; text = text; styp = t; pattern = Some p }; + + value symbol = Gram.Entry.mk "symbol"; + + value check_not_tok s = + match s with + [ {text = TXtok _loc _ _ } -> + Loc.raise _loc (Stream.Error + ("Deprecated syntax, use a sub rule. "^ + "LIST0 STRING becomes LIST0 [ x = STRING -> x ]")) + | _ -> () ]; + + EXTEND Gram + GLOBAL: expr symbol; + expr: AFTER "top" + [ [ "EXTEND"; e = extend_body; "END" -> e + | "DELETE_RULE"; e = delete_rule_body; "END" -> e + | "GDELETE_RULE" -> + Loc.raise _loc (Stream.Error + "Deprecated syntax, use DELETE_RULE MyGramModule ... END instead") + | "GEXTEND" -> + Loc.raise _loc (Stream.Error + "Deprecated syntax, use EXTEND MyGramModule ... END instead") ] ] + ; + extend_header: + [ [ "("; i = qualid; ":"; t = t_qualid; ")" -> (Some i, t) + | g = qualuid -> (None, g) ] ] + ; + extend_body: + [ [ (gram, g) = extend_header; global_list = OPT global; + el = LIST1 [ e = entry; semi_sep -> e ] -> + text_of_functorial_extend _loc g gram global_list el ] ] + ; + delete_rule_body: + [ [ g = qualuid; n = name; ":"; sl = LIST0 symbol SEP semi_sep -> + let (e, b) = expr_of_delete_rule _loc n sl in + subst_gmod <:expr< $uid:gm$.delete_rule $e$ $b$ >> g ] ] + ; + qualuid: + [ [ [ LIDENT | UIDENT "GLOBAL" ] -> + Loc.raise _loc + (Stream.Error + "Deprecated syntax, the grammar module is expected") ] + | [ x = UIDENT; "."; xs = SELF -> <:ident< $uid:x$.$xs$ >> + | i = UIDENT -> <:ident< $uid:i$ >> ] ] + ; + qualuid: + [ [ [ LIDENT | UIDENT "GLOBAL" ] -> + Loc.raise _loc + (Stream.Error + "Deprecated syntax, the grammar module is expected") ] + | [ x = UIDENT; "."; xs = SELF -> <:ident< $uid:x$.$xs$ >> + | i = UIDENT -> <:ident< $uid:i$ >> ] ] + ; + qualid: + [ [ x = UIDENT; "."; xs = SELF -> <:ident< $uid:x$.$xs$ >> + | i = UIDENT -> <:ident< $uid:i$ >> + | i = LIDENT -> <:ident< $lid:i$ >> + ] ] + ; + t_qualid: + [ [ x = UIDENT; "."; xs = SELF -> <:ident< $uid:x$.$xs$ >> + | x = UIDENT; "."; `LIDENT "t" -> <:ident< $uid:x$ >> + | `(LIDENT _ | UIDENT _) -> + Loc.raise _loc (Stream.Error + ("Wrong EXTEND header, the grammar type must finish by 't', "^ + "like in EXTEND (g : Gram.t) ... END")) ] ] + ; + global: + [ [ UIDENT "GLOBAL"; ":"; sl = LIST1 name; semi_sep -> sl ] ] + ; + entry: + [ [ n = name; ":"; pos = OPT position; ll = level_list -> + {name = n; pos = pos; levels = ll} ] ] + ; + position: + [ [ UIDENT "FIRST" -> <:expr< Camlp4.Sig.Grammar.First >> + | UIDENT "LAST" -> <:expr< Camlp4.Sig.Grammar.Last >> + | UIDENT "BEFORE"; n = string -> <:expr< Camlp4.Sig.Grammar.Before $n$ >> + | UIDENT "AFTER"; n = string -> <:expr< Camlp4.Sig.Grammar.After $n$ >> + | UIDENT "LEVEL"; n = string -> <:expr< Camlp4.Sig.Grammar.Level $n$ >> ] ] + ; + level_list: + [ [ "["; ll = LIST0 level SEP "|"; "]" -> ll ] ] + ; + level: + [ [ lab = OPT [ x = STRING -> x ]; ass = OPT assoc; rules = rule_list -> + {label = lab; assoc = ass; rules = rules} ] ] + ; + assoc: + [ [ UIDENT "LEFTA" -> <:expr< Camlp4.Sig.Grammar.LeftA >> + | UIDENT "RIGHTA" -> <:expr< Camlp4.Sig.Grammar.RightA >> + | UIDENT "NONA" -> <:expr< Camlp4.Sig.Grammar.NonA >> ] ] + ; + rule_list: + [ [ "["; "]" -> [] + | "["; rules = LIST1 rule SEP "|"; "]" -> + retype_rule_list_without_patterns _loc rules ] ] + ; + rule: + [ [ psl = LIST0 psymbol SEP semi_sep; "->"; act = expr -> + {prod = psl; action = Some act} + | psl = LIST0 psymbol SEP semi_sep -> + {prod = psl; action = None} ] ] + ; + psymbol: + [ [ p = LIDENT; "="; s = symbol -> + match s.pattern with + [ Some (<:patt< $uid:u$ ($tup:<:patt< _ >>$) >> as p') -> + let match_fun = <:expr< fun [ $pat:p'$ -> True | _ -> False ] >> in + let p' = <:patt< ($p'$ as $lid:p$) >> in + let descr = u ^ " _" in + let text = TXtok _loc match_fun descr in + { (s) with text = text; pattern = Some p' } + | _ -> { (s) with pattern = Some <:patt< $lid:p$ >> } ] + | i = LIDENT; lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] -> + let name = mk_name _loc <:ident< $lid:i$ >> in + let text = TXnterm _loc name lev in + let styp = STquo _loc i in + {used = [i]; text = text; styp = styp; pattern = None} + | p = pattern; "="; s = symbol -> + match s.pattern with + [ Some <:patt< $uid:u$ ($tup:<:patt< _ >>$) >> -> + mk_tok _loc <:patt< $uid:u$ $p$ >> s.styp + | _ -> { (s) with pattern = Some p } ] + | s = symbol -> s ] ] + ; + symbol: + [ "top" NONA + [ UIDENT "LIST0"; s = SELF; + sep = OPT [ UIDENT "SEP"; t = symbol -> t ] -> + let () = check_not_tok s in + let used = + match sep with + [ Some symb -> symb.used @ s.used + | None -> s.used ] + in + let styp = STapp _loc (STlid _loc "list") s.styp in + let text = slist _loc False sep s in + {used = used; text = text; styp = styp; pattern = None} + | UIDENT "LIST1"; s = SELF; + sep = OPT [ UIDENT "SEP"; t = symbol -> t ] -> + let () = check_not_tok s in + let used = + match sep with + [ Some symb -> symb.used @ s.used + | None -> s.used ] + in + let styp = STapp _loc (STlid _loc "list") s.styp in + let text = slist _loc True sep s in + {used = used; text = text; styp = styp; pattern = None} + | UIDENT "OPT"; s = SELF -> + let () = check_not_tok s in + let styp = STapp _loc (STlid _loc "option") s.styp in + let text = TXopt _loc s.text in + {used = s.used; text = text; styp = styp; pattern = None} ] + | [ UIDENT "SELF" -> + {used = []; text = TXself _loc; styp = STself _loc "SELF"; pattern = None} + | UIDENT "NEXT" -> + {used = []; text = TXnext _loc; styp = STself _loc "NEXT"; pattern = None} + | "["; rl = LIST0 rule SEP "|"; "]" -> + let rl = retype_rule_list_without_patterns _loc rl in + let t = new_type_var () in + {used = used_of_rule_list rl; + text = TXrules _loc (srules _loc t rl ""); + styp = STquo _loc t; pattern = None} + | "`"; p = patt -> mk_tok _loc p (STtok _loc) + | x = UIDENT -> mk_tok _loc <:patt< $uid:x$ ($tup:<:patt< _ >>$) >> + (STstring_tok _loc) + | x = UIDENT; s = STRING -> mk_tok _loc <:patt< $uid:x$ $str:s$ >> (STtok _loc) + | x = UIDENT; `ANTIQUOT "" s -> + let e = AntiquotSyntax.parse_expr _loc s in + let match_fun = <:expr< fun [ $uid:x$ camlp4_x when camlp4_x = $e$ -> True | _ -> False ] >> in + let descr = "$" ^ x ^ " " ^ s in + let text = TXtok _loc match_fun descr in + let p = <:patt< $uid:x$ ($tup:<:patt< _ >>$) >> in + {used = []; text = text; styp = STtok _loc; pattern = Some p } + | s = STRING -> + {used = []; text = TXkwd _loc s; + styp = STtok _loc; pattern = None } + | i = UIDENT; "."; il = qualid; + lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] -> + let n = mk_name _loc <:ident< $uid:i$.$il$ >> in + {used = [n.tvar]; text = TXnterm _loc n lev; + styp = STquo _loc n.tvar; pattern = None} + | n = name; lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] -> + {used = [n.tvar]; text = TXnterm _loc n lev; + styp = STquo _loc n.tvar; pattern = None} + | "("; s_t = SELF; ")" -> s_t ] ] + ; + pattern: + [ [ i = LIDENT -> <:patt< $lid:i$ >> + | "_" -> <:patt< _ >> + | "("; p = pattern; ")" -> <:patt< $p$ >> + | "("; p1 = pattern; ","; p2 = comma_patt; ")" -> <:patt< ( $p1$, $p2$ ) >> + ] ] + ; + comma_patt: + [ [ p1 = SELF; ","; p2 = SELF -> <:patt< $p1$, $p2$ >> + | p = pattern -> p + ] ] + ; + name: + [ [ il = qualid -> mk_name _loc il ] ] + ; + string: + [ [ s = STRING -> <:expr< $str:s$ >> + | `ANTIQUOT "" s -> AntiquotSyntax.parse_expr _loc s ] ] + ; + semi_sep: + [ [ ";" -> () ] ] + ; + END; + + + EXTEND Gram + symbol: LEVEL "top" + [ NONA + [ min = [ UIDENT "SLIST0" -> False | UIDENT "SLIST1" -> True ]; + s = SELF; sep = OPT [ UIDENT "SEP"; t = symbol -> t ] -> + sslist _loc min sep s + | UIDENT "SOPT"; s = SELF -> + ssopt _loc s ] ] + ; + END; + + value sfold _loc n foldfun f e s = + let styp = STquo _loc (new_type_var ()) in + let e = <:expr< $uid:gm$.$lid:foldfun$ $f$ $e$ >> in + let t = STapp _loc (STapp _loc (STtyp <:ctyp< $uid:gm$.fold _ >>) s.styp) styp in + {used = s.used; text = TXmeta _loc n [s.text] e t; styp = styp; pattern = None } + ; + + value sfoldsep _loc n foldfun f e s sep = + let styp = STquo _loc (new_type_var ()) in + let e = <:expr< $uid:gm$.$lid:foldfun$ $f$ $e$ >> in + let t = + STapp _loc (STapp _loc (STtyp <:ctyp< $uid:gm$.foldsep _ >>) s.styp) styp + in + {used = s.used @ sep.used; text = TXmeta _loc n [s.text; sep.text] e t; + styp = styp; pattern = None} + ; + + EXTEND Gram + GLOBAL: symbol; + symbol: LEVEL "top" + [ [ UIDENT "FOLD0"; f = simple_expr; e = simple_expr; s = SELF -> + sfold _loc "FOLD0" "sfold0" f e s + | UIDENT "FOLD1"; f = simple_expr; e = simple_expr; s = SELF -> + sfold _loc "FOLD1" "sfold1" f e s + | UIDENT "FOLD0"; f = simple_expr; e = simple_expr; s = SELF; + UIDENT "SEP"; sep = symbol -> + sfoldsep _loc "FOLD0 SEP" "sfold0sep" f e s sep + | UIDENT "FOLD1"; f = simple_expr; e = simple_expr; s = SELF; + UIDENT "SEP"; sep = symbol -> + sfoldsep _loc "FOLD1 SEP" "sfold1sep" f e s sep ] ] + ; + simple_expr: + [ [ i = a_LIDENT -> <:expr< $lid:i$ >> + | "("; e = expr; ")" -> e ] ] + ; + END; + + Options.add "-split_ext" (Arg.Set split_ext) + "Split EXTEND by functions to turn around a PowerPC problem."; + + Options.add "-split_gext" (Arg.Set split_ext) + "Old name for the option -split_ext."; + + Options.add "-meta_action" (Arg.Set meta_action) + "Undocumented"; (* FIXME *) + +end; + +module M = Register.OCamlSyntaxExtension Id Make; diff --git a/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml b/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml new file mode 100644 index 00000000..a4c239fd --- /dev/null +++ b/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml @@ -0,0 +1,148 @@ +open Camlp4; (* -*- camlp4r -*- *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nao Hirokawa: initial version + * - Nicolas Pouillard: revised syntax version + *) + + +module Id = struct + value name = "Camlp4ListComprenhsion"; + value version = "$Id: Camlp4ListComprehension.ml,v 1.1 2007/02/27 15:50:57 pouillar Exp $"; +end; + +module Make (Syntax : Sig.Camlp4Syntax) = struct + open Sig; + include Syntax; + + value rec loop n = + fun + [ [] -> None + | [(x, _)] -> if n = 1 then Some x else None + | [_ :: l] -> loop (n - 1) l ]; + + value stream_peek_nth n strm = loop n (Stream.npeek n strm); + + (* usual trick *) + value test_patt_lessminus = + Gram.Entry.of_parser "test_patt_lessminus" + (fun strm -> + let rec skip_patt n = + match stream_peek_nth n strm with + [ Some (KEYWORD "<-") -> n + | Some (KEYWORD ("[" | "[<")) -> + skip_patt (ignore_upto "]" (n + 1) + 1) + | Some (KEYWORD "(") -> + skip_patt (ignore_upto ")" (n + 1) + 1) + | Some (KEYWORD "{") -> + skip_patt (ignore_upto "}" (n + 1) + 1) + | Some (KEYWORD ("as" | "::" | ";" | "," | "_")) + | Some (LIDENT _ | UIDENT _) -> skip_patt (n + 1) + | Some _ | None -> raise Stream.Failure ] + and ignore_upto end_kwd n = + match stream_peek_nth n strm with + [ Some (KEYWORD prm) when prm = end_kwd -> n + | Some (KEYWORD ("[" | "[<")) -> + ignore_upto end_kwd (ignore_upto "]" (n + 1) + 1) + | Some (KEYWORD "(") -> + ignore_upto end_kwd (ignore_upto ")" (n + 1) + 1) + | Some (KEYWORD "{") -> + ignore_upto end_kwd (ignore_upto "}" (n + 1) + 1) + | Some _ -> ignore_upto end_kwd (n + 1) + | None -> raise Stream.Failure ] + in + skip_patt 1); + + value map _loc p e l = + match (p, e) with + [ (<:patt< $lid:x$ >>, <:expr< $lid:y$ >>) when x = y -> l + | _ -> + if Ast.is_irrefut_patt p then + <:expr< List.map (fun $p$ -> $e$) $l$ >> + else + <:expr< List.fold_right + (fun + [ $pat:p$ when True -> (fun x xs -> [ x :: xs ]) $e$ + | _ -> (fun l -> l) ]) + $l$ [] >> ]; + + value filter _loc p b l = + if Ast.is_irrefut_patt p then + <:expr< List.filter (fun $p$ -> $b$) $l$ >> + else + <:expr< List.filter (fun [ $p$ when True -> $b$ | _ -> False ]) $l$ >>; + + value concat _loc l = <:expr< List.concat $l$ >>; + + value rec compr _loc e = + fun + [ [`gen (p, l)] -> map _loc p e l + | [`gen (p, l); `cond b :: items] -> + compr _loc e [`gen (p, filter _loc p b l) :: items] + | [`gen (p, l) :: ([ `gen (_, _) :: _ ] as is )] -> + concat _loc (map _loc p (compr _loc e is) l) + | _ -> raise Stream.Failure ]; + + DELETE_RULE Gram expr: "["; sem_expr_for_list; "]" END; + + value is_revised = + try do { + DELETE_RULE Gram expr: "["; sem_expr_for_list; "::"; expr; "]" END; + True + } with [ Not_found -> False ]; + + value comprehension_or_sem_expr_for_list = + Gram.Entry.mk "comprehension_or_sem_expr_for_list"; + + EXTEND Gram + GLOBAL: expr comprehension_or_sem_expr_for_list; + + expr: LEVEL "simple" + [ [ "["; e = comprehension_or_sem_expr_for_list; "]" -> e ] ] + ; + + comprehension_or_sem_expr_for_list: + [ [ e = expr LEVEL "top"; ";"; mk = sem_expr_for_list -> + <:expr< [ $e$ :: $mk <:expr< [] >>$ ] >> + | e = expr LEVEL "top"; ";" -> <:expr< [$e$] >> + | e = expr LEVEL "top"; "|"; l = LIST1 item SEP ";" -> compr _loc e l + | e = expr LEVEL "top" -> <:expr< [$e$] >> ] ] + ; + + item: + [ [ test_patt_lessminus; + p = patt; "<-" ; e = expr LEVEL "top" -> `gen (p, e) + | e = expr LEVEL "top" -> `cond e ] ] + ; + + END; + + if is_revised then + EXTEND Gram + GLOBAL: expr comprehension_or_sem_expr_for_list; + + comprehension_or_sem_expr_for_list: + [ [ e = expr LEVEL "top"; ";"; mk = sem_expr_for_list; "::"; last = expr -> + <:expr< [ $e$ :: $mk last$ ] >> + | e = expr LEVEL "top"; "::"; last = expr -> + <:expr< [ $e$ :: $last$ ] >> ] ] + ; + END + else (); + +end; + +let module M = Register.OCamlSyntaxExtension Id Make in (); diff --git a/camlp4/Camlp4Parsers/Camlp4MacroParser.ml b/camlp4/Camlp4Parsers/Camlp4MacroParser.ml new file mode 100644 index 00000000..73d9a63b --- /dev/null +++ b/camlp4/Camlp4Parsers/Camlp4MacroParser.ml @@ -0,0 +1,303 @@ +open Camlp4; (* -*- camlp4r -*- *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Id = struct + value name = "Camlp4MacroParser"; + value version = "$Id: Camlp4MacroParser.ml,v 1.1 2007/02/07 10:09:22 ertai Exp $"; +end; + +(* +Added statements: + + At toplevel (structure item): + + DEFINE + DEFINE = + DEFINE () = + IFDEF THEN (END | ENDIF) + IFDEF THEN ELSE (END | ENDIF) + IFNDEF THEN (END | ENDIF) + IFNDEF THEN ELSE (END | ENDIF) + INCLUDE + + In expressions: + + IFDEF THEN ELSE (END | ENDIF) + IFNDEF THEN ELSE (END | ENDIF) + __FILE__ + __LOCATION__ + + In patterns: + + IFDEF THEN ELSE (END | ENDIF) + IFNDEF THEN ELSE (END | ENDIF) + + As Camlp4 options: + + -D define + -U undefine it + -I add to the search path for INCLUDE'd files + + After having used a DEFINE followed by "= ", you + can use it in expressions *and* in patterns. If the expression defining + the macro cannot be used as a pattern, there is an error message if + it is used in a pattern. + + + + The toplevel statement INCLUDE can be used to include a + file containing macro definitions and also any other toplevel items. + The included files are looked up in directories passed in via the -I + option, falling back to the current directory. + + The expression __FILE__ returns the current compiled file name. + The expression __LOCATION__ returns the current location of itself. + +*) + +open Camlp4; + +module Make (Syntax : Sig.Camlp4Syntax) = struct + open Sig; + include Syntax; + + type item_or_def 'a = + [ SdStr of 'a + | SdDef of string and option (list string * Ast.expr) + | SdUnd of string + | SdITE of string and 'a and 'a + | SdInc of string ]; + + value rec list_remove x = + fun + [ [(y, _) :: l] when y = x -> l + | [d :: l] -> [d :: list_remove x l] + | [] -> [] ]; + + value defined = ref []; + + value is_defined i = List.mem_assoc i defined.val; + + class reloc _loc = object + inherit Ast.map as super; + method _Loc_t _ = _loc; + end; + + class subst _loc env = object + inherit reloc _loc as super; + method expr = + fun + [ <:expr< $lid:x$ >> | <:expr< $uid:x$ >> as e -> + try List.assoc x env with + [ Not_found -> e ] + | e -> super#expr e ]; + end; + + value bad_patt _loc = + Loc.raise _loc + (Failure + "this macro cannot be used in a pattern (see its definition)"); + value substp _loc env = + loop where rec loop = + fun + [ <:expr< $e1$ $e2$ >> -> <:patt< $loop e1$ $loop e2$ >> + | <:expr< $lid:x$ >> -> + try List.assoc x env with + [ Not_found -> <:patt< $lid:x$ >> ] + | <:expr< $uid:x$ >> -> + try List.assoc x env with + [ Not_found -> <:patt< $uid:x$ >> ] + | <:expr< $int:x$ >> -> <:patt< $int:x$ >> + | <:expr< $str:s$ >> -> <:patt< $str:s$ >> + | <:expr< ($tup:x$) >> -> <:patt< ($tup:loop x$) >> + | <:expr< $x1$, $x2$ >> -> <:patt< $loop x1$, $loop x2$ >> + | <:expr< { $bi$ } >> -> + let rec substbi = fun + [ <:binding< $b1$; $b2$ >> -> <:patt< $substbi b1$; $substbi b2$ >> + | <:binding< $p$ = $e$ >> -> <:patt< $p$ = $loop e$ >> + | _ -> bad_patt _loc ] + in <:patt< { $substbi bi$ } >> + | _ -> bad_patt _loc ]; + + value incorrect_number loc l1 l2 = + Loc.raise loc + (Failure + (Printf.sprintf "expected %d parameters; found %d" + (List.length l2) (List.length l1))); + + value define eo x = + do { + match eo with + [ Some ([], e) -> + EXTEND Gram + expr: LEVEL "simple" + [ [ UIDENT $x$ -> (new reloc _loc)#expr e ]] + ; + patt: LEVEL "simple" + [ [ UIDENT $x$ -> + let p = substp _loc [] e + in (new reloc _loc)#patt p ]] + ; + END + | Some (sl, e) -> + EXTEND Gram + expr: LEVEL "apply" + [ [ UIDENT $x$; param = SELF -> + let el = + match param with + [ <:expr< ($tup:e$) >> -> Ast.list_of_expr e [] + | e -> [e] ] + in + if List.length el = List.length sl then + let env = List.combine sl el in + (new subst _loc env)#expr e + else + incorrect_number _loc el sl ] ] + ; + patt: LEVEL "simple" + [ [ UIDENT $x$; param = SELF -> + let pl = + match param with + [ <:patt< ($tup:p$) >> -> Ast.list_of_patt p [] + | p -> [p] ] + in + if List.length pl = List.length sl then + let env = List.combine sl pl in + let p = substp _loc env e in + (new reloc _loc)#patt p + else + incorrect_number _loc pl sl ] ] + ; + END + | None -> () ]; + defined.val := [(x, eo) :: defined.val]; + }; + + value undef x = + try + do { + let eo = List.assoc x defined.val in + match eo with + [ Some ([], _) -> + do { + DELETE_RULE Gram expr: UIDENT $x$ END; + DELETE_RULE Gram patt: UIDENT $x$ END; + } + | Some (_, _) -> + do { + DELETE_RULE Gram expr: UIDENT $x$; SELF END; + DELETE_RULE Gram patt: UIDENT $x$; SELF END; + } + | None -> () ]; + defined.val := list_remove x defined.val; + } + with + [ Not_found -> () ]; + + (* This is a list of directories to search for INCLUDE statements. *) + value include_dirs = ref []; + + (* Add something to the above, make sure it ends with a slash. *) + value add_include_dir str = + if str <> "" then + let str = + if String.get str ((String.length str)-1) = '/' + then str else str ^ "/" + in include_dirs.val := include_dirs.val @ [str] + else (); + + value parse_include_file rule = + let dir_ok file dir = Sys.file_exists (dir ^ file) in + fun file -> + let file = + try (List.find (dir_ok file) (include_dirs.val @ ["./"])) ^ file + with [ Not_found -> file ] + in + let ch = open_in file in + let st = Stream.of_channel ch in + Gram.parse rule (Loc.mk file) st; + + EXTEND Gram + GLOBAL: expr patt str_item sig_item; + str_item: FIRST + [ [ "DEFINE"; i = uident; def = opt_macro_value -> + do { define def i; <:str_item<>> } + | "UNDEF"; i = uident -> + do { undef i; <:str_item<>> } + | "IFDEF"; i = uident; "THEN"; st = str_items; _ = endif -> + if is_defined i then st else <:str_item<>> + | "IFDEF"; i = uident; "THEN"; st1 = str_items; "ELSE"; st2 = str_items; _ = endif -> + if is_defined i then st1 else st2 + | "IFNDEF"; i = uident; "THEN"; st = str_items; _ = endif -> + if is_defined i then <:str_item<>> else st + | "IFNDEF"; i = uident; "THEN"; st1 = str_items; "ELSE"; st2 = str_items; _ = endif -> + if is_defined i then st2 else st1 + | "INCLUDE"; fname = STRING -> + parse_include_file str_items fname ] ] + ; + sig_item: FIRST + [ [ "INCLUDE"; fname = STRING -> + parse_include_file sig_items fname ] ] + ; + endif: + [ [ "END" -> () + | "ENDIF" -> () ] ] + ; + opt_macro_value: + [ [ "("; pl = LIST1 [ x = LIDENT -> x ] SEP ","; ")"; "="; e = expr -> Some (pl, e) + | "="; e = expr -> Some ([], e) + | -> None ] ] + ; + expr: LEVEL "top" + [ [ "IFDEF"; i = uident; "THEN"; e1 = expr; "ELSE"; e2 = expr; _ = endif -> + if is_defined i then e1 else e2 + | "IFNDEF"; i = uident; "THEN"; e1 = expr; "ELSE"; e2 = expr; _ = endif -> + if is_defined i then e2 else e1 ] ] + ; + expr: LEVEL "simple" + [ [ LIDENT "__FILE__" -> <:expr< $`str:Loc.file_name _loc$ >> + | LIDENT "__LOCATION__" -> + let (a, b, c, d, e, f, g, h) = Loc.to_tuple _loc in + <:expr< Loc.of_tuple + ($`str:a$, $`int:b$, $`int:c$, $`int:d$, + $`int:e$, $`int:f$, $`int:g$, + $if h then <:expr< True >> else <:expr< False >> $) >> ] ] + ; + patt: + [ [ "IFDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; _ = endif -> + if is_defined i then p1 else p2 + | "IFNDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; _ = endif -> + if is_defined i then p2 else p1 ] ] + ; + uident: + [ [ i = UIDENT -> i ] ] + ; + END; + + Options.add "-D" (Arg.String (define None)) + " Define for IFDEF instruction."; + Options.add "-U" (Arg.String undef) + " Undefine for IFDEF instruction."; + Options.add "-I" (Arg.String add_include_dir) + " Add a directory to INCLUDE search path."; + +end; + +let module M = Register.OCamlSyntaxExtension Id Make in (); diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlOriginalQuotationExpander.ml b/camlp4/Camlp4Parsers/Camlp4OCamlOriginalQuotationExpander.ml new file mode 100644 index 00000000..b5b120ba --- /dev/null +++ b/camlp4/Camlp4Parsers/Camlp4OCamlOriginalQuotationExpander.ml @@ -0,0 +1,25 @@ +open Camlp4; (* -*- camlp4r -*- *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2002-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +open PreCast; +let module Gram = MakeGram Lexer in +let module M1 = OCamlInitSyntax.Make Warning Ast Gram Quotation in +let module M2 = Camlp4OCamlRevisedParser.Make M1 in +let module M3 = Camlp4OCamlParser.Make M2 in +let module M3 = Camlp4QuotationCommon.Make M3 Syntax.AntiquotSyntax in (); diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml new file mode 100644 index 00000000..5c07876c --- /dev/null +++ b/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml @@ -0,0 +1,881 @@ +open Camlp4; (* -*- camlp4r -*- *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2002-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + + +module Id : Sig.Id = struct + value name = "Camlp4OCamlParser"; + value version = "$Id: Camlp4OCamlParser.ml,v 1.3.2.1 2007/03/03 09:21:36 pouillar Exp $"; +end; + +module Make (Syntax : Sig.Camlp4Syntax) = struct + open Sig; + include Syntax; + + Camlp4_config.constructors_arity.val := False; + + (*FIXME remove this and use OCaml ones *) + value bigarray_get _loc arr arg = + let coords = + match arg with + [ <:expr< ($e1$, $e2$) >> | <:expr< $e1$, $e2$ >> -> + Ast.list_of_expr e1 (Ast.list_of_expr e2 []) + | _ -> [arg] ] + in + match coords with + [ [c1] -> <:expr< Bigarray.Array1.get $arr$ $c1$ >> + | [c1; c2] -> <:expr< Bigarray.Array2.get $arr$ $c1$ $c2$ >> + | [c1; c2; c3] -> <:expr< Bigarray.Array3.get $arr$ $c1$ $c2$ $c3$ >> + (* | coords -> <:expr< Bigarray.Genarray.get $arr$ [| $`list:coords$ |] >> ] *) + | coords -> + <:expr< Bigarray.Genarray.get $arr$ [| $Ast.exSem_of_list coords$ |] >> ]; + + value bigarray_set _loc var newval = + match var with + [ <:expr< Bigarray.Array1.get $arr$ $c1$ >> -> + Some <:expr< Bigarray.Array1.set $arr$ $c1$ $newval$ >> + | <:expr< Bigarray.Array2.get $arr$ $c1$ $c2$ >> -> + Some <:expr< Bigarray.Array2.set $arr$ $c1$ $c2$ $newval$ >> + | <:expr< Bigarray.Array3.get $arr$ $c1$ $c2$ $c3$ >> -> + Some <:expr< Bigarray.Array3.set $arr$ $c1$ $c2$ $c3$ $newval$ >> + | <:expr< Bigarray.Genarray.get $arr$ [| $coords$ |] >> -> + Some <:expr< Bigarray.Genarray.set $arr$ [| $coords$ |] $newval$ >> + | _ -> None ]; + value mkumin _loc f arg = + match (f, arg) with + [ ("-", <:expr< $int:n$ >>) when int_of_string n > 0 -> + <:expr< $int:"-" ^ n$ >> + | ("-", <:expr< $int32:n$ >>) when (Int32.of_string n) > 0l -> + <:expr< $int32:"-" ^ n$ >> + | ("-", <:expr< $int64:n$ >>) when (Int64.of_string n) > 0L -> + <:expr< $int64:"-" ^ n$ >> + | ("-", <:expr< $nativeint:n$ >>) when (Nativeint.of_string n) > 0n -> + <:expr< $nativeint:"-" ^ n$ >> + | (_, <:expr< $flo:n$ >>) when float_of_string n > 0.0 -> + <:expr< $flo:"-" ^ n$ >> + | _ -> + let f = "~" ^ f in + <:expr< $lid:f$ $arg$ >> ] + ; + value mk_anti ?(c = "") n s = "\\$"^n^c^":"^s; + (*FIXME*) + + value conc_seq e1 e2 = + match (e1, e2) with + [ (<:expr@_loc< do { $e1$ } >>, <:expr< do { $e2$ } >>) -> + <:expr< do { $e1$; $e2$ } >> + | (<:expr@_loc< do { $e1$ } >>, _) -> + <:expr< do { $e1$; $e2$ } >> + | (_, <:expr@_loc< do { $e2$ } >>) -> + <:expr< do { $e1$; $e2$ } >> + | _ -> + let _loc = + Loc.merge (Ast.loc_of_expr e1) + (Ast.loc_of_expr e2) in + <:expr< do { $e1$; $e2$ } >> ]; + + value get_seq = + fun + [ <:expr< do { $e$ } >> -> e + | e -> e ]; + + value is_operator = + let ht = Hashtbl.create 73 in + let ct = Hashtbl.create 73 in + do { + List.iter (fun x -> Hashtbl.add ht x True) + ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"]; + List.iter (fun x -> Hashtbl.add ct x True) + ['!'; '&'; '*'; '+'; '-'; '/'; ':'; '<'; '='; '>'; '@'; '^'; '|'; '~'; + '?'; '%'; '.'; '$']; + fun x -> + try Hashtbl.find ht x with + [ Not_found -> try Hashtbl.find ct x.[0] with [ Not_found -> False ] ] + } + ; + + value operator_rparen = + Gram.Entry.of_parser "operator_rparen" + (fun strm -> + match Stream.npeek 2 strm with + [ [(KEYWORD s | SYMBOL s, _); (KEYWORD ")", _)] when is_operator s -> + do { Stream.junk strm; Stream.junk strm; s } + | _ -> raise Stream.Failure ]) + ; + + value symbolchar = + let list = + ['!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?'; + '@'; '^'; '|'; '~'] + in + let rec loop s i = + if i == String.length s then True + else if List.mem s.[i] list then loop s (i + 1) + else False + in + loop + ; + + value prefixop = + let list = ['!'; '?'; '~'] in + let excl = ["!="; "??"] in + Gram.Entry.of_parser "prefixop" + (parser + [: `(KEYWORD x | SYMBOL x, _loc) + when + not (List.mem x excl) && String.length x >= 2 && + List.mem x.[0] list && symbolchar x 1 :] -> + <:expr< $lid:x$ >>) + ; + + value infixop0 = + let list_ok = ["<"; ">"; "<="; ">="; "="; "<>"; "=="; "!="; "$"] in + let list_first_char_ok = ['='; '<'; '>'; '|'; '&'; '$'; '!'] in + let excl = ["<-"; "||"; "&&"] in + Gram.Entry.of_parser "infixop0" + (parser + [: `(KEYWORD x | SYMBOL x, _loc) + when + (List.mem x list_ok) || + (not (List.mem x excl) && String.length x >= 2 && + List.mem x.[0] list_first_char_ok && symbolchar x 1) :] -> + <:expr< $lid:x$ >>) + ; + + value infixop1 = + let list = ['@'; '^'] in + Gram.Entry.of_parser "infixop1" + (parser + [: `(KEYWORD x | SYMBOL x, _loc) + when + String.length x >= 1 && List.mem x.[0] list && + symbolchar x 1 :] -> + <:expr< $lid:x$ >>) + ; + + value infixop2 = + let list = ['+'; '-'] in + Gram.Entry.of_parser "infixop2" + (parser + [: `(KEYWORD x | SYMBOL x, _loc) + when + x <> "->" && String.length x >= 1 && List.mem x.[0] list && + symbolchar x 1 :] -> + <:expr< $lid:x$ >>) + ; + + value infixop3 = + let list = ['*'; '/'; '%'] in + Gram.Entry.of_parser "infixop3" + (parser + [: `(KEYWORD x | SYMBOL x, _loc) + when + String.length x >= 1 && List.mem x.[0] list && + symbolchar x 1 :] -> + <:expr< $lid:x$ >>) + ; + + value infixop4 = + Gram.Entry.of_parser "infixop4" + (parser + [: `(KEYWORD x | SYMBOL x, _loc) + when + String.length x >= 3 && x.[0] == '*' && x.[1] == '*' && + symbolchar x 2 :] -> + <:expr< $lid:x$ >>) + ; + + value test_constr_decl = + Gram.Entry.of_parser "test_constr_decl" + (fun strm -> + match Stream.npeek 1 strm with + [ [(UIDENT _, _)] -> + match Stream.npeek 2 strm with + [ [_; (KEYWORD ".", _)] -> raise Stream.Failure + | [_; (KEYWORD "(", _)] -> raise Stream.Failure + | [_ :: _] -> () + | _ -> raise Stream.Failure ] + | [(KEYWORD "|", _)] -> () + | _ -> raise Stream.Failure ]) + ; + + value stream_peek_nth n strm = + loop n (Stream.npeek n strm) where rec loop n = + fun + [ [] -> None + | [(x, _)] -> if n == 1 then Some x else None + | [_ :: l] -> loop (n - 1) l ] + ; + + (* horrible hacks to be able to parse class_types *) + + value test_ctyp_minusgreater = + Gram.Entry.of_parser "test_ctyp_minusgreater" + (fun strm -> + let rec skip_simple_ctyp n = + match stream_peek_nth n strm with + [ Some (KEYWORD "->") -> n + | Some (KEYWORD ("[" | "[<")) -> + skip_simple_ctyp (ignore_upto "]" (n + 1) + 1) + | Some (KEYWORD "(") -> skip_simple_ctyp (ignore_upto ")" (n + 1) + 1) + | Some + (KEYWORD + ("as" | "'" | ":" | "*" | "." | "#" | "<" | ">" | ".." | ";" | + "_" | "?")) -> + skip_simple_ctyp (n + 1) + | Some (LIDENT _ | UIDENT _) -> + skip_simple_ctyp (n + 1) + | Some _ | None -> raise Stream.Failure ] + and ignore_upto end_kwd n = + match stream_peek_nth n strm with + [ Some (KEYWORD prm) when prm = end_kwd -> n + | Some (KEYWORD ("[" | "[<")) -> + ignore_upto end_kwd (ignore_upto "]" (n + 1) + 1) + | Some (KEYWORD "(") -> ignore_upto end_kwd (ignore_upto ")" (n + 1) + 1) + | Some _ -> ignore_upto end_kwd (n + 1) + | None -> raise Stream.Failure ] + in + match Stream.peek strm with + [ Some ((KEYWORD "[" | LIDENT _ | UIDENT _), _) -> skip_simple_ctyp 1 + | Some (KEYWORD "object", _) -> raise Stream.Failure + | _ -> 1 ]) + ; + + value test_label_eq = + Gram.Entry.of_parser "test_label_eq" + (test 1 where rec test lev strm = + match stream_peek_nth lev strm with + [ Some (UIDENT _ | LIDENT _ | KEYWORD ".") -> + test (lev + 1) strm + | Some (KEYWORD "=") -> () + | _ -> raise Stream.Failure ]) + ; + + value test_typevar_list_dot = + Gram.Entry.of_parser "test_typevar_list_dot" + (let rec test lev strm = + match stream_peek_nth lev strm with + [ Some (KEYWORD "'") -> test2 (lev + 1) strm + | Some (KEYWORD ".") -> () + | _ -> raise Stream.Failure ] + and test2 lev strm = + match stream_peek_nth lev strm with + [ Some (UIDENT _ | LIDENT _) -> test (lev + 1) strm + | _ -> raise Stream.Failure ] + in + test 1) + ; + + value test_just_a_lident_or_patt = + Gram.Entry.of_parser "test_just_a_lident_or_patt" + (fun strm -> + match Stream.npeek 3 strm with + [ [(KEYWORD "(", _); (KEYWORD s | SYMBOL s, _); (KEYWORD ")", _)] when is_operator s -> () + | [((LIDENT _ | ANTIQUOT "lid" _), _); (KEYWORD ("as"|"|"|"::"|","|"."), _); _] -> + raise Stream.Failure + | [((LIDENT _ | ANTIQUOT "lid" _), _); _; _] -> () + | _ -> raise Stream.Failure ]) + ; + + value lident_colon = + Gram.Entry.of_parser "lident_colon" + (fun strm -> + match Stream.npeek 2 strm with + [ [(LIDENT i, _); (KEYWORD ":", _)] -> + do { Stream.junk strm; Stream.junk strm; i } + | _ -> raise Stream.Failure ]) + ; + + value rec is_ident_constr_call = + fun + [ <:ident< $uid:_$ >> -> True + | <:ident< $_$.$i$ >> -> is_ident_constr_call i + | _ -> False ]; + + value rec is_expr_constr_call = + fun + [ <:expr< $id:i$ >> -> is_ident_constr_call i + | <:expr< `$_$ >> -> True + | <:expr< $_$.$e$ >> -> is_expr_constr_call e + | <:expr@_loc< $e$ $_$ >> -> + let res = is_expr_constr_call e in + if (not Camlp4_config.constructors_arity.val) && res then + Loc.raise _loc (Stream.Error "currified constructor") + else res + | _ -> False ]; + + DELETE_RULE Gram expr: SELF; "where"; opt_rec; let_binding END; + DELETE_RULE Gram value_let: "value" END; + DELETE_RULE Gram value_val: "value" END; + DELETE_RULE Gram str_item: value_let; opt_rec; binding END; + DELETE_RULE Gram module_type: "'"; a_ident END; + DELETE_RULE Gram label_expr: label_longident; fun_binding END; + + value clear = Gram.Entry.clear; + clear ctyp; + clear expr; + clear patt; + clear a_LIDENT_or_operator; + clear a_UIDENT; + clear type_longident_and_parameters; + clear type_parameters; + clear ipatt; + clear labeled_ipatt; + clear semi; + clear let_binding; + clear type_kind; + clear constructor_arg_list; + clear poly_type; + clear class_name_and_param; + clear class_longident_and_param; + clear class_type_longident_and_param; + clear class_type_plus; + clear type_constraint; + clear comma_expr; + clear comma_patt; + clear sequence; + clear sem_expr_for_list; + clear sem_expr; + clear label_declaration; + clear star_ctyp; + clear match_case; + clear with_constr; + + EXTEND Gram + GLOBAL: + a_CHAR a_FLOAT a_INT a_INT32 a_INT64 a_LABEL a_LIDENT + a_LIDENT_or_operator a_NATIVEINT a_OPTLABEL a_STRING a_UIDENT a_ident + amp_ctyp and_ctyp match_case match_case0 match_case_quot binding binding_quot + class_declaration class_description class_expr class_expr_quot + class_fun_binding class_fun_def class_info_for_class_expr + class_info_for_class_type class_longident class_longident_and_param + class_name_and_param class_sig_item class_sig_item_quot class_signature + class_str_item class_str_item_quot class_structure class_type + class_type_declaration class_type_longident + class_type_longident_and_param class_type_plus class_type_quot + comma_ctyp comma_expr comma_ipatt comma_patt comma_type_parameter + constrain constructor_arg_list constructor_declaration + constructor_declarations ctyp ctyp_quot cvalue_binding direction_flag + dummy eq_expr expr expr_eoi expr_quot field field_expr fun_binding + fun_def ident ident_quot implem interf ipatt ipatt_tcon label + label_declaration label_expr label_ipatt label_longident label_patt + labeled_ipatt let_binding meth_list module_binding module_binding0 + module_binding_quot module_declaration module_expr module_expr_quot + module_longident module_longident_with_app module_rec_declaration + module_type module_type_quot more_ctyp name_tags opt_as_lident + opt_class_self_patt opt_class_self_type + opt_comma_ctyp opt_dot_dot opt_eq_ctyp opt_expr + opt_meth_list opt_mutable opt_polyt opt_private opt_rec + opt_virtual opt_when_expr patt patt_as_patt_opt patt_eoi + patt_quot patt_tcon phrase pipe_ctyp poly_type row_field sem_ctyp + sem_expr sem_expr_for_list sem_patt sem_patt_for_list semi sequence + sig_item sig_item_quot sig_items star_ctyp str_item str_item_quot + str_items top_phrase type_constraint type_declaration + type_ident_and_parameters type_kind type_longident + type_longident_and_parameters type_parameter type_parameters typevars + use_file val_longident value_let value_val with_constr with_constr_quot + + infixop0 infixop1 infixop2 infixop3 infixop4 + ; + sem_expr: + [ [ e1 = expr LEVEL "top"; ";"; e2 = SELF -> <:expr< $e1$; $e2$ >> + | e = expr LEVEL "top"; ";" -> e + | e = expr LEVEL "top" -> e ] ] + ; + sequence: + [ [ e = sem_expr -> e ] ] + ; + sem_expr_for_list: + [ [ e = expr LEVEL "top"; ";"; el = SELF -> fun acc -> <:expr< [ $e$ :: $el acc$ ] >> + | e = expr LEVEL "top"; ";" -> fun acc -> <:expr< [ $e$ :: $acc$ ] >> + | e = expr LEVEL "top" -> fun acc -> <:expr< [ $e$ :: $acc$ ] >> + ] ] + ; + str_item: + [ "top" + [ "let"; r = opt_rec; bi = binding; "in"; x = expr -> + <:str_item< let $rec:r$ $bi$ in $x$ >> + | "let"; r = opt_rec; bi = binding -> + match bi with + [ <:binding< _ = $e$ >> -> <:str_item< $exp:e$ >> + | _ -> <:str_item< value $rec:r$ $bi$ >> ] + | "let"; "module"; m = a_UIDENT; mb = module_binding0; "in"; e = expr -> + <:str_item< let module $m$ = $mb$ in $e$ >> + ] ] + ; + expr: + [ ";" RIGHTA + [ e1 = SELF; ";"; e2 = SELF -> + conc_seq e1 e2 + | e1 = SELF; ";" -> e1 ] + | "top" + [ "let"; r = opt_rec; bi = binding; "in"; + x = expr LEVEL ";" -> + <:expr< let $rec:r$ $bi$ in $x$ >> + | "let"; "module"; m = a_UIDENT; mb = module_binding0; "in"; + e = expr LEVEL ";" -> + <:expr< let module $m$ = $mb$ in $e$ >> + | "function"; OPT "|"; a = match_case -> + <:expr< fun [ $a$ ] >> + | "fun"; p = labeled_ipatt; e = fun_def -> + <:expr< fun $p$ -> $e$ >> + | "match"; e = SELF; "with"; OPT "|"; a = match_case -> + <:expr< match $e$ with [ $a$ ] >> + | "try"; e = SELF; "with"; OPT "|"; a = match_case -> + <:expr< try $e$ with [ $a$ ] >> + | "if"; e1 = SELF; "then"; e2 = expr LEVEL "top"; + "else"; e3 = expr LEVEL "top" -> + <:expr< if $e1$ then $e2$ else $e3$ >> + | "if"; e1 = SELF; "then"; e2 = expr LEVEL "top" -> + <:expr< if $e1$ then $e2$ else () >> + | "for"; i = a_LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF; + "do"; el = SELF; "done" -> + <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $get_seq el$ } >> + | "while"; e1 = SELF; "do"; e2 = SELF; "done" -> + <:expr< while $e1$ do { $get_seq e2$ } >> + | "object"; csp = opt_class_self_patt; cst = class_structure; "end" -> + <:expr< object ($csp$) $cst$ end >> ] + | [ e = SELF; ","; el = (*FIXME comma_expr*)LIST1 NEXT SEP "," -> + <:expr< ( $e$, $Ast.exCom_of_list el$ ) >> ] + | ":=" NONA + [ e1 = SELF; ":="; e2 = expr LEVEL "top" -> + <:expr< $e1$.val := $e2$ >> + | e1 = SELF; "<-"; e2 = expr LEVEL "top" -> + match bigarray_set _loc e1 e2 with + [ Some e -> e + | None -> <:expr< $e1$ := $e2$ >> ] ] + | "||" RIGHTA + [ e1 = SELF; op = infixop6; e2 = SELF -> <:expr< $op$ $e1$ $e2$ >> ] + | "&&" RIGHTA + [ e1 = SELF; op = infixop5; e2 = SELF -> <:expr< $op$ $e1$ $e2$ >> ] + | "<" LEFTA + [ e1 = SELF; op = infixop0; e2 = SELF -> <:expr< $op$ $e1$ $e2$ >> ] + | "^" RIGHTA + [ e1 = SELF; op = infixop1; e2 = SELF -> <:expr< $op$ $e1$ $e2$ >> ] + | RIGHTA + [ e1 = SELF; "::"; e2 = SELF -> <:expr< [$e1$ :: $e2$] >> ] + | "+" LEFTA + [ e1 = SELF; op = infixop2; e2 = SELF -> <:expr< $op$ $e1$ $e2$ >> ] + | "*" LEFTA + [ e1 = SELF; "*"; e2 = SELF -> <:expr< $e1$ * $e2$ >> + | e1 = SELF; "/"; e2 = SELF -> <:expr< $e1$ / $e2$ >> + | e1 = SELF; "%"; e2 = SELF -> <:expr< $lid:"%"$ $e1$ $e2$ >> + | e1 = SELF; "land"; e2 = SELF -> <:expr< $e1$ land $e2$ >> + | e1 = SELF; "lor"; e2 = SELF -> <:expr< $e1$ lor $e2$ >> + | e1 = SELF; "lxor"; e2 = SELF -> <:expr< $e1$ lxor $e2$ >> + | e1 = SELF; "mod"; e2 = SELF -> <:expr< $e1$ mod $e2$ >> + | e1 = SELF; op = infixop3; e2 = SELF -> <:expr< $op$ $e1$ $e2$ >> ] + | "**" RIGHTA + [ e1 = SELF; "**"; e2 = SELF -> <:expr< $e1$ ** $e2$ >> + | e1 = SELF; "asr"; e2 = SELF -> <:expr< $e1$ asr $e2$ >> + | e1 = SELF; "lsl"; e2 = SELF -> <:expr< $e1$ lsl $e2$ >> + | e1 = SELF; "lsr"; e2 = SELF -> <:expr< $e1$ lsr $e2$ >> + | e1 = SELF; op = infixop4; e2 = SELF -> <:expr< $op$ $e1$ $e2$ >> ] + | "unary minus" NONA + [ "-"; e = SELF -> <:expr< $mkumin _loc "-" e$ >> + | "-."; e = SELF -> <:expr< $mkumin _loc "-." e$ >> ] + | "apply" LEFTA + [ e1 = SELF; e2 = SELF -> + match (is_expr_constr_call e1, e2) with + [ (True, <:expr< ( $tup:e$ ) >>) -> + List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) e1 + (Ast.list_of_expr e []) + | _ -> <:expr< $e1$ $e2$ >> ] + | "assert"; e = SELF -> + match e with + [ <:expr< False >> -> <:expr< assert False >> + | _ -> <:expr< assert $e$ >> ] + | "lazy"; e = SELF -> + <:expr< lazy $e$ >> ] + | "label" + [ i = LABEL; e = SELF -> <:expr< ~ $i$ : $e$ >> (* Here it's LABEL and not + tilde_label since ~a:b + is different than ~a : b *) + | "~"; i = a_LIDENT -> <:expr< ~ $i$ >> + | i = OPTLABEL; e = SELF -> <:expr< ? $i$ : $e$ >> (* Same remark for ?a:b *) + | "?"; i = a_LIDENT -> <:expr< ? $i$ >> ] + | "." LEFTA + [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >> + | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >> + | e1 = SELF; "."; "{"; e2 = SELF; "}" -> bigarray_get _loc e1 e2 + | e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> + | e = SELF; "#"; lab = label -> <:expr< $e$ # $lab$ >> ] + | "~-" NONA + [ "!"; e = SELF -> <:expr< $e$ . val>> + | "~-"; e = SELF -> <:expr< ~- $e$ >> + | "~-."; e = SELF -> <:expr< ~-. $e$ >> + | f = prefixop; e = SELF -> <:expr< $f$ $e$ >> ] + | "simple" LEFTA + [ `QUOTATION x -> Quotation.expand_expr (Gram.parse_string expr) _loc x + | `ANTIQUOT ("exp"|""|"anti" as n) s -> + <:expr< $anti:mk_anti ~c:"expr" n s$ >> + | `ANTIQUOT ("tup" as n) s -> + <:expr< ($tup: <:expr< $anti:mk_anti ~c:"expr" n s$ >>$) >> + | s = a_INT -> <:expr< $int:s$ >> + | s = a_INT32 -> <:expr< $int32:s$ >> + | s = a_INT64 -> <:expr< $int64:s$ >> + | s = a_NATIVEINT -> <:expr< $nativeint:s$ >> + | s = a_FLOAT -> <:expr< $flo:s$ >> + | s = a_STRING -> <:expr< $str:s$ >> + | c = a_CHAR -> <:expr< $chr:c$ >> + | i = val_longident -> <:expr< $id:i$ >> + | "false" -> <:expr< False >> + | "true" -> <:expr< True >> + | "["; "]" -> <:expr< [] >> + | "["; mk = sem_expr_for_list; "]" -> mk <:expr< [] >> + | "[|"; "|]" -> <:expr< [| |] >> + | "[|"; el = sem_expr; "|]" -> <:expr< [| $el$ |] >> + | "{"; test_label_eq; lel = label_expr; "}" -> + <:expr< { $lel$ } >> + | "{"; e = expr LEVEL "."; "with"; lel = label_expr; "}" -> + <:expr< { ($e$) with $lel$ } >> + | "{<"; ">}" -> <:expr< {< >} >> + | "{<"; fel = field_expr; ">}" -> <:expr< {< $fel$ >} >> + | "("; ")" -> <:expr< () >> + | "("; op = operator_rparen -> <:expr< $lid:op$ >> + | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >> + | "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" -> + <:expr< ($e$ : $t$ :> $t2$) >> + | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >> + | "("; e = SELF; ")" -> <:expr< $e$ >> + | "begin"; e = SELF; "end" -> <:expr< $e$ >> + | "begin"; "end" -> <:expr< () >> + | "new"; i = class_longident -> <:expr< new $i$ >> + | "`"; s = a_ident -> <:expr< ` $s$ >> + ] ] + ; + val_longident: + [ [ `ANTIQUOT (""|"id"|"anti"|"list" as n) s -> + <:ident< $anti:mk_anti ~c:"ident" n s$ >> + | i = a_UIDENT -> <:ident< $uid:i$ >> + | i = a_LIDENT -> <:ident< $lid:i$ >> + | `ANTIQUOT (""|"id"|"anti"|"list" as n) s; "."; i = SELF -> + <:ident< $anti:mk_anti ~c:"ident" n s$.$i$ >> + | i = a_UIDENT; "."; "("; j = operator_rparen -> + <:ident< $uid:i$.$lid:j$ >> + | i = a_UIDENT; "."; j = SELF -> <:ident< $uid:i$.$j$ >> ] ] + ; + match_case: + [ [ l = LIST1 match_case0 SEP "|" -> Ast.mcOr_of_list l ] ] + ; + patt_constr: + [ [ i = module_longident -> <:patt< $id:i$ >> + | "`"; s = a_ident -> <:patt< `$s$ >> ] ] + ; + (* Patterns *) + patt: + [ "as" LEFTA + [ p1 = SELF; "as"; i = a_LIDENT -> <:patt< ($p1$ as $lid:i$) >> ] + | "|" LEFTA + [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ] + | "," + [ p = SELF; ","; pl = (*FIXME comma_patt*) LIST1 NEXT SEP "," -> + <:patt< ( $p$, $Ast.paCom_of_list pl$ ) >> ] + | "::" RIGHTA + [ p1 = SELF; "::"; p2 = SELF -> <:patt< [$p1$ :: $p2$] >> ] + | "apply" RIGHTA + [ p1 = patt_constr; p2 = SELF -> + match p2 with + [ <:patt< ( $tup:p$ ) >> -> + List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>) p1 + (Ast.list_of_patt p []) + | _ -> <:patt< $p1$ $p2$ >> ] + | p = patt_constr -> p ] + | "simple" + [ `ANTIQUOT (""|"pat"|"anti" as n) s -> + <:patt< $anti:mk_anti ~c:"patt" n s$ >> + | `ANTIQUOT ("tup" as n) s -> <:patt< ($tup:<:patt< $anti:mk_anti ~c:"patt" n s$ >>$) >> + | i = ident -> <:patt< $id:i$ >> + | s = a_INT -> <:patt< $int:s$ >> + | s = a_INT32 -> <:patt< $int32:s$ >> + | s = a_INT64 -> <:patt< $int64:s$ >> + | s = a_NATIVEINT -> <:patt< $nativeint:s$ >> + | "-"; s = a_INT -> <:patt< $int:"-" ^ s$ >> + | "-"; s = a_INT32 -> <:patt< $int32:"-" ^ s$ >> + | "-"; s = a_INT64 -> <:patt< $int64:"-" ^ s$ >> + | "-"; s = a_NATIVEINT -> <:patt< $nativeint:"-" ^ s$ >> + | "-"; s = a_FLOAT -> <:patt< $flo:"-" ^ s$ >> + | s = a_FLOAT -> <:patt< $flo:s$ >> + | s = a_STRING -> <:patt< $str:s$ >> + | s1 = a_CHAR; ".."; s2 = a_CHAR -> <:patt< $chr:s1$ .. $chr:s2$ >> + | s = a_CHAR -> <:patt< $chr:s$ >> + | "false" -> <:patt< False >> + | "true" -> <:patt< True >> + | "["; "]" -> <:patt< [] >> + | "["; mk_list = sem_patt_for_list; "::"; last = patt; "]" -> + mk_list last + | "["; mk_list = sem_patt_for_list; "]" -> + mk_list <:patt< [] >> + | "[|"; "|]" -> <:patt< [||] >> + | "[|"; pl = sem_patt; "|]" -> <:patt< [| $pl$ |] >> + | "{"; pl = label_patt; "}" -> <:patt< { $pl$ } >> + | "("; ")" -> <:patt< () >> + | "("; op = operator_rparen -> <:patt< $lid:op$ >> + | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> + | "("; p = patt; ")" -> <:patt< $p$ >> + | "_" -> <:patt< _ >> + | "`"; s = a_ident -> <:patt< ` $s$ >> + | "#"; i = type_longident -> <:patt< # $i$ >> + | `QUOTATION x -> + Quotation.expand_patt (Gram.parse_string patt) _loc x ] ] + ; + infixop5: + [ [ x = [ "&" | "&&" ] -> <:expr< $lid:x$ >> ] ] + ; + infixop6: + [ [ x = [ "or" | "||" ] -> <:expr< $lid:x$ >> ] ] + ; + (* comma_expr: + [ [ e1 = SELF; ","; e2 = SELF -> <:expr< $e1$, $e2$ >> + | e = expr LEVEL ":=" -> e ] ] + ; *) + let_binding: + [ [ test_just_a_lident_or_patt; s = a_LIDENT_or_operator; e = fun_binding -> + <:binding< $lid:s$ = $e$ >> + | p = patt; "="; e = expr -> + <:binding< $p$ = $e$ >> ] ] + ; + (* comma_patt: + [ [ p1 = SELF; ","; p2 = SELF -> <:patt< $p1$, $p2$ >> + | p = patt LEVEL ".." -> p ] ] + ; *) + type_constraint: + [ [ "constraint" -> () ] ] + ; + with_constr: + [ LEFTA + [ wc1 = SELF; "and"; wc2 = SELF -> <:with_constr< $wc1$ and $wc2$ >> + | `ANTIQUOT (""|"with_constr"|"anti"|"list" as n) s -> + <:with_constr< $anti:mk_anti ~c:"with_constr" n s$ >> + | "type"; `ANTIQUOT (""|"typ"|"anti" as n) s; "="; t = opt_private_ctyp -> + <:with_constr< type $anti:mk_anti ~c:"ctyp" n s$ = $t$ >> + | "type"; t1 = type_longident_and_parameters; "="; t2 = opt_private_ctyp -> + <:with_constr< type $t1$ = $t2$ >> + | "module"; i1 = module_longident; "="; i2 = module_longident_with_app -> + <:with_constr< module $i1$ = $i2$ >> ] ] + ; + opt_private_ctyp: + [ [ "private"; t = ctyp -> <:ctyp< private $t$ >> + | t = ctyp -> t ] ] + ; + class_type_plus: + [ [ i = lident_colon; t = ctyp LEVEL "star"; "->"; ct = SELF -> + <:class_type< [ ~ $i$ : $t$ ] -> $ct$ >> + | "?"; i = a_LIDENT; ":"; t = ctyp LEVEL "star"; "->"; ct = SELF -> + <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> + | i = OPTLABEL (* FIXME inline a_OPTLABEL *); t = ctyp LEVEL "star"; "->"; ct = SELF -> + <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> + | test_ctyp_minusgreater; t = ctyp LEVEL "star"; "->"; ct = SELF -> + <:class_type< [ $t$ ] -> $ct$ >> + | ct = class_type -> ct ] ] + ; + class_type_longident_and_param: + [ [ "["; t = comma_ctyp; "]"; i = class_type_longident -> + <:class_type< $id:i$ [ $t$ ] >> + | i = class_type_longident -> <:class_type< $id:i$ >> ] ] + ; + class_longident_and_param: + [ [ "["; t = comma_ctyp; "]"; ci = class_longident -> + <:class_expr< $id:ci$ [ $t$ ] >> + | ci = class_longident -> <:class_expr< $id:ci$ >> + ] ] + ; + class_name_and_param: + [ [ "["; x = comma_type_parameter; "]"; i = a_LIDENT -> (i, x) + | i = a_LIDENT -> (i, <:ctyp<>>) + ] ] + ; + ctyp: + [ [ t1 = SELF; "as"; "'"; i = a_ident -> <:ctyp< $t1$ as '$i$ >> ] + | "arrow" RIGHTA + [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> + | i = lident_colon; t1 = ctyp LEVEL "star"; "->"; t2 = SELF -> + <:ctyp< ( ~ $i$ : $t1$ ) -> $t2$ >> + | i = a_OPTLABEL; t1 = ctyp LEVEL "star"; "->"; t2 = SELF -> + <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >> + | "?"; i=lident_colon;t1 = ctyp LEVEL "star"; "->"; t2 = SELF -> + <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >> ] + | "star" + [ t = SELF; "*"; tl = star_ctyp -> + <:ctyp< ( $t$ * $tl$ ) >> ] + | "ctyp1" + [ t1 = SELF; t2 = SELF -> <:ctyp< $t2$ $t1$ >> ] + | "ctyp2" + [ t1 = SELF; "."; t2 = SELF -> + try <:ctyp< $id:Ast.ident_of_ctyp t1$.$id:Ast.ident_of_ctyp t2$ >> + with [ Invalid_argument s -> raise (Stream.Error s) ] + | t1 = SELF; "("; t2 = SELF; ")" -> + let t = <:ctyp< $t1$ $t2$ >> in + try <:ctyp< $id:Ast.ident_of_ctyp t$ >> + with [ Invalid_argument s -> raise (Stream.Error s) ] ] + | "simple" + [ "'"; i = a_ident -> <:ctyp< '$i$ >> + | "_" -> <:ctyp< _ >> + | i = a_LIDENT -> <:ctyp< $lid:i$ >> + | i = a_UIDENT -> <:ctyp< $uid:i$ >> + | `ANTIQUOT (""|"typ"|"anti" as n) s -> + <:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >> + | `ANTIQUOT ("tup" as n) s -> + <:ctyp< ($tup:<:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >>$) >> + | `ANTIQUOT ("id" as n) s -> + <:ctyp< $id:<:ident< $anti:mk_anti ~c:"ident" n s$ >>$ >> + | "("; t = SELF; ","; mk = comma_ctyp_app; ")"; + i = ctyp LEVEL "ctyp2" -> + mk <:ctyp< $i$ $t$ >> + | "("; t = SELF; ")" -> <:ctyp< $t$ >> + | "#"; i = class_longident -> <:ctyp< # $i$ >> + | "<"; ml = opt_meth_list; v = opt_dot_dot; ">" -> + <:ctyp< < $ml$ $..:v$ > >> + | "["; OPT "|"; rfl = row_field; "]" -> + <:ctyp< [ = $rfl$ ] >> + | "["; ">"; "]" -> <:ctyp< [ > $<:ctyp<>>$ ] >> + | "["; ">"; OPT "|"; rfl = row_field; "]" -> + <:ctyp< [ > $rfl$ ] >> + | "[<"; OPT "|"; rfl = row_field; "]" -> + <:ctyp< [ < $rfl$ ] >> + | "[<"; OPT "|"; rfl = row_field; ">"; ntl = name_tags; "]" -> + <:ctyp< [ < $rfl$ > $ntl$ ] >> + ] ] + ; + comma_ctyp_app: + [ [ t1 = ctyp; ","; t2 = SELF -> fun acc -> t2 <:ctyp< $acc$ $t1$ >> + | t = ctyp -> fun acc -> <:ctyp< $acc$ $t$ >> + ] ] + ; + star_ctyp: + [ [ t1 = ctyp LEVEL "ctyp1"; "*"; t2 = SELF -> <:ctyp< $t1$ * $t2$ >> + | t = ctyp LEVEL "ctyp1" -> t + ] ] + ; + semi: + [ [ ";;" -> () | -> () ] ] + ; + ipatt: + [ [ p = patt -> p ] ] + ; + type_longident_and_parameters: + [ [ "("; tpl = type_parameters; ")"; i = type_longident -> + tpl <:ctyp< $id:i$ >> + | tp = type_parameter; i = type_longident -> + <:ctyp< $id:i$ $tp$ >> + | i = type_longident -> + <:ctyp< $id:i$ >> + ] ] + ; + type_parameters: + [ [ t1 = type_parameter; ","; t2 = SELF -> + fun acc -> t2 <:ctyp< $acc$ $t1$ >> + | t = type_parameter -> fun acc -> <:ctyp< $acc$ $t$ >> + ] ] + ; + type_ident_and_parameters: + [ [ "("; tpl = LIST1 type_parameter SEP ","; ")"; i = a_LIDENT -> (i, tpl) + | t = type_parameter; i = a_LIDENT -> (i, [t]) + | i = a_LIDENT -> (i, []) + ] ] + ; + type_kind: + [ [ "private"; tk = type_kind -> <:ctyp< private $tk$ >> + | test_constr_decl; OPT "|"; + t = constructor_declarations -> <:ctyp< [ $t$ ] >> + | t = ctyp -> <:ctyp< $t$ >> + | t = ctyp; "="; "private"; tk = type_kind -> + <:ctyp< $t$ == private $tk$ >> + | t1 = ctyp; "="; "{"; t2 = label_declaration; "}" -> + <:ctyp< $t1$ == { $t2$ } >> + | t1 = ctyp; "="; OPT "|"; t2 = constructor_declarations -> + <:ctyp< $t1$ == [ $t2$ ] >> + | "{"; t = label_declaration; "}" -> + <:ctyp< { $t$ } >> ] ] + ; + constructor_arg_list: + [ [ t1 = SELF; "*"; t2 = SELF -> <:ctyp< $t1$ and $t2$ >> + | t = ctyp LEVEL "ctyp1" -> t + ] ] + ; + value_let: + [ [ "let" -> () ] ] + ; + value_val: + [ [ "val" -> () ] ] + ; + a_LIDENT_or_operator: + [ [ x = a_LIDENT -> x + | "("; x = operator_rparen -> x ] ] + ; + label_declaration: + [ LEFTA + [ t1 = SELF; ";"; t2 = SELF -> <:ctyp< $t1$; $t2$ >> + | `ANTIQUOT (""|"typ" as n) s -> + <:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >> + | s = a_LIDENT; ":"; t = poly_type -> <:ctyp< $lid:s$ : $t$ >> + | "mutable"; s = a_LIDENT; ":"; t = poly_type -> + <:ctyp< $lid:s$ : mutable $t$ >> + ] ] + ; + poly_type: + [ [ test_typevar_list_dot; t1 = typevars; "."; t2 = ctyp -> + <:ctyp< ! $t1$ . $t2$ >> + | t = ctyp -> t ] ] + ; + labeled_ipatt: + [ [ i = a_LABEL; p = patt LEVEL "simple" -> + <:patt< ~ $i$ : $p$ >> + | "~"; i = a_LIDENT -> <:patt< ~ $i$ >> + | "~"; "("; i = a_LIDENT; ")" -> + <:patt< ~ $i$ >> + | "~"; "("; i = a_LIDENT; ":"; t = ctyp; ")" -> + <:patt< ~ $i$ : ($lid:i$ : $t$) >> + | i = a_OPTLABEL; j = a_LIDENT -> (* ?a:b <> ?a : b *) + <:patt< ? $i$ : ($lid:j$) >> + | i = a_OPTLABEL; "("; p = patt; ")" -> + <:patt< ? $i$ : ($p$) >> + | i = a_OPTLABEL; "("; p = patt; "="; e = expr; ")" -> + <:patt< ? $i$ : ( $p$ = $e$ ) >> + | i = a_OPTLABEL; "("; p = patt; ":"; t = ctyp; ")" -> + <:patt< ? $i$ : ( $p$ : $t$ ) >> + | i = a_OPTLABEL; "("; p = patt; ":"; t = ctyp; "="; + e = expr; ")" -> + <:patt< ? $i$ : ( $p$ : $t$ = $e$ ) >> + | "?"; i = a_LIDENT -> <:patt< ? $i$ >> + | "?"; "("; i = a_LIDENT; "="; e = expr; ")" -> + <:patt< ? ( $lid:i$ = $e$ ) >> + | "?"; "("; i = a_LIDENT; ":"; t = ctyp; "="; e = expr; ")" -> + <:patt< ? ( $lid:i$ : $t$ = $e$ ) >> + | "?"; "("; i = a_LIDENT; ")" -> + <:patt< ? $i$ >> + | "?"; "("; i = a_LIDENT; ":"; t = ctyp; ")" -> + <:patt< ? ( $lid:i$ : $t$ ) >> + | p = patt LEVEL "simple" -> p + ] ] + ; + label_expr: + [ [ p = label_longident; "="; e = expr LEVEL "top" -> + <:binding< $id:p$ = $e$ >> ] ] + ; + a_UIDENT: + [ [ `ANTIQUOT (""|"uid" as n) s -> mk_anti n s + | `UIDENT "True" -> " True" + | `UIDENT "False" -> " False" + | `UIDENT s -> s + ] ] + ; + END; +end; +let module M = Register.OCamlSyntaxExtension Id Make in (); diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlParserParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlParserParser.ml new file mode 100644 index 00000000..ccc38915 --- /dev/null +++ b/camlp4/Camlp4Parsers/Camlp4OCamlParserParser.ml @@ -0,0 +1,60 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 1998-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + + +open Camlp4; + +module Id : Sig.Id = struct + value name = "Camlp4OCamlParserParser"; + value version = "$Id: Camlp4OCamlParserParser.ml,v 1.1 2007/02/07 10:09:22 ertai Exp $"; +end; + +module Make (Syntax : Sig.Camlp4Syntax) = struct + open Sig; + include Syntax; + + module M = Camlp4OCamlRevisedParserParser.Make Syntax; + open M; + + Gram.Entry.clear stream_expr; + Gram.Entry.clear stream_begin; + Gram.Entry.clear stream_end; + Gram.Entry.clear stream_quot; + Gram.Entry.clear parser_case_list; + + EXTEND Gram + stream_expr: + [ [ e = expr LEVEL "top" -> e ] ] + ; + stream_begin: + [ [ "[<" -> () ] ] + ; + stream_end: + [ [ ">]" -> () ] ] + ; + stream_quot: + [ [ "'" -> () ] ] + ; + parser_case_list: + [ [ OPT "|"; pcl = LIST1 parser_case SEP "|" -> pcl ] ] + ; + END; +end; + +let module M = Register.OCamlSyntaxExtension Id Make in (); diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml new file mode 100644 index 00000000..d5f550fd --- /dev/null +++ b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml @@ -0,0 +1,1588 @@ +open Camlp4; (* -*- camlp4r -*- *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2002-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +module Id = struct + value name = "Camlp4RevisedParserParser"; + value version = "$Id: Camlp4OCamlRevisedParser.ml,v 1.2.2.1 2007/03/03 09:21:36 pouillar Exp $"; +end; + +module Make (Syntax : Sig.Camlp4Syntax) = struct + open Sig; + include Syntax; + + (* Camlp4_config.constructors_arity.val := True; *) + Camlp4_config.constructors_arity.val := False; + + value help_sequences () = + do { + Printf.eprintf "\ +New syntax: + do {e1; e2; ... ; en} + while e do {e1; e2; ... ; en} + for v = v1 to/downto v2 do {e1; e2; ... ; en} +Old (no more supported) syntax: + do e1; e2; ... ; en-1; return en + while e do e1; e2; ... ; en; done + for v = v1 to/downto v2 do e1; e2; ... ; en; done + "; + flush stderr; + exit 1 + } + ; + Options.add "-help_seq" (Arg.Unit help_sequences) + "Print explanations about new sequences and exit."; + + Gram.Entry.clear a_CHAR; + Gram.Entry.clear a_FLOAT; + Gram.Entry.clear a_INT; + Gram.Entry.clear a_INT32; + Gram.Entry.clear a_INT64; + Gram.Entry.clear a_LABEL; + Gram.Entry.clear a_LIDENT; + Gram.Entry.clear a_LIDENT_or_operator; + Gram.Entry.clear a_NATIVEINT; + Gram.Entry.clear a_OPTLABEL; + Gram.Entry.clear a_STRING; + Gram.Entry.clear a_UIDENT; + Gram.Entry.clear a_ident; + Gram.Entry.clear amp_ctyp; + Gram.Entry.clear and_ctyp; + Gram.Entry.clear match_case; + Gram.Entry.clear match_case0; + Gram.Entry.clear match_case_quot; + Gram.Entry.clear binding; + Gram.Entry.clear binding_quot; + Gram.Entry.clear class_declaration; + Gram.Entry.clear class_description; + Gram.Entry.clear class_expr; + Gram.Entry.clear class_expr_quot; + Gram.Entry.clear class_fun_binding; + Gram.Entry.clear class_fun_def; + Gram.Entry.clear class_info_for_class_expr; + Gram.Entry.clear class_info_for_class_type; + Gram.Entry.clear class_longident; + Gram.Entry.clear class_longident_and_param; + Gram.Entry.clear class_name_and_param; + Gram.Entry.clear class_sig_item; + Gram.Entry.clear class_sig_item_quot; + Gram.Entry.clear class_signature; + Gram.Entry.clear class_str_item; + Gram.Entry.clear class_str_item_quot; + Gram.Entry.clear class_structure; + Gram.Entry.clear class_type; + Gram.Entry.clear class_type_declaration; + Gram.Entry.clear class_type_longident; + Gram.Entry.clear class_type_longident_and_param; + Gram.Entry.clear class_type_plus; + Gram.Entry.clear class_type_quot; + Gram.Entry.clear comma_ctyp; + Gram.Entry.clear comma_expr; + Gram.Entry.clear comma_ipatt; + Gram.Entry.clear comma_patt; + Gram.Entry.clear comma_type_parameter; + Gram.Entry.clear constrain; + Gram.Entry.clear constructor_arg_list; + Gram.Entry.clear constructor_declaration; + Gram.Entry.clear constructor_declarations; + Gram.Entry.clear ctyp; + Gram.Entry.clear ctyp_quot; + Gram.Entry.clear cvalue_binding; + Gram.Entry.clear direction_flag; + Gram.Entry.clear dummy; + Gram.Entry.clear eq_expr; + Gram.Entry.clear expr; + Gram.Entry.clear expr_eoi; + Gram.Entry.clear expr_quot; + Gram.Entry.clear field; + Gram.Entry.clear field_expr; + Gram.Entry.clear fun_binding; + Gram.Entry.clear fun_def; + Gram.Entry.clear ident; + Gram.Entry.clear ident_quot; + Gram.Entry.clear implem; + Gram.Entry.clear interf; + Gram.Entry.clear ipatt; + Gram.Entry.clear ipatt_tcon; + Gram.Entry.clear label; + Gram.Entry.clear label_declaration; + Gram.Entry.clear label_expr; + Gram.Entry.clear label_ipatt; + Gram.Entry.clear label_longident; + Gram.Entry.clear label_patt; + Gram.Entry.clear labeled_ipatt; + Gram.Entry.clear let_binding; + Gram.Entry.clear meth_list; + Gram.Entry.clear module_binding; + Gram.Entry.clear module_binding0; + Gram.Entry.clear module_binding_quot; + Gram.Entry.clear module_declaration; + Gram.Entry.clear module_expr; + Gram.Entry.clear module_expr_quot; + Gram.Entry.clear module_longident; + Gram.Entry.clear module_longident_with_app; + Gram.Entry.clear module_rec_declaration; + Gram.Entry.clear module_type; + Gram.Entry.clear module_type_quot; + Gram.Entry.clear more_ctyp; + Gram.Entry.clear name_tags; + Gram.Entry.clear opt_as_lident; + Gram.Entry.clear opt_class_self_patt; + Gram.Entry.clear opt_class_self_type; + Gram.Entry.clear opt_comma_ctyp; + Gram.Entry.clear opt_dot_dot; + Gram.Entry.clear opt_eq_ctyp; + Gram.Entry.clear opt_expr; + Gram.Entry.clear opt_meth_list; + Gram.Entry.clear opt_mutable; + Gram.Entry.clear opt_polyt; + Gram.Entry.clear opt_private; + Gram.Entry.clear opt_rec; + Gram.Entry.clear opt_virtual; + Gram.Entry.clear opt_when_expr; + Gram.Entry.clear patt; + Gram.Entry.clear patt_as_patt_opt; + Gram.Entry.clear patt_eoi; + Gram.Entry.clear patt_quot; + Gram.Entry.clear patt_tcon; + Gram.Entry.clear phrase; + Gram.Entry.clear pipe_ctyp; + Gram.Entry.clear poly_type; + Gram.Entry.clear row_field; + Gram.Entry.clear sem_ctyp; + Gram.Entry.clear sem_expr; + Gram.Entry.clear sem_expr_for_list; + Gram.Entry.clear sem_patt; + Gram.Entry.clear sem_patt_for_list; + Gram.Entry.clear semi; + Gram.Entry.clear sequence; + Gram.Entry.clear sig_item; + Gram.Entry.clear sig_item_quot; + Gram.Entry.clear sig_items; + Gram.Entry.clear star_ctyp; + Gram.Entry.clear str_item; + Gram.Entry.clear str_item_quot; + Gram.Entry.clear str_items; + Gram.Entry.clear top_phrase; + Gram.Entry.clear type_constraint; + Gram.Entry.clear type_declaration; + Gram.Entry.clear type_ident_and_parameters; + Gram.Entry.clear type_kind; + Gram.Entry.clear type_longident; + Gram.Entry.clear type_longident_and_parameters; + Gram.Entry.clear type_parameter; + Gram.Entry.clear type_parameters; + Gram.Entry.clear typevars; + Gram.Entry.clear use_file; + Gram.Entry.clear val_longident; + Gram.Entry.clear value_let; + Gram.Entry.clear value_val; + Gram.Entry.clear with_constr; + Gram.Entry.clear with_constr_quot; + + value neg_string n = + let len = String.length n in + if len > 0 && n.[0] = '-' then String.sub n 1 (len - 1) + else "-" ^ n + ; + + value mkumin _loc f arg = + match arg with + [ <:expr< $int:n$ >> -> <:expr< $int:neg_string n$ >> + | <:expr< $int32:n$ >> -> <:expr< $int32:neg_string n$ >> + | <:expr< $int64:n$ >> -> <:expr< $int64:neg_string n$ >> + | <:expr< $nativeint:n$ >> -> <:expr< $nativeint:neg_string n$ >> + | <:expr< $flo:n$ >> -> <:expr< $flo:neg_string n$ >> + | _ -> <:expr< $lid:"~" ^ f$ $arg$ >> ]; + + value mklistexp _loc last = + loop True where rec loop top = + fun + [ [] -> + match last with + [ Some e -> e + | None -> <:expr< [] >> ] + | [e1 :: el] -> + let _loc = + if top then _loc else Loc.merge (Ast.loc_of_expr e1) _loc + in + <:expr< [$e1$ :: $loop False el$] >> ] + ; + + value mkassert _loc = + fun + [ <:expr< False >> -> + <:expr< assert False >> (* this case take care about + the special assert false node *) + | e -> <:expr< assert $e$ >> ] + ; + + value append_eLem el e = el @ [e]; + value mk_anti ?(c = "") n s = "\\$"^n^c^":"^s; + + value mksequence _loc = + fun + [ <:expr< $_$; $_$ >> | <:expr< $anti:_$ >> as e -> <:expr< do { $e$ } >> + | e -> e ] + ; + + value bigarray_get _loc arr arg = + let coords = + match arg with + [ <:expr< ($e1$, $e2$) >> | <:expr< $e1$, $e2$ >> -> + Ast.list_of_expr e1 (Ast.list_of_expr e2 []) + | _ -> [arg] ] + in + match coords with + [ [c1] -> <:expr< Bigarray.Array1.get $arr$ $c1$ >> + | [c1; c2] -> <:expr< Bigarray.Array2.get $arr$ $c1$ $c2$ >> + | [c1; c2; c3] -> <:expr< Bigarray.Array3.get $arr$ $c1$ $c2$ $c3$ >> + (* | coords -> <:expr< Bigarray.Genarray.get $arr$ [| $`list:coords$ |] >> ] *) + | coords -> + <:expr< Bigarray.Genarray.get $arr$ [| $Ast.exSem_of_list coords$ |] >> ]; + + value bigarray_set _loc var newval = + match var with + [ <:expr< Bigarray.Array1.get $arr$ $c1$ >> -> + Some <:expr< Bigarray.Array1.set $arr$ $c1$ $newval$ >> + | <:expr< Bigarray.Array2.get $arr$ $c1$ $c2$ >> -> + Some <:expr< Bigarray.Array2.set $arr$ $c1$ $c2$ $newval$ >> + | <:expr< Bigarray.Array3.get $arr$ $c1$ $c2$ $c3$ >> -> + Some <:expr< Bigarray.Array3.set $arr$ $c1$ $c2$ $c3$ $newval$ >> + | <:expr< Bigarray.Genarray.get $arr$ [| $coords$ |] >> -> + Some <:expr< Bigarray.Genarray.set $arr$ [| $coords$ |] $newval$ >> + | _ -> None ]; + + value choose_tvar tpl = + let abs = "abstract" in + let rec find_alpha n = + let ns = if n = 0 then "" else string_of_int n in + let s' = abs ^ ns in + let rec mem = + fun + [ [ <:ctyp< '$s$ >> | <:ctyp< +'$s$ >> | <:ctyp< -'$s$ >> :: xs ] -> + (s = s') || mem xs + | [] -> False + | _ -> assert False ] in + if mem tpl then find_alpha (succ n) + else s' + in find_alpha 0; + + value stopped_at _loc = + Some (Loc.move_line 1 _loc) (* FIXME be more precise *); + + (* value list1sep symb sep one cons = + let rec kont al = + parser + [ [: v = sep; a = symb; s :] -> kont (cons al (one a)) s + | [: :] -> al ] + in + parser [: a = symb; s :] -> kont (one a) s; + + value sem_expr = + list1sep expr ";" (fun x -> x) (fun e1 e2 -> <:expr< $e1$; $e2$ >>) *) + + (* transmit the context *) + Gram.Entry.setup_parser sem_expr + (let symb = Gram.parse_tokens_after_filter expr in + let rec kont al = + parser + [ [: `(KEYWORD ";", _loc); a = symb; s :] -> kont <:expr< $al$; $a$ >> s + | [: :] -> al ] + in + parser [: a = symb; s :] -> kont a s); + (* sem_expr_for_list: + [ [ e = expr; ";"; el = SELF -> fun acc -> <:expr< [ $e$ :: $el acc$ ] >> + | e = expr -> fun acc -> <:expr< [ $e$ :: $acc$ ] >> + ] ] + ; + comma_expr: + [ [ e1 = SELF; ","; e2 = SELF -> <:expr< $e1$, $e2$ >> + | e = expr -> e ] ] + ; *) + + EXTEND Gram + GLOBAL: + a_CHAR a_FLOAT a_INT a_INT32 a_INT64 a_LABEL a_LIDENT + a_LIDENT_or_operator a_NATIVEINT a_OPTLABEL a_STRING a_UIDENT a_ident + amp_ctyp and_ctyp match_case match_case0 match_case_quot binding binding_quot + class_declaration class_description class_expr class_expr_quot + class_fun_binding class_fun_def class_info_for_class_expr + class_info_for_class_type class_longident class_longident_and_param + class_name_and_param class_sig_item class_sig_item_quot class_signature + class_str_item class_str_item_quot class_structure class_type + class_type_declaration class_type_longident + class_type_longident_and_param class_type_plus class_type_quot + comma_ctyp comma_expr comma_ipatt comma_patt comma_type_parameter + constrain constructor_arg_list constructor_declaration + constructor_declarations ctyp ctyp_quot cvalue_binding direction_flag + dummy eq_expr expr expr_eoi expr_quot field field_expr fun_binding + fun_def ident ident_quot implem interf ipatt ipatt_tcon label + label_declaration label_expr label_ipatt label_longident label_patt + labeled_ipatt let_binding meth_list module_binding module_binding0 + module_binding_quot module_declaration module_expr module_expr_quot + module_longident module_longident_with_app module_rec_declaration + module_type module_type_quot more_ctyp name_tags opt_as_lident + opt_class_self_patt opt_class_self_type opt_comma_ctyp opt_dot_dot opt_eq_ctyp opt_expr + opt_meth_list opt_mutable opt_polyt opt_private opt_rec + opt_virtual opt_when_expr patt patt_as_patt_opt patt_eoi + patt_quot patt_tcon phrase pipe_ctyp poly_type row_field sem_ctyp + sem_expr sem_expr_for_list sem_patt sem_patt_for_list semi sequence + sig_item sig_item_quot sig_items star_ctyp str_item str_item_quot + str_items top_phrase type_constraint type_declaration + type_ident_and_parameters type_kind type_longident + type_longident_and_parameters type_parameter type_parameters typevars + use_file val_longident value_let value_val with_constr with_constr_quot; + module_expr: + [ [ "functor"; "("; i = a_UIDENT; ":"; t = module_type; ")"; "->"; + me = SELF -> + <:module_expr< functor ( $i$ : $t$ ) -> $me$ >> + | "struct"; st = str_items; "end" -> + <:module_expr< struct $st$ end >> ] + | [ me1 = SELF; me2 = SELF -> <:module_expr< $me1$ $me2$ >> ] + | "simple" + [ `ANTIQUOT (""|"mexp"|"anti"|"list" as n) s -> + <:module_expr< $anti:mk_anti ~c:"module_expr" n s$ >> + | i = module_longident -> <:module_expr< $id:i$ >> + | "("; me = SELF; ":"; mt = module_type; ")" -> + <:module_expr< ( $me$ : $mt$ ) >> + | "("; me = SELF; ")" -> <:module_expr< $me$ >> ] ] + ; + str_item: + [ "top" + [ "exception"; t = constructor_declaration -> + <:str_item< exception $t$ >> + | "exception"; t = constructor_declaration; "="; i = type_longident -> + <:str_item< exception $t$ = $i$ >> + | "external"; i = a_LIDENT; ":"; t = ctyp; "="; sl = string_list -> + <:str_item< external $i$ : $t$ = $sl$ >> + | "include"; me = module_expr -> <:str_item< include $me$ >> + | "module"; i = a_UIDENT; mb = module_binding0 -> + <:str_item< module $i$ = $mb$ >> + | "module"; "rec"; mb = module_binding -> + <:str_item< module rec $mb$ >> + | "module"; "type"; i = a_UIDENT; "="; mt = module_type -> + <:str_item< module type $i$ = $mt$ >> + | "open"; i = module_longident -> <:str_item< open $i$ >> + | "type"; td = type_declaration -> + <:str_item< type $td$ >> + | value_let; r = opt_rec; bi = binding -> + <:str_item< value $rec:r$ $bi$ >> + | "class"; cd = class_declaration -> + <:str_item< class $cd$ >> + | "class"; "type"; ctd = class_type_declaration -> + <:str_item< class type $ctd$ >> + | `ANTIQUOT (""|"stri"|"anti"|"list" as n) s -> + <:str_item< $anti:mk_anti ~c:"str_item" n s$ >> + | e = expr -> <:str_item< $exp:e$ >> ] ] + ; + module_binding0: + [ RIGHTA + [ "("; m = a_UIDENT; ":"; mt = module_type; ")"; mb = SELF -> + <:module_expr< functor ( $m$ : $mt$ ) -> $mb$ >> + | ":"; mt = module_type; "="; me = module_expr -> + <:module_expr< ( $me$ : $mt$ ) >> + | "="; me = module_expr -> <:module_expr< $me$ >> ] ] + ; + module_binding: + [ LEFTA + [ b1 = SELF; "and"; b2 = SELF -> + <:module_binding< $b1$ and $b2$ >> + | `ANTIQUOT ("module_binding"|"anti"|"list" as n) s -> + <:module_binding< $anti:mk_anti ~c:"module_binding" n s$ >> + | `ANTIQUOT ("" as n) s -> + <:module_binding< $anti:mk_anti ~c:"module_binding" n s$ >> + | `ANTIQUOT ("" as n) m; ":"; mt = module_type; "="; me = module_expr -> + <:module_binding< $mk_anti n m$ : $mt$ = $me$ >> + | m = a_UIDENT; ":"; mt = module_type; "="; me = module_expr -> + <:module_binding< $m$ : $mt$ = $me$ >> ] ] + ; + module_type: + [ [ "functor"; "("; i = a_UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF -> + <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] + | [ mt = SELF; "with"; wc = with_constr -> + <:module_type< $mt$ with $wc$ >> ] + | [ "sig"; sg = sig_items; "end" -> + <:module_type< sig $sg$ end >> ] + | "simple" + [ `ANTIQUOT (""|"mtyp"|"anti"|"list" as n) s -> + <:module_type< $anti:mk_anti ~c:"module_type" n s$ >> + | i = module_longident_with_app -> <:module_type< $id:i$ >> + | "'"; i = a_ident -> <:module_type< ' $i$ >> + | "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ] + ; + sig_item: + [ "top" + [ `ANTIQUOT (""|"sigi"|"anti"|"list" as n) s -> + <:sig_item< $anti:mk_anti ~c:"sig_item" n s$ >> + | "exception"; t = constructor_declaration -> + <:sig_item< exception $t$ >> + | "external"; i = a_LIDENT; ":"; t = ctyp; "="; sl = string_list -> + <:sig_item< external $i$ : $t$ = $sl$ >> + | "include"; mt = module_type -> <:sig_item< include $mt$ >> + | "module"; i = a_UIDENT; mt = module_declaration -> + <:sig_item< module $i$ : $mt$ >> + | "module"; "rec"; mb = module_rec_declaration -> + <:sig_item< module rec $mb$ >> + | "module"; "type"; i = a_UIDENT; "="; mt = module_type -> + <:sig_item< module type $i$ = $mt$ >> + | "open"; i = module_longident -> <:sig_item< open $i$ >> + | "type"; t = type_declaration -> + <:sig_item< type $t$ >> + | value_val; i = a_LIDENT_or_operator; ":"; t = ctyp -> + <:sig_item< value $i$ : $t$ >> + | "class"; cd = class_description -> + <:sig_item< class $cd$ >> + | "class"; "type"; ctd = class_type_declaration -> + <:sig_item< class type $ctd$ >> ] ] + ; + module_declaration: + [ RIGHTA + [ ":"; mt = module_type -> <:module_type< $mt$ >> + | "("; i = a_UIDENT; ":"; t = module_type; ")"; mt = SELF -> + <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] ] + ; + module_rec_declaration: + [ LEFTA + [ m1 = SELF; "and"; m2 = SELF -> <:module_binding< $m1$ and $m2$ >> + | `ANTIQUOT (""|"module_binding"|"anti"|"list" as n) s -> + <:module_binding< $anti:mk_anti ~c:"module_binding" n s$ >> + | m = a_UIDENT; ":"; mt = module_type -> <:module_binding< $m$ : $mt$ >> + ] ] + ; + with_constr: + [ LEFTA + [ wc1 = SELF; "and"; wc2 = SELF -> <:with_constr< $wc1$ and $wc2$ >> + | `ANTIQUOT (""|"with_constr"|"anti"|"list" as n) s -> + <:with_constr< $anti:mk_anti ~c:"with_constr" n s$ >> + | "type"; `ANTIQUOT (""|"typ"|"anti" as n) s; "="; t = ctyp -> + <:with_constr< type $anti:mk_anti ~c:"ctyp" n s$ = $t$ >> + | "type"; t1 = type_longident_and_parameters; "="; t2 = ctyp -> + <:with_constr< type $t1$ = $t2$ >> + | "module"; i1 = module_longident; "="; i2 = module_longident_with_app -> + <:with_constr< module $i1$ = $i2$ >> ] ] + ; + expr: + [ "top" RIGHTA + [ "let"; r = opt_rec; bi = binding; "in"; + x = SELF -> + <:expr< let $rec:r$ $bi$ in $x$ >> + | "let"; "module"; m = a_UIDENT; mb = module_binding0; "in"; e = SELF -> + <:expr< let module $m$ = $mb$ in $e$ >> + | "fun"; "["; a = match_case; "]" -> + <:expr< fun [ $a$ ] >> + | "fun"; p = labeled_ipatt; e = fun_def -> + <:expr< fun $p$ -> $e$ >> + | "match"; e = SELF; "with"; "["; a = match_case; "]" -> + <:expr< match $e$ with [ $a$ ] >> + | "match"; e1 = SELF; "with"; p = ipatt; "->"; e2 = SELF -> + <:expr< match $e1$ with $p$ -> $e2$ >> + | "try"; e = SELF; "with"; "["; a = match_case; "]" -> + <:expr< try $e$ with [ $a$ ] >> + | "try"; e1 = SELF; "with"; p = ipatt; "->"; e2 = SELF -> + <:expr< try $e1$ with $p$ -> $e2$ >> + | "if"; e1 = SELF; "then"; e2 = SELF; "else"; e3 = SELF -> + <:expr< if $e1$ then $e2$ else $e3$ >> + | "do"; "{"; seq = sequence; "}" -> mksequence _loc seq + | "for"; i = a_LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF; + "do"; "{"; seq = sequence; "}" -> + <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $seq$ } >> + | "while"; e = SELF; "do"; "{"; seq = sequence; "}" -> + <:expr< while $e$ do { $seq$ } >> + | "object"; csp = opt_class_self_patt; cst = class_structure; "end" -> + <:expr< object ($csp$) $cst$ end >> ] + | "where" + [ e = SELF; "where"; rf = opt_rec; lb = let_binding -> + <:expr< let $rec:rf$ $lb$ in $e$ >> ] + | ":=" NONA + [ e1 = SELF; ":="; e2 = SELF; dummy -> + match bigarray_set _loc e1 e2 with + [ Some e -> e + | None -> <:expr< $e1$ := $e2$ >> ] ] + | "||" RIGHTA + [ e1 = SELF; "||"; e2 = SELF -> <:expr< $e1$ || $e2$ >> ] + | "&&" RIGHTA + [ e1 = SELF; "&&"; e2 = SELF -> <:expr< $e1$ && $e2$ >> ] + | "<" LEFTA + [ e1 = SELF; "<"; e2 = SELF -> <:expr< $e1$ < $e2$ >> + | e1 = SELF; ">"; e2 = SELF -> <:expr< $e1$ > $e2$ >> + | e1 = SELF; "<="; e2 = SELF -> <:expr< $e1$ <= $e2$ >> + | e1 = SELF; ">="; e2 = SELF -> <:expr< $e1$ >= $e2$ >> + | e1 = SELF; "="; e2 = SELF -> <:expr< $e1$ = $e2$ >> + | e1 = SELF; "<>"; e2 = SELF -> <:expr< $e1$ <> $e2$ >> + | e1 = SELF; "=="; e2 = SELF -> <:expr< $e1$ == $e2$ >> + | e1 = SELF; "!="; e2 = SELF -> <:expr< $e1$ != $e2$ >> ] + | "^" RIGHTA + [ e1 = SELF; "^"; e2 = SELF -> <:expr< $e1$ ^ $e2$ >> + | e1 = SELF; "^^"; e2 = SELF -> <:expr< $lid:"^^"$ $e1$ $e2$ >> + | e1 = SELF; "@"; e2 = SELF -> <:expr< $e1$ @ $e2$ >> ] + | "+" LEFTA + [ e1 = SELF; "+"; e2 = SELF -> <:expr< $e1$ + $e2$ >> + | e1 = SELF; "-"; e2 = SELF -> <:expr< $e1$ - $e2$ >> + | e1 = SELF; "+."; e2 = SELF -> <:expr< $e1$ +. $e2$ >> + | e1 = SELF; "-."; e2 = SELF -> <:expr< $e1$ -. $e2$ >> ] + | "*" LEFTA + [ e1 = SELF; "*"; e2 = SELF -> <:expr< $e1$ * $e2$ >> + | e1 = SELF; "/"; e2 = SELF -> <:expr< $e1$ / $e2$ >> + | e1 = SELF; "*."; e2 = SELF -> <:expr< $e1$ *. $e2$ >> + | e1 = SELF; "/."; e2 = SELF -> <:expr< $e1$ /. $e2$ >> + | e1 = SELF; "land"; e2 = SELF -> <:expr< $e1$ land $e2$ >> + | e1 = SELF; "lor"; e2 = SELF -> <:expr< $e1$ lor $e2$ >> + | e1 = SELF; "lxor"; e2 = SELF -> <:expr< $e1$ lxor $e2$ >> + | e1 = SELF; "mod"; e2 = SELF -> <:expr< $e1$ mod $e2$ >> ] + | "**" RIGHTA + [ e1 = SELF; "**"; e2 = SELF -> <:expr< $e1$ ** $e2$ >> + | e1 = SELF; "asr"; e2 = SELF -> <:expr< $e1$ asr $e2$ >> + | e1 = SELF; "lsl"; e2 = SELF -> <:expr< $e1$ lsl $e2$ >> + | e1 = SELF; "lsr"; e2 = SELF -> <:expr< $e1$ lsr $e2$ >> ] + | "unary minus" NONA + [ "-"; e = SELF -> mkumin _loc "-" e + | "-."; e = SELF -> mkumin _loc "-." e ] + | "apply" LEFTA + [ e1 = SELF; e2 = SELF -> <:expr< $e1$ $e2$ >> + | "assert"; e = SELF -> mkassert _loc e + | "new"; i = class_longident -> <:expr< new $i$ >> + | "lazy"; e = SELF -> <:expr< lazy $e$ >> ] + | "label" NONA + [ "~"; i = a_LIDENT; ":"; e = SELF -> <:expr< ~ $i$ : $e$ >> + | `LABEL i; e = SELF -> <:expr< ~ $i$ : $e$ >> + | "~"; i = a_LIDENT -> <:expr< ~ $i$ >> + | `OPTLABEL i; e = SELF -> <:expr< ? $i$ : $e$ >> + | "?"; i = a_LIDENT; ":"; e = SELF -> <:expr< ? $i$ : $e$ >> + | "?"; i = a_LIDENT -> <:expr< ? $i$ >> ] + | "." LEFTA + [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >> + | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >> + | e1 = SELF; "."; "{"; e2 = comma_expr; "}" -> bigarray_get _loc e1 e2 + | e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> + | e = SELF; "#"; lab = label -> <:expr< $e$ # $lab$ >> ] + | "~-" NONA + [ "~-"; e = SELF -> <:expr< ~- $e$ >> + | "~-."; e = SELF -> <:expr< ~-. $e$ >> ] + | "simple" + [ `QUOTATION x -> Quotation.expand_expr (Gram.parse_string expr) _loc x + | `ANTIQUOT ("exp"|""|"anti" as n) s -> + <:expr< $anti:mk_anti ~c:"expr" n s$ >> + | `ANTIQUOT ("tup" as n) s -> + <:expr< ($tup: <:expr< $anti:mk_anti ~c:"expr" n s$ >>$) >> + | s = a_INT -> <:expr< $int:s$ >> + | s = a_INT32 -> <:expr< $int32:s$ >> + | s = a_INT64 -> <:expr< $int64:s$ >> + | s = a_NATIVEINT -> <:expr< $nativeint:s$ >> + | s = a_FLOAT -> <:expr< $flo:s$ >> + | s = a_STRING -> <:expr< $str:s$ >> + | s = a_CHAR -> <:expr< $chr:s$ >> + | i = val_longident -> <:expr< $id:i$ >> + | "`"; s = a_ident -> <:expr< ` $s$ >> + | "["; "]" -> <:expr< [] >> + | "["; mk_list = sem_expr_for_list; "::"; last = expr; "]" -> + mk_list last + | "["; mk_list = sem_expr_for_list; "]" -> + mk_list <:expr< [] >> + | "[|"; "|]" -> <:expr< [| $<:expr<>>$ |] >> + | "[|"; el = sem_expr; "|]" -> <:expr< [| $el$ |] >> + | "{"; el = label_expr; "}" -> <:expr< { $el$ } >> + | "{"; "("; e = SELF; ")"; "with"; el = label_expr; "}" -> + <:expr< { ($e$) with $el$ } >> + | "{<"; ">}" -> <:expr< {<>} >> + | "{<"; fel = field_expr; ">}" -> <:expr< {< $fel$ >} >> + | "("; ")" -> <:expr< () >> + | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >> + | "("; e = SELF; ","; el = comma_expr; ")" -> <:expr< ( $e$, $el$ ) >> + | "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" -> + <:expr< ($e$ : $t$ :> $t2$ ) >> + | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >> + | "("; e = SELF; ")" -> e ] ] + ; + (* sem_expr: + [ [ e1 = SELF; ";"; e2 = SELF -> <:expr< $e1$; $e2$ >> + | e = expr -> e ] ] + ; *) + sem_expr_for_list: + [ [ e = expr; ";"; el = SELF -> fun acc -> <:expr< [ $e$ :: $el acc$ ] >> + | e = expr -> fun acc -> <:expr< [ $e$ :: $acc$ ] >> + ] ] + ; + comma_expr: + [ [ e1 = SELF; ","; e2 = SELF -> <:expr< $e1$, $e2$ >> + | e = expr -> e ] ] + ; + dummy: + [ [ -> () ] ] + ; + sequence: + [ [ "let"; rf = opt_rec; bi = binding; [ "in" | ";" ]; el = SELF -> + <:expr< let $rec:rf$ $bi$ in $mksequence _loc el$ >> + | e = expr; ";"; el = SELF -> <:expr< $e$; $el$ >> + | e = expr; ";" -> e + | e = expr -> e ] ] + ; + binding: + [ LEFTA + [ `ANTIQUOT ("binding"|"list" as n) s -> + <:binding< $anti:mk_anti ~c:"binding" n s$ >> + | `ANTIQUOT (""|"anti" as n) s; "="; e = expr -> + <:binding< $anti:mk_anti ~c:"patt" n s$ = $e$ >> + | `ANTIQUOT (""|"anti" as n) s -> <:binding< $anti:mk_anti ~c:"binding" n s$ >> + | b1 = SELF; "and"; b2 = SELF -> <:binding< $b1$ and $b2$ >> + | b = let_binding -> b + ] ] + ; + let_binding: + [ [ p = ipatt; e = fun_binding -> <:binding< $p$ = $e$ >> ] ] + ; + fun_binding: + [ RIGHTA + [ p = labeled_ipatt; e = SELF -> + <:expr< fun $p$ -> $e$ >> + | "="; e = expr -> <:expr< $e$ >> + | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> + | ":>"; t = ctyp; "="; e = expr -> <:expr< ($e$ :> $t$) >> ] ] + ; + match_case: + [ [ l = LIST0 match_case0 SEP "|" -> Ast.mcOr_of_list l ] ] + ; + match_case0: + [ [ `ANTIQUOT ("match_case"|"list" as n) s -> + <:match_case< $anti:mk_anti ~c:"match_case" n s$ >> + | `ANTIQUOT (""|"anti" as n) s -> + <:match_case< $anti:mk_anti ~c:"match_case" n s$ >> + | `ANTIQUOT (""|"anti" as n) s; "->"; e = expr -> + <:match_case< $anti:mk_anti ~c:"patt" n s$ -> $e$ >> + | `ANTIQUOT (""|"anti" as n) s; "when"; w = expr; "->"; e = expr -> + <:match_case< $anti:mk_anti ~c:"patt" n s$ when $w$ -> $e$ >> + | p = patt_as_patt_opt; w = opt_when_expr; "->"; e = expr -> <:match_case< $p$ when $w$ -> $e$ >> + ] ] + ; + opt_when_expr: + [ [ "when"; w = expr -> w + | -> <:expr<>> + ] ] + ; + patt_as_patt_opt: + [ [ p1 = patt; "as"; p2 = patt -> <:patt< ($p1$ as $p2$) >> + | p = patt -> p + ] ] + ; + label_expr: + [ LEFTA + [ b1 = SELF; ";"; b2 = SELF -> <:binding< $b1$ ; $b2$ >> + | `ANTIQUOT (""|"binding"|"anti" as n) s -> + <:binding< $anti:mk_anti ~c:"binding" n s$ >> + | `ANTIQUOT ("list" as n) s -> + <:binding< $anti:mk_anti ~c:"binding;" n s$ >> + | p = label_longident; e = fun_binding -> <:binding< $id:p$ = $e$ >> ] ] + ; + fun_def: + [ RIGHTA + [ p = labeled_ipatt; e = SELF -> <:expr< fun $p$ -> $e$ >> + | "->"; e = expr -> e ] ] + ; + patt: + [ LEFTA + [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ] + | NONA + [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ] + | LEFTA + [ p1 = SELF; p2 = SELF -> <:patt< $p1$ $p2$ >> ] + | "simple" + [ `ANTIQUOT (""|"pat"|"anti" as n) s -> + <:patt< $anti:mk_anti ~c:"patt" n s$ >> + | `ANTIQUOT ("tup" as n) s -> <:patt< ($tup:<:patt< $anti:mk_anti ~c:"patt" n s$ >>$) >> + | i = ident -> <:patt< $id:i$ >> + | s = a_INT -> <:patt< $int:s$ >> + | s = a_INT32 -> <:patt< $int32:s$ >> + | s = a_INT64 -> <:patt< $int64:s$ >> + | s = a_NATIVEINT -> <:patt< $nativeint:s$ >> + | s = a_FLOAT -> <:patt< $flo:s$ >> + | s = a_STRING -> <:patt< $str:s$ >> + | s = a_CHAR -> <:patt< $chr:s$ >> + | "-"; s = a_INT -> <:patt< $int:neg_string s$ >> + | "-"; s = a_INT32 -> <:patt< $int32:neg_string s$ >> + | "-"; s = a_INT64 -> <:patt< $int64:neg_string s$ >> + | "-"; s = a_NATIVEINT -> <:patt< $nativeint:neg_string s$ >> + | "-"; s = a_FLOAT -> <:patt< $flo:neg_string s$ >> + | "["; "]" -> <:patt< [] >> + | "["; mk_list = sem_patt_for_list; "::"; last = patt; "]" -> + mk_list last + | "["; mk_list = sem_patt_for_list; "]" -> + mk_list <:patt< [] >> + | "[|"; "|]" -> <:patt< [| $<:patt<>>$ |] >> + | "[|"; pl = sem_patt; "|]" -> <:patt< [| $pl$ |] >> + | "{"; pl = label_patt; "}" -> <:patt< { $pl$ } >> + | "("; ")" -> <:patt< () >> + | "("; p = SELF; ")" -> p + | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> + | "("; p = SELF; "as"; p2 = SELF; ")" -> <:patt< ($p$ as $p2$) >> + | "("; p = SELF; ","; pl = comma_patt; ")" -> <:patt< ($p$, $pl$) >> + | "_" -> <:patt< _ >> + | `QUOTATION x -> Quotation.expand_patt (Gram.parse_string patt) _loc x + | "`"; s = a_ident -> <:patt< ` $s$ >> + | "#"; i = type_longident -> <:patt< # $i$ >> + | `LABEL i; p = SELF -> <:patt< ~ $i$ : $p$ >> + | "~"; `ANTIQUOT (""|"lid" as n) i; ":"; p = SELF -> + <:patt< ~ $mk_anti n i$ : $p$ >> + | "~"; `ANTIQUOT (""|"lid" as n) i -> <:patt< ~ $mk_anti n i$ >> + | "~"; `LIDENT i -> <:patt< ~ $i$ >> + (* | i = opt_label; "("; p = patt_tcon; ")" -> *) + (* <:patt< ? $i$ : ($p$) >> *) + | `OPTLABEL i; "("; p = patt_tcon; f = eq_expr; ")" -> f i p + | "?"; `ANTIQUOT (""|"lid" as n) i; ":"; "("; p = patt_tcon; f = eq_expr; ")" -> + f (mk_anti n i) p + | "?"; `LIDENT i -> <:patt< ? $i$ >> + | "?"; `ANTIQUOT (""|"lid" as n) i -> <:patt< ? $mk_anti n i$ >> + | "?"; "("; p = patt_tcon; ")" -> + <:patt< ? ($p$) >> + | "?"; "("; p = patt_tcon; "="; e = expr; ")" -> + <:patt< ? ($p$ = $e$) >> ] ] + ; + comma_patt: + [ [ p1 = SELF; ","; p2 = SELF -> <:patt< $p1$, $p2$ >> + | p = patt -> p ] ] + ; + sem_patt: + [ LEFTA + [ p1 = SELF; ";"; p2 = SELF -> <:patt< $p1$; $p2$ >> + | p = patt -> p ] ] + ; + sem_patt_for_list: + [ [ p = patt; ";"; pl = SELF -> fun acc -> <:patt< [ $p$ :: $pl acc$ ] >> + | p = patt -> fun acc -> <:patt< [ $p$ :: $acc$ ] >> + ] ] + ; + label_patt: + [ LEFTA + [ p1 = SELF; ";"; p2 = SELF -> <:patt< $p1$; $p2$ >> + | `ANTIQUOT (""|"pat"|"anti" as n) s -> + <:patt< $anti:mk_anti ~c:"patt" n s$ >> + | `ANTIQUOT ("list" as n) s -> + <:patt< $anti:mk_anti ~c:"patt;" n s$ >> + | i = label_longident; "="; p = patt -> <:patt< $id:i$ = $p$ >> + ] ] + ; + ipatt: + [ [ "{"; pl = label_ipatt; "}" -> <:patt< { $pl$ } >> + | `ANTIQUOT (""|"pat"|"anti" as n) s -> + <:patt< $anti:mk_anti ~c:"patt" n s$ >> + | `ANTIQUOT ("tup" as n) s -> + <:patt< ($tup:<:patt< $anti:mk_anti ~c:"patt" n s$ >>$) >> + | "("; ")" -> <:patt< () >> + | "("; p = SELF; ")" -> p + | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> + | "("; p = SELF; "as"; p2 = SELF; ")" -> <:patt< ($p$ as $p2$) >> + | "("; p = SELF; ","; pl = comma_ipatt; ")" -> <:patt< ($p$, $pl$) >> + | s = a_LIDENT -> <:patt< $lid:s$ >> + | "_" -> <:patt< _ >> ] ] + ; + labeled_ipatt: + [ [ p = ipatt -> p ] ] + ; + comma_ipatt: + [ LEFTA + [ p1 = SELF; ","; p2 = SELF -> <:patt< $p1$, $p2$ >> + | p = ipatt -> p ] ] + ; + label_ipatt: + [ LEFTA + [ p1 = SELF; ";"; p2 = SELF -> <:patt< $p1$; $p2$ >> + | `ANTIQUOT (""|"pat"|"anti" as n) s -> + <:patt< $anti:mk_anti ~c:"patt" n s$ >> + | i = label_longident; "="; p = ipatt -> <:patt< $id:i$ = $p$ >> + ] ] + ; + type_declaration: + [ LEFTA + [ `ANTIQUOT (""|"typ"|"anti" as n) s -> + <:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >> + | `ANTIQUOT ("list" as n) s -> + <:ctyp< $anti:mk_anti ~c:"ctypand" n s$ >> + | t1 = SELF; "and"; t2 = SELF -> <:ctyp< $t1$ and $t2$ >> + | (n, tpl) = type_ident_and_parameters; tk = opt_eq_ctyp; + cl = LIST0 constrain -> Ast.TyDcl _loc n tpl (tk tpl) cl ] ] + ; + constrain: + [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ] + ; + opt_eq_ctyp: + [ [ "="; tk = type_kind -> fun _ -> tk + | -> fun tpl -> <:ctyp< '$choose_tvar tpl$ >> ] ] + ; + type_kind: + [ [ t = ctyp -> t ] ] + ; + type_ident_and_parameters: + [ [ i = a_LIDENT; tpl = LIST0 type_parameter -> (i, tpl) ] ] + ; + type_longident_and_parameters: + [ [ i = type_longident; tpl = type_parameters -> tpl <:ctyp< $id:i$ >> + ] ] + ; + type_parameters: + [ [ t1 = type_parameter; t2 = SELF -> + fun acc -> t2 <:ctyp< $acc$ $t1$ >> + | t = type_parameter -> fun acc -> <:ctyp< $acc$ $t$ >> + | -> fun t -> t + ] ] + ; + type_parameter: + [ [ `ANTIQUOT (""|"typ"|"anti" as n) s -> <:ctyp< $anti:mk_anti n s$ >> + | "'"; i = a_ident -> <:ctyp< '$lid:i$ >> + | "+"; "'"; i = a_ident -> <:ctyp< +'$lid:i$ >> + | "-"; "'"; i = a_ident -> <:ctyp< -'$lid:i$ >> ] ] + ; + ctyp: + [ LEFTA + [ t1 = SELF; "=="; t2 = SELF -> <:ctyp< $t1$ == $t2$ >> ] + | NONA + [ "private"; t = ctyp LEVEL "alias" -> <:ctyp< private $t$ >> ] + | "alias" LEFTA + [ t1 = SELF; "as"; t2 = SELF -> <:ctyp< $t1$ as $t2$ >> ] + | LEFTA + [ "!"; t1 = typevars; "."; t2 = ctyp -> <:ctyp< ! $t1$ . $t2$ >> ] + | "arrow" RIGHTA + [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ] + | "label" NONA + [ "~"; i = a_LIDENT; ":"; t = SELF -> <:ctyp< ~ $i$ : $t$ >> + | i = a_LABEL; t = SELF -> <:ctyp< ~ $i$ : $t$ >> + | "?"; i = a_LIDENT; ":"; t = SELF -> <:ctyp< ? $i$ : $t$ >> + | i = a_OPTLABEL; t = SELF -> <:ctyp< ? $i$ : $t$ >> ] + | LEFTA + [ t1 = SELF; t2 = SELF -> + let t = <:ctyp< $t1$ $t2$ >> in + try <:ctyp< $id:Ast.ident_of_ctyp t$ >> + with [ Invalid_argument _ -> t ] ] + | LEFTA + [ t1 = SELF; "."; t2 = SELF -> + try <:ctyp< $id:Ast.ident_of_ctyp t1$.$id:Ast.ident_of_ctyp t2$ >> + with [ Invalid_argument s -> raise (Stream.Error s) ] ] + | "simple" + [ "'"; i = a_ident -> <:ctyp< '$i$ >> + | "_" -> <:ctyp< _ >> + | `ANTIQUOT (""|"typ"|"anti" as n) s -> + <:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >> + | `ANTIQUOT ("tup" as n) s -> + <:ctyp< ($tup:<:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >>$) >> + | `ANTIQUOT ("id" as n) s -> + <:ctyp< $id:<:ident< $anti:mk_anti ~c:"ident" n s$ >>$ >> + | i = a_LIDENT -> <:ctyp< $lid:i$ >> + | i = a_UIDENT -> <:ctyp< $uid:i$ >> + | "("; t = SELF; "*"; tl = star_ctyp; ")" -> + <:ctyp< ( $t$ * $tl$ ) >> + | "("; t = SELF; ")" -> t + | "["; t = constructor_declarations; "]" -> <:ctyp< [ $t$ ] >> + | "["; "="; rfl = row_field; "]" -> + <:ctyp< [ = $rfl$ ] >> + | "["; ">"; "]" -> <:ctyp< [ > $<:ctyp<>>$ ] >> + | "["; ">"; rfl = row_field; "]" -> + <:ctyp< [ > $rfl$ ] >> + | "["; "<"; rfl = row_field; "]" -> + <:ctyp< [ < $rfl$ ] >> + | "["; "<"; rfl = row_field; ">"; ntl = name_tags; "]" -> + <:ctyp< [ < $rfl$ > $ntl$ ] >> + | "[<"; rfl = row_field; "]" -> + <:ctyp< [ < $rfl$ ] >> + | "[<"; rfl = row_field; ">"; ntl = name_tags; "]" -> + <:ctyp< [ < $rfl$ > $ntl$ ] >> + | "{"; t = label_declaration; OPT ";"; "}" -> <:ctyp< { $t$ } >> + | "#"; i = class_longident -> <:ctyp< # $i$ >> + | "<"; ml = opt_meth_list; v = opt_dot_dot; ">" -> + <:ctyp< < $ml$ $..:v$ > >> + ] ] + ; + star_ctyp: + [ [ t1 = SELF; "*"; t2 = SELF -> <:ctyp< $t1$ * $t2$ >> + | t = ctyp -> t + ] ] + ; + constructor_declarations: + [ [ l = LIST1 constructor_declaration SEP "|" -> Ast.tyOr_of_list l ] ] + ; + constructor_declaration: + [ [ `ANTIQUOT (""|"typ" as n) s -> + <:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >> + | s = a_UIDENT; "of"; t = constructor_arg_list -> + <:ctyp< $uid:s$ of $t$ >> + | s = a_UIDENT -> <:ctyp< $uid:s$ >> + ] ] + ; + constructor_arg_list: + [ [ `ANTIQUOT ("list" as n) s -> + <:ctyp< $anti:mk_anti ~c:"ctypand" n s$ >> + | t1 = SELF; "and"; t2 = SELF -> <:ctyp< $t1$ and $t2$ >> + | t = ctyp -> t + ] ] + ; + label_declaration: + [ LEFTA + [ t1 = SELF; ";"; t2 = SELF -> <:ctyp< $t1$; $t2$ >> + | `ANTIQUOT (""|"typ" as n) s -> + <:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >> + | s = a_LIDENT; ":"; t = poly_type -> <:ctyp< $lid:s$ : $t$ >> + | s = a_LIDENT; ":"; "mutable"; t = poly_type -> + <:ctyp< $lid:s$ : mutable $t$ >> + ] ] + ; + a_ident: + [ [ i = a_LIDENT -> i + | i = a_UIDENT -> i ] ] + ; + ident: + [ [ `ANTIQUOT (""|"id"|"anti"|"list" as n) s -> + <:ident< $anti:mk_anti ~c:"ident" n s$ >> + | i = a_UIDENT -> <:ident< $uid:i$ >> + | i = a_LIDENT -> <:ident< $lid:i$ >> + | `ANTIQUOT (""|"id"|"anti"|"list" as n) s; "."; i = SELF -> + <:ident< $anti:mk_anti ~c:"ident" n s$.$i$ >> + | i = a_UIDENT; "."; j = SELF -> <:ident< $uid:i$.$j$ >> ] ] + ; + module_longident: + [ [ `ANTIQUOT (""|"id"|"anti"|"list" as n) s -> + <:ident< $anti:mk_anti ~c:"ident" n s$ >> + | m = a_UIDENT; "."; l = SELF -> <:ident< $uid:m$.$l$ >> + | i = a_UIDENT -> <:ident< $uid:i$ >> ] ] + ; + module_longident_with_app: + [ [ i = SELF; j = SELF -> <:ident< $i$ $j$ >> ] + | [ i = SELF; "."; j = SELF -> <:ident< $i$.$j$ >> ] + | [ `ANTIQUOT (""|"id"|"anti"|"list" as n) s -> + <:ident< $anti:mk_anti ~c:"ident" n s$ >> + | i = a_UIDENT -> <:ident< $uid:i$ >> + | "("; i = SELF; ")" -> i ] ] + ; + type_longident: + [ [ i = SELF; j = SELF -> <:ident< $i$ $j$ >> ] + | [ i = SELF; "."; j = SELF -> <:ident< $i$.$j$ >> ] + | [ `ANTIQUOT (""|"id"|"anti"|"list" as n) s -> + <:ident< $anti:mk_anti ~c:"ident" n s$ >> + | i = a_LIDENT -> <:ident< $lid:i$ >> + | i = a_UIDENT -> <:ident< $uid:i$ >> + | "("; i = SELF; ")" -> i ] ] + ; + label_longident: + [ [ `ANTIQUOT (""|"id"|"anti"|"list" as n) s -> + <:ident< $anti:mk_anti ~c:"ident" n s$ >> + | m = a_UIDENT; "."; l = SELF -> <:ident< $uid:m$.$l$ >> + | i = a_LIDENT -> <:ident< $lid:i$ >> ] ] + ; + class_type_longident: + [ [ x = type_longident -> x ] ] + ; + val_longident: + [ [ x = ident -> x ] ] + ; + class_longident: + [ [ x = label_longident -> x ] ] + ; + class_declaration: + [ LEFTA + [ c1 = SELF; "and"; c2 = SELF -> + <:class_expr< $c1$ and $c2$ >> + | `ANTIQUOT (""|"cdcl"|"anti"|"list" as n) s -> + <:class_expr< $anti:mk_anti ~c:"class_expr" n s$ >> + | ci = class_info_for_class_expr; ce = class_fun_binding -> + <:class_expr< $ci$ = $ce$ >> + ] ] + ; + class_fun_binding: + [ [ "="; ce = class_expr -> ce + | ":"; ct = class_type_plus; "="; ce = class_expr -> + <:class_expr< ($ce$ : $ct$) >> + | p = labeled_ipatt; cfb = SELF -> + <:class_expr< fun $p$ -> $cfb$ >> + ] ] + ; + class_info_for_class_type: + [ [ mv = opt_virtual; (i, ot) = class_name_and_param -> + Ast.CtCon _loc mv (Ast.IdLid _loc i) ot + (* <:class_type< $virtual:mv$ $lid:i$ [ $t$ ] >> *) + + (* | mv = opt_virtual; i = a_LIDENT -> *) + (* Ast.CeCon (_loc, mv, Ast.IdLid (_loc, i), Ast.ONone) *) + (* <:class_type< $lid:i$ >> *) + ] ] + ; + (* [ [ "virtual"; i = a_LIDENT; "["; t = comma_type_parameter; "]" -> + <:class_type< virtual $lid:i$ [ $t$ ] >> + | "virtual"; i = a_LIDENT -> + <:class_type< virtual $lid:i$ >> + | i = a_LIDENT; "["; t = comma_type_parameter; "]" -> + <:class_type< $lid:i$ [ $t$ ] >> + | i = a_LIDENT -> <:class_type< $lid:i$ >> + ] ] + ; *) + class_info_for_class_expr: + [ [ + (* "virtual"; i = a_LIDENT; "["; t = comma_type_parameter; "]" -> *) + (* <:class_expr< virtual $lid:i$ [ $t$ ] >> *) + (* | "virtual"; i = a_LIDENT -> *) + (* <:class_expr< virtual $lid:i$ >> *) + (* | *) + mv = opt_virtual; (i, ot) = class_name_and_param -> + Ast.CeCon _loc mv (Ast.IdLid _loc i) ot + (* <:class_expr< $virtual:mv$ $lid:i$ [ $t$ ] >> *) + + (* <:class_expr< $lid:i$ [ $t$ ] >> *) + (* | mv = opt_virtual; i = a_LIDENT -> *) + (* Ast.CeCon (_loc, mv, Ast.IdLid (_loc, i), Ast.ONone) *) + (* <:class_expr< $lid:i$ >> *) + ] ] + ; + class_name_and_param: + [ [ i = a_LIDENT; "["; x = comma_type_parameter; "]" -> (i, x) + | i = a_LIDENT -> (i, <:ctyp<>>) + ] ] + ; + comma_type_parameter: + [ LEFTA + [ t1 = SELF; ","; t2 = SELF -> <:ctyp< $t1$, $t2$ >> + | t = type_parameter -> t + ] ] + ; + opt_comma_ctyp: + [ [ "["; x = comma_ctyp; "]" -> x + | -> <:ctyp<>> + ] ] + ; + comma_ctyp: + [ [ t1 = SELF; ","; t2 = SELF -> <:ctyp< $t1$, $t2$ >> + | t = ctyp -> t + ] ] + ; + class_fun_def: + [ [ p = labeled_ipatt; ce = SELF -> <:class_expr< fun $p$ -> $ce$ >> + | "->"; ce = class_expr -> ce ] ] + ; + class_expr: + [ "top" + [ "fun"; p = labeled_ipatt; ce = class_fun_def -> + <:class_expr< fun $p$ -> $ce$ >> + | "let"; rf = opt_rec; bi = binding; "in"; ce = SELF -> + <:class_expr< let $rec:rf$ $bi$ in $ce$ >> ] + | "apply" NONA + [ ce = SELF; e = expr LEVEL "label" -> + <:class_expr< $ce$ $e$ >> ] + | "simple" + [ `ANTIQUOT (""|"cexp"|"anti" as n) s -> + <:class_expr< $anti:mk_anti ~c:"class_expr" n s$ >> + | ce = class_longident_and_param -> ce + | "object"; csp = opt_class_self_patt; cst = class_structure; "end" -> + <:class_expr< object ($csp$) $cst$ end >> + | "("; ce = SELF; ":"; ct = class_type; ")" -> + <:class_expr< ($ce$ : $ct$) >> + | "("; ce = SELF; ")" -> ce ] ] + ; + class_longident_and_param: + [ [ ci = class_longident; "["; t = comma_ctyp; "]" -> + <:class_expr< $id:ci$ [ $t$ ] >> + | ci = class_longident -> <:class_expr< $id:ci$ >> + ] ] + ; + class_structure: + [ [ `ANTIQUOT (""|"cst"|"anti"|"list" as n) s -> + <:class_str_item< $anti:mk_anti ~c:"class_str_item" n s$ >> + | l = LIST0 [ cst = class_str_item; semi -> cst ] -> Ast.crSem_of_list l + ] ] + ; + opt_class_self_patt: + [ [ "("; p = patt; ")" -> p + | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> + | -> <:patt<>> ] ] + ; + class_str_item: + [ LEFTA + [ `ANTIQUOT (""|"cst"|"anti"|"list" as n) s -> + <:class_str_item< $anti:mk_anti ~c:"class_str_item" n s$ >> + | "inherit"; ce = class_expr; pb = opt_as_lident -> + <:class_str_item< inherit $ce$ as $pb$ >> + | value_val; mf = opt_mutable; lab = label; e = cvalue_binding -> + <:class_str_item< value $mutable:mf$ $lab$ = $e$ >> + | value_val; "virtual"; mf = opt_mutable; l = label; ":"; t = poly_type -> + <:class_str_item< value virtual $mutable:mf$ $l$ : $t$ >> + | "method"; "virtual"; pf = opt_private; l = label; ":"; t = poly_type -> + <:class_str_item< method virtual $private:pf$ $l$ : $t$ >> + | "method"; pf = opt_private; l = label; topt = opt_polyt; + e = fun_binding -> + <:class_str_item< method $private:pf$ $l$ : $topt$ = $e$ >> + | "type"; t1 = ctyp; "="; t2 = ctyp -> + <:class_str_item< type $t1$ = $t2$ >> + | "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ] + ; + opt_as_lident: + [ [ "as"; i = a_LIDENT -> i + | -> "" + ] ] + ; + opt_polyt: + [ [ ":"; t = poly_type -> t + | -> <:ctyp<>> ] ] + ; + cvalue_binding: + [ [ "="; e = expr -> e + | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> + | ":"; t = ctyp; ":>"; t2 = ctyp; "="; e = expr -> + <:expr< ($e$ : $t$ :> $t2$) >> + | ":>"; t = ctyp; "="; e = expr -> <:expr< ($e$ :> $t$) >> ] ] + ; + label: + [ [ i = a_LIDENT -> i ] ] + ; + class_type: + [ [ `ANTIQUOT (""|"ctyp"|"anti" as n) s -> + <:class_type< $anti:mk_anti ~c:"class_type" n s$ >> + | ct = class_type_longident_and_param -> ct + | "object"; cst = opt_class_self_type; csg = class_signature; "end" -> + <:class_type< object ($cst$) $csg$ end >> ] ] + ; + class_type_longident_and_param: + [ [ i = class_type_longident; "["; t = comma_ctyp; "]" -> + <:class_type< $id:i$ [ $t$ ] >> + | i = class_type_longident -> <:class_type< $id:i$ >> ] ] + ; + class_type_plus: + [ [ "["; t = ctyp; "]"; "->"; ct = SELF -> <:class_type< [ $t$ ] -> $ct$ >> + | ct = class_type -> ct ] ] + ; + opt_class_self_type: + [ [ "("; t = ctyp; ")" -> t + | -> <:ctyp<>> ] ] + ; + class_signature: + [ [ `ANTIQUOT (""|"csg"|"anti"|"list" as n) s -> + <:class_sig_item< $anti:mk_anti ~c:"class_sig_item" n s$ >> + | l = LIST0 [ csg = class_sig_item; semi -> csg ] -> Ast.cgSem_of_list l + ] ] + ; + class_sig_item: + [ [ `ANTIQUOT (""|"csg"|"anti"|"list" as n) s -> + <:class_sig_item< $anti:mk_anti ~c:"class_sig_item" n s$ >> + | "inherit"; cs = class_type -> <:class_sig_item< inherit $cs$ >> + | value_val; mf = opt_mutable; mv = opt_virtual; + l = label; ":"; t = ctyp -> + <:class_sig_item< value $mutable:mf$ $virtual:mv$ $l$ : $t$ >> + | "method"; "virtual"; pf = opt_private; l = label; ":"; t = poly_type -> + <:class_sig_item< method virtual $private:pf$ $l$ : $t$ >> + | "method"; pf = opt_private; l = label; ":"; t = poly_type -> + <:class_sig_item< method $private:pf$ $l$ : $t$ >> + | type_constraint; t1 = ctyp; "="; t2 = ctyp -> + <:class_sig_item< type $t1$ = $t2$ >> ] ] + ; + type_constraint: + [ [ "type" -> () ] ] + ; + class_description: + [ [ cd1 = SELF; "and"; cd2 = SELF -> <:class_type< $cd1$ and $cd2$ >> + | `ANTIQUOT (""|"typ"|"anti"|"list" as n) s -> + <:class_type< $anti:mk_anti ~c:"class_type" n s$ >> + | ci = class_info_for_class_type; ":"; ct = class_type_plus -> <:class_type< $ci$ : $ct$ >> + ] ] + ; + class_type_declaration: + [ LEFTA + [ cd1 = SELF; "and"; cd2 = SELF -> <:class_type< $cd1$ and $cd2$ >> + | `ANTIQUOT (""|"typ"|"anti"|"list" as n) s -> + <:class_type< $anti:mk_anti ~c:"class_type" n s$ >> + | ci = class_info_for_class_type; "="; ct = class_type -> <:class_type< $ci$ = $ct$ >> + ] ] + ; + field_expr: + [ LEFTA + [ b1 = SELF; ";"; b2 = SELF -> <:binding< $b1$ ; $b2$ >> + | `ANTIQUOT (""|"bi"|"anti" as n) s -> + <:binding< $anti:mk_anti ~c:"binding" n s$ >> + | `ANTIQUOT ("list" as n) s -> + <:binding< $anti:mk_anti ~c:"binding;" n s$ >> + | l = label; "="; e = expr -> <:binding< $lid:l$ = $e$ >> ] ] + ; + meth_list: + [ [ f = field; ";"; ml = SELF -> <:ctyp< $f$; $ml$ >> + | f = field; OPT ";" -> f ] ] + ; + opt_meth_list: + [ [ ml = meth_list -> ml + | -> <:ctyp<>> + ] ] + ; + field: + [ [ `ANTIQUOT (""|"typ" as n) s -> + <:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >> + | lab = a_LIDENT; ":"; t = poly_type -> <:ctyp< $lid:lab$ : $t$ >> ] ] + ; + poly_type: + [ [ t = ctyp -> t ] ] + ; + typevars: + [ LEFTA + [ t1 = SELF; t2 = SELF -> <:ctyp< $t1$ $t2$ >> + | `ANTIQUOT (""|"typ" as n) s -> + <:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >> + | "'"; i = a_ident -> <:ctyp< '$lid:i$ >> + ] ] + ; + row_field: + [ [ `ANTIQUOT (""|"typ" as n) s -> + <:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >> + | t1 = SELF; "|"; t2 = SELF -> <:ctyp< $t1$ | $t2$ >> + | "`"; i = a_ident -> <:ctyp< `$i$ >> + | "`"; i = a_ident; "of"; "&"; t = amp_ctyp -> <:ctyp< `$i$ of & $t$ >> + | "`"; i = a_ident; "of"; t = amp_ctyp -> <:ctyp< `$i$ of $t$ >> + | t = ctyp -> t ] ] + ; + sem_ctyp: + [ [ t1 = SELF; ";"; t2 = SELF -> <:ctyp< $t1$ ; $t2$ >> + | t = ctyp -> t + ] ] + ; + pipe_ctyp: + [ [ t1 = SELF; "|"; t2 = SELF -> <:ctyp< $t1$ | $t2$ >> + | t = ctyp -> t + ] ] + ; + amp_ctyp: + [ [ t1 = SELF; "&"; t2 = SELF -> <:ctyp< $t1$ & $t2$ >> + | t = ctyp -> t + ] ] + ; + name_tags: + [ [ `ANTIQUOT (""|"typ" as n) s -> + <:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >> + | t1 = SELF; t2 = SELF -> <:ctyp< $t1$ $t2$ >> + | "`"; i = a_ident -> <:ctyp< `$i$ >> + ] ] + ; + eq_expr: + [ [ "="; e = expr -> fun i p -> <:patt< ? $i$ : ($p$ = $e$) >> + | -> fun i p -> <:patt< ? $i$ : ($p$) >> ] ] + ; + patt_tcon: + [ [ p = patt; ":"; t = ctyp -> <:patt< ($p$ : $t$) >> + | p = patt -> p ] ] + ; + ipatt: + [ [ `LABEL i; p = SELF -> <:patt< ~ $i$ : $p$ >> + | "~"; `ANTIQUOT (""|"lid" as n) i; ":"; p = SELF -> + <:patt< ~ $mk_anti n i$ : $p$ >> + | "~"; `ANTIQUOT (""|"lid" as n) i -> <:patt< ~ $mk_anti n i$ >> + | "~"; `LIDENT i -> <:patt< ~ $i$ >> + (* | i = opt_label; "("; p = ipatt_tcon; ")" -> + <:patt< ? $i$ : ($p$) >> + | i = opt_label; "("; p = ipatt_tcon; "="; e = expr; ")" -> + <:patt< ? $i$ : ($p$ = $e$) >> *) + | `OPTLABEL i; "("; p = ipatt_tcon; f = eq_expr; ")" -> f i p + | "?"; `ANTIQUOT (""|"lid" as n) i; ":"; "("; p = ipatt_tcon; + f = eq_expr; ")" -> f (mk_anti n i) p + | "?"; `LIDENT i -> <:patt< ? $i$ >> + | "?"; `ANTIQUOT (""|"lid" as n) i -> <:patt< ? $mk_anti n i$ >> + | "?"; "("; p = ipatt_tcon; ")" -> + <:patt< ? ($p$) >> + | "?"; "("; p = ipatt_tcon; "="; e = expr; ")" -> + <:patt< ? ($p$ = $e$) >> ] ] + ; + ipatt_tcon: + [ [ p = ipatt; ":"; t = ctyp -> <:patt< ($p$ : $t$) >> + | p = ipatt -> p ] ] + ; + direction_flag: + [ [ "to" -> Ast.BTrue + | "downto" -> Ast.BFalse + | `ANTIQUOT ("to" as n) s -> Ast.BAnt (mk_anti n s) ] ] + ; + opt_private: + [ [ "private" -> Ast.BTrue + | `ANTIQUOT ("private" as n) s -> Ast.BAnt (mk_anti n s) + | -> Ast.BFalse + ] ] + ; + opt_mutable: + [ [ "mutable" -> Ast.BTrue + | `ANTIQUOT ("mutable" as n) s -> Ast.BAnt (mk_anti n s) + | -> Ast.BFalse + ] ] + ; + opt_virtual: + [ [ "virtual" -> Ast.BTrue + | `ANTIQUOT ("virtual" as n) s -> Ast.BAnt (mk_anti n s) + | -> Ast.BFalse + ] ] + ; + opt_dot_dot: + [ [ ".." -> Ast.BTrue + | `ANTIQUOT (".." as n) s -> Ast.BAnt (mk_anti n s) + | -> Ast.BFalse + ] ] + ; + opt_rec: + [ [ "rec" -> Ast.BTrue + | `ANTIQUOT ("rec" as n) s -> Ast.BAnt (mk_anti n s) + | -> Ast.BFalse + ] ] + ; + opt_expr: + [ [ e = expr -> e + | -> <:expr<>> + ] ] + ; + interf: + [ [ "#"; n = a_LIDENT; dp = opt_expr; semi -> + ([ <:sig_item< # $n$ $dp$ >> ], stopped_at _loc) + | si = sig_item; semi; (sil, stopped) = SELF -> ([si :: sil], stopped) + | `EOI -> ([], None) ] ] + ; + sig_items: + [ [ `ANTIQUOT (""|"sigi"|"anti"|"list" as n) s -> + <:sig_item< $anti:mk_anti n ~c:"sig_item" s$ >> + | l = LIST0 [ sg = sig_item; semi -> sg ] -> Ast.sgSem_of_list l + ] ] + ; + implem: + [ [ "#"; n = a_LIDENT; dp = opt_expr; semi -> + ([ <:str_item< # $n$ $dp$ >> ], stopped_at _loc) + | si = str_item; semi; (sil, stopped) = SELF -> ([si :: sil], stopped) + | `EOI -> ([], None) + ] ] + ; + str_items: + [ [ `ANTIQUOT (""|"stri"|"anti"|"list" as n) s -> + <:str_item< $anti:mk_anti n ~c:"str_item" s$ >> + | l = LIST0 [ st = str_item; semi -> st ] -> Ast.stSem_of_list l + ] ] + ; + top_phrase: + [ [ ph = phrase -> Some ph + | `EOI -> None + ] ] + ; + use_file: + [ [ "#"; n = a_LIDENT; dp = opt_expr; semi -> + ([ <:str_item< # $n$ $dp$ >> ], stopped_at _loc) + | si = str_item; semi; (sil, stopped) = SELF -> ([si :: sil], stopped) + | `EOI -> ([], None) + ] ] + ; + phrase: + [ [ "#"; n = a_LIDENT; dp = opt_expr; semi -> + <:str_item< # $n$ $dp$ >> + | st = str_item; semi -> st + ] ] + ; + a_INT: + [ [ `ANTIQUOT (""|"int"|"`int" as n) s -> mk_anti n s + | `INT _ s -> s ] ] + ; + a_INT32: + [ [ `ANTIQUOT (""|"int32"|"`int32" as n) s -> mk_anti n s + | `INT32 _ s -> s ] ] + ; + a_INT64: + [ [ `ANTIQUOT (""|"int64"|"`int64" as n) s -> mk_anti n s + | `INT64 _ s -> s ] ] + ; + a_NATIVEINT: + [ [ `ANTIQUOT (""|"nativeint"|"`nativeint" as n) s -> mk_anti n s + | `NATIVEINT _ s -> s ] ] + ; + a_FLOAT: + [ [ `ANTIQUOT (""|"flo"|"`flo" as n) s -> mk_anti n s + | `FLOAT _ s -> s ] ] + ; + a_CHAR: + [ [ `ANTIQUOT (""|"chr"|"`chr" as n) s -> mk_anti n s + | `CHAR _ s -> s ] ] + ; + a_UIDENT: + [ [ `ANTIQUOT (""|"uid" as n) s -> mk_anti n s + | `UIDENT s -> s ] ] + ; + a_LIDENT: + [ [ `ANTIQUOT (""|"lid" as n) s -> mk_anti n s + | `LIDENT s -> s ] ] + ; + a_LIDENT_or_operator: + [ [ x = a_LIDENT -> x ] ] + ; + a_LABEL: + [ [ "~"; `ANTIQUOT ("" as n) s; ":" -> mk_anti n s + | `LABEL s -> s ] ] + ; + a_OPTLABEL: + [ [ "?"; `ANTIQUOT ("" as n) s; ":" -> mk_anti n s + | `OPTLABEL s -> s ] ] + ; + a_STRING: + [ [ `ANTIQUOT (""|"str"|"`str" as n) s -> mk_anti n s + | `STRING _ s -> s ] ] + ; + string_list: + [ [ `ANTIQUOT (""|"str_list") s -> Ast.LAnt (mk_anti "str_list" s) + | `STRING _ x; xs = string_list -> Ast.LCons x xs + | `STRING _ x -> Ast.LCons x Ast.LNil ] ] + ; + value_let: + [ [ "value" -> () ] ] + ; + value_val: + [ [ "value" -> () ] ] + ; + semi: + [ [ ";" -> () ] ] + ; + expr_quot: + [ [ e1 = expr; ","; e2 = comma_expr -> <:expr< $e1$, $e2$ >> + | e1 = expr; ";"; e2 = sem_expr -> <:expr< $e1$; $e2$ >> + | e = expr -> e + | -> <:expr<>> + ] ] + ; + patt_quot: + [ [ x = patt; ","; y = comma_patt -> <:patt< $x$, $y$ >> + | x = patt; ";"; y = sem_patt -> <:patt< $x$; $y$ >> + | x = patt; "="; y = patt -> <:patt< $x$ = $y$ >> + | x = patt -> x + | -> <:patt<>> + ] ] + ; + ctyp_quot: + [ [ x = more_ctyp; ","; y = comma_ctyp -> <:ctyp< $x$, $y$ >> + | x = more_ctyp; ";"; y = sem_ctyp -> <:ctyp< $x$; $y$ >> + | x = more_ctyp; "|"; y = pipe_ctyp -> <:ctyp< $x$ | $y$ >> + | x = more_ctyp; "of"; y = constructor_arg_list -> <:ctyp< $x$ of $y$ >> + | x = more_ctyp; "of"; "&"; y = amp_ctyp -> <:ctyp< $x$ of & $y$ >> + | x = more_ctyp; ":"; y = more_ctyp -> <:ctyp< $x$ : $y$ >> + | x = more_ctyp; "*"; y = star_ctyp -> <:ctyp< $x$ * $y$ >> + | x = more_ctyp; "&"; y = amp_ctyp -> <:ctyp< $x$ & $y$ >> + | x = more_ctyp; "and"; y = constructor_arg_list -> <:ctyp< $x$ and $y$ >> + | x = more_ctyp -> x + | -> <:ctyp<>> + ] ] + ; + more_ctyp: + [ [ "mutable"; x = SELF -> <:ctyp< mutable $x$ >> + | "`"; x = a_LIDENT -> <:ctyp< `$x$ >> + | x = ctyp -> x + | x = type_parameter -> x + ] ] + ; + str_item_quot: + [ [ "#"; n = a_LIDENT; dp = opt_expr -> <:str_item< # $n$ $dp$ >> + | st1 = str_item; semi; st2 = SELF -> <:str_item< $st1$; $st2$ >> + | st = str_item -> st + | -> <:str_item<>> ] ] + ; + sig_item_quot: + [ [ "#"; n = a_LIDENT; dp = opt_expr -> <:sig_item< # $n$ $dp$ >> + | sg1 = sig_item; semi; sg2 = SELF -> <:sig_item< $sg1$; $sg2$ >> + | sg = sig_item -> sg + | -> <:sig_item<>> ] ] + ; + module_type_quot: + [ [ x = module_type -> x + ] ] + ; + module_expr_quot: + [ [ x = module_expr -> x + ] ] + ; + match_case_quot: + [ [ x = match_case -> x + | -> <:match_case<>> ] ] + ; + binding_quot: + [ [ b1 = SELF; "and"; b2 = SELF -> <:binding< $b1$ and $b2$ >> + | b1 = SELF; ";"; b2 = SELF -> <:binding< $b1$ ; $b2$ >> + | x = binding -> x + | x = label_expr -> x + | -> <:binding<>> + ] ] + ; + module_binding_quot: + [ [ b1 = SELF; "and"; b2 = SELF -> + <:module_binding< $b1$ and $b2$ >> + | `ANTIQUOT ("module_binding"|"anti" as n) s -> + <:module_binding< $anti:mk_anti ~c:"module_binding" n s$ >> + | `ANTIQUOT ("" as n) s -> <:module_binding< $anti:mk_anti ~c:"module_binding" n s$ >> + | `ANTIQUOT ("" as n) m; ":"; mt = module_type -> + <:module_binding< $mk_anti n m$ : $mt$ >> + | `ANTIQUOT ("" as n) m; ":"; mt = module_type; "="; me = module_expr -> + <:module_binding< $mk_anti n m$ : $mt$ = $me$ >> + | m = a_UIDENT; ":"; mt = module_type -> <:module_binding< $m$ : $mt$ >> + | m = a_UIDENT; ":"; mt = module_type; "="; me = module_expr -> + <:module_binding< $m$ : $mt$ = $me$ >> + | -> <:module_binding<>> + ] ] + ; + ident_quot: + [ [ i = SELF; j = SELF -> <:ident< $i$ $j$ >> ] + | [ i = SELF; "."; j = SELF -> <:ident< $i$.$j$ >> ] + | [ `ANTIQUOT (""|"id"|"anti"|"list" as n) s -> + <:ident< $anti:mk_anti ~c:"ident" n s$ >> + | i = a_UIDENT -> <:ident< $uid:i$ >> + | i = a_LIDENT -> <:ident< $lid:i$ >> + | `ANTIQUOT (""|"id"|"anti"|"list" as n) s; "."; i = SELF -> + <:ident< $anti:mk_anti ~c:"ident" n s$.$i$ >> + | "("; i = SELF; ")" -> i + ] ] + ; + class_expr_quot: + [ [ ce1 = SELF; "and"; ce2 = SELF -> <:class_expr< $ce1$ and $ce2$ >> + | ce1 = SELF; "="; ce2 = SELF -> <:class_expr< $ce1$ = $ce2$ >> + | "virtual"; (i, ot) = class_name_and_param -> + Ast.CeCon _loc Ast.BTrue (Ast.IdLid _loc i) ot + | `ANTIQUOT ("virtual" as n) s; i = ident; ot = opt_comma_ctyp -> + Ast.CeCon _loc (Ast.BAnt (mk_anti ~c:"class_expr" n s)) i ot + | x = class_expr -> x + | -> <:class_expr<>> + ] ] + ; + class_type_quot: + [ [ ct1 = SELF; "and"; ct2 = SELF -> <:class_type< $ct1$ and $ct2$ >> + | ct1 = SELF; "="; ct2 = SELF -> <:class_type< $ct1$ = $ct2$ >> + | ct1 = SELF; ":"; ct2 = SELF -> <:class_type< $ct1$ : $ct2$ >> + | "virtual"; (i, ot) = class_name_and_param -> + Ast.CtCon _loc Ast.BTrue (Ast.IdLid _loc i) ot + | `ANTIQUOT ("virtual" as n) s; i = ident; ot = opt_comma_ctyp -> + Ast.CtCon _loc (Ast.BAnt (mk_anti ~c:"class_type" n s)) i ot + | x = class_type_plus -> x + | -> <:class_type<>> + ] ] + ; + class_str_item_quot: + [ [ x1 = class_str_item; semi; x2 = SELF -> + <:class_str_item< $x1$; $x2$ >> + | x = class_str_item -> x + | -> <:class_str_item<>> ] ] + ; + class_sig_item_quot: + [ [ x1 = class_sig_item; semi; x2 = SELF -> <:class_sig_item< $x1$; $x2$ >> + | x = class_sig_item -> x + | -> <:class_sig_item<>> ] ] + ; + with_constr_quot: + [ [ x = with_constr -> x + | -> <:with_constr<>> ] ] + ; + patt_eoi: + [ [ x = patt; `EOI -> x ] ] + ; + expr_eoi: + [ [ x = expr; `EOI -> x ] ] + ; + END; + +end; + +let module M = Register.OCamlSyntaxExtension Id Make in (); diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml new file mode 100644 index 00000000..ccc9ef11 --- /dev/null +++ b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml @@ -0,0 +1,404 @@ +open Camlp4; (* -*- camlp4r -*- *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 1998-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + + +module Id : Sig.Id = struct + value name = "Camlp4OCamlRevisedParserParser"; + value version = "$Id: Camlp4OCamlRevisedParserParser.ml,v 1.1 2007/02/07 10:09:22 ertai Exp $"; +end; + +module Make (Syntax : Sig.Camlp4Syntax) = struct + open Sig; + include Syntax; + + type spat_comp = + [ SpTrm of Loc.t and Ast.patt and option Ast.expr + | SpNtr of Loc.t and Ast.patt and Ast.expr + | SpStr of Loc.t and Ast.patt ] + ; + type sexp_comp = + [ SeTrm of Loc.t and Ast.expr | SeNtr of Loc.t and Ast.expr ] + ; + + value stream_expr = Gram.Entry.mk "stream_expr"; + value stream_begin = Gram.Entry.mk "stream_begin"; + value stream_end = Gram.Entry.mk "stream_end"; + value stream_quot = Gram.Entry.mk "stream_quot"; + value parser_case = Gram.Entry.mk "parser_case"; + value parser_case_list = Gram.Entry.mk "parser_case_list"; + + value strm_n = "__strm"; + value peek_fun _loc = <:expr< Stream.peek >>; + value junk_fun _loc = <:expr< Stream.junk >>; + + (* Parsers. *) + (* In syntax generated, many cases are optimisations. *) + + value rec pattern_eq_expression p e = + match (p, e) with + [ (<:patt< $lid:a$ >>, <:expr< $lid:b$ >>) -> a = b + | (<:patt< $uid:a$ >>, <:expr< $uid:b$ >>) -> a = b + | (<:patt< $p1$ $p2$ >>, <:expr< $e1$ $e2$ >>) -> + pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2 + | _ -> False ] + ; + + value is_raise e = + match e with + [ <:expr< raise $_$ >> -> True + | _ -> False ] + ; + + value is_raise_failure e = + match e with + [ <:expr< raise Stream.Failure >> -> True + | _ -> False ] + ; + + value rec handle_failure e = + match e with + [ <:expr< try $_$ with [ Stream.Failure -> $e$] >> -> + handle_failure e + | <:expr< match $me$ with [ $a$ ] >> -> + let rec match_case_handle_failure = + fun + [ <:match_case< $a1$ | $a2$ >> -> + match_case_handle_failure a1 && match_case_handle_failure a2 + | <:match_case< $pat:_$ -> $e$ >> -> handle_failure e + | _ -> False ] + in handle_failure me && match_case_handle_failure a + | <:expr< let $bi$ in $e$ >> -> + let rec binding_handle_failure = + fun + [ <:binding< $b1$ and $b2$ >> -> + binding_handle_failure b1 && binding_handle_failure b2 + | <:binding< $_$ = $e$ >> -> handle_failure e + | _ -> False ] + in binding_handle_failure bi && handle_failure e + | <:expr< $lid:_$ >> | <:expr< $int:_$ >> | <:expr< $str:_$ >> | + <:expr< $chr:_$ >> | <:expr< fun [ $_$ ] >> | <:expr< $uid:_$ >> -> + True + | <:expr< raise $e$ >> -> + match e with + [ <:expr< Stream.Failure >> -> False + | _ -> True ] + | <:expr< $f$ $x$ >> -> + is_constr_apply f && handle_failure f && handle_failure x + | _ -> False ] + and is_constr_apply = + fun + [ <:expr< $uid:_$ >> -> True + | <:expr< $lid:_$ >> -> False + | <:expr< $x$ $_$ >> -> is_constr_apply x + | _ -> False ] + ; + + value rec subst v e = + let _loc = Ast.loc_of_expr e in + match e with + [ <:expr< $lid:x$ >> -> + let x = if x = v then strm_n else x in + <:expr< $lid:x$ >> + | <:expr< $uid:_$ >> -> e + | <:expr< $int:_$ >> -> e + | <:expr< $chr:_$ >> -> e + | <:expr< $str:_$ >> -> e + | <:expr< $_$ . $_$ >> -> e + | <:expr< let $rec:rf$ $bi$ in $e$ >> -> + <:expr< let $rec:rf$ $subst_binding v bi$ in $subst v e$ >> + | <:expr< $e1$ $e2$ >> -> <:expr< $subst v e1$ $subst v e2$ >> + | <:expr< ( $tup:e$ ) >> -> <:expr< ( $tup:subst v e$ ) >> + | <:expr< $e1$, $e2$ >> -> <:expr< $subst v e1$, $subst v e2$ >> + | _ -> raise Not_found ] + and subst_binding v = + fun + [ <:binding@_loc< $b1$ and $b2$ >> -> + <:binding< $subst_binding v b1$ and $subst_binding v b2$ >> + | <:binding@_loc< $lid:v'$ = $e$ >> -> + <:binding< $lid:v'$ = $if v = v' then e else subst v e$ >> + | _ -> raise Not_found ]; + + value stream_pattern_component skont ckont = + fun + [ SpTrm _loc p None -> + <:expr< match $peek_fun _loc$ $lid:strm_n$ with + [ Some $p$ -> + do { $junk_fun _loc$ $lid:strm_n$; $skont$ } + | _ -> $ckont$ ] >> + | SpTrm _loc p (Some w) -> + <:expr< match $peek_fun _loc$ $lid:strm_n$ with + [ Some $p$ when $w$ -> + do { $junk_fun _loc$ $lid:strm_n$; $skont$ } + | _ -> $ckont$ ] >> + | SpNtr _loc p e -> + let e = + match e with + [ <:expr< fun [ ($lid:v$ : Stream.t _) -> $e$ ] >> when v = strm_n -> e + | _ -> <:expr< $e$ $lid:strm_n$ >> ] + in + if pattern_eq_expression p skont then + if is_raise_failure ckont then e + else if handle_failure e then e + else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> + else if is_raise_failure ckont then + <:expr< let $p$ = $e$ in $skont$ >> + else if pattern_eq_expression <:patt< Some $p$ >> skont then + <:expr< try Some $e$ with [ Stream.Failure -> $ckont$ ] >> + else if is_raise ckont then + let tst = + if handle_failure e then e + else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> + in + <:expr< let $p$ = $tst$ in $skont$ >> + else + <:expr< match try Some $e$ with [ Stream.Failure -> None ] with + [ Some $p$ -> $skont$ + | _ -> $ckont$ ] >> + | SpStr _loc p -> + try + match p with + [ <:patt< $lid:v$ >> -> subst v skont + | _ -> raise Not_found ] + with + [ Not_found -> <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ] ] + ; + + value rec stream_pattern _loc epo e ekont = + fun + [ [] -> + match epo with + [ Some ep -> <:expr< let $ep$ = Stream.count $lid:strm_n$ in $e$ >> + | _ -> e ] + | [(spc, err) :: spcl] -> + let skont = + let ekont err = + let str = + match err with + [ Some estr -> estr + | _ -> <:expr< "" >> ] + in + <:expr< raise (Stream.Error $str$) >> + in + stream_pattern _loc epo e ekont spcl + in + let ckont = ekont err in stream_pattern_component skont ckont spc ] + ; + + value stream_patterns_term _loc ekont tspel = + let pel = + List.fold_right + (fun (p, w, _loc, spcl, epo, e) acc -> + let p = <:patt< Some $p$ >> in + let e = + let ekont err = + let str = + match err with + [ Some estr -> estr + | _ -> <:expr< "" >> ] + in + <:expr< raise (Stream.Error $str$) >> + in + let skont = stream_pattern _loc epo e ekont spcl in + <:expr< do { $junk_fun _loc$ $lid:strm_n$; $skont$ } >> + in + match w with + [ Some w -> <:match_case< $pat:p$ when $w$ -> $e$ | $acc$ >> + | None -> <:match_case< $pat:p$ -> $e$ | $acc$ >> ]) + tspel <:match_case<>> + in + <:expr< match $peek_fun _loc$ $lid:strm_n$ with [ $pel$ | _ -> $ekont ()$ ] >> + ; + + value rec group_terms = + fun + [ [([(SpTrm _loc p w, None) :: spcl], epo, e) :: spel] -> + let (tspel, spel) = group_terms spel in + ([(p, w, _loc, spcl, epo, e) :: tspel], spel) + | spel -> ([], spel) ] + ; + + value rec parser_cases _loc = + fun + [ [] -> <:expr< raise Stream.Failure >> + | spel -> + match group_terms spel with + [ ([], [(spcl, epo, e) :: spel]) -> + stream_pattern _loc epo e (fun _ -> parser_cases _loc spel) spcl + | (tspel, spel) -> + stream_patterns_term _loc (fun _ -> parser_cases _loc spel) tspel ] ] + ; + + value cparser _loc bpo pc = + let e = parser_cases _loc pc in + let e = + match bpo with + [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >> + | None -> e ] + in + let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in + <:expr< fun $p$ -> $e$ >> + ; + + value cparser_match _loc me bpo pc = + let pc = parser_cases _loc pc in + let e = + match bpo with + [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >> + | None -> pc ] + in + match me with + [ <:expr< $lid:x$ >> when x = strm_n -> e + | _ -> <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >> ] + ; + + (* streams *) + + value rec not_computing = + fun + [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $int:_$ >> | + <:expr< $flo:_$ >> | <:expr< $chr:_$ >> | <:expr< $str:_$ >> -> True + | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y + | _ -> False ] + and is_cons_apply_not_computing = + fun + [ <:expr< $uid:_$ >> -> True + | <:expr< $lid:_$ >> -> False + | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y + | _ -> False ] + ; + + value slazy _loc e = + match e with + [ <:expr< $f$ () >> -> + match f with + [ <:expr< $lid:_$ >> -> f + | _ -> <:expr< fun _ -> $e$ >> ] + | _ -> <:expr< fun _ -> $e$ >> ] + ; + + value rec cstream gloc = + fun + [ [] -> let _loc = gloc in <:expr< Stream.sempty >> + | [SeTrm _loc e] -> + if not_computing e then <:expr< Stream.ising $e$ >> + else <:expr< Stream.lsing $slazy _loc e$ >> + | [SeTrm _loc e :: secl] -> + if not_computing e then <:expr< Stream.icons $e$ $cstream gloc secl$ >> + else <:expr< Stream.lcons $slazy _loc e$ $cstream gloc secl$ >> + | [SeNtr _loc e] -> + if not_computing e then e else <:expr< Stream.slazy $slazy _loc e$ >> + | [SeNtr _loc e :: secl] -> + if not_computing e then <:expr< Stream.iapp $e$ $cstream gloc secl$ >> + else <:expr< Stream.lapp $slazy _loc e$ $cstream gloc secl$ >> ] + ; + (* Syntax extensions in Revised Syntax grammar *) + + EXTEND Gram + GLOBAL: expr stream_expr stream_begin stream_end stream_quot + parser_case parser_case_list; + expr: LEVEL "top" + [ [ "parser"; po = OPT parser_ipatt; pcl = parser_case_list -> + <:expr< $cparser _loc po pcl$ >> + | "match"; e = SELF; "with"; "parser"; po = OPT parser_ipatt; + pcl = parser_case_list -> + <:expr< $cparser_match _loc e po pcl$ >> + ] ] + ; + parser_case_list: + [ [ "["; pcl = LIST0 parser_case SEP "|"; "]" -> pcl + | pc = parser_case -> [pc] + ] ] + ; + parser_case: + [ [ stream_begin; sp = stream_patt; stream_end; po = OPT parser_ipatt; "->"; e = expr -> + (sp, po, e) ] ] + ; + stream_begin: + [ [ "[:" -> () ] ] + ; + stream_end: + [ [ ":]" -> () ] ] + ; + stream_quot: + [ [ "`" -> () ] ] + ; + stream_expr: + [ [ e = expr -> e ] ] + ; + stream_patt: + [ [ spc = stream_patt_comp -> [(spc, None)] + | spc = stream_patt_comp; ";"; sp = stream_patt_comp_err_list -> + [(spc, None) :: sp] + | -> [] ] ] + ; + stream_patt_comp_err: + [ [ spc = stream_patt_comp; eo = OPT [ "??"; e = stream_expr -> e ] -> + (spc, eo) ] ] + ; + stream_patt_comp_err_list: + [ [ spc = stream_patt_comp_err -> [spc] + | spc = stream_patt_comp_err; ";" -> [spc] + | spc = stream_patt_comp_err; ";"; sp = stream_patt_comp_err_list -> + [spc :: sp] ] ] + ; + stream_patt_comp: + [ [ stream_quot; p = patt; eo = OPT [ "when"; e = stream_expr -> e ] -> SpTrm _loc p eo + | p = patt; "="; e = stream_expr -> SpNtr _loc p e + | p = patt -> SpStr _loc p ] ] + ; + parser_ipatt: + [ [ i = a_LIDENT -> <:patt< $lid:i$ >> + | "_" -> <:patt< _ >> + ] ] + ; + expr: LEVEL "simple" + [ [ stream_begin; stream_end -> <:expr< $cstream _loc []$ >> + | stream_begin; sel = stream_expr_comp_list; stream_end -> + <:expr< $cstream _loc sel$ >> ] ] + ; + stream_expr_comp_list: + [ [ se = stream_expr_comp; ";"; sel = stream_expr_comp_list -> [se :: sel] + | se = stream_expr_comp; ";" -> [se] + | se = stream_expr_comp -> [se] ] ] + ; + stream_expr_comp: + [ [ stream_quot; e = stream_expr -> SeTrm _loc e | e = stream_expr -> SeNtr _loc e ] ] + ; + (* + Gram.Entry.clear stream_expr; + Gram.Entry.clear stream_expr; + stream_expr: + [ [ e = expr LEVEL "stream_expr" -> e ] ] + ; + stream_begin: + [ [ "[<" -> () ] ] + ; + stream_end: + [ [ ">]" -> () ] ] + ; + stream_quot: + [ [ "'" -> () ] ] + ; + *) + END; + +end; + +module M = Register.OCamlSyntaxExtension Id Make; diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedQuotationExpander.ml b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedQuotationExpander.ml new file mode 100644 index 00000000..b013be25 --- /dev/null +++ b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedQuotationExpander.ml @@ -0,0 +1,24 @@ +open Camlp4; (* -*- camlp4r -*- *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2002-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +open PreCast; +let module Gram = MakeGram Lexer in +let module M1 = OCamlInitSyntax.Make Warning Ast Gram Quotation in +let module M2 = Camlp4OCamlRevisedParser.Make M1 in +let module M3 = Camlp4QuotationCommon.Make M2 Syntax.AntiquotSyntax in (); diff --git a/camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml b/camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml new file mode 100644 index 00000000..6a1dafca --- /dev/null +++ b/camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml @@ -0,0 +1,182 @@ +open Camlp4; (* -*- camlp4r -*- *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2002-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +module Id = struct + value name = "Camlp4QuotationCommon"; + value version = "$Id: Camlp4QuotationCommon.ml,v 1.1 2007/02/07 10:09:22 ertai Exp $"; +end; + +module Make (Syntax : Sig.Camlp4Syntax) + (TheAntiquotSyntax : Sig.AntiquotSyntax + with module Ast = Sig.Camlp4AstToAst Syntax.Ast) += struct + open Sig; + include Syntax; (* Be careful an AntiquotSyntax module appears here *) + + module MetaLocHere = Ast.Meta.MetaLoc; + module MetaLoc = struct + module Ast = Ast; + value loc_name = ref None; + value meta_loc_expr _loc loc = + match loc_name.val with + [ None -> <:expr< $lid:Loc.name.val$ >> + | Some "here" -> MetaLocHere.meta_loc_expr _loc loc + | Some x -> <:expr< $lid:x$ >> ]; + value meta_loc_patt _loc _ = <:patt< _ >>; + end; + module MetaAst = Ast.Meta.Make MetaLoc; + module ME = MetaAst.Expr; + module MP = MetaAst.Patt; + + value is_antiquot s = + let len = String.length s in + len > 2 && s.[0] = '\\' && s.[1] = '$'; + + value handle_antiquot_in_string s term parse loc decorate = + if is_antiquot s then + let pos = String.index s ':' in + let name = String.sub s 2 (pos - 2) + and code = String.sub s (pos + 1) (String.length s - pos - 1) in + decorate name (parse loc code) + else term; + + value antiquot_expander = object + inherit Ast.map as super; + method patt = fun + [ <:patt@_loc< $anti:s$ >> | <:patt@_loc< $str:s$ >> as p -> + let mloc _loc = MetaLoc.meta_loc_patt _loc _loc in + handle_antiquot_in_string s p TheAntiquotSyntax.parse_patt _loc (fun n p -> + match n with + [ "antisig_item" -> <:patt< Ast.SgAnt $mloc _loc$ $p$ >> + | "antistr_item" -> <:patt< Ast.StAnt $mloc _loc$ $p$ >> + | "antictyp" -> <:patt< Ast.TyAnt $mloc _loc$ $p$ >> + | "antipatt" -> <:patt< Ast.PaAnt $mloc _loc$ $p$ >> + | "antiexpr" -> <:patt< Ast.ExAnt $mloc _loc$ $p$ >> + | "antimodule_type" -> <:patt< Ast.MtAnt $mloc _loc$ $p$ >> + | "antimodule_expr" -> <:patt< Ast.MeAnt $mloc _loc$ $p$ >> + | "anticlass_type" -> <:patt< Ast.CtAnt $mloc _loc$ $p$ >> + | "anticlass_expr" -> <:patt< Ast.CeAnt $mloc _loc$ $p$ >> + | "anticlass_sig_item" -> <:patt< Ast.CgAnt $mloc _loc$ $p$ >> + | "anticlass_str_item" -> <:patt< Ast.CrAnt $mloc _loc$ $p$ >> + | "antiwith_constr" -> <:patt< Ast.WcAnt $mloc _loc$ $p$ >> + | "antibinding" -> <:patt< Ast.BiAnt $mloc _loc$ $p$ >> + | "antimatch_case" -> <:patt< Ast.McAnt $mloc _loc$ $p$ >> + | "antimodule_binding" -> <:patt< Ast.MbAnt $mloc _loc$ $p$ >> + | "antiident" -> <:patt< Ast.IdAnt $mloc _loc$ $p$ >> + | _ -> p ]) + | p -> super#patt p ]; + method expr = fun + [ <:expr@_loc< $anti:s$ >> | <:expr@_loc< $str:s$ >> as e -> + let mloc _loc = MetaLoc.meta_loc_expr _loc _loc in + handle_antiquot_in_string s e TheAntiquotSyntax.parse_expr _loc (fun n e -> + match n with + [ "`int" -> <:expr< string_of_int $e$ >> + | "`int32" -> <:expr< Int32.to_string $e$ >> + | "`int64" -> <:expr< Int64.to_string $e$ >> + | "`nativeint" -> <:expr< Nativeint.to_string $e$ >> + | "`flo" -> <:expr< string_of_float $e$ >> + | "`str" -> <:expr< Ast.safe_string_escaped $e$ >> + | "`chr" -> <:expr< Char.escaped $e$ >> + | "liststr_item" -> <:expr< Ast.stSem_of_list $e$ >> + | "listsig_item" -> <:expr< Ast.sgSem_of_list $e$ >> + | "listclass_sig_item" -> <:expr< Ast.cgSem_of_list $e$ >> + | "listclass_str_item" -> <:expr< Ast.crSem_of_list $e$ >> + | "listmodule_expr" -> <:expr< Ast.meApp_of_list $e$ >> + | "listmodule_type" -> <:expr< Ast.mtApp_of_list $e$ >> + | "listmodule_binding" -> <:expr< Ast.mbAnd_of_list $e$ >> + | "listbinding" -> <:expr< Ast.biAnd_of_list $e$ >> + | "listbinding;" -> <:expr< Ast.biSem_of_list $e$ >> + | "listclass_type" -> <:expr< Ast.ctAnd_of_list $e$ >> + | "listclass_expr" -> <:expr< Ast.ceAnd_of_list $e$ >> + | "listident" -> <:expr< Ast.idAcc_of_list $e$ >> + | "listctypand" -> <:expr< Ast.tyAnd_of_list $e$ >> + | "listwith_constr" -> <:expr< Ast.wcAnd_of_list $e$ >> + | "listmatch_case" -> <:expr< Ast.mcOr_of_list $e$ >> + | "listpatt;" -> <:expr< Ast.paSem_of_list $e$ >> + | "antisig_item" -> <:expr< Ast.SgAnt $mloc _loc$ $e$ >> + | "antistr_item" -> <:expr< Ast.StAnt $mloc _loc$ $e$ >> + | "antictyp" -> <:expr< Ast.TyAnt $mloc _loc$ $e$ >> + | "antipatt" -> <:expr< Ast.PaAnt $mloc _loc$ $e$ >> + | "antiexpr" -> <:expr< Ast.ExAnt $mloc _loc$ $e$ >> + | "antimodule_type" -> <:expr< Ast.MtAnt $mloc _loc$ $e$ >> + | "antimodule_expr" -> <:expr< Ast.MeAnt $mloc _loc$ $e$ >> + | "anticlass_type" -> <:expr< Ast.CtAnt $mloc _loc$ $e$ >> + | "anticlass_expr" -> <:expr< Ast.CeAnt $mloc _loc$ $e$ >> + | "anticlass_sig_item" -> <:expr< Ast.CgAnt $mloc _loc$ $e$ >> + | "anticlass_str_item" -> <:expr< Ast.CrAnt $mloc _loc$ $e$ >> + | "antiwith_constr" -> <:expr< Ast.WcAnt $mloc _loc$ $e$ >> + | "antibinding" -> <:expr< Ast.BiAnt $mloc _loc$ $e$ >> + | "antimatch_case" -> <:expr< Ast.McAnt $mloc _loc$ $e$ >> + | "antimodule_binding" -> <:expr< Ast.MbAnt $mloc _loc$ $e$ >> + | "antiident" -> <:expr< Ast.IdAnt $mloc _loc$ $e$ >> + | _ -> e ]) + | e -> super#expr e ]; + end; + + value add_quotation name entry mexpr mpatt = + let entry_eoi = Gram.Entry.mk (Gram.Entry.name entry) in + let expand_expr loc loc_name_opt s = + let ast = Gram.parse_string entry_eoi loc s in + let () = MetaLoc.loc_name.val := loc_name_opt in + let meta_ast = mexpr loc ast in + let exp_ast = antiquot_expander#expr meta_ast in + exp_ast in + let expand_patt _loc loc_name_opt s = + let ast = Gram.parse_string entry_eoi _loc s in + let meta_ast = mpatt _loc ast in + let exp_ast = antiquot_expander#patt meta_ast in + match loc_name_opt with + [ None -> exp_ast + | Some name -> + let rec subst_first_loc = + fun + [ <:patt@_loc< Ast.$uid:u$ $_$ >> -> <:patt< Ast.$uid:u$ $lid:name$ >> + | <:patt@_loc< $a$ $b$ >> -> <:patt< $subst_first_loc a$ $b$ >> + | p -> p ] in + subst_first_loc exp_ast ] in + do { + EXTEND Gram + entry_eoi: + [ [ x = entry; `EOI -> x ] ] + ; + END; + Quotation.add name (Quotation.ExAst (expand_expr, expand_patt)) + }; + + add_quotation "sig_item" sig_item_quot ME.meta_sig_item MP.meta_sig_item; + add_quotation "str_item" str_item_quot ME.meta_str_item MP.meta_str_item; + add_quotation "ctyp" ctyp_quot ME.meta_ctyp MP.meta_ctyp; + add_quotation "patt" patt_quot ME.meta_patt MP.meta_patt; + add_quotation "expr" expr_quot ME.meta_expr MP.meta_expr; + add_quotation "module_type" module_type_quot ME.meta_module_type MP.meta_module_type; + add_quotation "module_expr" module_expr_quot ME.meta_module_expr MP.meta_module_expr; + add_quotation "class_type" class_type_quot ME.meta_class_type MP.meta_class_type; + add_quotation "class_expr" class_expr_quot ME.meta_class_expr MP.meta_class_expr; + add_quotation "class_sig_item" + class_sig_item_quot ME.meta_class_sig_item MP.meta_class_sig_item; + add_quotation "class_str_item" + class_str_item_quot ME.meta_class_str_item MP.meta_class_str_item; + add_quotation "with_constr" with_constr_quot ME.meta_with_constr MP.meta_with_constr; + add_quotation "binding" binding_quot ME.meta_binding MP.meta_binding; + add_quotation "match_case" match_case_quot ME.meta_match_case MP.meta_match_case; + add_quotation "module_binding" + module_binding_quot ME.meta_module_binding MP.meta_module_binding; + add_quotation "ident" ident_quot ME.meta_ident MP.meta_ident; + +end; diff --git a/camlp4/Camlp4Parsers/Camlp4QuotationExpander.ml b/camlp4/Camlp4Parsers/Camlp4QuotationExpander.ml new file mode 100644 index 00000000..2f8be435 --- /dev/null +++ b/camlp4/Camlp4Parsers/Camlp4QuotationExpander.ml @@ -0,0 +1,33 @@ +open Camlp4; (* -*- camlp4r -*- *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2002-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + + +module Id = struct + value name = "Camlp4QuotationExpander"; + value version = "$Id: Camlp4QuotationExpander.ml,v 1.1 2007/02/07 10:09:22 ertai Exp $"; +end; + +module Make (Syntax : Sig.Camlp4Syntax) += struct + module M = Camlp4QuotationCommon.Make Syntax Syntax.AntiquotSyntax; + include M; +end; + +let module M = Register.OCamlSyntaxExtension Id Make in (); diff --git a/camlp4/Camlp4Printers/Camlp4AstDumper.ml b/camlp4/Camlp4Printers/Camlp4AstDumper.ml new file mode 100644 index 00000000..f89fed40 --- /dev/null +++ b/camlp4/Camlp4Printers/Camlp4AstDumper.ml @@ -0,0 +1,19 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +Camlp4.Register.enable_dump_camlp4_ast_printer (); diff --git a/camlp4/Camlp4Printers/Camlp4AutoPrinter.ml b/camlp4/Camlp4Printers/Camlp4AutoPrinter.ml new file mode 100644 index 00000000..eb6b9a24 --- /dev/null +++ b/camlp4/Camlp4Printers/Camlp4AutoPrinter.ml @@ -0,0 +1,24 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +open Camlp4.Register; + +if Unix.isatty Unix.stdout then + enable_ocaml_printer () +else + enable_dump_ocaml_ast_printer (); diff --git a/camlp4/Camlp4Printers/Camlp4NullDumper.ml b/camlp4/Camlp4Printers/Camlp4NullDumper.ml new file mode 100644 index 00000000..0e02b66d --- /dev/null +++ b/camlp4/Camlp4Printers/Camlp4NullDumper.ml @@ -0,0 +1,19 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +Camlp4.Register.enable_null_printer (); diff --git a/camlp4/Camlp4Printers/Camlp4OCamlAstDumper.ml b/camlp4/Camlp4Printers/Camlp4OCamlAstDumper.ml new file mode 100644 index 00000000..174e5ad1 --- /dev/null +++ b/camlp4/Camlp4Printers/Camlp4OCamlAstDumper.ml @@ -0,0 +1,19 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +Camlp4.Register.enable_dump_ocaml_ast_printer (); diff --git a/camlp4/Camlp4Printers/Camlp4OCamlPrinter.ml b/camlp4/Camlp4Printers/Camlp4OCamlPrinter.ml new file mode 100644 index 00000000..487b8627 --- /dev/null +++ b/camlp4/Camlp4Printers/Camlp4OCamlPrinter.ml @@ -0,0 +1,19 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +Camlp4.Register.enable_ocaml_printer (); diff --git a/camlp4/Camlp4Printers/Camlp4OCamlRevisedPrinter.ml b/camlp4/Camlp4Printers/Camlp4OCamlRevisedPrinter.ml new file mode 100644 index 00000000..bd5af1f5 --- /dev/null +++ b/camlp4/Camlp4Printers/Camlp4OCamlRevisedPrinter.ml @@ -0,0 +1,19 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) + +Camlp4.Register.enable_ocamlr_printer (); diff --git a/camlp4/Camlp4Top.mlpack b/camlp4/Camlp4Top.mlpack new file mode 100644 index 00000000..d3560fbb --- /dev/null +++ b/camlp4/Camlp4Top.mlpack @@ -0,0 +1,2 @@ +Top +Rprint diff --git a/camlp4/Camlp4Top/Rprint.ml b/camlp4/Camlp4Top/Rprint.ml new file mode 100644 index 00000000..c4f932d3 --- /dev/null +++ b/camlp4/Camlp4Top/Rprint.ml @@ -0,0 +1,442 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2002-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + + +(* $Id: Rprint.ml,v 1.2 2006/07/08 17:21:32 pouillar Exp $ *) + +(* This file originally come from typing/oprint.ml *) + +open Format; +open Outcometree; +open Camlp4; + +exception Ellipsis; +value cautious f ppf arg = + try f ppf arg with [ Ellipsis -> fprintf ppf "..." ] +; + +value rec print_ident ppf = + fun + [ Oide_ident s -> fprintf ppf "%s" s + | Oide_dot id s -> fprintf ppf "%a.%s" print_ident id s + | Oide_apply id1 id2 -> + fprintf ppf "%a(%a)" print_ident id1 print_ident id2 ] +; + +value value_ident ppf name = + if List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"] + then + fprintf ppf "( %s )" name + else + match name.[0] with + [ 'a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' -> + fprintf ppf "%s" name + | _ -> fprintf ppf "( %s )" name ] +; + +(* Values *) + +value print_out_value ppf tree = + let rec print_tree ppf = + fun + [ Oval_constr name ([_ :: _] as params) -> + fprintf ppf "@[<1>%a@ %a@]" print_ident name + (print_tree_list print_simple_tree "") params + | Oval_variant name (Some param) -> + fprintf ppf "@[<2>`%s@ %a@]" name print_simple_tree param + | tree -> print_simple_tree ppf tree ] + and print_simple_tree ppf = + fun + [ Oval_int i -> fprintf ppf "%i" i + | Oval_int32 i -> fprintf ppf "%ldl" i + | Oval_int64 i -> fprintf ppf "%LdL" i + | Oval_nativeint i -> fprintf ppf "%ndn" i + | Oval_float f -> fprintf ppf "%.12g" f + | Oval_char c -> fprintf ppf "'%s'" (Char.escaped c) + | Oval_string s -> + try fprintf ppf "\"%s\"" (String.escaped s) with + [ Invalid_argument "String.create" -> fprintf ppf "" ] + | Oval_list tl -> + fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree ";") tl + | Oval_array tl -> + fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree ";") tl + | Oval_constr (Oide_ident "true") [] -> fprintf ppf "True" + | Oval_constr (Oide_ident "false") [] -> fprintf ppf "False" + | Oval_constr name [] -> print_ident ppf name + | Oval_variant name None -> fprintf ppf "`%s" name + | Oval_stuff s -> fprintf ppf "%s" s + | Oval_record fel -> + fprintf ppf "@[<1>{%a}@]" (cautious (print_fields True)) fel + | Oval_tuple tree_list -> + fprintf ppf "@[(%a)@]" (print_tree_list print_tree ",") tree_list + | Oval_ellipsis -> raise Ellipsis + | Oval_printer f -> f ppf + | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree) tree ] + and print_fields first ppf = + fun + [ [] -> () + | [(name, tree) :: fields] -> + let name = + match name with + [ Oide_ident "contents" -> Oide_ident "val" + | x -> x ] + in + do { + if not first then fprintf ppf ";@ " else (); + fprintf ppf "@[<1>%a=@,%a@]" print_ident name (cautious print_tree) + tree; + print_fields False ppf fields + } ] + and print_tree_list print_item sep ppf tree_list = + let rec print_list first ppf = + fun + [ [] -> () + | [tree :: tree_list] -> + do { + if not first then fprintf ppf "%s@ " sep else (); + print_item ppf tree; + print_list False ppf tree_list + } ] + in + cautious (print_list True) ppf tree_list + in + cautious print_tree ppf tree +; + +value rec print_list pr sep ppf = + fun + [ [] -> () + | [a] -> pr ppf a + | [a :: l] -> do { pr ppf a; sep ppf; print_list pr sep ppf l } ] +; + +value pr_vars = + print_list (fun ppf s -> fprintf ppf "'%s" s) (fun ppf -> fprintf ppf "@ ") +; + +value pr_present = + print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ") +; + +(* Types *) + +value rec print_out_type ppf = + fun + [ Otyp_alias ty s -> fprintf ppf "@[%a as '%s@]" print_out_type ty s + | ty -> print_out_type_1 ppf ty ] +and print_out_type_1 ppf = + fun + [ Otyp_arrow lab ty1 ty2 -> + fprintf ppf "@[%a%a ->@ %a@]" print_ty_label lab + print_out_type_2 ty1 print_out_type_1 ty2 + | Otyp_poly sl ty -> + fprintf ppf "@[!%a.@ %a@]" + pr_vars sl + print_out_type ty + | ty -> print_out_type_2 ppf ty ] +and print_out_type_2 ppf = + fun + [ Otyp_constr id ([_ :: _] as tyl) -> + fprintf ppf "@[%a@;<1 2>%a@]" print_ident id + (print_typlist print_simple_out_type "") tyl + | ty -> print_simple_out_type ppf ty ] +and print_simple_out_type ppf = + let rec print_tkind ppf = + fun + [ Otyp_var ng s -> fprintf ppf "'%s%s" (if ng then "_" else "") s + | Otyp_constr id [] -> fprintf ppf "@[%a@]" print_ident id + | Otyp_tuple tyl -> + fprintf ppf "@[<1>(%a)@]" (print_typlist print_out_type " *") tyl + | Otyp_stuff s -> fprintf ppf "%s" s + | Otyp_variant non_gen row_fields closed tags -> + let print_present ppf = + fun + [ None | Some [] -> () + | Some l -> fprintf ppf "@;<1 -2>> @[%a@]" pr_present l ] + in + let print_fields ppf = + fun + [ Ovar_fields fields -> + print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ") + ppf fields + | Ovar_name id tyl -> + fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id ] + in + fprintf ppf "%s[%s@[@[%a@]%a ]@]" (if non_gen then "_" else "") + (if closed then if tags = None then "= " else "< " + else if tags = None then "> " + else "? ") + print_fields row_fields + print_present tags + | Otyp_object fields rest -> + fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields + | Otyp_class ng id tyl -> + fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "") + print_ident id + | Otyp_manifest ty1 ty2 -> + fprintf ppf "@[<2>%a ==@ %a@]" print_out_type ty1 print_out_type ty2 + | Otyp_sum constrs -> + fprintf ppf "@[[ %a ]@]" + (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs + | Otyp_record lbls -> + fprintf ppf "@[{ %a }@]" + (print_list print_out_label (fun ppf -> fprintf ppf ";@ ")) lbls + | Otyp_abstract -> fprintf ppf "'abstract" + | Otyp_alias _ _ | Otyp_poly _ _ + | Otyp_arrow _ _ _ | Otyp_constr _ [_ :: _] as ty -> + fprintf ppf "@[<1>(%a)@]" print_out_type ty ] + in + print_tkind ppf +and print_out_constr ppf (name, tyl) = + match tyl with + [ [] -> fprintf ppf "%s" name + | _ -> + fprintf ppf "@[<2>%s of@ %a@]" name + (print_typlist print_out_type " and") tyl ] +and print_out_label ppf (name, mut, arg) = + fprintf ppf "@[<2>%s :@ %s%a@]" name (if mut then "mutable " else "") + print_out_type arg +and print_fields rest ppf = + fun + [ [] -> + match rest with + [ Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "") + | None -> () ] + | [(s, t)] -> + do { + fprintf ppf "%s : %a" s print_out_type t; + match rest with + [ Some _ -> fprintf ppf ";@ " + | None -> () ]; + print_fields rest ppf [] + } + | [(s, t) :: l] -> + fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l ] +and print_row_field ppf (l, opt_amp, tyl) = + let pr_of ppf = + if opt_amp then fprintf ppf " of@ &@ " + else if tyl <> [] then fprintf ppf " of@ " + else fprintf ppf "" + in + fprintf ppf "@[`%s%t%a@]" l pr_of (print_typlist print_out_type " &") + tyl +and print_typlist print_elem sep ppf = + fun + [ [] -> () + | [ty] -> print_elem ppf ty + | [ty :: tyl] -> + fprintf ppf "%a%s@ %a" print_elem ty sep (print_typlist print_elem sep) + tyl ] +and print_typargs ppf = + fun + [ [] -> () + | [ty1] -> fprintf ppf "%a@ " print_simple_out_type ty1 + | tyl -> + fprintf ppf "@[<1>(%a)@]@ " (print_typlist print_out_type ",") tyl ] +and print_ty_label ppf lab = + if lab <> "" then fprintf ppf "~%s:" lab else () +; + +value type_parameter ppf (ty, (co, cn)) = + fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "") + ty +; + +value print_out_class_params ppf = + fun + [ [] -> () + | tyl -> + fprintf ppf "@[<1>[%a]@]@ " + (print_list type_parameter (fun ppf -> fprintf ppf ", ")) + tyl ] +; + +(* Signature items *) + +value rec print_out_class_type ppf = + fun + [ Octy_constr id tyl -> + let pr_tyl ppf = + fun + [ [] -> () + | tyl -> + fprintf ppf "@[<1>[%a]@]@ " + (print_typlist Toploop.print_out_type.val ",") tyl ] + in + fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id + | Octy_fun lab ty cty -> + fprintf ppf "@[%a[ %a ] ->@ %a@]" print_ty_label lab + Toploop.print_out_type.val ty print_out_class_type cty + | Octy_signature self_ty csil -> + let pr_param ppf = + fun + [ Some ty -> fprintf ppf "@ @[(%a)@]" Toploop.print_out_type.val ty + | None -> () ] + in + fprintf ppf "@[@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty + (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ ")) + csil ] +and print_out_class_sig_item ppf = + fun + [ Ocsg_constraint ty1 ty2 -> + fprintf ppf "@[<2>type %a =@ %a;@]" Toploop.print_out_type.val ty1 + Toploop.print_out_type.val ty2 + | Ocsg_method name priv virt ty -> + fprintf ppf "@[<2>method %s%s%s :@ %a;@]" + (if priv then "private " else "") (if virt then "virtual " else "") + name Toploop.print_out_type.val ty + | Ocsg_value name mut virt ty -> + fprintf ppf "@[<2>value %s%s%s :@ %a;@]" + (if mut then "mutable " else "") (if virt then "virtual " else "") + name Toploop.print_out_type.val ty ] +; + +value rec print_out_module_type ppf = + fun + [ Omty_ident id -> fprintf ppf "%a" print_ident id + | Omty_signature sg -> + fprintf ppf "@[sig@ %a@;<1 -2>end@]" + Toploop.print_out_signature.val sg + | Omty_functor name mty_arg mty_res -> + fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name + print_out_module_type mty_arg print_out_module_type mty_res + | Omty_abstract -> () ] +and print_out_signature ppf = + fun + [ [] -> () + | [item] -> fprintf ppf "%a;" Toploop.print_out_sig_item.val item + | [item :: items] -> + fprintf ppf "%a;@ %a" Toploop.print_out_sig_item.val item + print_out_signature items ] +and print_out_sig_item ppf = + fun + [ Osig_class vir_flag name params clt rs -> + fprintf ppf "@[<2>%s%s@ %a%s@ :@ %a@]" + (if rs = Orec_next then "and" else "class") + (if vir_flag then " virtual" else "") print_out_class_params params + name Toploop.print_out_class_type.val clt + | Osig_class_type vir_flag name params clt rs -> + fprintf ppf "@[<2>%s%s@ %a%s@ =@ %a@]" + (if rs = Orec_next then "and" else "class type") + (if vir_flag then " virtual" else "") print_out_class_params params + name Toploop.print_out_class_type.val clt + | Osig_exception id tyl -> + fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl) + | Osig_modtype name Omty_abstract -> + fprintf ppf "@[<2>module type %s@]" name + | Osig_modtype name mty -> + fprintf ppf "@[<2>module type %s =@ %a@]" name + Toploop.print_out_module_type.val mty + | Osig_module name mty rs -> + fprintf ppf "@[<2>%s %s :@ %a@]" + (match rs with [ Orec_not -> "module" + | Orec_first -> "module rec" + | Orec_next -> "and" ]) name + Toploop.print_out_module_type.val mty + | Osig_type td rs -> + print_out_type_decl + (if rs = Orec_next then "and" else "type") + ppf td + | Osig_value name ty prims -> + let kwd = if prims = [] then "value" else "external" in + let pr_prims ppf = + fun + [ [] -> () + | [s :: sl] -> + do { + fprintf ppf "@ = \"%s\"" s; + List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl + } ] + in + fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name + Toploop.print_out_type.val ty pr_prims prims ] + +and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) = + let constrain ppf (ty, ty') = + fprintf ppf "@ @[<2>constraint %a =@ %a@]" Toploop.print_out_type.val ty + Toploop.print_out_type.val ty' + in + let print_constraints ppf params = List.iter (constrain ppf) params in + let type_defined ppf = + match args with + [ [] -> fprintf ppf "%s" name + | [arg] -> fprintf ppf "%s %a" name type_parameter arg + | _ -> + fprintf ppf "%s@ %a" name + (print_list type_parameter (fun ppf -> fprintf ppf "@ ")) args ] + and print_kind ppf ty = + fprintf ppf "%s@ %a" + (if priv = Asttypes.Private then " private" else "") + Toploop.print_out_type.val ty + in + let print_types ppf = fun + [ Otyp_manifest ty1 ty2 -> + fprintf ppf "@ @[<2>%a ==%a@]" + Toploop.print_out_type.val ty1 + print_kind ty2 + | ty -> print_kind ppf ty ] + in + fprintf ppf "@[<2>@[@[%s %t@] =%a@]%a@]" kwd type_defined + print_types ty print_constraints constraints +; + +(* Phrases *) + +value print_out_exception ppf exn outv = + match exn with + [ Sys.Break -> fprintf ppf "Interrupted.@." + | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@." + | Stack_overflow -> + fprintf ppf "Stack overflow during evaluation (looping recursion?).@." + | _ -> + fprintf ppf "@[Exception:@ %a.@]@." Toploop.print_out_value.val outv ] +; + +value rec print_items ppf = + fun + [ [] -> () + | [(tree, valopt) :: items] -> + do { + match valopt with + [ Some v -> + fprintf ppf "@[<2>%a =@ %a@]" Toploop.print_out_sig_item.val tree + Toploop.print_out_value.val v + | None -> fprintf ppf "@[%a@]" Toploop.print_out_sig_item.val tree ]; + if items <> [] then fprintf ppf "@ %a" print_items items else () + } ] +; + +value print_out_phrase ppf = + fun + [ Ophr_eval outv ty -> + fprintf ppf "@[- : %a@ =@ %a@]@." Toploop.print_out_type.val ty + Toploop.print_out_value.val outv + | Ophr_signature [] -> () + | Ophr_signature items -> fprintf ppf "@[%a@]@." print_items items + | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv ] +; + +Toploop.print_out_value.val := print_out_value; +Toploop.print_out_type.val := print_out_type; +Toploop.print_out_class_type.val := print_out_class_type; +Toploop.print_out_module_type.val := print_out_module_type; +Toploop.print_out_sig_item.val := print_out_sig_item; +Toploop.print_out_signature.val := print_out_signature; +Toploop.print_out_phrase.val := print_out_phrase; diff --git a/camlp4/Camlp4Top/Top.ml b/camlp4/Camlp4Top/Top.ml new file mode 100644 index 00000000..3767d1ee --- /dev/null +++ b/camlp4/Camlp4Top/Top.ml @@ -0,0 +1,107 @@ +(* camlp4r q_MLast.cmo *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2002-2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +(* $Id: Top.ml,v 1.1 2007/02/07 10:09:23 ertai Exp $ *) + +open Parsetree; +open Lexing; +open Camlp4; +open PreCast; +open Syntax; +open Camlp4.Sig; +module Ast2pt = Camlp4.Struct.Camlp4Ast2OCamlAst.Make Ast; +module Lexer = Camlp4.Struct.Lexer.Make Token; + +external not_filtered : 'a -> Gram.not_filtered 'a = "%identity"; + +value wrap parse_fun = + let token_stream_ref = ref None in + fun lb -> + let () = Register.iter_and_take_callbacks (fun (_, f) -> f ()) in + let token_stream = + match token_stream_ref.val with + [ None -> + let () = if Sys.interactive.val then + Format.printf "\tCamlp4 Parsing version %s\n@." Camlp4_config.version + else () in + let not_filtered_token_stream = Lexer.from_lexbuf lb in + let token_stream = Gram.filter (not_filtered not_filtered_token_stream) in + do { token_stream_ref.val := Some token_stream; token_stream } + | Some token_stream -> token_stream ] + in try + match token_stream with parser + [ [: `(EOI, _) :] -> raise End_of_file + | [: :] -> parse_fun token_stream ] + with + [ End_of_file | Sys.Break | (Loc.Exc_located _ (End_of_file | Sys.Break)) + as x -> raise x + | x -> + let () = Stream.junk token_stream in + let x = + match x with + [ Loc.Exc_located loc x -> do { + Toploop.print_location Format.err_formatter + (Loc.to_ocaml_location loc); + x } + | x -> x ] + in + do { + Format.eprintf "@[<0>%a@]@." Camlp4.ErrorHandler.print x; + raise Exit + } ]; + +value toplevel_phrase token_stream = + match Gram.parse_tokens_after_filter Syntax.top_phrase token_stream with + [ Some phr -> Ast2pt.phrase phr + | None -> raise End_of_file ]; + +value use_file token_stream = + let (pl0, eoi) = + loop () where rec loop () = + let (pl, stopped_at_directive) = + Gram.parse_tokens_after_filter Syntax.use_file token_stream + in + if stopped_at_directive <> None then + match pl with + [ [ <:str_item< #load $str:s$ >> ] -> + do { Topdirs.dir_load Format.std_formatter s; loop () } + | [ <:str_item< #directory $str:s$ >> ] -> + do { Topdirs.dir_directory s; loop () } + | _ -> (pl, False) ] + else (pl, True) + in + let pl = + if eoi then [] + else + loop () where rec loop () = + let (pl, stopped_at_directive) = + Gram.parse_tokens_after_filter Syntax.use_file token_stream + in + if stopped_at_directive <> None then pl @ loop () else pl + in List.map Ast2pt.phrase (pl0 @ pl); + +Toploop.parse_toplevel_phrase.val := wrap toplevel_phrase; + +Toploop.parse_use_file.val := wrap use_file; + +Warning.current.val := + fun loc txt -> + Toploop.print_warning (Loc.to_ocaml_location loc) Format.err_formatter + (Warnings.Camlp4 txt); diff --git a/camlp4/Camlp4_config.ml b/camlp4/Camlp4_config.ml new file mode 100644 index 00000000..36284849 --- /dev/null +++ b/camlp4/Camlp4_config.ml @@ -0,0 +1,39 @@ +(* camlp4r *) +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +let ocaml_standard_library = Config.standard_library;; + +let camlp4_standard_library = + try Sys.getenv "CAMLP4LIB" + with Not_found -> + Filename.concat ocaml_standard_library "camlp4";; + +let version = Sys.ocaml_version;; +let program_name = ref "camlp4";; +let constructors_arity = ref true;; +let unsafe = ref false;; +let verbose = ref false;; +let quotations = ref true;; +let inter_phrases = ref None;; +let camlp4_ast_impl_magic_number = "Camlp42006M001";; +let camlp4_ast_intf_magic_number = "Camlp42006N001";; +let ocaml_ast_intf_magic_number = Config.ast_intf_magic_number;; +let ocaml_ast_impl_magic_number = Config.ast_impl_magic_number;; +let current_input_file = ref "";; diff --git a/camlp4/Camlp4_config.mli b/camlp4/Camlp4_config.mli new file mode 100644 index 00000000..c2647b89 --- /dev/null +++ b/camlp4/Camlp4_config.mli @@ -0,0 +1,33 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + +val version : string;; +val ocaml_standard_library : string;; +val camlp4_standard_library : string;; +val ocaml_ast_impl_magic_number : string;; +val ocaml_ast_intf_magic_number : string;; +val camlp4_ast_impl_magic_number : string;; +val camlp4_ast_intf_magic_number : string;; +val program_name : string ref;; +val unsafe : bool ref;; +val verbose : bool ref;; +val quotations : bool ref;; +val constructors_arity : bool ref;; +val inter_phrases : (string option) ref;; +val current_input_file : string ref;; diff --git a/camlp4/Makefile b/camlp4/Makefile index 712f938d..1fbb95f7 100644 --- a/camlp4/Makefile +++ b/camlp4/Makefile @@ -1,211 +1,99 @@ -# $Id: Makefile,v 1.23 2004/07/13 12:19:10 xleroy Exp $ - -include config/Makefile - -DIRS=odyl camlp4 meta lib etc top ocpp man -FDIRS=odyl camlp4 meta lib -OPTDIRS=lib odyl camlp4 meta etc compile -SHELL=/bin/sh -COLD_FILES=ocaml_src/camlp4/argl.ml ocaml_src/camlp4/ast2pt.ml ocaml_src/camlp4/ast2pt.mli ocaml_src/camlp4/mLast.mli ocaml_src/camlp4/pcaml.ml ocaml_src/camlp4/pcaml.mli ocaml_src/camlp4/quotation.ml ocaml_src/camlp4/quotation.mli ocaml_src/camlp4/reloc.ml ocaml_src/camlp4/reloc.mli ocaml_src/camlp4/spretty.ml ocaml_src/camlp4/spretty.mli ocaml_src/lib/extfun.ml ocaml_src/lib/extfun.mli ocaml_src/lib/fstream.ml ocaml_src/lib/fstream.mli ocaml_src/lib/gramext.ml ocaml_src/lib/gramext.mli ocaml_src/lib/grammar.ml ocaml_src/lib/grammar.mli ocaml_src/lib/plexer.ml ocaml_src/lib/plexer.mli ocaml_src/lib/stdpp.ml ocaml_src/lib/stdpp.mli ocaml_src/lib/token.ml ocaml_src/lib/token.mli ocaml_src/meta/pa_extend.ml ocaml_src/meta/pa_extend_m.ml ocaml_src/meta/pa_macro.ml ocaml_src/meta/pa_r.ml ocaml_src/meta/pa_rp.ml ocaml_src/meta/pr_dump.ml ocaml_src/meta/q_MLast.ml ocaml_src/odyl/odyl_main.ml ocaml_src/odyl/odyl_main.mli ocaml_src/odyl/odyl.ml +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2006 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +# $Id: Makefile,v 1.40 2007/02/07 10:09:21 ertai Exp $ + +# RELEASE NOTE: +# Do not forget to call make genclean to update Makefile.clean before a +# release. + +OCAMLC=../boot/ocamlrun ../ocamlc -nostdlib \ + -I ../stdlib -I ../otherlibs/unix -I ../otherlibs/win32unix -I build -g +OCAMLRUN=../boot/ocamlrun -I ../otherlibs/unix -I ../otherlibs/win32unix +YAM=$(OCAMLRUN) ./yam +YAM_OPTIONS=-verbosity '$(VERBOSE)' + +default: all + +opt install doc all pack just_doc: yam + @echo 'YAM $@ (use "make $@ VERBOSE=1" for a verbose make)' + @$(YAM) $(YAM_OPTIONS) $@ + +smartclean:: + if test -x ../boot/ocamlrun; then \ + if test -x ../ocaml; then \ + $(OCAML) build/build.ml -clean; \ + else \ + if test -x ./yam; then \ + $(YAM) $(YAM_OPTIONS) -clean; \ + else \ + $(MAKE) staticclean; \ + fi; \ + fi; \ + else \ + rm -f $(CLEANFILES); \ + fi -all: boot/camlp4$(EXE) - set -e; for i in $(DIRS); do cd $$i; $(MAKE) all; cd ..; done +genclean: yam + $(YAM) -genclean Makefile.clean + (echo /Camlp4Ast.ml/d; echo w; echo q) | ed Makefile.clean -opt: - cd lib; $(MAKE) opt +clean:: + rm -f yam .cache-status + rm -f $(CLEANFILES) + rm -f *.cm[io] build/*.cm[io] -opt.opt: - set -e; for i in $(OPTDIRS); do cd $$i; $(MAKE) opt; cd ..; done +YAM_OBJS=build/YaM.cmo build/camlp4_config.cmo Makefile.cmo -boot/camlp4$(EXE): $(COLD_FILES) - $(MAKE) clean_cold library_cold compile_cold - $(MAKE) promote_cold - $(MAKE) clean_cold clean_hot library +yam: $(YAM_OBJS) + $(OCAMLC) -o yam unix.cma $(YAM_OBJS) -clean_hot: - for i in $(DIRS) compile; do (cd $$i; $(MAKE) clean); done +.SUFFIXES: .mli .ml .cmi .cmo -depend: - for i in $(DIRS) compile; do (cd $$i; $(MAKE) depend); done +.mli.cmi: + $(OCAMLC) -c $*.mli +.ml.cmo: + $(OCAMLC) -c $*.ml -install: - for i in $(DIRS) compile; do (cd $$i; $(MAKE) install BINDIR="$(BINDIR)" LIBDIR="$(LIBDIR)" MANDIR="$(MANDIR)"); done +build/YaM.cmo: build/YaM.cmi +Makefile.cmo: build/YaM.cmi build/camlp4_config.cmo uninstall: rm -rf "$(LIBDIR)/camlp4" - cd "$(BINDIR)"; rm -f *camlp4* odyl ocpp + cd "$(BINDIR)"; rm -f *camlp4* -clean:: - $(MAKE) clean_hot clean_cold - rm -f boot/*.cm[oi] boot/camlp4* - rm -rf boot/SAVED - -scratch: clean - -always: +depend: # Normal bootstrap -bootstrap: backup promote clean_hot all compare +bootstrap: backup promote clean all compare +bootstrap-debug: backup promote-debug clean all compare -backup: - mkdir boot.new - make mv_cvs FROM=boot TO=boot.new - mv boot boot.new/SAVED - mv boot.new boot +backup restore boot-clean:: + cd boot && $(MAKE) $@ -restore: - mv boot/SAVED boot.new - make mv_cvs FROM=boot TO=boot.new - rm -rf boot - mv boot.new boot +promote-debug: + cp camlp4boot-debug.run boot/camlp4boot promote: - for i in $(FDIRS); do (cd $$i; $(MAKE) promote); done + cp camlp4boot.run boot/camlp4boot compare: - @if (for i in $(FDIRS); do \ - if (cd $$i; $(MAKE) compare 2>/dev/null); then :; \ - else exit 1; fi; \ - done); \ + @if (cmp camlp4boot.run boot/camlp4boot); \ then echo "Fixpoint reached, bootstrap succeeded."; \ else echo "Fixpoint not reached, try one more bootstrapping cycle."; \ fi -cleanboot: - rm -rf boot/SAVED/SAVED - - -# Core and core bootstrap - -bootstrap_core: backup promote clean_hot core compare - -core: boot/camlp4$(EXE) - set -e; for i in $(FDIRS); do cd $$i; $(MAKE) all; cd ..; done - -clean_core: - for i in $(FDIRS); do (cd $$i; $(MAKE) clean); done - - -# The very beginning - -world: - $(MAKE) clean_cold library_cold compile_cold - $(MAKE) promote_cold - $(MAKE) clean_cold clean_hot library all - -library: - cd lib; $(MAKE) all promote - -# Cold start using pure Objective Caml sources - -library_cold: - cd ocaml_src/lib; $(MAKE) all promote OTOP=../$(OTOP) - -compile_cold: - cd ocaml_src; set -e; \ - for i in $(FDIRS); do \ - cd $$i; $(MAKE) all OTOP=../$(OTOP); cd ..; \ - done - -promote_cold: - for i in $(FDIRS); do \ - (cd ocaml_src/$$i; $(MAKE) promote); \ - done - -clean_cold: - for i in $(FDIRS); do \ - (cd ocaml_src/$$i; $(MAKE) clean); \ - done - -# Configuring for native win32 - -configure_nt: - echo pouet - echo BINDIR = $(BINDIR) - -# Bootstrap the sources - -TXTGEN=This file has been generated by program: do not edit! - -bootstrap_sources: - cd etc; make pr_o.cmo - mkdir ocaml_src.new - @-for i in $(FDIRS); do \ - (mkdir ocaml_src.new/$$i; cd ocaml_src.new/$$i; \ - sed 's/# $$Id.*\$$/# $(TXTGEN)/' ../../$$i/Makefile | \ - sed 's-include ../config-include ../../config-g' | \ - sed 's-../boot-../../boot-g' > Makefile; \ - cp ../../$$i/.depend . ; \ - ); \ - done - @-for i in $(FDIRS); do \ - (cd $$i; \ - for j in *.ml*; do \ - echo ============================================; \ - echo ocaml_src.new/$$i/$$j; \ - OTOP=../.. ../tools/conv.sh $$j | \ - sed 's/$$Id.*\$$/$(TXTGEN)/' > \ - ../ocaml_src.new/$$i/$$j; \ - done); \ - done - -my_bootstrap_sources: - mkdir ocaml_src.new - @-for i in $(FDIRS); do \ - (mkdir ocaml_src.new/$$i; cd ocaml_src.new/$$i; \ - sed 's/# $$Id.*\$$/# $(TXTGEN)/' ../../$$i/Makefile | \ - sed 's-include ../config-include ../../config-g' | \ - sed 's-../boot-../../boot-g' > Makefile; \ - sed 's/# $$Id.*\$$/# $(TXTGEN)/' ../../$$i/Makefile.Mac | \ - sed 's-:boot-::boot-g' > Makefile.Mac; \ - cp ../../$$i/.depend . ; \ - cp ../../$$i/Makefile.Mac.depend .); \ - done - @-for i in $(FDIRS); do \ - (cd $$i; \ - for j in *.ml*; do \ - echo ============================================; \ - echo ocaml_src.new/$$i/$$j; \ - $$HOME/bin/conv.sh $$j | \ - sed 's/$$Id.*\$$/$(TXTGEN)/' > \ - ../ocaml_src.new/$$i/$$j; \ - done); \ - done - -untouch_sources: - @-cd ocaml_src; \ - for i in $(FDIRS); do \ - for j in $$i/*.ml* $$i/Makefile*; do \ - if cmp -s $$j ../ocaml_src.new/$$j 2>/dev/null; then \ - cp -p $$j ../ocaml_src.new/$$j; \ - fi; \ - done; \ - done - -promote_sources: - make mv_cvs FROM=ocaml_src TO=ocaml_src.new - for i in $(FDIRS); do \ - make mv_cvs FROM=ocaml_src/$$i TO=ocaml_src.new/$$i; \ - done - mv ocaml_src/tools ocaml_src.new/. - mv ocaml_src ocaml_src.new/SAVED - mv ocaml_src.new ocaml_src - -unpromote_sources: - mv ocaml_src ocaml_src.new - mv ocaml_src.new/SAVED ocaml_src - mv ocaml_src.new/tools ocaml_src/. - for i in $(FDIRS); do \ - make mv_cvs FROM=ocaml_src.new/$$i TO=ocaml_src/$$i; \ - done - make mv_cvs FROM=ocaml_src.new TO=ocaml_src - -clean_sources: - rm -rf ocaml_src/SAVED/SAVED - -# Utility - -mv_cvs: - test ! -d $(FROM)/CVS || mv $(FROM)/CVS $(TO)/. - test ! -f $(FROM)/.cvsignore || mv $(FROM)/.cvsignore $(TO)/. +.PHONY: clean install all uninstall backup restore boot-clean promote-debug \ + promote compare opt doc smartclean depend + +include Makefile.clean diff --git a/camlp4/Makefile.ml b/camlp4/Makefile.ml new file mode 100644 index 00000000..3383f594 --- /dev/null +++ b/camlp4/Makefile.ml @@ -0,0 +1,567 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Nicolas Pouillard: initial version + *) +open YaM +open Format + +let getenv var default = + try Sys.getenv var + with Not_found -> + default + +let libdir_camlp4 = (getenv "LIBDIR" Camlp4_config.libdir) ^ "/camlp4/." + +let bindir = (getenv "BINDIR" Camlp4_config.bindir) ^ "/." + +(** +let unixlib = + match Sys.os_type with + | "Win32" -> "../otherlibs/win32unix" + | _ -> "../otherlibs/unix" +**) +let ocamlrun = "../boot/ocamlrun" (* " -I " ^ unixlib *) +let ocamlrun_os = + Filename.concat Filename.parent_dir_name + (Filename.concat "boot" "ocamlrun") +(* ^ " -I " ^ unixlib *) + +let ocaml = ocamlrun ^ " ../ocaml -I ../stdlib" (* "-I " ^ unixlib *) + +let debug_mode = + (* true *) + false + +let camlp4_modules = + [ + ocamlrun_os; + "./boot/camlp4boot"; + ] +let camlp4_modules = + if debug_mode then "env STATIC_CAMLP4_DEBUG=\\*" :: camlp4_modules + else camlp4_modules + +let debug_opt x = if debug_mode && Sys.file_exists x then [x] else [] +let filter_opt x = if Sys.file_exists x then [x] else [] + +let camlp4boot = "'" ^ String.concat " " camlp4_modules ^ "'" +let camlp4boot_may_debug mods = + let camlp4_modules = camlp4_modules @ + debug_opt "./boot/ExceptionTracer.cmo" @ + filter_opt "./boot/Profiler.cmo" @ mods + in "'" ^ String.concat " " camlp4_modules ^ "'" + +let ocamlc = + best ["../ocamlc.opt", "../ocamlc.opt"; + "../ocamlc", ocamlrun ^^ "../ocamlc"; + "", "echo no byte compiler available && false"] +let ocamlopt = + best ["../ocamlopt.opt", "../ocamlopt.opt"; + "../ocamlopt", ocamlrun ^^ "../ocamlopt"; + "", "echo no native compiler available && false"] + +let () = + !options.ocamlc := ocamlc ^^ " -nostdlib -I ../stdlib"; + !options.ocamlopt := ocamlopt ^^ " -nostdlib -I ../stdlib"; + !options.ocamldoc := ocamlrun ^^ "../ocamldoc/ocamldoc"; + !options.ocamlyacc := ocamlrun ^^ "../boot/ocamlyacc"; + !options.ocamllex := ocamlrun ^^ "../boot/ocamllex"; + !options.ocamldep := ocamlrun ^^ "../tools/ocamldep"; + () + +let options_without_camlp4 = new_scope (lazy !options) + +let windows = Sys.os_type = "Win32" + +let may_define_unix = if windows then [] else ["-D UNIX"] + +let () = + !options.ocaml_Flags ^= "-w Ale -warn-error Ale"^^ + (if getenv "DTYPES" "" <> "" then "-dtypes" + else ""); + !options.ocaml_P4 := camlp4boot_may_debug may_define_unix; + !options.ocaml_P4_opt := camlp4boot_may_debug ("-D OPT" :: may_define_unix); + () + +let options_without_debug () = { (!options) with ocaml_P4 = ref camlp4boot + ; ocaml_P4_opt = ref camlp4boot } + +let parsing = "../parsing" +and typing = "../typing" +and toplevel = "../toplevel" +and utils = "../utils" +and dynlink = "../otherlibs/dynlink" +and unix = + match Sys.os_type with + | "Win32" -> "../otherlibs/win32unix" + | _ -> "../otherlibs/unix" +and build = "build" + +let ocaml_Module_with_genmap = + generic_ocaml_Module_extension ".genmap.ml" + (fun _ i o -> + "if test ! -e"^^o^^ + "|| ( test -e ./camlp4boot.run"^^ + "&& test -e Camlp4Filters/GenerateMap.cmo"^^ + "&& test -e Camlp4Filters/GenerateFold.cmo"^^ + "&& test -e Camlp4Filters/MetaGenerator.cmo"^^ + "&& test -e Camlp4Filters/RemoveTrashModule.cmo ) ;"^^ + "then ( echo 'module Camlp4FiltersTrash = struct' ;"^^ + "cat Camlp4/Sig/Camlp4Ast.ml ; echo 'end;' ) > Camlp4/Struct/Camlp4Ast.tmp.ml ;"^^ + "( echo '(* Generated file! Do not edit by hand *)' ;"^^ + "../boot/ocamlrun ./camlp4boot.run"^^ + "./Camlp4Filters/GenerateMap.cmo"^^ + "./Camlp4Filters/GenerateFold.cmo"^^ + "./Camlp4Filters/MetaGenerator.cmo"^^ + "./Camlp4Filters/RemoveTrashModule.cmo -printer OCamlr"^^ + i^^" -no_comments ) >"^^o^^"; else : ; fi") + +let misc_modules = + let mk = ocaml_fake_IModule ~includes:[parsing;utils] + ~o:options_without_camlp4 in + [ + ocaml_Module ~o:options_without_camlp4 "build/camlp4_config"; + mk "../utils/misc"; + mk "../utils/warnings"; + mk "../parsing/linenum"; + mk "../parsing/location"; + ] + +let camlp4_package_as_one_file = + ocaml_Module ~includes:[build] + ~ext_includes:[parsing; dynlink] + ~o:options_without_camlp4 + "Camlp4" + +let camlp4_package_as_one_dir = + ocaml_PackageDir "Camlp4" (lazy [ + ocaml_IModule ~includes:[build] "Config"; + ocaml_IModule ~o:(options_without_debug ()) "Debug"; + ocaml_IModule "Options"; + ocaml_PackageDir "Sig" (lazy [ + ocaml_Interface "Id"; + ocaml_Interface ~ext_includes:[parsing] "Loc"; + ocaml_Interface "Error"; + ocaml_Interface "Warning"; + ocaml_Interface "Type"; + ocaml_Interface "Token"; + ocaml_Interface "Lexer"; + ocaml_PackageDir "Grammar" (lazy [ + ocaml_Interface "Action"; + ocaml_Interface "Structure"; + ocaml_Interface "Dynamic"; + ocaml_Interface "Static" + ]); + ocaml_IModule "Mapper"; + ocaml_Interface "Ast"; + ocaml_Module "Camlp4Ast"; + ocaml_Interface "Quotation"; + ocaml_Interface "Camlp4Token"; + ocaml_Interface "DynLoader"; + ocaml_Interface "AntiquotSyntax"; + ocaml_Interface "Parser"; + ocaml_Interface "Printer"; + ocaml_Interface "Syntax"; + ocaml_Interface "Camlp4Syntax"; + ocaml_Interface "AstFilters"; + ocaml_Interface "SyntaxExtension"; + ]); + ocaml_IModule "ErrorHandler"; + ocaml_PackageDir "Struct" (lazy [ + ocaml_IModule ~ext_includes:[parsing] "Loc"; + ocaml_Module "Warning"; + ocaml_IModule "EmptyError"; + ocaml_IModule "EmptyPrinter"; + ocaml_IModule "Token"; + ocaml_Lexer ~includes:[utils] ~ext_includes:[parsing] ~pp:"" "Lexer"; + ocaml_PackageDir "Grammar" (lazy [ + ocaml_Module "Context"; + ocaml_Module "Structure"; + ocaml_Module "Search"; + ocaml_Module "Tools"; + ocaml_IModule "Print"; + ocaml_Module "Failed"; + ocaml_Module "Parser"; + ocaml_IModule "Fold"; + ocaml_Module "Insert"; + ocaml_Module "Delete"; + ocaml_Module "Entry"; + ocaml_Module "Find"; + ocaml_Module "Dynamic"; + ocaml_Module "Static" + ]); + ocaml_Module "Quotation"; + ocaml_IModule ~ext_includes:[dynlink] "DynLoader"; + ocaml_Module_with_genmap ~flags:"-w z -warn-error z" "Camlp4Ast"; + ocaml_IModule "FreeVars"; + ocaml_Module "AstFilters"; + ocaml_IModule ~ext_includes:[parsing] "Camlp4Ast2OCamlAst"; + ocaml_Module "CleanAst"; + ocaml_IModule "CommentFilter"; + ]); + ocaml_Module "OCamlInitSyntax"; + ocaml_PackageDir "Printers" (lazy [ + ocaml_IModule "Null"; + ocaml_IModule "DumpOCamlAst"; + ocaml_IModule "DumpCamlp4Ast"; + ocaml_IModule "OCaml"; + ocaml_IModule "OCamlr" ~flags:"-w v -warn-error v"; + (* ocaml_IModule "OCamlrr"; *) + ]); + ocaml_IModule "PreCast"; + ocaml_IModule "Register" + ]) + +let camlp4_package = + if Sys.file_exists "Camlp4.ml" && not (is_file_empty "Camlp4.ml") + then camlp4_package_as_one_file + else camlp4_package_as_one_dir + +let camlp4_parsers = + ocaml_PackageDir "Camlp4Parsers" (lazy [ + ocaml_Module "OCamlr"; + ocaml_Module "OCaml"; + (* ocaml_Module "OCamlrr"; *) + ocaml_Module "OCamlQuotationBase"; + ocaml_Module "OCamlQuotation"; + ocaml_Module "OCamlRevisedQuotation"; + ocaml_Module "OCamlOriginalQuotation"; + ocaml_Module "OCamlRevisedParser"; + ocaml_Module "OCamlParser"; + ocaml_Module "Grammar"; + ocaml_Module "Macro"; + ocaml_Module ~o:(options_without_debug ()) "Debug"; + ocaml_Module "LoadCamlp4Ast"; + ]) + +let camlp4_printers = + ocaml_PackageDir "Camlp4Printers" (lazy [ + ocaml_Module "DumpOCamlAst"; + ocaml_Module "DumpCamlp4Ast"; + ocaml_Module "OCaml"; + ocaml_Module "OCamlr"; + (* ocaml_Module "OCamlrr"; *) + ocaml_Module "Null"; + ocaml_Module ~ext_includes:[unix] "Auto"; + ]) + +let camlp4_filters = + ocaml_PackageDir "Camlp4Filters" (lazy [ + ocaml_Module "ExceptionTracer"; + ocaml_Module "Tracer"; + ocaml_Module "StripLocations"; + ocaml_Module "LiftCamlp4Ast"; + ocaml_Module "GenerateMap"; + ocaml_Module "GenerateFold"; + ocaml_Module "MetaGenerator"; + ocaml_Module "RemoveTrashModule"; + ocaml_Module "Profiler"; + ]) + +let camlp4_top = + ocaml_PackageDir "Camlp4Top" (lazy [ + ocaml_Module ~ext_includes:[toplevel; typing; parsing] "Rprint"; + ocaml_Module ~ext_includes:[toplevel; parsing; utils] "Camlp4Top"; + ]) + +let extensions = [ camlp4_parsers; camlp4_printers; camlp4_filters; camlp4_top ] + + +let pa_r = ocaml_Module "Camlp4Parsers/OCamlr" +let pa_o = ocaml_Module "Camlp4Parsers/OCaml" +let pa_q = ocaml_Module "Camlp4Parsers/OCamlQuotation" +let pa_qb = ocaml_Module "Camlp4Parsers/OCamlQuotationBase" +let pa_rq = ocaml_Module "Camlp4Parsers/OCamlRevisedQuotation" +let pa_oq = ocaml_Module "Camlp4Parsers/OCamlOriginalQuotation" +let pa_rp = ocaml_Module "Camlp4Parsers/OCamlRevisedParser" +let pa_op = ocaml_Module "Camlp4Parsers/OCamlParser" +let pa_g = ocaml_Module "Camlp4Parsers/Grammar" +let pa_macro = ocaml_Module "Camlp4Parsers/Macro" +let pa_debug = ocaml_Module "Camlp4Parsers/Debug" +let pr_dump = ocaml_Module "Camlp4Printers/DumpOCamlAst" +let pr_r = ocaml_Module "Camlp4Printers/OCamlr" +let pr_o = ocaml_Module "Camlp4Printers/OCaml" +let pr_a = ocaml_Module "Camlp4Printers/Auto" +let fi_exc = ocaml_Module "Camlp4Filters/ExceptionTracer" +let fi_tracer = ocaml_Module "Camlp4Filters/Tracer" +let fi_meta = ocaml_Module "Camlp4Filters/MetaGenerator" +let camlp4_bin = ocaml_Module "Camlp4Bin" +let top_rprint = ocaml_Module "Camlp4Top/Rprint" +let top_camlp4_top = ocaml_Module "Camlp4Top/Camlp4Top" +let camlp4Profiler = ocaml_IModule "Camlp4Profiler" + +let byte_programs = ref [] +let opt_programs = ref [] +let byte_libraries = ref [] +(* let opt_libraries = ref [] *) + +let special_modules = + if Sys.file_exists "./boot/Profiler.cmo" then [camlp4Profiler] else [] + +let mk_camlp4_top_lib name modules = + byte_libraries += (name ^ ".cma"); + ocaml_Library ~default:`Byte ~libraries:["Camlp4"] ~flags:"-linkall" name + (special_modules @ modules @ [top_camlp4_top]) + +let mk_camlp4_bin name ?unix:(link_unix=true) modules = + byte_programs += (name ^ ".run"); + opt_programs += (name ^ ".opt"); + let libraries = ["Camlp4"] in + let libraries = if link_unix then "unix" :: libraries else libraries in + ocaml_Program ~default:`Byte ~includes:[unix] ~libraries ~flags:"-linkall" name + (special_modules @ modules @ [camlp4_bin]) + +let mk_camlp4_tool name modules = + byte_programs += (name ^ ".run"); + opt_programs += (name ^ ".opt"); + [ocaml_Program ~default:`Byte ~libraries:["Camlp4"] ~flags:"-linkall" name modules] + +let mk_camlp4 name ?unix modules bin_mods top_mods = + [mk_camlp4_bin name ?unix (modules @ bin_mods); + mk_camlp4_top_lib name (modules @ top_mods)] + +let split c s = + let rec self acc s = + try + let pos = String.rindex s c in + let x = String.sub s 0 pos + and y = String.sub s (pos + 1) (String.length s - pos - 1) + in self (y :: acc) x + with Not_found -> s :: acc + in self [] s +let chop_end c s = + let pos = String.rindex s c in + String.sub s (pos + 1) (String.length s - pos - 1) +let file ppf f = + let cin = open_in f in + let rec loop () = + pp_print_string ppf (input_line cin); + fprintf ppf "@\n"; + loop () + in try loop () with End_of_file -> () +let ext_split f = split '.' f + + +let print_packed_sources ppf ?(skip = fun _ -> false) package_dir = + let _ = + fold_units_sources [package_dir] (fun name sources k (skip, inside) -> + eprintf "%s: [%s] (%b)@." name (String.concat "; " sources) inside; + let name = try chop_end '/' name with Not_found -> name in + let k () = ignore (k (skip, true)) in + if not inside then k () else ( + if skip name then fprintf ppf "(**/**)@\n" else fprintf ppf "(** *)@\n"; + fprintf ppf "@[<2>module %s " name; + let (mli, ml, mll, k) = + List.fold_right + (fun x (mli, ml, mll, k) -> + match ext_split x with + | [_; "mli"] -> (Some x, ml, mll, k) + | [_; "ml"] -> (mli, Some x, mll, k) + | [_; "mll"] -> (mli, ml, Some x, k) + | [x; "meta"; "ml"] -> (mli, Some (x^".ml"), mll, fun () -> ()) + | [x; "genmap"; "ml"] -> (mli, Some (x^".ml"), mll, fun () -> ()) + | [_; ext] -> failwith ("unknown extension " ^ ext) + | _ -> failwith ("bad file "^x)) + sources (None, None, None, k) in + (match (ml, mll, mli) with + | (None, None, Some mli) -> fprintf ppf "=@ @[<2>struct@\n" + | (_, _, Some mli) -> fprintf ppf ":@,@[<2>sig@\n%a@]@\nend@\n" file mli; + fprintf ppf "=@ @[<2>struct@\n" + | _ -> fprintf ppf "=@ @[<2>struct@\n"); + (match (ml, mll, mli) with + | (_, Some mll, _) -> + fprintf ppf "(*___CAMLP4_LEXER___ %a ___CAMLP4_LEXER___*)@\n();" + file (String.sub mll 0 (String.length mll - 1)) + | (Some ml, _, _) -> k (); fprintf ppf "%a" file ml + | (None, _, Some mli) -> k (); fprintf ppf "%a" file mli + | _ -> if sources <> [] then () else k ()); + fprintf ppf "@]@\nend;@]@\n"; + if skip name then fprintf ppf "(**/**)@\n"; + ); + (skip, inside) + ) (skip, false) in fprintf ppf "@." + +let run l = + let cmd = String.concat " " l in + let () = Format.printf "%s@." cmd in + let st = YaM.call cmd in + if st <> 0 then failwith ("Exit: " ^ string_of_int st) + +let mkdir l = run ("mkdir" :: "-p" :: l) + +let cp src dest = run ["cp"; src; dest] + +let sed re str file = + run ["sed"; "-i"; "-e"; "'s/"^re^"/"^str^"/'"; file] + +let try_cp src dest = if Sys.file_exists src then cp src dest + +let pack () = + let revised_to_ocaml f = + run ["./boot/camlp4boot -printer OCaml -o "^f^".ml -impl "^f^".ml4"] in + let ppf_of_file f = formatter_of_out_channel (open_out f) in + let skip_struct = function "Struct" -> true | _ -> false in + print_packed_sources (ppf_of_file "Camlp4.ml4") + ~skip:skip_struct camlp4_package_as_one_dir; + print_packed_sources (ppf_of_file "Camlp4Parsers.ml4") camlp4_parsers; + print_packed_sources (ppf_of_file "Camlp4Printers.ml4") camlp4_printers; + print_packed_sources (ppf_of_file "Camlp4Filters.ml4") camlp4_filters; + print_packed_sources (ppf_of_file "Camlp4Top.ml4") camlp4_top; + revised_to_ocaml "Camlp4"; + sed "(\\*___CAMLP4_LEXER___" "" "Camlp4.ml"; + sed "___CAMLP4_LEXER___\\*)" "" "Camlp4.ml"; + sed "^ *# [0-9]\\+.*$" "" "Camlp4.ml"; + revised_to_ocaml "Camlp4Parsers"; + revised_to_ocaml "Camlp4Printers"; + revised_to_ocaml "Camlp4Filters"; + revised_to_ocaml "Camlp4Top" + +let just_doc () = + run ["cd doc && ../../ocamldoc/ocamldoc"; + "-v -short-functors -html"; + "-I ../../parsing -I ../build -I ../../utils -I .."; + "-dump ocamldoc.out"; + "-t 'Camlp4 a Pre-Processor-Pretty-Printer for Objective Caml'"; + "../Camlp4.ml"; "../Camlp4Parsers.ml"; "../Camlp4Printers.ml"; + "../Camlp4Filters.ml"; "../Camlp4Top.ml"] + +let doc () = + pack (); just_doc () + +let other_objs = + [ + (* "../utils/misc"; "../parsing/linenum"; "../utils/warnings"; *) + (* "../parsing/location" *) + ] +let other_byte_objs = String.concat " " (List.map (fun x -> x ^ ".cmo") other_objs) +let other_opt_objs = String.concat " " (List.map (fun x -> x ^ ".cmx") other_objs) +let all = + List.flatten [ + [ocaml_Library ~default:`Byte + ~includes:[dynlink] + ~byte_flags:("dynlink.cma"^^other_byte_objs) ~opt_flags:other_opt_objs + ~flags:"-linkall" "Camlp4" + (misc_modules @ special_modules @ [camlp4_package])]; + [mk_camlp4_bin "camlp4" []]; + mk_camlp4 "camlp4boot" ~unix:false + [pa_r; pa_qb; pa_q; pa_rp; pa_g; pa_macro; pa_debug] [pr_dump] [top_rprint]; + mk_camlp4 "camlp4r" + [pa_r; pa_rp] [pr_a] [top_rprint]; + mk_camlp4 "camlp4rf" + [pa_r; pa_qb; pa_q; pa_rp; pa_g; pa_macro] [pr_a] [top_rprint]; + mk_camlp4 "camlp4o" + [pa_r; pa_o; pa_rp; pa_op] [pr_a] []; + mk_camlp4 "camlp4of" + [pa_r; pa_qb; pa_q; pa_o; pa_rp; pa_op; pa_g; pa_macro] [pr_a] []; + mk_camlp4 "camlp4oof" + [pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_oq; pa_g; pa_macro] [pr_a] []; + mk_camlp4 "camlp4orf" + [pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_rq; pa_g; pa_macro] [pr_a] []; + mk_camlp4_tool "mkcamlp4" + [ocaml_Module ~o:(options_without_debug ()) "mkcamlp4"]; + mk_camlp4_tool "camlp4prof" + [camlp4Profiler; ocaml_Module ~o:(options_without_debug ()) "camlp4prof"]; + ] @ extensions + + +(* X.run -> X.exe || X.run -> X *) +let conv_byte_extension f = + if windows then + let c = String.copy f in + (String.blit c (String.rindex c '.') ".exe" 0 4; c) + else String.sub f 0 (String.rindex f '.') + +(* X.opt -> X.opt.exe || X.opt -> X.opt *) +let conv_opt_extension f = + if windows then f ^ ".exe" else f + +let install_all dir = + printf "Installing %s@. " dir; + run ["for i in " ^ dir ^ "/*.cm[io]; do"^^ + "echo \" install $i\" ; mkdir -p"^^libdir_camlp4^ + "/`dirname $i`; cp $i"^^libdir_camlp4^"/`dirname $i`; done"] + + +let byte = + "Camlp4.cmi" :: + "Camlp4.cma" :: + "Camlp4Parsers.cmi" :: + "Camlp4Printers.cmi" :: + "Camlp4Filters.cmi" :: + "Camlp4Top.cmi" :: + "Camlp4Bin.cmi" :: + "Camlp4Parsers.cmo" :: + "Camlp4Printers.cmo" :: + "Camlp4Filters.cmo" :: + "Camlp4Top.cmo" :: + "Camlp4Bin.cmo" :: + !byte_libraries + +let opt = + "Camlp4.cmxa" :: + "Camlp4.a" :: + "build/camlp4_config.cmx" :: + "Camlp4Parsers.cmx" :: + "Camlp4Printers.cmx" :: + "Camlp4Filters.cmx" :: + "Camlp4Bin.cmx" :: + (* !opt_libraries @ *) + [] + +let install () = + mkdir [libdir_camlp4; bindir]; + install_all "Camlp4Parsers"; + install_all "Camlp4Printers"; + install_all "Camlp4Filters"; + install_all "Camlp4Top"; + let cp_bin conv bin = + if Sys.file_exists bin then cp bin (bindir ^ "/" ^ conv bin) in + List.iter (fun x -> cp x libdir_camlp4) byte; + List.iter (fun x -> try_cp x libdir_camlp4) opt; + List.iter (cp_bin conv_byte_extension) !byte_programs; + List.iter (cp_bin conv_opt_extension) !opt_programs; + () + (* cp mkcamlp4.sh "$(BINDIR)/mkcamlp4" *) + (* chmod a+x "$(BINDIR)/mkcamlp4" *) + + +let byte = byte @ !byte_programs +let opt = opt @ !opt_programs + +;; + +main ~rebuild:(ocaml ^^ "build/build.ml") + (all @ [ + phony_unit ~depends:byte "all"; + phony_unit ~depends:opt "opt"; + generic_unit ~name:"install" ~targets:["install"] ~trash:[] + ~dependencies:(fun ~native:_ _ -> []) + ~compile_cmd:(fun _ -> install (); exit 0) + (); + generic_unit ~name:"doc" ~targets:["doc"] ~trash:[] + ~dependencies:(fun ~native:_ _ -> []) + ~compile_cmd:(fun _ -> doc (); exit 0) + (); + generic_unit ~name:"just_doc" ~targets:["just_doc"] ~trash:[] + ~dependencies:(fun ~native:_ _ -> []) + ~compile_cmd:(fun _ -> just_doc (); exit 0) + (); + generic_unit ~name:"pack" ~targets:["pack"] ~trash:[] + ~dependencies:(fun ~native:_ _ -> []) + ~compile_cmd:(fun _ -> pack (); exit 0) + (); + ]) + diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml new file mode 100644 index 00000000..ef4b7686 --- /dev/null +++ b/camlp4/boot/Camlp4.ml @@ -0,0 +1,16506 @@ +module Debug : + sig + (****************************************************************************) + (* *) + (* Objective Caml *) + (* *) + (* INRIA Rocquencourt *) + (* *) + (* Copyright 2006 Institut National de Recherche en Informatique et *) + (* en Automatique. All rights reserved. This file is distributed under *) + (* the terms of the GNU Library General Public License, with the special *) + (* exception on linking described in LICENSE at the top of the Objective *) + (* Caml source tree. *) + (* *) + (****************************************************************************) + (* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + (* camlp4r *) + type section = string + val mode : section -> bool + val printf : section -> ('a, Format.formatter, unit) format -> 'a + end = + struct + (****************************************************************************) + (* *) + (* Objective Caml *) + (* *) + (* INRIA Rocquencourt *) + (* *) + (* Copyright 2006 Institut National de Recherche en Informatique et *) + (* en Automatique. All rights reserved. This file is distributed under *) + (* the terms of the GNU Library General Public License, with the special *) + (* exception on linking described in LICENSE at the top of the Objective *) + (* Caml source tree. *) + (* *) + (****************************************************************************) + (* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + (* camlp4r *) + open Format + module Debug = struct let mode _ = false end + type section = string + let 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 -> stderr + module StringSet = Set.Make(String) + let 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) + let formatter = + let header = "camlp4-debug: " in + let normal s = + let rec self from accu = + try + let i = String.index_from s from '\n' + in self (i + 1) ((String.sub s from ((i - from) + 1)) :: accu) + with + | Not_found -> + (String.sub s from ((String.length s) - from)) :: accu + in String.concat header (List.rev (self 0 [])) in + let after_new_line str = header ^ (normal str) in + let f = ref after_new_line in + let output str chr = + (output_string out_channel (!f str); + output_char out_channel chr; + f := if chr = '\n' then after_new_line else normal) + in + make_formatter + (fun buf pos len -> + let p = pred len in output (String.sub buf pos p) buf.[pos + p]) + (fun () -> flush out_channel) + let printf section fmt = fprintf formatter ("%s: " ^^ fmt) section + end +module Options : + sig + (****************************************************************************) + (* *) + (* Objective Caml *) + (* *) + (* INRIA Rocquencourt *) + (* *) + (* Copyright 2006 Institut National de Recherche en Informatique et *) + (* en Automatique. All rights reserved. This file is distributed under *) + (* the terms of the GNU Library General Public License, with the special *) + (* exception on linking described in LICENSE at the top of the Objective *) + (* Caml source tree. *) + (* *) + (****************************************************************************) + (* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + type spec_list = (string * Arg.spec * string) list + val init : spec_list -> unit + val add : string -> Arg.spec -> string -> unit + (** Add an option to the command line options. *) + val print_usage_list : spec_list -> unit + val ext_spec_list : unit -> spec_list + val parse : (string -> unit) -> string array -> string list + end = + struct + (****************************************************************************) + (* *) + (* Objective Caml *) + (* *) + (* INRIA Rocquencourt *) + (* *) + (* Copyright 2006 Institut National de Recherche en Informatique et *) + (* en Automatique. All rights reserved. This file is distributed under *) + (* the terms of the GNU Library General Public License, with the special *) + (* exception on linking described in LICENSE at the top of the Objective *) + (* Caml source tree. *) + (* *) + (****************************************************************************) + (* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + type spec_list = (string * Arg.spec * string) list + open Format + let rec action_arg s sl = + function + | Arg.Unit f -> if s = "" then (f (); Some sl) else None + | Arg.Bool f -> + if s = "" + then + (match sl with + | s :: sl -> + (try (f (bool_of_string s); Some sl) + with | Invalid_argument "bool_of_string" -> None) + | [] -> None) + else + (try (f (bool_of_string s); Some sl) + with | Invalid_argument "bool_of_string" -> None) + | Arg.Set r -> if s = "" then (r := true; Some sl) else None + | Arg.Clear r -> if s = "" then (r := false; Some sl) else None + | Arg.Rest f -> (List.iter f (s :: sl); Some []) + | Arg.String f -> + if s = "" + then (match sl with | s :: sl -> (f s; Some sl) | [] -> None) + else (f s; Some sl) + | Arg.Set_string r -> + if s = "" + then (match sl with | s :: sl -> (r := s; Some sl) | [] -> None) + else (r := s; Some sl) + | Arg.Int f -> + if s = "" + then + (match sl with + | s :: sl -> + (try (f (int_of_string s); Some sl) + with | Failure "int_of_string" -> None) + | [] -> None) + else + (try (f (int_of_string s); Some sl) + with | Failure "int_of_string" -> None) + | Arg.Set_int r -> + if s = "" + then + (match sl with + | s :: sl -> + (try (r := int_of_string s; Some sl) + with | Failure "int_of_string" -> None) + | [] -> None) + else + (try (r := int_of_string s; Some sl) + with | Failure "int_of_string" -> None) + | Arg.Float f -> + if s = "" + then + (match sl with + | s :: sl -> (f (float_of_string s); Some sl) + | [] -> None) + else (f (float_of_string s); Some sl) + | Arg.Set_float r -> + if s = "" + then + (match sl with + | s :: sl -> (r := float_of_string s; Some sl) + | [] -> None) + else (r := float_of_string s; Some sl) + | Arg.Tuple specs -> + let rec action_args s sl = + (function + | [] -> 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 -> (f s; Some sl) + | _ -> None) + let common_start s1 s2 = + let 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 + in loop 0 + let 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 + let rec parse_aux fold anon_fun = + function + | [] -> [] + | 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 ((anon_fun s : unit); parse_aux fold anon_fun sl) + let align_doc key s = + let s = + let 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 loop 0 in + let (p, s) = + if (String.length s) > 0 + then + if s.[0] = '<' + then + (let 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 + let 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))) + in loop (i + 1)) + in loop 0) + else ("", s) + else ("", "") in + let tab = + String.make (max 1 ((16 - (String.length key)) - (String.length p))) + ' ' + in p ^ (tab ^ s) + let make_symlist l = + match l with + | [] -> "" + | h :: t -> + (List.fold_left (fun x y -> x ^ ("|" ^ y)) ("{" ^ h) t) ^ "}" + let 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 + let 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 + 1)) + let init_spec_list = ref [] + let ext_spec_list = ref [] + let init spec_list = init_spec_list := spec_list + let add name spec descr = + ext_spec_list := (name, spec, descr) :: !ext_spec_list + let fold f init = + let spec_list = !init_spec_list @ !ext_spec_list in + let specs = Sort.list (fun (k1, _, _) (k2, _, _) -> k1 >= k2) spec_list + in List.fold_right f specs init + let parse anon_fun argv = + let remaining_args = remaining_args argv + in parse_aux fold anon_fun remaining_args + let ext_spec_list () = !ext_spec_list + end +module Sig = + struct + (* camlp4r *) + (****************************************************************************) + (* *) + (* Objective Caml *) + (* *) + (* INRIA Rocquencourt *) + (* *) + (* Copyright 2006 Institut National de Recherche en Informatique et *) + (* en Automatique. All rights reserved. This file is distributed under *) + (* the terms of the GNU Library General Public License, with the special *) + (* exception on linking described in LICENSE at the top of the Objective *) + (* Caml source tree. *) + (* *) + (****************************************************************************) + (* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + 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 + val to_string : t -> string + val print : Format.formatter -> t -> unit + end + (** A signature for extensions identifiers. *) + module type Id = + sig + (** The name of the extension, typically the module name. *) + val name : string + (** The version of the extension, typically $Id: Camlp4.ml,v 1.3 2007/02/26 16:43:01 ertai Exp $ with a versionning system. *) + val version : string + end + module type Loc = + sig + type t + (** Return a start location for the given file name. + This location starts at the begining of the file. *) + val mk : string -> t + (** The [ghost] location can be used when no location + information is available. *) + val ghost : t + (** {6 Conversion functions} *) + (** Return a location where both positions are set the given position. *) + val of_lexing_position : Lexing.position -> t + (** Return an OCaml location. *) + val to_ocaml_location : t -> Location.t + (** Return a location from an OCaml location. *) + val of_ocaml_location : Location.t -> t + (** Return a location from ocamllex buffer. *) + val of_lexbuf : Lexing.lexbuf -> t + (** Return a location from [(file_name, start_line, start_bol, start_off, + stop_line, stop_bol, stop_off, ghost)]. *) + val 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)]. *) + val to_tuple : + t -> (string * int * int * int * int * int * int * bool) + (** [merge loc1 loc2] Return a location that starts at [loc1] and end at [loc2]. *) + val merge : t -> t -> t + (** The stop pos becomes equal to the start pos. *) + val 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]. *) + val 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]. *) + val 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. *) + val move_line : int -> t -> t + (** Accessors *) + (** Return the file name *) + val file_name : t -> string + (** Return the line number of the begining of this location. *) + val start_line : t -> int + (** Return the line number of the ending of this location. *) + val stop_line : t -> int + (** Returns the number of characters from the begining of the file + to the begining of the line of location's begining. *) + val start_bol : t -> int + (** Returns the number of characters from the begining of the file + to the begining of the line of location's ending. *) + val stop_bol : t -> int + (** Returns the number of characters from the begining of the file + of the begining of this location. *) + val start_off : t -> int + (** Return the number of characters from the begining of the file + of the ending of this location. *) + val stop_off : t -> int + (** Return the start position as a Lexing.position. *) + val start_pos : t -> Lexing.position + (** Return the stop position as a Lexing.position. *) + val stop_pos : t -> Lexing.position + (** Generally, return true if this location does not come + from an input stream. *) + val is_ghost : t -> bool + (** Return the associated ghost location. *) + val ghostify : t -> t + (** Return the location with the give file name *) + val 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]. *) + val strictly_before : t -> t -> bool + (** Return the location with an absolute file name. *) + val make_absolute : t -> t + (** Print the location into the formatter in a format suitable for error + reporting. *) + val print : Format.formatter -> t -> unit + (** Print the location in a short format useful for debugging. *) + val dump : Format.formatter -> t -> unit + (** Same as {!print} but return a string instead of printting it. *) + val 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 * exn + (** [raise loc e], if [e] is already an [Exc_located] exception, + re-raise it, else raise the exception [Exc_located loc e]. *) + val raise : t -> exn -> 'a + (** The name of the location variable used in grammars and in + the predefined quotations for OCaml syntax trees. Default: [_loc]. *) + val name : string ref + end + module type Warning = + sig + module Loc : Loc + type t = Loc.t -> string -> unit + val default : t + val current : t ref + val print : t + end + (** Base class for map traversal, it includes some builtin types. *) + class mapper = + (object method string = fun x -> (x : string) + method int = fun x -> (x : int) + method float = fun x -> (x : float) + method bool = fun x -> (x : bool) + method list : 'a 'b. ('a -> 'b) -> 'a list -> 'b list = List.map + method option : 'a 'b. ('a -> 'b) -> 'a option -> 'b option = + fun f -> function | None -> None | Some x -> Some (f x) + method array : 'a 'b. ('a -> 'b) -> 'a array -> 'b array = Array.map + method ref : 'a 'b. ('a -> 'b) -> 'a ref -> 'b ref = + fun f { contents = x } -> { contents = f x; } + end : + object + method string : string -> string + method int : int -> int + method float : float -> float + method bool : bool -> bool + method list : 'a 'b. ('a -> 'b) -> 'a list -> 'b list + method option : 'a 'b. ('a -> 'b) -> 'a option -> 'b option + method array : 'a 'b. ('a -> 'b) -> 'a array -> 'b array + method ref : 'a 'b. ('a -> 'b) -> 'a ref -> 'b ref + end) + (** Abstract syntax tree minimal signature. + Types of this signature are abstract. + See the {!Camlp4Ast} signature for a concrete definition. *) + module type Ast = + sig + module Loc : Loc + type meta_bool + type 'a meta_option + type 'a meta_list + 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 module_binding + val loc_of_ctyp : ctyp -> Loc.t + val loc_of_patt : patt -> Loc.t + val loc_of_expr : expr -> Loc.t + val loc_of_module_type : module_type -> Loc.t + val loc_of_module_expr : module_expr -> Loc.t + val loc_of_sig_item : sig_item -> Loc.t + val loc_of_str_item : str_item -> Loc.t + val loc_of_class_type : class_type -> Loc.t + val loc_of_class_sig_item : class_sig_item -> Loc.t + val loc_of_class_expr : class_expr -> Loc.t + val loc_of_class_str_item : class_str_item -> Loc.t + val loc_of_with_constr : with_constr -> Loc.t + val loc_of_binding : binding -> Loc.t + val loc_of_module_binding : module_binding -> Loc.t + val loc_of_match_case : match_case -> Loc.t + val loc_of_ident : ident -> Loc.t + (** 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 + inherit mapper + method meta_bool : meta_bool -> meta_bool + method meta_option : + 'a 'b. ('a -> 'b) -> 'a meta_option -> 'b meta_option + method meta_list : + 'a 'b. ('a -> 'b) -> 'a meta_list -> 'b meta_list + method _Loc_t : Loc.t -> Loc.t + 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 module_binding : module_binding -> module_binding + method match_case : match_case -> match_case + method ident : ident -> ident + end + class fold : + object ('self_type) + method string : string -> 'self_type + method int : int -> 'self_type + method float : float -> 'self_type + method bool : bool -> 'self_type + method list : + 'a. ('self_type -> 'a -> 'self_type) -> 'a list -> 'self_type + method option : + 'a. ('self_type -> 'a -> 'self_type) -> 'a option -> 'self_type + method array : + 'a. ('self_type -> 'a -> 'self_type) -> 'a array -> 'self_type + method ref : + 'a. ('self_type -> 'a -> 'self_type) -> 'a ref -> 'self_type + method meta_bool : meta_bool -> 'self_type + method meta_option : + 'a. + ('self_type -> 'a -> 'self_type) -> + 'a meta_option -> 'self_type + method meta_list : + 'a. + ('self_type -> 'a -> 'self_type) -> + 'a meta_list -> 'self_type + method _Loc_t : Loc.t -> '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 module_binding : module_binding -> 'self_type + method match_case : match_case -> 'self_type + method ident : ident -> 'self_type + end + end + (** The AntiquotSyntax signature describe the minimal interface needed + for antiquotation handling. *) + module type AntiquotSyntax = + sig + module Ast : Ast + (** The parse function for expressions. + The underlying expression grammar entry is generally "expr; EOI". *) + val parse_expr : Ast.Loc.t -> string -> Ast.expr + (** The parse function for patterns. + The underlying pattern grammar entry is generally "patt; EOI". *) + val parse_patt : Ast.Loc.t -> string -> Ast.patt + 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. *) + module type Camlp4Ast = + sig + module Loc : Loc + type meta_bool = | BTrue | BFalse | BAnt of string + type 'a meta_option = | ONone | OSome of 'a | OAnt of string + type 'a meta_list = + | LNil | LCons of 'a * 'a meta_list | LAnt of string + type ident = + | IdAcc of Loc.t * ident * ident | (* i . i *) + IdApp of Loc.t * ident * ident | (* i i *) IdLid of Loc.t * string + | (* foo *) IdUid of Loc.t * string | (* Bar *) + IdAnt of Loc.t * string + (* $s$ *) + type ctyp = + | TyNil of Loc.t | TyAli of Loc.t * ctyp * ctyp | (* t as t *) + (* list 'a as 'a *) TyAny of Loc.t | (* _ *) + TyApp of Loc.t * ctyp * ctyp | (* t t *) (* list 'a *) + TyArr of Loc.t * ctyp * ctyp | (* t -> t *) (* int -> string *) + TyCls of Loc.t * ident | (* #i *) (* #point *) + TyLab of Loc.t * string * ctyp | (* ~s *) TyId of Loc.t * ident + | (* i *) (* Lazy.t *) TyMan of Loc.t * ctyp * ctyp | (* t == t *) + (* type t = [ A | B ] == Foo.t *) + (* type t 'a 'b 'c = t constraint t = t constraint t = t *) + TyDcl of Loc.t * string * ctyp list * ctyp * (ctyp * ctyp) list + | (* < (t)? (..)? > *) (* < move : int -> 'a .. > as 'a *) + TyObj of Loc.t * ctyp * meta_bool | TyOlb of Loc.t * string * ctyp + | (* ?s *) TyPol of Loc.t * ctyp * ctyp | (* ! t . t *) + (* ! 'a . list 'a -> 'a *) TyQuo of Loc.t * string | (* 's *) + TyQuP of Loc.t * string | (* +'s *) TyQuM of Loc.t * string + | (* -'s *) TyVrn of Loc.t * string | (* `s *) + TyRec of Loc.t * ctyp | (* { t } *) + (* { foo : int ; bar : mutable string } *) + TyCol of Loc.t * ctyp * ctyp | (* t : t *) + TySem of Loc.t * ctyp * ctyp | (* t; t *) + TyCom of Loc.t * ctyp * ctyp | (* t, t *) TySum of Loc.t * ctyp + | (* [ t ] *) (* [ A of int and string | B ] *) + TyOf of Loc.t * ctyp * ctyp | (* t of t *) (* A of int *) + TyAnd of Loc.t * ctyp * ctyp | (* t and t *) + TyOr of Loc.t * ctyp * ctyp | (* t | t *) TyPrv of Loc.t * ctyp + | (* private t *) TyMut of Loc.t * ctyp | (* mutable t *) + TyTup of Loc.t * ctyp | (* ( t ) *) (* (int * string) *) + TySta of Loc.t * ctyp * ctyp | (* t * t *) TyVrnEq of Loc.t * ctyp + | (* [ = t ] *) TyVrnSup of Loc.t * ctyp | (* [ > t ] *) + TyVrnInf of Loc.t * ctyp | (* [ < t ] *) + TyVrnInfSup of Loc.t * ctyp * ctyp | (* [ < t > t ] *) + TyAmp of Loc.t * ctyp * ctyp | (* t & t *) + TyOfAmp of Loc.t * ctyp * ctyp | (* t of & t *) + TyAnt of Loc.t * string + (* $s$ *) + type (* i *) + (* p as p *) + (* (Node x y as n) *) + (* $s$ *) + (* _ *) + (* p p *) + (* fun x y -> *) + (* [| p |] *) + (* p, p *) + (* p; p *) + (* c *) + (* 'x' *) + (* ~s or ~s:(p) *) + (* ?s or ?s:(p = e) or ?(p = e) *) + (* | PaOlb of Loc.t and string and meta_option(*FIXME*) (patt * meta_option(*FIXME*) expr) *) + (* ?s or ?s:(p) *) + (* ?s:(p = e) or ?(p = e) *) + (* p | p *) + (* p .. p *) + (* { p } *) + (* p = p *) + (* s *) + (* ( p ) *) + (* (p : t) *) + (* #i *) + (* `s *) + (* i *) + (* e.e *) + (* $s$ *) + (* e e *) + (* e.(e) *) + (* [| e |] *) + (* e; e *) + (* assert False *) + (* assert e *) + (* e := e *) + (* 'c' *) + (* (e : t) or (e : t :> t) *) + (* 3.14 *) + (* for s = e to/downto e do { e } *) + (* fun [ a ] *) + (* if e then e else e *) + (* 42 *) + (* ~s or ~s:e *) + (* lazy e *) + (* let b in e or let rec b in e *) + (* let module s = me in e *) + (* match e with [ a ] *) + (* new i *) + (* object ((p))? (cst)? end *) + (* ?s or ?s:e *) + (* {< b >} *) + (* { b } or { (e) with b } *) + (* do { e } *) + (* e#s *) + (* e.[e] *) + (* s *) + (* "foo" *) + (* try e with [ a ] *) + (* (e) *) + (* e, e *) + (* (e : t) *) + (* `s *) + (* while e do { e } *) + (* i *) + (* A.B.C *) + (* functor (s : mt) -> mt *) + (* 's *) + (* sig (sg)? end *) + (* mt with wc *) + (* $s$ *) + (* class cict *) + (* class type cict *) + (* sg ; sg *) + (* # s or # s e *) + (* exception t *) + (* external s : t = s ... s *) + (* include mt *) + (* module s : mt *) + (* module rec mb *) + (* module type s = mt *) + (* open i *) + (* type t *) + (* value s : t *) + (* $s$ *) + (* type t = t *) + (* module i = i *) + (* wc and wc *) + (* $s$ *) + (* b and b *) + (* let a = 42 and c = 43 *) + (* b ; b *) + (* p = e *) + (* let patt = expr *) + (* $s$ *) + (* mb and mb *) + (* module rec (s : mt) = me and (s : mt) = me *) + (* s : mt = me *) + (* s : mt *) + (* $s$ *) + (* a | a *) + (* p (when e)? -> e *) + (* $s$ *) + (* i *) + (* me me *) + (* functor (s : mt) -> me *) + (* struct (st)? end *) + (* (me : mt) *) + (* $s$ *) + (* class cice *) + (* class type cict *) + (* st ; st *) + (* # s or # s e *) + (* exception t or exception t = i *) + (*FIXME*) + (* e *) + (* external s : t = s ... s *) + (* include me *) + (* module s = me *) + (* module rec mb *) + (* module type s = mt *) + (* open i *) + (* type t *) + (* value b or value rec b *) + (* $s$ *) + (* (virtual)? i ([ t ])? *) + (* [t] -> ct *) + (* object ((t))? (csg)? end *) + (* ct and ct *) + (* ct : ct *) + (* ct = ct *) + (* $s$ *) + (* type t = t *) + (* csg ; csg *) + (* inherit ct *) + (* method s : t or method private s : t *) + (* value (virtual)? (mutable)? s : t *) + (* method virtual (mutable)? s : t *) + (* $s$ *) + (* ce e *) + (* (virtual)? i ([ t ])? *) + (* fun p -> ce *) + (* let (rec)? b in ce *) + (* object ((p))? (cst)? end *) + (* ce : ct *) + (* ce and ce *) + (* ce = ce *) + (* $s$ *) + patt = + | PaNil of Loc.t | PaId of Loc.t * ident + | PaAli of Loc.t * patt * patt | PaAnt of Loc.t * string + | PaAny of Loc.t | PaApp of Loc.t * patt * patt + | PaArr of Loc.t * patt | PaCom of Loc.t * patt * patt + | PaSem of Loc.t * patt * patt | PaChr of Loc.t * string + | PaInt of Loc.t * string | PaInt32 of Loc.t * string + | PaInt64 of Loc.t * string | PaNativeInt of Loc.t * string + | PaFlo of Loc.t * string | PaLab of Loc.t * string * patt + | PaOlb of Loc.t * string * patt + | PaOlbi of Loc.t * string * patt * expr + | PaOrp of Loc.t * patt * patt | PaRng of Loc.t * patt * patt + | PaRec of Loc.t * patt | PaEq of Loc.t * patt * patt + | PaStr of Loc.t * string | PaTup of Loc.t * patt + | PaTyc of Loc.t * patt * ctyp | PaTyp of Loc.t * ident + | PaVrn of Loc.t * string + and expr = + | ExNil of Loc.t | ExId of Loc.t * ident + | ExAcc of Loc.t * expr * expr | ExAnt of Loc.t * string + | ExApp of Loc.t * expr * expr | ExAre of Loc.t * expr * expr + | ExArr of Loc.t * expr | ExSem of Loc.t * expr * expr + | ExAsf of Loc.t | ExAsr of Loc.t * expr + | ExAss of Loc.t * expr * expr | ExChr of Loc.t * string + | ExCoe of Loc.t * expr * ctyp * ctyp | ExFlo of Loc.t * string + | ExFor of Loc.t * string * expr * expr * meta_bool * expr + | ExFun of Loc.t * match_case | ExIfe of Loc.t * expr * expr * expr + | ExInt of Loc.t * string | ExInt32 of Loc.t * string + | ExInt64 of Loc.t * string | ExNativeInt of Loc.t * string + | ExLab of Loc.t * string * expr | ExLaz of Loc.t * expr + | ExLet of Loc.t * meta_bool * binding * expr + | ExLmd of Loc.t * string * module_expr * expr + | ExMat of Loc.t * expr * match_case | ExNew of Loc.t * ident + | ExObj of Loc.t * patt * class_str_item + | ExOlb of Loc.t * string * expr | ExOvr of Loc.t * binding + | ExRec of Loc.t * binding * expr | ExSeq of Loc.t * expr + | ExSnd of Loc.t * expr * string | ExSte of Loc.t * expr * expr + | ExStr of Loc.t * string | ExTry of Loc.t * expr * match_case + | ExTup of Loc.t * expr | ExCom of Loc.t * expr * expr + | ExTyc of Loc.t * expr * ctyp | ExVrn of Loc.t * string + | ExWhi of Loc.t * expr * expr + and module_type = + | MtId of Loc.t * ident + | MtFun of Loc.t * string * module_type * module_type + | MtQuo of Loc.t * string | MtSig of Loc.t * sig_item + | MtWit of Loc.t * module_type * with_constr + | MtAnt of Loc.t * string + and sig_item = + | SgNil of Loc.t | SgCls of Loc.t * class_type + | SgClt of Loc.t * class_type + | SgSem of Loc.t * sig_item * sig_item + | SgDir of Loc.t * string * expr | SgExc of Loc.t * ctyp + | SgExt of Loc.t * string * ctyp * string meta_list + | SgInc of Loc.t * module_type + | SgMod of Loc.t * string * module_type + | SgRecMod of Loc.t * module_binding + | SgMty of Loc.t * string * module_type | SgOpn of Loc.t * ident + | SgTyp of Loc.t * ctyp | SgVal of Loc.t * string * ctyp + | SgAnt of Loc.t * string + and with_constr = + | WcNil of Loc.t | WcTyp of Loc.t * ctyp * ctyp + | WcMod of Loc.t * ident * ident + | WcAnd of Loc.t * with_constr * with_constr + | WcAnt of Loc.t * string + and binding = + | BiNil of Loc.t | BiAnd of Loc.t * binding * binding + | BiSem of Loc.t * binding * binding | BiEq of Loc.t * patt * expr + | BiAnt of Loc.t * string + and module_binding = + | MbNil of Loc.t | MbAnd of Loc.t * module_binding * module_binding + | MbColEq of Loc.t * string * module_type * module_expr + | MbCol of Loc.t * string * module_type | MbAnt of Loc.t * string + and match_case = + | McNil of Loc.t | McOr of Loc.t * match_case * match_case + | McArr of Loc.t * patt * expr * expr | McAnt of Loc.t * string + and module_expr = + | MeId of Loc.t * ident + | MeApp of Loc.t * module_expr * module_expr + | MeFun of Loc.t * string * module_type * module_expr + | MeStr of Loc.t * str_item + | MeTyc of Loc.t * module_expr * module_type + | MeAnt of Loc.t * string + and str_item = + | StNil of Loc.t | StCls of Loc.t * class_expr + | StClt of Loc.t * class_type + | StSem of Loc.t * str_item * str_item + | StDir of Loc.t * string * expr + | StExc of Loc.t * ctyp * ident meta_option | StExp of Loc.t * expr + | StExt of Loc.t * string * ctyp * string meta_list + | StInc of Loc.t * module_expr + | StMod of Loc.t * string * module_expr + | StRecMod of Loc.t * module_binding + | StMty of Loc.t * string * module_type | StOpn of Loc.t * ident + | StTyp of Loc.t * ctyp | StVal of Loc.t * meta_bool * binding + | StAnt of Loc.t * string + and class_type = + | CtNil of Loc.t | CtCon of Loc.t * meta_bool * ident * ctyp + | CtFun of Loc.t * ctyp * class_type + | CtSig of Loc.t * ctyp * class_sig_item + | CtAnd of Loc.t * class_type * class_type + | CtCol of Loc.t * class_type * class_type + | CtEq of Loc.t * class_type * class_type | CtAnt of Loc.t * string + and class_sig_item = + | CgNil of Loc.t | CgCtr of Loc.t * ctyp * ctyp + | CgSem of Loc.t * class_sig_item * class_sig_item + | CgInh of Loc.t * class_type + | CgMth of Loc.t * string * meta_bool * ctyp + | CgVal of Loc.t * string * meta_bool * meta_bool * ctyp + | CgVir of Loc.t * string * meta_bool * ctyp + | CgAnt of Loc.t * string + and class_expr = + | CeNil of Loc.t | CeApp of Loc.t * class_expr * expr + | CeCon of Loc.t * meta_bool * ident * ctyp + | CeFun of Loc.t * patt * class_expr + | CeLet of Loc.t * meta_bool * binding * class_expr + | CeStr of Loc.t * patt * class_str_item + | CeTyc of Loc.t * class_expr * class_type + | CeAnd of Loc.t * class_expr * class_expr + | CeEq of Loc.t * class_expr * class_expr | CeAnt of Loc.t * string + and class_str_item = + | CrNil of Loc.t | (* cst ; cst *) + CrSem of Loc.t * class_str_item * class_str_item | (* type t = t *) + CrCtr of Loc.t * ctyp * ctyp | (* inherit ce or inherit ce as s *) + CrInh of Loc.t * class_expr * string | (* initializer e *) + CrIni of Loc.t * expr + | (* method (private)? s : t = e or method (private)? s = e *) + CrMth of Loc.t * string * meta_bool * expr * ctyp + | (* value (mutable)? s = e *) + CrVal of Loc.t * string * meta_bool * expr + | (* method virtual (private)? s : t *) + CrVir of Loc.t * string * meta_bool * ctyp + | (* value virtual (private)? s : t *) + CrVvr of Loc.t * string * meta_bool * ctyp + | CrAnt of Loc.t * string + val loc_of_ctyp : ctyp -> Loc.t + val loc_of_patt : patt -> Loc.t + val loc_of_expr : expr -> Loc.t + val loc_of_module_type : module_type -> Loc.t + val loc_of_module_expr : module_expr -> Loc.t + val loc_of_sig_item : sig_item -> Loc.t + val loc_of_str_item : str_item -> Loc.t + val loc_of_class_type : class_type -> Loc.t + val loc_of_class_sig_item : class_sig_item -> Loc.t + val loc_of_class_expr : class_expr -> Loc.t + val loc_of_class_str_item : class_str_item -> Loc.t + val loc_of_with_constr : with_constr -> Loc.t + val loc_of_binding : binding -> Loc.t + val loc_of_module_binding : module_binding -> Loc.t + val loc_of_match_case : match_case -> Loc.t + val loc_of_ident : ident -> Loc.t + module Meta : + sig + module type META_LOC = + sig + val meta_loc_patt : Loc.t -> Loc.t -> patt + val meta_loc_expr : Loc.t -> Loc.t -> expr + end + module MetaLoc : + sig + val meta_loc_patt : Loc.t -> Loc.t -> patt + val meta_loc_expr : Loc.t -> Loc.t -> expr + end + module MetaGhostLoc : + sig + val meta_loc_patt : Loc.t -> 'a -> patt + val meta_loc_expr : Loc.t -> 'a -> expr + end + module MetaLocVar : + sig + val meta_loc_patt : Loc.t -> 'a -> patt + val meta_loc_expr : Loc.t -> 'a -> expr + end + module Make (MetaLoc : META_LOC) : + sig + module Expr : + sig + val meta_string : Loc.t -> string -> expr + val meta_int : Loc.t -> string -> expr + val meta_float : Loc.t -> string -> expr + val meta_char : Loc.t -> string -> expr + val meta_bool : Loc.t -> bool -> expr + val meta_list : + (Loc.t -> 'a -> expr) -> Loc.t -> 'a list -> expr + val meta_binding : Loc.t -> binding -> expr + val meta_class_expr : Loc.t -> class_expr -> expr + val meta_class_sig_item : Loc.t -> class_sig_item -> expr + val meta_class_str_item : Loc.t -> class_str_item -> expr + val meta_class_type : Loc.t -> class_type -> expr + val meta_ctyp : Loc.t -> ctyp -> expr + val meta_expr : Loc.t -> expr -> expr + val meta_ident : Loc.t -> ident -> expr + val meta_match_case : Loc.t -> match_case -> expr + val meta_module_binding : Loc.t -> module_binding -> expr + val meta_module_expr : Loc.t -> module_expr -> expr + val meta_module_type : Loc.t -> module_type -> expr + val meta_patt : Loc.t -> patt -> expr + val meta_sig_item : Loc.t -> sig_item -> expr + val meta_str_item : Loc.t -> str_item -> expr + val meta_with_constr : Loc.t -> with_constr -> expr + end + module Patt : + sig + val meta_string : Loc.t -> string -> patt + val meta_int : Loc.t -> string -> patt + val meta_float : Loc.t -> string -> patt + val meta_char : Loc.t -> string -> patt + val meta_bool : Loc.t -> bool -> patt + val meta_list : + (Loc.t -> 'a -> patt) -> Loc.t -> 'a list -> patt + val meta_binding : Loc.t -> binding -> patt + val meta_class_expr : Loc.t -> class_expr -> patt + val meta_class_sig_item : Loc.t -> class_sig_item -> patt + val meta_class_str_item : Loc.t -> class_str_item -> patt + val meta_class_type : Loc.t -> class_type -> patt + val meta_ctyp : Loc.t -> ctyp -> patt + val meta_expr : Loc.t -> expr -> patt + val meta_ident : Loc.t -> ident -> patt + val meta_match_case : Loc.t -> match_case -> patt + val meta_module_binding : Loc.t -> module_binding -> patt + val meta_module_expr : Loc.t -> module_expr -> patt + val meta_module_type : Loc.t -> module_type -> patt + val meta_patt : Loc.t -> patt -> patt + val meta_sig_item : Loc.t -> sig_item -> patt + val meta_str_item : Loc.t -> str_item -> patt + val meta_with_constr : Loc.t -> with_constr -> patt + end + end + end + class map : + object + inherit mapper + method meta_bool : meta_bool -> meta_bool + method meta_option : + 'a 'b. ('a -> 'b) -> 'a meta_option -> 'b meta_option + method meta_list : + 'a 'b. ('a -> 'b) -> 'a meta_list -> 'b meta_list + method _Loc_t : Loc.t -> Loc.t + 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 module_binding : module_binding -> module_binding + method match_case : match_case -> match_case + method ident : ident -> ident + end + class fold : + object ('self_type) + method string : string -> 'self_type + method int : int -> 'self_type + method float : float -> 'self_type + method bool : bool -> 'self_type + method list : + 'a. ('self_type -> 'a -> 'self_type) -> 'a list -> 'self_type + method option : + 'a. ('self_type -> 'a -> 'self_type) -> 'a option -> 'self_type + method array : + 'a. ('self_type -> 'a -> 'self_type) -> 'a array -> 'self_type + method ref : + 'a. ('self_type -> 'a -> 'self_type) -> 'a ref -> 'self_type + method meta_bool : meta_bool -> 'self_type + method meta_option : + 'a. + ('self_type -> 'a -> 'self_type) -> + 'a meta_option -> 'self_type + method meta_list : + 'a. + ('self_type -> 'a -> 'self_type) -> + 'a meta_list -> 'self_type + method _Loc_t : Loc.t -> '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 module_binding : module_binding -> 'self_type + method match_case : match_case -> 'self_type + method ident : ident -> 'self_type + end + class c_expr : (expr -> expr) -> object inherit map end + class c_patt : (patt -> patt) -> object inherit map end + class c_ctyp : (ctyp -> ctyp) -> object inherit map end + class c_str_item : (str_item -> str_item) -> object inherit map end + class c_sig_item : (sig_item -> sig_item) -> object inherit map end + class c_loc : (Loc.t -> Loc.t) -> object inherit map end + val map_expr : (expr -> expr) -> expr -> expr + val map_patt : (patt -> patt) -> patt -> patt + val map_ctyp : (ctyp -> ctyp) -> ctyp -> ctyp + val map_str_item : (str_item -> str_item) -> str_item -> str_item + val map_sig_item : (sig_item -> sig_item) -> sig_item -> sig_item + val map_loc : (Loc.t -> Loc.t) -> Loc.t -> Loc.t + val ident_of_expr : expr -> ident + val ident_of_ctyp : ctyp -> ident + val biAnd_of_list : binding list -> binding + val biSem_of_list : binding list -> binding + val paSem_of_list : patt list -> patt + val paCom_of_list : patt list -> patt + val tyOr_of_list : ctyp list -> ctyp + val tyAnd_of_list : ctyp list -> ctyp + val tySem_of_list : ctyp list -> ctyp + val stSem_of_list : str_item list -> str_item + val sgSem_of_list : sig_item list -> sig_item + val crSem_of_list : class_str_item list -> class_str_item + val cgSem_of_list : class_sig_item list -> class_sig_item + val ctAnd_of_list : class_type list -> class_type + val ceAnd_of_list : class_expr list -> class_expr + val wcAnd_of_list : with_constr list -> with_constr + val meApp_of_list : module_expr list -> module_expr + val mbAnd_of_list : module_binding list -> module_binding + val mcOr_of_list : match_case list -> match_case + val idAcc_of_list : ident list -> ident + val idApp_of_list : ident list -> ident + val exSem_of_list : expr list -> expr + val exCom_of_list : expr list -> expr + val list_of_ctyp : ctyp -> ctyp list -> ctyp list + val list_of_binding : binding -> binding list -> binding list + val list_of_with_constr : + with_constr -> with_constr list -> with_constr list + val list_of_patt : patt -> patt list -> patt list + val list_of_expr : expr -> expr list -> expr list + val list_of_str_item : str_item -> str_item list -> str_item list + val list_of_sig_item : sig_item -> sig_item list -> sig_item list + val list_of_class_sig_item : + class_sig_item -> class_sig_item list -> class_sig_item list + val list_of_class_str_item : + class_str_item -> class_str_item list -> class_str_item list + val list_of_class_type : + class_type -> class_type list -> class_type list + val list_of_class_expr : + class_expr -> class_expr list -> class_expr list + val list_of_module_expr : + module_expr -> module_expr list -> module_expr list + val list_of_module_binding : + module_binding -> module_binding list -> module_binding list + val list_of_match_case : + match_case -> match_case list -> match_case list + val list_of_ident : ident -> ident list -> ident list + val safe_string_escaped : string -> string + val is_irrefut_patt : patt -> bool + val is_constructor : ident -> bool + val is_patt_constructor : patt -> bool + val is_expr_constructor : expr -> bool + val ty_of_stl : (Loc.t * string * (ctyp list)) -> ctyp + val ty_of_sbt : (Loc.t * string * bool * ctyp) -> ctyp + val bi_of_pe : (patt * expr) -> binding + val pel_of_binding : binding -> (patt * expr) list + val binding_of_pel : (patt * expr) list -> binding + val sum_type_of_list : (Loc.t * string * (ctyp list)) list -> ctyp + val record_type_of_list : (Loc.t * string * bool * ctyp) list -> ctyp + end + module Camlp4AstToAst (M : Camlp4Ast) : Ast with module Loc = M.Loc + and type meta_bool = M.meta_bool + and type 'a meta_option = 'a M.meta_option + and type 'a meta_list = 'a M.meta_list 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 module_binding = M.module_binding + and type match_case = M.match_case and type ident = M.ident = M + module MakeCamlp4Ast (Loc : Type) = + struct + type meta_bool = | BTrue | BFalse | BAnt of string + type 'a meta_option = | ONone | OSome of 'a | OAnt of string + type 'a meta_list = + | LNil | LCons of 'a * 'a meta_list | LAnt of string + type ident = + | IdAcc of Loc.t * ident * ident | IdApp of Loc.t * ident * ident + | IdLid of Loc.t * string | IdUid of Loc.t * string + | IdAnt of Loc.t * string + type ctyp = + | TyNil of Loc.t | TyAli of Loc.t * ctyp * ctyp | TyAny of Loc.t + | TyApp of Loc.t * ctyp * ctyp | TyArr of Loc.t * ctyp * ctyp + | TyCls of Loc.t * ident | TyLab of Loc.t * string * ctyp + | TyId of Loc.t * ident | TyMan of Loc.t * ctyp * ctyp + | TyDcl of Loc.t * string * ctyp list * ctyp * (ctyp * ctyp) list + | TyObj of Loc.t * ctyp * meta_bool + | TyOlb of Loc.t * string * ctyp | TyPol of Loc.t * ctyp * ctyp + | TyQuo of Loc.t * string | TyQuP of Loc.t * string + | TyQuM of Loc.t * string | TyVrn of Loc.t * string + | TyRec of Loc.t * ctyp | TyCol of Loc.t * ctyp * ctyp + | TySem of Loc.t * ctyp * ctyp | TyCom of Loc.t * ctyp * ctyp + | TySum of Loc.t * ctyp | TyOf of Loc.t * ctyp * ctyp + | TyAnd of Loc.t * ctyp * ctyp | TyOr of Loc.t * ctyp * ctyp + | TyPrv of Loc.t * ctyp | TyMut of Loc.t * ctyp + | TyTup of Loc.t * ctyp | TySta of Loc.t * ctyp * ctyp + | TyVrnEq of Loc.t * ctyp | TyVrnSup of Loc.t * ctyp + | TyVrnInf of Loc.t * ctyp | TyVrnInfSup of Loc.t * ctyp * ctyp + | TyAmp of Loc.t * ctyp * ctyp | TyOfAmp of Loc.t * ctyp * ctyp + | TyAnt of Loc.t * string + type patt = + | PaNil of Loc.t | PaId of Loc.t * ident + | PaAli of Loc.t * patt * patt | PaAnt of Loc.t * string + | PaAny of Loc.t | PaApp of Loc.t * patt * patt + | PaArr of Loc.t * patt | PaCom of Loc.t * patt * patt + | PaSem of Loc.t * patt * patt | PaChr of Loc.t * string + | PaInt of Loc.t * string | PaInt32 of Loc.t * string + | PaInt64 of Loc.t * string | PaNativeInt of Loc.t * string + | PaFlo of Loc.t * string | PaLab of Loc.t * string * patt + | PaOlb of Loc.t * string * patt + | PaOlbi of Loc.t * string * patt * expr + | PaOrp of Loc.t * patt * patt | PaRng of Loc.t * patt * patt + | PaRec of Loc.t * patt | PaEq of Loc.t * patt * patt + | PaStr of Loc.t * string | PaTup of Loc.t * patt + | PaTyc of Loc.t * patt * ctyp | PaTyp of Loc.t * ident + | PaVrn of Loc.t * string + and expr = + | ExNil of Loc.t | ExId of Loc.t * ident + | ExAcc of Loc.t * expr * expr | ExAnt of Loc.t * string + | ExApp of Loc.t * expr * expr | ExAre of Loc.t * expr * expr + | ExArr of Loc.t * expr | ExSem of Loc.t * expr * expr + | ExAsf of Loc.t | ExAsr of Loc.t * expr + | ExAss of Loc.t * expr * expr | ExChr of Loc.t * string + | ExCoe of Loc.t * expr * ctyp * ctyp | ExFlo of Loc.t * string + | ExFor of Loc.t * string * expr * expr * meta_bool * expr + | ExFun of Loc.t * match_case | ExIfe of Loc.t * expr * expr * expr + | ExInt of Loc.t * string | ExInt32 of Loc.t * string + | ExInt64 of Loc.t * string | ExNativeInt of Loc.t * string + | ExLab of Loc.t * string * expr | ExLaz of Loc.t * expr + | ExLet of Loc.t * meta_bool * binding * expr + | ExLmd of Loc.t * string * module_expr * expr + | ExMat of Loc.t * expr * match_case | ExNew of Loc.t * ident + | ExObj of Loc.t * patt * class_str_item + | ExOlb of Loc.t * string * expr | ExOvr of Loc.t * binding + | ExRec of Loc.t * binding * expr | ExSeq of Loc.t * expr + | ExSnd of Loc.t * expr * string | ExSte of Loc.t * expr * expr + | ExStr of Loc.t * string | ExTry of Loc.t * expr * match_case + | ExTup of Loc.t * expr | ExCom of Loc.t * expr * expr + | ExTyc of Loc.t * expr * ctyp | ExVrn of Loc.t * string + | ExWhi of Loc.t * expr * expr + and module_type = + | MtId of Loc.t * ident + | MtFun of Loc.t * string * module_type * module_type + | MtQuo of Loc.t * string | MtSig of Loc.t * sig_item + | MtWit of Loc.t * module_type * with_constr + | MtAnt of Loc.t * string + and sig_item = + | SgNil of Loc.t | SgCls of Loc.t * class_type + | SgClt of Loc.t * class_type + | SgSem of Loc.t * sig_item * sig_item + | SgDir of Loc.t * string * expr | SgExc of Loc.t * ctyp + | SgExt of Loc.t * string * ctyp * string meta_list + | SgInc of Loc.t * module_type + | SgMod of Loc.t * string * module_type + | SgRecMod of Loc.t * module_binding + | SgMty of Loc.t * string * module_type | SgOpn of Loc.t * ident + | SgTyp of Loc.t * ctyp | SgVal of Loc.t * string * ctyp + | SgAnt of Loc.t * string + and with_constr = + | WcNil of Loc.t | WcTyp of Loc.t * ctyp * ctyp + | WcMod of Loc.t * ident * ident + | WcAnd of Loc.t * with_constr * with_constr + | WcAnt of Loc.t * string + and binding = + | BiNil of Loc.t | BiAnd of Loc.t * binding * binding + | BiSem of Loc.t * binding * binding | BiEq of Loc.t * patt * expr + | BiAnt of Loc.t * string + and module_binding = + | MbNil of Loc.t | MbAnd of Loc.t * module_binding * module_binding + | MbColEq of Loc.t * string * module_type * module_expr + | MbCol of Loc.t * string * module_type | MbAnt of Loc.t * string + and match_case = + | McNil of Loc.t | McOr of Loc.t * match_case * match_case + | McArr of Loc.t * patt * expr * expr | McAnt of Loc.t * string + and module_expr = + | MeId of Loc.t * ident + | MeApp of Loc.t * module_expr * module_expr + | MeFun of Loc.t * string * module_type * module_expr + | MeStr of Loc.t * str_item + | MeTyc of Loc.t * module_expr * module_type + | MeAnt of Loc.t * string + and str_item = + | StNil of Loc.t | StCls of Loc.t * class_expr + | StClt of Loc.t * class_type + | StSem of Loc.t * str_item * str_item + | StDir of Loc.t * string * expr + | StExc of Loc.t * ctyp * ident meta_option | StExp of Loc.t * expr + | StExt of Loc.t * string * ctyp * string meta_list + | StInc of Loc.t * module_expr + | StMod of Loc.t * string * module_expr + | StRecMod of Loc.t * module_binding + | StMty of Loc.t * string * module_type | StOpn of Loc.t * ident + | StTyp of Loc.t * ctyp | StVal of Loc.t * meta_bool * binding + | StAnt of Loc.t * string + and class_type = + | CtNil of Loc.t | CtCon of Loc.t * meta_bool * ident * ctyp + | CtFun of Loc.t * ctyp * class_type + | CtSig of Loc.t * ctyp * class_sig_item + | CtAnd of Loc.t * class_type * class_type + | CtCol of Loc.t * class_type * class_type + | CtEq of Loc.t * class_type * class_type | CtAnt of Loc.t * string + and class_sig_item = + | CgNil of Loc.t | CgCtr of Loc.t * ctyp * ctyp + | CgSem of Loc.t * class_sig_item * class_sig_item + | CgInh of Loc.t * class_type + | CgMth of Loc.t * string * meta_bool * ctyp + | CgVal of Loc.t * string * meta_bool * meta_bool * ctyp + | CgVir of Loc.t * string * meta_bool * ctyp + | CgAnt of Loc.t * string + and class_expr = + | CeNil of Loc.t | CeApp of Loc.t * class_expr * expr + | CeCon of Loc.t * meta_bool * ident * ctyp + | CeFun of Loc.t * patt * class_expr + | CeLet of Loc.t * meta_bool * binding * class_expr + | CeStr of Loc.t * patt * class_str_item + | CeTyc of Loc.t * class_expr * class_type + | CeAnd of Loc.t * class_expr * class_expr + | CeEq of Loc.t * class_expr * class_expr | CeAnt of Loc.t * string + and class_str_item = + | CrNil of Loc.t | CrSem of Loc.t * class_str_item * class_str_item + | CrCtr of Loc.t * ctyp * ctyp + | CrInh of Loc.t * class_expr * string | CrIni of Loc.t * expr + | CrMth of Loc.t * string * meta_bool * expr * ctyp + | CrVal of Loc.t * string * meta_bool * expr + | CrVir of Loc.t * string * meta_bool * ctyp + | CrVvr of Loc.t * string * meta_bool * ctyp + | CrAnt of Loc.t * string + end + module type AstFilters = + sig + module Ast : Camlp4Ast + type 'a filter = 'a -> 'a + val register_sig_item_filter : Ast.sig_item filter -> unit + val register_str_item_filter : Ast.str_item filter -> unit + val fold_interf_filters : + ('a -> Ast.sig_item filter -> 'a) -> 'a -> 'a + val fold_implem_filters : + ('a -> Ast.str_item filter -> 'a) -> 'a -> 'a + end + type quotation = + { q_name : string; q_loc : string; q_shift : int; q_contents : string + } + module type Quotation = + sig + module Ast : Ast + open Ast + type 'a expand_fun = Loc.t -> string option -> string -> 'a + type expander = + | ExStr of (bool -> string expand_fun) + | ExAst of Ast.expr expand_fun * Ast.patt expand_fun + val add : string -> expander -> unit + val find : string -> expander + val default : string ref + val translate : (string -> string) ref + val expand_expr : + (Loc.t -> string -> Ast.expr) -> Loc.t -> quotation -> Ast.expr + val expand_patt : + (Loc.t -> string -> Ast.patt) -> Loc.t -> quotation -> Ast.patt + val dump_file : (string option) ref + module Error : Error + end + type ('a, 'loc) stream_filter = + ('a * 'loc) Stream.t -> ('a * 'loc) Stream.t + module type Token = + sig + module Loc : Loc + type t + val to_string : t -> string + val print : Format.formatter -> t -> unit + val match_keyword : string -> t -> bool + val extract_string : t -> string + module Filter : + sig + type token_filter = (t, Loc.t) stream_filter + type t + val mk : (string -> bool) -> t + val define_filter : t -> (token_filter -> token_filter) -> unit + val filter : t -> token_filter + val keyword_added : t -> string -> bool -> unit + val keyword_removed : t -> string -> unit + end + module Error : Error + end + type camlp4_token = + | KEYWORD of string | SYMBOL of string | LIDENT of string + | UIDENT of string | ESCAPED_IDENT of string | INT of int * string + | INT32 of int32 * string | INT64 of int64 * string + | NATIVEINT of nativeint * string | FLOAT of float * string + | CHAR of char * string | STRING of string * string | LABEL of string + | OPTLABEL of string | QUOTATION of quotation + | ANTIQUOT of string * string | COMMENT of string | BLANKS of string + | NEWLINE | LINE_DIRECTIVE of int * string option | EOI + module type Camlp4Token = Token with type t = camlp4_token + module type DynLoader = + sig + type t + exception Error of string * string + val mk : ?ocaml_stdlib: bool -> ?camlp4_stdlib: bool -> unit -> t + val fold_load_path : t -> (string -> 'a -> 'a) -> 'a -> 'a + val load : t -> string -> unit + val include_dir : t -> string -> unit + val find_in_path : t -> string -> string + end + module Grammar = + struct + module type Action = + sig + type t + val mk : 'a -> t + val get : t -> 'a + val getf : t -> 'a -> 'b + val getf2 : t -> 'a -> 'b -> 'c + end + type assoc = | NonA | RightA | LeftA + type position = + | First | Last | Before of string | After of string + | Level of string + 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 symbol = + | Smeta of string * symbol list * Action.t + | Snterm of internal_entry | Snterml of internal_entry * string + | Slist0 of symbol | Slist0sep of symbol * symbol + | Slist1 of symbol | Slist1sep of symbol * symbol + | Sopt of symbol | Sself | Snext | Stoken of token_pattern + | Skeyword of string | Stree of tree + type production_rule = ((symbol list) * Action.t) + type single_extend_statment = + ((string option) * (assoc option) * (production_rule list)) + type extend_statment = + ((position option) * (single_extend_statment list)) + type delete_statment = symbol list + type ('a, 'b, 'c) fold = + internal_entry -> + symbol list -> ('a Stream.t -> 'b) -> 'a Stream.t -> 'c + type ('a, 'b, 'c) foldsep = + internal_entry -> + symbol list -> + ('a Stream.t -> 'b) -> + ('a Stream.t -> unit) -> 'a Stream.t -> 'c + end + module type Dynamic = + sig + include Structure + val mk : unit -> gram + module Entry : + sig + type 'a t + val mk : gram -> string -> 'a t + val of_parser : + gram -> + string -> ((Token.t * Loc.t) Stream.t -> 'a) -> 'a t + val setup_parser : + 'a t -> ((Token.t * Loc.t) Stream.t -> 'a) -> unit + val name : 'a t -> string + val print : Format.formatter -> 'a t -> unit + val dump : Format.formatter -> 'a t -> unit + val obj : 'a t -> internal_entry + val clear : 'a t -> unit + end + val get_filter : gram -> Token.Filter.t + type 'a not_filtered + val extend : 'a Entry.t -> extend_statment -> unit + val delete_rule : 'a Entry.t -> delete_statment -> unit + val srules : + 'a Entry.t -> ((symbol list) * Action.t) list -> symbol + val sfold0 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold + val sfold1 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold + val sfold0sep : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) foldsep + val lex : + gram -> + Loc.t -> + char Stream.t -> ((Token.t * Loc.t) Stream.t) not_filtered + val lex_string : + gram -> + Loc.t -> string -> ((Token.t * Loc.t) Stream.t) not_filtered + val filter : + gram -> + ((Token.t * Loc.t) Stream.t) not_filtered -> + (Token.t * Loc.t) Stream.t + val parse : 'a Entry.t -> Loc.t -> char Stream.t -> 'a + val parse_string : 'a Entry.t -> Loc.t -> string -> 'a + val parse_tokens_before_filter : + 'a Entry.t -> ((Token.t * Loc.t) Stream.t) not_filtered -> 'a + val parse_tokens_after_filter : + 'a Entry.t -> (Token.t * Loc.t) Stream.t -> 'a + end + module type Static = + sig + include Structure + module Entry : + sig + type 'a t + val mk : string -> 'a t + val of_parser : + string -> ((Token.t * Loc.t) Stream.t -> 'a) -> 'a t + val setup_parser : + 'a t -> ((Token.t * Loc.t) Stream.t -> 'a) -> unit + val name : 'a t -> string + val print : Format.formatter -> 'a t -> unit + val dump : Format.formatter -> 'a t -> unit + val obj : 'a t -> internal_entry + val clear : 'a t -> unit + end + val get_filter : unit -> Token.Filter.t + type 'a not_filtered + val extend : 'a Entry.t -> extend_statment -> unit + val delete_rule : 'a Entry.t -> delete_statment -> unit + val srules : + 'a Entry.t -> ((symbol list) * Action.t) list -> symbol + val sfold0 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold + val sfold1 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold + val sfold0sep : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) foldsep + val lex : + Loc.t -> + char Stream.t -> ((Token.t * Loc.t) Stream.t) not_filtered + val lex_string : + Loc.t -> string -> ((Token.t * Loc.t) Stream.t) not_filtered + val filter : + ((Token.t * Loc.t) Stream.t) not_filtered -> + (Token.t * Loc.t) Stream.t + val parse : 'a Entry.t -> Loc.t -> char Stream.t -> 'a + val parse_string : 'a Entry.t -> Loc.t -> string -> 'a + val parse_tokens_before_filter : + 'a Entry.t -> ((Token.t * Loc.t) Stream.t) not_filtered -> 'a + val parse_tokens_after_filter : + 'a Entry.t -> (Token.t * Loc.t) Stream.t -> 'a + end + end + module type Lexer = + sig + module Loc : Loc + module Token : Token with module Loc = Loc + module Error : Error + val mk : unit -> Loc.t -> char Stream.t -> (Token.t * Loc.t) Stream.t + end + module type Parser = + sig + module Ast : Ast + open Ast + val parse_implem : + ?directive_handler: (str_item -> str_item option) -> + Loc.t -> char Stream.t -> Ast.str_item + val parse_interf : + ?directive_handler: (sig_item -> sig_item option) -> + Loc.t -> char Stream.t -> Ast.sig_item + end + module type Printer = + sig + module Ast : Ast + val print_interf : + ?input_file: string -> ?output_file: string -> Ast.sig_item -> unit + val print_implem : + ?input_file: string -> ?output_file: string -> Ast.str_item -> unit + end + module type Syntax = + sig + module Loc : Loc + module Warning : Warning with module Loc = Loc + module Ast : Ast with module Loc = Loc + module Token : Token with module Loc = Loc + module Gram : Grammar.Static with module Loc = Loc + and module Token = Token + module AntiquotSyntax : AntiquotSyntax with module Ast = Ast + module Quotation : Quotation with module Ast = Ast + module Parser : Parser with module Ast = Ast + module Printer : Printer with module Ast = Ast + end + module type Camlp4Syntax = + sig + module Loc : Loc + module Warning : Warning with 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 AntiquotSyntax : + AntiquotSyntax with module Ast = Camlp4AstToAst(Ast) + module Quotation : Quotation with module Ast = Camlp4AstToAst(Ast) + module Parser : Parser with module Ast = Camlp4AstToAst(Ast) + module Printer : Printer with module Ast = Camlp4AstToAst(Ast) + val interf : ((Ast.sig_item list) * (Loc.t option)) Gram.Entry.t + val implem : ((Ast.str_item list) * (Loc.t option)) Gram.Entry.t + val top_phrase : (Ast.str_item option) Gram.Entry.t + val use_file : ((Ast.str_item list) * (Loc.t option)) Gram.Entry.t + val a_CHAR : string Gram.Entry.t + val a_FLOAT : string Gram.Entry.t + val a_INT : string Gram.Entry.t + val a_INT32 : string Gram.Entry.t + val a_INT64 : string Gram.Entry.t + val a_LABEL : string Gram.Entry.t + val a_LIDENT : string Gram.Entry.t + val a_LIDENT_or_operator : string Gram.Entry.t + val a_NATIVEINT : string Gram.Entry.t + val a_OPTLABEL : string Gram.Entry.t + val a_STRING : string Gram.Entry.t + val a_UIDENT : string Gram.Entry.t + val a_ident : string Gram.Entry.t + val amp_ctyp : Ast.ctyp Gram.Entry.t + val and_ctyp : Ast.ctyp Gram.Entry.t + val match_case : Ast.match_case Gram.Entry.t + val match_case0 : Ast.match_case Gram.Entry.t + val match_case_quot : Ast.match_case Gram.Entry.t + val binding : Ast.binding Gram.Entry.t + val binding_quot : Ast.binding Gram.Entry.t + val class_declaration : Ast.class_expr Gram.Entry.t + val class_description : Ast.class_type Gram.Entry.t + val class_expr : Ast.class_expr Gram.Entry.t + val class_expr_quot : Ast.class_expr Gram.Entry.t + val class_fun_binding : Ast.class_expr Gram.Entry.t + val class_fun_def : Ast.class_expr Gram.Entry.t + val class_info_for_class_expr : Ast.class_expr Gram.Entry.t + val class_info_for_class_type : Ast.class_type Gram.Entry.t + val class_longident : Ast.ident Gram.Entry.t + val class_longident_and_param : Ast.class_expr Gram.Entry.t + val class_name_and_param : (string * Ast.ctyp) Gram.Entry.t + val class_sig_item : Ast.class_sig_item Gram.Entry.t + val class_sig_item_quot : Ast.class_sig_item Gram.Entry.t + val class_signature : Ast.class_sig_item Gram.Entry.t + val class_str_item : Ast.class_str_item Gram.Entry.t + val class_str_item_quot : Ast.class_str_item Gram.Entry.t + val class_structure : Ast.class_str_item Gram.Entry.t + val class_type : Ast.class_type Gram.Entry.t + val class_type_declaration : Ast.class_type Gram.Entry.t + val class_type_longident : Ast.ident Gram.Entry.t + val class_type_longident_and_param : Ast.class_type Gram.Entry.t + val class_type_plus : Ast.class_type Gram.Entry.t + val class_type_quot : Ast.class_type Gram.Entry.t + val comma_ctyp : Ast.ctyp Gram.Entry.t + val comma_expr : Ast.expr Gram.Entry.t + val comma_ipatt : Ast.patt Gram.Entry.t + val comma_patt : Ast.patt Gram.Entry.t + val comma_type_parameter : Ast.ctyp Gram.Entry.t + val constrain : (Ast.ctyp * Ast.ctyp) Gram.Entry.t + val constructor_arg_list : Ast.ctyp Gram.Entry.t + val constructor_declaration : Ast.ctyp Gram.Entry.t + val constructor_declarations : Ast.ctyp Gram.Entry.t + val ctyp : Ast.ctyp Gram.Entry.t + val ctyp_quot : Ast.ctyp Gram.Entry.t + val cvalue_binding : Ast.expr Gram.Entry.t + val direction_flag : Ast.meta_bool Gram.Entry.t + val dummy : unit Gram.Entry.t + val eq_expr : (string -> Ast.patt -> Ast.patt) Gram.Entry.t + val expr : Ast.expr Gram.Entry.t + val expr_eoi : Ast.expr Gram.Entry.t + val expr_quot : Ast.expr Gram.Entry.t + val field : Ast.ctyp Gram.Entry.t + val field_expr : Ast.binding Gram.Entry.t + val fun_binding : Ast.expr Gram.Entry.t + val fun_def : Ast.expr Gram.Entry.t + val ident : Ast.ident Gram.Entry.t + val ident_quot : Ast.ident Gram.Entry.t + val ipatt : Ast.patt Gram.Entry.t + val ipatt_tcon : Ast.patt Gram.Entry.t + val label : string Gram.Entry.t + val label_declaration : Ast.ctyp Gram.Entry.t + val label_expr : Ast.binding Gram.Entry.t + val label_ipatt : Ast.patt Gram.Entry.t + val label_longident : Ast.ident Gram.Entry.t + val label_patt : Ast.patt Gram.Entry.t + val labeled_ipatt : Ast.patt Gram.Entry.t + val let_binding : Ast.binding Gram.Entry.t + val meth_list : Ast.ctyp Gram.Entry.t + val module_binding : Ast.module_binding Gram.Entry.t + val module_binding0 : Ast.module_expr Gram.Entry.t + val module_binding_quot : Ast.module_binding Gram.Entry.t + val module_declaration : Ast.module_type Gram.Entry.t + val module_expr : Ast.module_expr Gram.Entry.t + val module_expr_quot : Ast.module_expr Gram.Entry.t + val module_longident : Ast.ident Gram.Entry.t + val module_longident_with_app : Ast.ident Gram.Entry.t + val module_rec_declaration : Ast.module_binding Gram.Entry.t + val module_type : Ast.module_type Gram.Entry.t + val module_type_quot : Ast.module_type Gram.Entry.t + val more_ctyp : Ast.ctyp Gram.Entry.t + val name_tags : Ast.ctyp Gram.Entry.t + val opt_as_lident : string Gram.Entry.t + val opt_class_self_patt : Ast.patt Gram.Entry.t + val opt_class_self_type : Ast.ctyp Gram.Entry.t + val opt_comma_ctyp : Ast.ctyp Gram.Entry.t + val opt_dot_dot : Ast.meta_bool Gram.Entry.t + val opt_eq_ctyp : (Ast.ctyp list -> Ast.ctyp) Gram.Entry.t + val opt_expr : Ast.expr Gram.Entry.t + val opt_meth_list : Ast.ctyp Gram.Entry.t + val opt_mutable : Ast.meta_bool Gram.Entry.t + val opt_polyt : Ast.ctyp Gram.Entry.t + val opt_private : Ast.meta_bool Gram.Entry.t + val opt_rec : Ast.meta_bool Gram.Entry.t + val opt_virtual : Ast.meta_bool Gram.Entry.t + val opt_when_expr : Ast.expr Gram.Entry.t + val patt : Ast.patt Gram.Entry.t + val patt_as_patt_opt : Ast.patt Gram.Entry.t + val patt_eoi : Ast.patt Gram.Entry.t + val patt_quot : Ast.patt Gram.Entry.t + val patt_tcon : Ast.patt Gram.Entry.t + val phrase : Ast.str_item Gram.Entry.t + val pipe_ctyp : Ast.ctyp Gram.Entry.t + val poly_type : Ast.ctyp Gram.Entry.t + val row_field : Ast.ctyp Gram.Entry.t + val sem_ctyp : Ast.ctyp Gram.Entry.t + val sem_expr : Ast.expr Gram.Entry.t + val sem_expr_for_list : (Ast.expr -> Ast.expr) Gram.Entry.t + val sem_patt : Ast.patt Gram.Entry.t + val sem_patt_for_list : (Ast.patt -> Ast.patt) Gram.Entry.t + val semi : unit Gram.Entry.t + val sequence : Ast.expr Gram.Entry.t + val sig_item : Ast.sig_item Gram.Entry.t + val sig_item_quot : Ast.sig_item Gram.Entry.t + val sig_items : Ast.sig_item Gram.Entry.t + val star_ctyp : Ast.ctyp Gram.Entry.t + val str_item : Ast.str_item Gram.Entry.t + val str_item_quot : Ast.str_item Gram.Entry.t + val str_items : Ast.str_item Gram.Entry.t + val type_constraint : unit Gram.Entry.t + val type_declaration : Ast.ctyp Gram.Entry.t + val type_ident_and_parameters : + (string * (Ast.ctyp list)) Gram.Entry.t + val type_kind : Ast.ctyp Gram.Entry.t + val type_longident : Ast.ident Gram.Entry.t + val type_longident_and_parameters : Ast.ctyp Gram.Entry.t + val type_parameter : Ast.ctyp Gram.Entry.t + val type_parameters : (Ast.ctyp -> Ast.ctyp) Gram.Entry.t + val typevars : Ast.ctyp Gram.Entry.t + val val_longident : Ast.ident Gram.Entry.t + val value_let : unit Gram.Entry.t + val value_val : unit Gram.Entry.t + val with_constr : Ast.with_constr Gram.Entry.t + val with_constr_quot : Ast.with_constr Gram.Entry.t + end + module type SyntaxExtension = + functor (Syn : Syntax) -> Syntax with module Loc = Syn.Loc + and module Warning = Syn.Warning and module Ast = Syn.Ast + and module Token = Syn.Token and module Gram = Syn.Gram + and module AntiquotSyntax = Syn.AntiquotSyntax + and module Quotation = Syn.Quotation + end +module ErrorHandler : + sig + val print : Format.formatter -> exn -> unit + val try_print : Format.formatter -> exn -> unit + val to_string : exn -> string + val try_to_string : exn -> string + val register : (Format.formatter -> exn -> unit) -> unit + module Register (Error : Sig.Error) : sig end + module ObjTools : + sig + val print : Format.formatter -> Obj.t -> unit + val print_desc : Format.formatter -> Obj.t -> unit + val to_string : Obj.t -> string + val desc : Obj.t -> string + end + end = + struct + open Format + module ObjTools = + struct + let desc obj = + if Obj.is_block obj + then "tag = " ^ (string_of_int (Obj.tag obj)) + else "int_val = " ^ (string_of_int (Obj.obj obj)) + let rec to_string r = + if Obj.is_int r + then + (let i : int = Obj.magic r + in (string_of_int i) ^ (" | CstTag" ^ (string_of_int (i + 1)))) + else + (let rec get_fields acc = + function + | 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)))) 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 = "<" ^ (name ^ ">") in + let s = Obj.size r + and t = Obj.tag r + in + 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 -> 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 + "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 -> + string_of_float (Obj.magic r : float) + | x when x = Obj.abstract_tag -> opaque "abstract" + | x when x = Obj.custom_tag -> opaque "custom" + | x when x = Obj.final_tag -> opaque "final" + | _ -> + failwith + ("ObjTools.to_string: unknown tag (" ^ + ((string_of_int t) ^ ")"))) + let print ppf x = fprintf ppf "%s" (to_string x) + let print_desc ppf x = fprintf ppf "%s" (desc x) + end + let default_handler ppf x = + let x = Obj.repr x + in + (fprintf ppf "Camlp4: Uncaught exception: %s" + (Obj.obj (Obj.field (Obj.field x 0) 0) : string); + if (Obj.size x) > 1 + then + (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 "@.") + let handler = + ref (fun ppf default_handler exn -> default_handler ppf exn) + let register f = + let current_handler = !handler + in + handler := + fun ppf default_handler exn -> + try f ppf exn + with | exn -> current_handler ppf default_handler exn + module Register (Error : Sig.Error) = + struct + let _ = + let current_handler = !handler + in + handler := + fun ppf default_handler -> + function + | Error.E x -> Error.print ppf x + | x -> current_handler ppf default_handler x + end + let gen_print ppf default_handler = + function + | 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 ppf default_handler x + let print ppf = gen_print ppf default_handler + let try_print ppf = gen_print ppf (fun _ -> raise) + let to_string exn = + let buf = Buffer.create 128 in + let () = bprintf buf "%a" print exn in Buffer.contents buf + let try_to_string exn = + let buf = Buffer.create 128 in + let () = bprintf buf "%a" try_print exn in Buffer.contents buf + end +module Struct = + struct + module Loc : sig include Sig.Loc end = + struct + open Format + type pos = { line : int; bol : int; off : int } + type t = + { file_name : string; start : pos; stop : pos; ghost : bool + } + let dump_sel f x = + let s = + match x with + | `start -> "`start" + | `stop -> "`stop" + | `both -> "`both" + | _ -> "" + in pp_print_string f s + let dump_pos f x = + fprintf f "@[{ line = %d ;@ bol = %d ;@ off = %d } : pos@]" + x.line x.bol x.off + let 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 + let 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 ()) + let start_pos = { line = 1; bol = 0; off = 0; } + let ghost = + { + + file_name = "ghost-location"; + start = start_pos; + stop = start_pos; + ghost = true; + } + let mk file_name = + { + + file_name = file_name; + start = start_pos; + stop = start_pos; + ghost = false; + } + let 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; + } + let 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) + let pos_of_lexing_position p = + let pos = + { + + line = p.Lexing.pos_lnum; + bol = p.Lexing.pos_bol; + off = p.Lexing.pos_cnum; + } + in pos + let pos_to_lexing_position p file_name = + { + + Lexing.pos_fname = file_name; + pos_lnum = p.line; + pos_bol = p.bol; + pos_cnum = p.off; + } + let better_file_name a b = + match (a, b) with + | ("", "") -> a + | ("", x) -> x + | (x, "") -> x + | ("-", x) -> x + | (x, "-") -> x + | (x, _) -> x + let 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 loc + let 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 loc + let to_ocaml_location x = + { + + 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; + } + let of_ocaml_location x = + let (a, b) = ((x.Location.loc_start), (x.Location.loc_end)) in + 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 = x.Location.loc_ghost; + } + in res + let start_pos x = pos_to_lexing_position x.start x.file_name + let stop_pos x = pos_to_lexing_position x.stop x.file_name + let merge a b = + if a == b + then a + else + (let r = + match ((a.ghost), (b.ghost)) with + | (false, false) -> { (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 r) + let join x = { (x) with stop = x.start; } + let 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; } + let move_pos chars x = { (x) with off = x.off + chars; } + let move s chars x = map (move_pos chars) s x + let move_line lines x = + let move_line_pos x = + { (x) with line = x.line + lines; bol = x.off; } + in map move_line_pos `both x + let shift width x = + { (x) with start = x.stop; stop = move_pos width x.stop; } + let file_name x = x.file_name + let start_line x = x.start.line + let stop_line x = x.stop.line + let start_bol x = x.start.bol + let stop_bol x = x.stop.bol + let start_off x = x.start.off + let stop_off x = x.stop.off + let is_ghost x = x.ghost + let set_file_name s x = { (x) with file_name = s; } + let ghostify x = { (x) with ghost = true; } + let make_absolute x = + 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 + let strictly_before x y = + let b = (x.stop.off < y.start.off) && (x.file_name = y.file_name) + in b + let to_string x = + 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 + let print out x = pp_print_string out (to_string x) + let 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)))))))) + then + (eprintf "*** Warning: (%s) strange positions ***\n%a@\n" msg + print x; + false) + else true + exception Exc_located of t * exn + let _ = + ErrorHandler.register + (fun ppf -> + function + | Exc_located (loc, exn) -> + fprintf ppf "%a:@\n%a" print loc ErrorHandler.print exn + | exn -> raise exn) + let name = ref "_loc" + let raise loc exc = + match exc with + | Exc_located (_, _) -> raise exc + | _ -> raise (Exc_located (loc, exc)) + end + module Warning = + struct + module Make (Loc : Sig.Loc) : Sig.Warning with module Loc = Loc = + struct + module Loc = Loc + open Format + type t = Loc.t -> string -> unit + let default loc txt = eprintf " %a: %s@." Loc.print loc txt + let current = ref default + let print loc txt = !current loc txt + end + end + module Token : + sig + module Make (Loc : Sig.Loc) : Sig.Camlp4Token with module Loc = Loc + module Eval : + sig + val char : string -> char + val string : ?strict: unit -> string -> string + end + end = + struct + 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 + let to_string = + function + | 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 + | 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 + let print ppf x = pp_print_string ppf (to_string x) + let match_keyword kwd = + function | KEYWORD kwd' when kwd = kwd' -> true | _ -> false + let extract_string = + function + | 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 a this token: " ^ + (to_string tok)) + module Error = + struct + type t = + | Illegal_token of string | Keyword_as_label of string + | Illegal_token_pattern of string * string + | Illegal_constructor of string + exception E of t + let print ppf = + function + | 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 + let to_string x = + let b = Buffer.create 50 in + let () = bprintf b "%a" print x in Buffer.contents b + end + let _ = let module M = ErrorHandler.Register(Error) in () + module Filter = + struct + type token_filter = (t, Loc.t) stream_filter + type t = + { is_kwd : string -> bool; mutable filter : token_filter + } + let err error loc = + raise (Loc.Exc_located (loc, Error.E error)) + let 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 + let 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 () + let check_unknown_keywords tok loc = + match tok with + | SYMBOL s -> err (Error.Illegal_token s) loc + | _ -> () + let error_no_respect_rules p_con p_prm = + raise + (Error.E (Error.Illegal_token_pattern (p_con, p_prm))) + let check_keyword _ = true + let error_on_unknown_keywords = ref false + let rec ignore_layout (__strm : _ Stream.t) = + match Stream.peek __strm with + | Some + (((COMMENT _ | BLANKS _ | NEWLINE | + LINE_DIRECTIVE (_, _)), + _)) + -> (Stream.junk __strm; ignore_layout __strm) + | Some x -> + (Stream.junk __strm; + let s = __strm + in + Stream.icons x + (Stream.slazy (fun _ -> ignore_layout s))) + | _ -> Stream.sempty + let mk is_kwd = { is_kwd = is_kwd; filter = ignore_layout; } + let filter x = + let f tok loc = + let tok = keyword_conversion tok x.is_kwd + in + (check_keyword_as_label tok loc x.is_kwd; + if !error_on_unknown_keywords + then check_unknown_keywords tok loc + else (); + (tok, loc)) in + let rec filter (__strm : _ Stream.t) = + match Stream.peek __strm with + | Some ((tok, loc)) -> + (Stream.junk __strm; + let s = __strm + in + Stream.lcons (fun _ -> f tok loc) + (Stream.slazy (fun _ -> filter s))) + | _ -> Stream.sempty in + let rec tracer (__strm : _ Stream.t) = + match Stream.peek __strm with + | Some (((_tok, _loc) as x)) -> + (Stream.junk __strm; + let xs = __strm + in + Stream.icons x (Stream.slazy (fun _ -> tracer xs))) + | _ -> Stream.sempty + in fun strm -> tracer (x.filter (filter strm)) + let define_filter x f = x.filter <- f x.filter + let keyword_added _ _ _ = () + let keyword_removed _ _ = () + end + end + module Eval = + struct + let valch x = (Char.code x) - (Char.code '0') + let 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 + let rec skip_indent (__strm : _ Stream.t) = + match Stream.peek __strm with + | Some (' ' | '\t') -> (Stream.junk __strm; skip_indent __strm) + | _ -> () + let skip_opt_linefeed (__strm : _ Stream.t) = + match Stream.peek __strm with + | Some '\010' -> (Stream.junk __strm; ()) + | _ -> () + let rec backslash (__strm : _ Stream.t) = + match Stream.peek __strm with + | Some '\010' -> (Stream.junk __strm; '\010') + | Some '\013' -> (Stream.junk __strm; '\013') + | Some 'n' -> (Stream.junk __strm; '\n') + | Some 'r' -> (Stream.junk __strm; '\r') + | Some 't' -> (Stream.junk __strm; '\t') + | Some 'b' -> (Stream.junk __strm; '\b') + | Some '\\' -> (Stream.junk __strm; '\\') + | Some '"' -> (Stream.junk __strm; '"') + | Some '\'' -> (Stream.junk __strm; '\'') + | Some ' ' -> (Stream.junk __strm; ' ') + | Some (('0' .. '9' as c1)) -> + (Stream.junk __strm; + (match Stream.peek __strm with + | Some (('0' .. '9' as c2)) -> + (Stream.junk __strm; + (match Stream.peek __strm with + | Some (('0' .. '9' as c3)) -> + (Stream.junk __strm; + Char.chr + (((100 * (valch c1)) + (10 * (valch c2))) + + (valch c3))) + | _ -> raise (Stream.Error ""))) + | _ -> raise (Stream.Error ""))) + | Some 'x' -> + (Stream.junk __strm; + (match Stream.peek __strm with + | Some (('0' .. '9' | 'a' .. 'f' | 'A' .. 'F' as c1)) -> + (Stream.junk __strm; + (match Stream.peek __strm with + | Some + (('0' .. '9' | 'a' .. 'f' | 'A' .. 'F' as c2)) + -> + (Stream.junk __strm; + Char.chr + ((16 * (valch_hex c1)) + (valch_hex c2))) + | _ -> raise (Stream.Error ""))) + | _ -> raise (Stream.Error ""))) + | _ -> raise Stream.Failure + let rec backslash_in_string strict store (__strm : _ Stream.t) = + match Stream.peek __strm with + | Some '\010' -> (Stream.junk __strm; skip_indent __strm) + | Some '\013' -> + (Stream.junk __strm; + let s = __strm in (skip_opt_linefeed s; skip_indent s)) + | _ -> + (match try Some (backslash __strm) + with | Stream.Failure -> None + with + | Some x -> store x + | _ -> + (match Stream.peek __strm with + | Some c when not strict -> + (Stream.junk __strm; store '\\'; store c) + | _ -> failwith "invalid string token")) + let char s = + if (String.length s) = 1 + then s.[0] + else + if (String.length s) = 0 + then failwith "invalid char token" + else + (let (__strm : _ Stream.t) = Stream.of_string s + in + match Stream.peek __strm with + | Some '\\' -> + (Stream.junk __strm; + (try backslash __strm + with | Stream.Failure -> raise (Stream.Error ""))) + | _ -> failwith "invalid char token") + let string ?strict s = + let buf = Buffer.create 23 in + let store = Buffer.add_char buf in + let rec parse (__strm : _ Stream.t) = + match Stream.peek __strm with + | Some '\\' -> + (Stream.junk __strm; + let _ = + (try backslash_in_string (strict <> None) store __strm + with | Stream.Failure -> raise (Stream.Error "")) + in parse __strm) + | Some c -> + (Stream.junk __strm; + let s = __strm in (store c; parse s)) + | _ -> Buffer.contents buf + in parse (Stream.of_string s) + end + end + module Lexer = + struct + module TokenEval = Token.Eval + module Make (Token : Sig.Camlp4Token) = + struct + module Loc = Token.Loc + module Token = Token + open Lexing + open Sig + 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 + 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" + let to_string x = + let b = Buffer.create 50 in + let () = bprintf b "%a" print x in Buffer.contents b + end + let _ = let module M = ErrorHandler.Register(Error) in () + open Error + type context = + { loc : Loc.t; in_comment : bool; quotations : bool; + lexbuf : lexbuf; buffer : Buffer.t + } + let default_context lb = + { + + loc = Loc.ghost; + in_comment = false; + quotations = true; + lexbuf = lb; + buffer = Buffer.create 256; + } + 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 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 = + let p = c.lexbuf.lex_start_p + in + c.lexbuf.lex_start_p <- + { (p) with pos_cnum = p.pos_cnum + shift; } + let with_curr_loc f c = + f { (c) with loc = Loc.of_lexbuf c.lexbuf; } 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 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; + } + 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; + } + 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 __ocaml_lex_tables = + { + + Lexing.lex_base = + "\000\000\227\255\228\255\001\001\001\001\231\255\232\255\160\001\ + \198\001\067\000\091\000\069\000\071\000\084\000\122\000\235\001\ + \014\002\092\000\102\001\244\255\035\002\068\002\141\002\093\003\ + \060\004\152\004\126\000\001\000\255\255\104\005\253\255\056\006\ + \252\255\245\255\246\255\247\255\023\001\001\001\088\000\091\000\ + \216\002\168\003\179\005\179\001\088\004\132\000\024\007\108\000\ + \151\000\109\000\243\255\242\255\241\255\012\005\033\001\111\000\ + \239\002\193\005\111\000\239\255\238\255\024\007\063\007\109\007\ + \148\007\183\007\174\006\015\003\004\000\233\255\093\001\199\001\ + \151\002\094\001\005\000\233\255\054\008\246\008\006\000\117\004\ + \251\255\208\009\095\000\115\000\115\000\254\255\016\010\207\010\ + \159\011\111\012\079\013\121\000\152\000\124\000\126\000\249\255\ + \248\255\144\006\197\003\127\000\060\004\128\000\200\007\129\000\ + \008\003\007\000\106\013\250\255\054\008\169\004\089\001\082\001\ + \179\004\198\008\054\008\172\013\139\014\169\014\136\015\103\016\ + \135\016\199\016\151\017\254\255\204\001\008\000\107\000\053\001\ + \215\017\150\018\102\019\054\020\018\021\062\001\236\021\197\022\ + \064\001\149\023\248\003\155\001\009\000\213\023\148\024\100\025\ + \052\026"; + Lexing.lex_backtrk = + "\255\255\255\255\255\255\028\000\025\000\255\255\255\255\025\000\ + \025\000\023\000\023\000\023\000\023\000\023\000\023\000\025\000\ + \025\000\023\000\023\000\255\255\006\000\006\000\005\000\004\000\ + \025\000\025\000\001\000\000\000\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\007\000\255\255\255\255\ + \255\255\006\000\006\000\006\000\007\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\014\000\014\000\014\000\ + \255\255\255\255\015\000\255\255\255\255\021\000\020\000\018\000\ + \025\000\019\000\255\255\255\255\022\000\255\255\255\255\255\255\ + \255\255\255\255\022\000\255\255\026\000\255\255\013\000\014\000\ + \255\255\003\000\014\000\014\000\014\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\005\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\006\000\008\000\255\255\005\000\005\000\001\000\001\000\ + \255\255\255\255\000\000\001\000\001\000\255\255\002\000\002\000\ + \255\255\255\255\255\255\255\255\255\255\003\000\004\000\004\000\ + \255\255\255\255\255\255\255\255\255\255\002\000\002\000\002\000\ + \255\255\255\255\255\255\004\000\002\000\255\255\255\255\255\255\ + \255\255"; + Lexing.lex_default = + "\001\000\000\000\000\000\076\000\255\255\000\000\000\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\047\000\000\000\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\000\000\255\255\000\000\255\255\ + \000\000\000\000\000\000\000\000\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\052\000\255\255\ + \255\255\255\255\000\000\000\000\000\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\000\000\000\000\255\255\255\255\255\255\ + \255\255\255\255\070\000\255\255\255\255\000\000\070\000\071\000\ + \070\000\073\000\255\255\000\000\076\000\052\000\255\255\091\000\ + \000\000\255\255\255\255\255\255\255\255\000\000\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\000\000\ + \000\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \035\000\255\255\107\000\000\000\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\000\000\080\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\030\000\255\255\255\255\255\255\ + \255\255\255\255\080\000\255\255\255\255\255\255\255\255\255\255\ + \255\255"; + Lexing.lex_trans = + "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\026\000\028\000\028\000\026\000\027\000\069\000\075\000\ + \051\000\095\000\032\000\030\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \026\000\004\000\019\000\014\000\005\000\004\000\004\000\018\000\ + \017\000\006\000\016\000\004\000\006\000\004\000\013\000\004\000\ + \021\000\020\000\020\000\020\000\020\000\020\000\020\000\020\000\ + \020\000\020\000\012\000\011\000\015\000\004\000\007\000\024\000\ + \004\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\010\000\003\000\006\000\004\000\023\000\ + \006\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\009\000\008\000\006\000\025\000\006\000\ + \006\000\006\000\006\000\067\000\006\000\006\000\058\000\026\000\ + \043\000\043\000\026\000\042\000\042\000\042\000\042\000\042\000\ + \042\000\042\000\042\000\051\000\050\000\006\000\051\000\006\000\ + \059\000\087\000\067\000\030\000\085\000\028\000\026\000\086\000\ + \035\000\049\000\093\000\096\000\006\000\095\000\034\000\033\000\ + \019\000\085\000\066\000\066\000\066\000\066\000\066\000\066\000\ + \066\000\066\000\066\000\066\000\044\000\044\000\044\000\044\000\ + \044\000\044\000\044\000\044\000\044\000\044\000\050\000\096\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\006\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\000\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \002\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\004\000\255\255\255\255\004\000\004\000\004\000\ + \000\000\255\255\255\255\004\000\004\000\255\255\004\000\004\000\ + \004\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\ + \037\000\037\000\037\000\004\000\255\255\004\000\004\000\004\000\ + \004\000\004\000\045\000\000\000\045\000\000\000\036\000\044\000\ + \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ + \044\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\ + \056\000\056\000\056\000\111\000\255\255\255\255\255\255\004\000\ + \037\000\255\255\111\000\111\000\000\000\000\000\036\000\069\000\ + \075\000\000\000\068\000\074\000\136\000\000\000\136\000\129\000\ + \049\000\028\000\111\000\048\000\000\000\128\000\000\000\000\000\ + \085\000\111\000\085\000\000\000\255\255\004\000\255\255\004\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\004\000\046\000\000\000\004\000\004\000\004\000\000\000\ + \000\000\000\000\004\000\004\000\000\000\004\000\004\000\004\000\ + \000\000\069\000\000\000\000\000\068\000\142\000\032\000\032\000\ + \255\255\125\000\004\000\141\000\004\000\004\000\004\000\004\000\ + \004\000\000\000\000\000\043\000\043\000\000\000\000\000\004\000\ + \000\000\073\000\004\000\004\000\004\000\000\000\000\000\000\000\ + \004\000\004\000\000\000\004\000\004\000\004\000\000\000\000\000\ + \255\255\000\000\000\000\000\000\000\000\006\000\004\000\034\000\ + \004\000\255\255\004\000\004\000\004\000\004\000\004\000\000\000\ + \127\000\000\000\126\000\000\000\004\000\000\000\000\000\004\000\ + \004\000\004\000\043\000\000\000\000\000\004\000\004\000\000\000\ + \004\000\004\000\004\000\000\000\004\000\006\000\004\000\035\000\ + \000\000\033\000\000\000\006\000\004\000\061\000\000\000\063\000\ + \004\000\004\000\004\000\062\000\000\000\000\000\000\000\004\000\ + \000\000\000\000\004\000\004\000\004\000\000\000\000\000\060\000\ + \004\000\004\000\000\000\004\000\004\000\004\000\000\000\000\000\ + \000\000\000\000\004\000\000\000\004\000\000\000\000\000\000\000\ + \004\000\004\000\004\000\004\000\004\000\004\000\004\000\000\000\ + \000\000\037\000\000\000\020\000\020\000\020\000\020\000\020\000\ + \020\000\020\000\020\000\020\000\020\000\255\255\255\255\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\255\255\004\000\ + \036\000\004\000\000\000\000\000\004\000\000\000\000\000\034\000\ + \000\000\000\000\037\000\000\000\020\000\020\000\020\000\020\000\ + \020\000\020\000\020\000\020\000\020\000\020\000\000\000\000\000\ + \000\000\000\000\020\000\000\000\000\000\000\000\038\000\000\000\ + \036\000\036\000\004\000\000\000\004\000\000\000\000\000\035\000\ + \034\000\033\000\000\000\039\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\040\000\000\000\000\000\000\000\ + \072\000\069\000\000\000\020\000\068\000\000\000\038\000\000\000\ + \000\000\036\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \035\000\000\000\033\000\039\000\022\000\000\000\000\000\072\000\ + \000\000\071\000\000\000\000\000\040\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\255\255\ + \000\000\000\000\000\000\000\000\030\000\000\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \000\000\000\000\000\000\000\000\022\000\000\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \041\000\041\000\041\000\041\000\041\000\041\000\041\000\041\000\ + \041\000\041\000\095\000\000\000\000\000\105\000\000\000\000\000\ + \067\000\041\000\041\000\041\000\041\000\041\000\041\000\047\000\ + \047\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ + \047\000\000\000\028\000\000\000\000\000\000\000\000\000\067\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\041\000\041\000\041\000\041\000\041\000\041\000\066\000\ + \066\000\066\000\066\000\066\000\066\000\066\000\066\000\066\000\ + \066\000\000\000\000\000\000\000\000\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\106\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\023\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\255\255\ + \000\000\000\000\000\000\000\000\000\000\000\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \000\000\000\000\000\000\000\000\023\000\000\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \041\000\041\000\041\000\041\000\041\000\041\000\041\000\041\000\ + \041\000\041\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\041\000\041\000\041\000\041\000\041\000\041\000\000\000\ + \000\000\000\000\000\000\000\000\034\000\100\000\100\000\100\000\ + \100\000\100\000\100\000\100\000\100\000\100\000\100\000\000\000\ + \000\000\000\000\030\000\000\000\000\000\140\000\000\000\041\000\ + \096\000\041\000\041\000\041\000\041\000\041\000\041\000\000\000\ + \000\000\000\000\000\000\000\000\035\000\000\000\033\000\000\000\ + \000\000\000\000\000\000\000\000\028\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\139\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\000\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\004\000\000\000\000\000\ + \004\000\004\000\004\000\000\000\000\000\000\000\004\000\004\000\ + \000\000\004\000\004\000\004\000\101\000\101\000\101\000\101\000\ + \101\000\101\000\101\000\101\000\101\000\101\000\004\000\000\000\ + \004\000\004\000\004\000\004\000\004\000\000\000\000\000\093\000\ + \000\000\000\000\092\000\000\000\000\000\000\000\000\000\000\000\ + \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ + \044\000\044\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\004\000\031\000\094\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\044\000\ + \004\000\004\000\004\000\000\000\004\000\004\000\004\000\000\000\ + \000\000\000\000\004\000\004\000\000\000\004\000\004\000\004\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\090\000\004\000\000\000\004\000\004\000\004\000\004\000\ + \004\000\112\000\112\000\112\000\112\000\112\000\112\000\112\000\ + \112\000\112\000\112\000\032\000\032\000\032\000\032\000\032\000\ + \032\000\032\000\032\000\032\000\032\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\004\000\029\000\ + \085\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\000\000\004\000\000\000\004\000\000\000\ + \000\000\000\000\000\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\000\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\057\000\057\000\057\000\057\000\ + \057\000\057\000\057\000\057\000\057\000\057\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\057\000\057\000\057\000\ + \057\000\057\000\057\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\057\000\057\000\057\000\ + \057\000\057\000\057\000\000\000\000\000\255\255\000\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\030\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\000\000\000\000\000\000\000\000\029\000\ + \000\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\042\000\042\000\042\000\042\000\042\000\ + \042\000\042\000\042\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\047\000\047\000\047\000\047\000\047\000\047\000\047\000\ + \047\000\047\000\047\000\000\000\000\000\000\000\000\000\034\000\ + \000\000\000\000\047\000\047\000\047\000\047\000\047\000\047\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\042\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\035\000\ + \000\000\033\000\047\000\047\000\047\000\047\000\047\000\047\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\000\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\031\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\032\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\000\000\000\000\000\000\000\000\031\000\ + \000\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\000\000\000\000\000\000\000\000\072\000\ + \069\000\000\000\000\000\068\000\000\000\000\000\000\000\000\000\ + \102\000\102\000\102\000\102\000\102\000\102\000\102\000\102\000\ + \102\000\102\000\000\000\000\000\000\000\000\000\072\000\000\000\ + \071\000\102\000\102\000\102\000\102\000\102\000\102\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\066\000\066\000\ + \066\000\066\000\066\000\066\000\066\000\066\000\066\000\066\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\102\000\102\000\102\000\102\000\102\000\102\000\000\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\000\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\000\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \055\000\004\000\055\000\000\000\004\000\004\000\004\000\055\000\ + \000\000\000\000\004\000\004\000\000\000\004\000\004\000\004\000\ + \054\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\ + \054\000\054\000\004\000\000\000\004\000\004\000\004\000\004\000\ + \004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \004\000\000\000\000\000\004\000\004\000\004\000\000\000\000\000\ + \000\000\004\000\004\000\000\000\004\000\004\000\004\000\000\000\ + \000\000\000\000\000\000\000\000\055\000\000\000\004\000\000\000\ + \000\000\004\000\055\000\004\000\004\000\004\000\004\000\004\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\055\000\000\000\ + \000\000\000\000\055\000\000\000\055\000\000\000\004\000\000\000\ + \053\000\004\000\004\000\004\000\004\000\000\000\004\000\004\000\ + \004\000\000\000\004\000\004\000\004\000\004\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\004\000\ + \000\000\004\000\004\000\064\000\004\000\004\000\255\255\000\000\ + \000\000\000\000\000\000\000\000\000\000\004\000\000\000\000\000\ + \004\000\004\000\004\000\004\000\000\000\004\000\004\000\004\000\ + \000\000\004\000\004\000\004\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\004\000\000\000\000\000\004\000\000\000\ + \004\000\004\000\065\000\004\000\004\000\000\000\000\000\000\000\ + \004\000\000\000\000\000\004\000\004\000\004\000\000\000\000\000\ + \000\000\004\000\004\000\000\000\004\000\004\000\004\000\000\000\ + \000\000\004\000\000\000\004\000\000\000\000\000\000\000\000\000\ + \000\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ + \103\000\103\000\103\000\103\000\103\000\103\000\103\000\103\000\ + \103\000\103\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\103\000\103\000\103\000\103\000\103\000\103\000\000\000\ + \004\000\000\000\004\000\000\000\000\000\004\000\000\000\000\000\ + \255\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\103\000\103\000\103\000\103\000\103\000\103\000\000\000\ + \000\000\000\000\000\000\004\000\000\000\004\000\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\114\000\ + \255\255\255\255\114\000\114\000\114\000\000\000\255\255\255\255\ + \114\000\114\000\255\255\114\000\114\000\114\000\113\000\113\000\ + \113\000\113\000\113\000\113\000\113\000\113\000\113\000\113\000\ + \114\000\255\255\114\000\114\000\114\000\114\000\114\000\113\000\ + \113\000\113\000\113\000\113\000\113\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\255\255\255\255\255\255\114\000\000\000\255\255\113\000\ + \113\000\113\000\113\000\113\000\113\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\255\255\114\000\255\255\114\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\080\000\080\000\ + \080\000\080\000\080\000\080\000\080\000\080\000\080\000\080\000\ + \051\000\000\000\000\000\078\000\000\000\000\000\000\000\080\000\ + \080\000\080\000\080\000\080\000\080\000\255\255\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \080\000\000\000\000\000\000\000\000\000\079\000\084\000\000\000\ + \083\000\000\000\000\000\000\000\000\000\000\000\000\000\080\000\ + \080\000\080\000\080\000\080\000\080\000\255\255\000\000\000\000\ + \000\000\000\000\082\000\000\000\000\000\000\000\255\255\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\000\000\000\000\000\000\000\000\081\000\000\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\000\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\000\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\050\000\081\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\000\000\000\000\000\000\000\000\081\000\ + \000\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\000\000\000\000\000\000\000\000\089\000\ + \000\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\000\000\000\000\000\000\000\000\000\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\000\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\000\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\000\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\000\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\000\000\000\000\000\000\000\000\088\000\000\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\000\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\000\000\000\000\030\000\000\000\000\000\000\000\086\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\000\000\000\000\000\000\000\000\088\000\000\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\000\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\089\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\000\000\000\000\030\000\000\000\000\000\000\000\000\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\000\000\000\000\000\000\000\000\089\000\000\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\000\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\000\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\099\000\ + \000\000\099\000\000\000\000\000\111\000\000\000\099\000\110\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\098\000\ + \098\000\098\000\098\000\098\000\098\000\098\000\098\000\098\000\ + \098\000\000\000\030\000\000\000\030\000\000\000\000\000\000\000\ + \000\000\030\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\109\000\109\000\109\000\109\000\109\000\109\000\ + \109\000\109\000\109\000\109\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\099\000\000\000\000\000\000\000\000\000\ + \000\000\099\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\099\000\000\000\000\000\ + \000\000\099\000\000\000\099\000\000\000\000\000\030\000\097\000\ + \000\000\000\000\000\000\000\000\030\000\116\000\000\000\000\000\ + \116\000\116\000\116\000\000\000\000\000\000\000\116\000\116\000\ + \030\000\116\000\116\000\116\000\030\000\000\000\030\000\000\000\ + \000\000\000\000\108\000\000\000\000\000\000\000\116\000\000\000\ + \116\000\116\000\116\000\116\000\116\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\000\000\ + \000\000\000\000\116\000\117\000\000\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\000\000\ + \116\000\000\000\116\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\255\255\000\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\000\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\000\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\116\000\000\000\000\000\116\000\ + \116\000\116\000\000\000\000\000\000\000\116\000\116\000\000\000\ + \116\000\116\000\116\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\116\000\000\000\116\000\ + \116\000\116\000\116\000\116\000\000\000\000\000\000\000\000\000\ + \117\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\000\000\000\000\028\000\000\000\000\000\ + \000\000\116\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\000\000\000\000\000\000\116\000\ + \117\000\116\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \000\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \000\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\119\000\000\000\000\000\119\000\119\000\119\000\000\000\ + \000\000\000\000\119\000\119\000\000\000\119\000\119\000\119\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\119\000\000\000\119\000\119\000\119\000\119\000\ + \119\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\000\000\000\000\000\000\119\000\120\000\ + \000\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\000\000\119\000\000\000\119\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\000\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\000\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \119\000\000\000\000\000\119\000\119\000\119\000\000\000\000\000\ + \000\000\119\000\119\000\000\000\119\000\119\000\119\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\119\000\000\000\119\000\119\000\119\000\119\000\119\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\120\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\000\000\000\000\028\000\000\000\119\000\000\000\121\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\000\000\119\000\000\000\119\000\120\000\000\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\000\000\000\000\000\000\000\000\122\000\000\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\000\000\000\000\000\000\000\000\000\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\000\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\000\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\000\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\000\000\000\000\123\000\000\000\000\000\000\000\000\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\000\000\000\000\000\000\000\000\122\000\000\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\000\000\000\000\000\000\000\000\131\000\000\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\000\000\000\000\000\000\000\000\000\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\000\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\000\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\000\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\000\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\000\000\000\000\000\000\000\000\130\000\000\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\000\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \000\000\000\000\028\000\000\000\000\000\000\000\128\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\000\000\000\000\000\000\000\000\130\000\000\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\000\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\131\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \000\000\000\000\028\000\000\000\000\000\000\000\000\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\000\000\000\000\000\000\000\000\131\000\000\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\000\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\000\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\028\000\000\000\ + \000\000\134\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \133\000\000\000\134\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\085\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\134\000\000\000\000\000\000\000\ + \000\000\134\000\135\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\134\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\134\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\000\000\134\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\000\000\134\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\134\000\255\255\137\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\085\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\000\000\ + \000\000\000\000\000\000\137\000\000\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\000\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\000\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\136\000\000\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\085\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \000\000\000\000\000\000\000\000\137\000\000\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\000\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\085\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \000\000\000\000\000\000\000\000\137\000\000\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \000\000\000\000\000\000\000\000\144\000\000\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \000\000\000\000\000\000\000\000\000\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\000\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\000\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\000\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\000\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\000\000\ + \000\000\000\000\000\000\143\000\000\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\000\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\000\000\000\000\ + \032\000\000\000\000\000\000\000\141\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\000\000\ + \000\000\000\000\000\000\143\000\000\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\000\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\144\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\000\000\000\000\ + \032\000\000\000\000\000\000\000\000\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\000\000\ + \000\000\000\000\000\000\144\000\000\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\000\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\000\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\000\000"; + Lexing.lex_check = + "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\000\000\000\000\027\000\000\000\000\000\068\000\074\000\ + \078\000\105\000\125\000\140\000\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\009\000\ + \011\000\012\000\013\000\014\000\012\000\012\000\017\000\026\000\ + \038\000\038\000\026\000\039\000\039\000\039\000\039\000\039\000\ + \039\000\039\000\039\000\047\000\049\000\010\000\055\000\010\000\ + \058\000\082\000\014\000\082\000\083\000\084\000\026\000\082\000\ + \091\000\048\000\092\000\093\000\012\000\094\000\099\000\101\000\ + \103\000\126\000\014\000\014\000\014\000\014\000\014\000\014\000\ + \014\000\014\000\014\000\014\000\045\000\045\000\045\000\045\000\ + \045\000\045\000\045\000\045\000\045\000\045\000\048\000\092\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\010\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\255\255\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\004\000\003\000\003\000\004\000\004\000\004\000\ + \255\255\003\000\003\000\004\000\004\000\003\000\004\000\004\000\ + \004\000\037\000\037\000\037\000\037\000\037\000\037\000\037\000\ + \037\000\037\000\037\000\004\000\003\000\004\000\004\000\004\000\ + \004\000\004\000\036\000\255\255\036\000\255\255\037\000\036\000\ + \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\ + \054\000\054\000\054\000\111\000\003\000\003\000\003\000\004\000\ + \037\000\003\000\110\000\110\000\255\255\255\255\037\000\070\000\ + \073\000\255\255\070\000\073\000\133\000\255\255\136\000\127\000\ + \018\000\127\000\111\000\018\000\255\255\127\000\255\255\255\255\ + \133\000\110\000\136\000\255\255\003\000\004\000\003\000\004\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ + \003\000\007\000\018\000\255\255\007\000\007\000\007\000\255\255\ + \255\255\255\255\007\000\007\000\255\255\007\000\007\000\007\000\ + \255\255\071\000\255\255\255\255\071\000\139\000\124\000\139\000\ + \003\000\124\000\007\000\139\000\007\000\007\000\007\000\007\000\ + \007\000\255\255\255\255\043\000\043\000\255\255\255\255\008\000\ + \255\255\071\000\008\000\008\000\008\000\255\255\255\255\255\255\ + \008\000\008\000\255\255\008\000\008\000\008\000\255\255\255\255\ + \003\000\255\255\255\255\255\255\255\255\007\000\007\000\043\000\ + \008\000\003\000\008\000\008\000\008\000\008\000\008\000\255\255\ + \124\000\255\255\124\000\255\255\015\000\255\255\255\255\015\000\ + \015\000\015\000\043\000\255\255\255\255\015\000\015\000\255\255\ + \015\000\015\000\015\000\255\255\007\000\007\000\007\000\043\000\ + \255\255\043\000\255\255\008\000\008\000\015\000\255\255\015\000\ + \015\000\015\000\015\000\015\000\255\255\255\255\255\255\016\000\ + \255\255\255\255\016\000\016\000\016\000\255\255\255\255\016\000\ + \016\000\016\000\255\255\016\000\016\000\016\000\255\255\255\255\ + \255\255\255\255\008\000\255\255\008\000\255\255\255\255\255\255\ + \016\000\015\000\016\000\016\000\016\000\016\000\016\000\255\255\ + \255\255\020\000\255\255\020\000\020\000\020\000\020\000\020\000\ + \020\000\020\000\020\000\020\000\020\000\070\000\073\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\018\000\015\000\ + \020\000\015\000\255\255\255\255\016\000\255\255\255\255\020\000\ + \255\255\255\255\021\000\255\255\021\000\021\000\021\000\021\000\ + \021\000\021\000\021\000\021\000\021\000\021\000\255\255\255\255\ + \255\255\255\255\020\000\255\255\255\255\255\255\021\000\255\255\ + \020\000\021\000\016\000\255\255\016\000\255\255\255\255\020\000\ + \021\000\020\000\255\255\021\000\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\021\000\255\255\255\255\255\255\ + \072\000\072\000\255\255\021\000\072\000\255\255\021\000\255\255\ + \255\255\021\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \021\000\255\255\021\000\021\000\022\000\255\255\255\255\072\000\ + \255\255\072\000\255\255\255\255\021\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\071\000\ + \255\255\255\255\255\255\255\255\124\000\255\255\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \255\255\255\255\255\255\255\255\022\000\255\255\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \040\000\040\000\040\000\040\000\040\000\040\000\040\000\040\000\ + \040\000\040\000\104\000\255\255\255\255\104\000\255\255\255\255\ + \067\000\040\000\040\000\040\000\040\000\040\000\040\000\056\000\ + \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\ + \056\000\255\255\104\000\255\255\255\255\255\255\255\255\067\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\040\000\040\000\040\000\040\000\040\000\040\000\067\000\ + \067\000\067\000\067\000\067\000\067\000\067\000\067\000\067\000\ + \067\000\255\255\255\255\255\255\255\255\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\104\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\023\000\022\000\022\000\022\000\ + \022\000\022\000\022\000\022\000\022\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\072\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \255\255\255\255\255\255\255\255\023\000\255\255\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \041\000\041\000\041\000\041\000\041\000\041\000\041\000\041\000\ + \041\000\041\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\041\000\041\000\041\000\041\000\041\000\041\000\255\255\ + \255\255\255\255\255\255\255\255\041\000\098\000\098\000\098\000\ + \098\000\098\000\098\000\098\000\098\000\098\000\098\000\255\255\ + \255\255\255\255\138\000\255\255\255\255\138\000\255\255\041\000\ + \104\000\041\000\041\000\041\000\041\000\041\000\041\000\255\255\ + \255\255\255\255\255\255\255\255\041\000\255\255\041\000\255\255\ + \255\255\255\255\255\255\255\255\138\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\138\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\255\255\023\000\023\000\023\000\ + \023\000\023\000\023\000\023\000\023\000\024\000\255\255\255\255\ + \024\000\024\000\024\000\255\255\255\255\255\255\024\000\024\000\ + \255\255\024\000\024\000\024\000\100\000\100\000\100\000\100\000\ + \100\000\100\000\100\000\100\000\100\000\100\000\024\000\255\255\ + \024\000\024\000\024\000\024\000\024\000\255\255\255\255\079\000\ + \255\255\255\255\079\000\255\255\255\255\255\255\255\255\255\255\ + \044\000\044\000\044\000\044\000\044\000\044\000\044\000\044\000\ + \044\000\044\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\024\000\024\000\079\000\024\000\024\000\024\000\ + \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ + \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ + \024\000\024\000\024\000\024\000\024\000\024\000\024\000\044\000\ + \024\000\025\000\024\000\255\255\025\000\025\000\025\000\255\255\ + \255\255\255\255\025\000\025\000\255\255\025\000\025\000\025\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\079\000\025\000\255\255\025\000\025\000\025\000\025\000\ + \025\000\109\000\109\000\109\000\109\000\109\000\109\000\109\000\ + \109\000\109\000\109\000\112\000\112\000\112\000\112\000\112\000\ + \112\000\112\000\112\000\112\000\112\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\025\000\025\000\ + \138\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ + \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ + \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ + \025\000\025\000\025\000\255\255\025\000\255\255\025\000\255\255\ + \255\255\255\255\255\255\024\000\024\000\024\000\024\000\024\000\ + \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ + \024\000\024\000\024\000\024\000\024\000\024\000\024\000\024\000\ + \024\000\024\000\024\000\255\255\024\000\024\000\024\000\024\000\ + \024\000\024\000\024\000\024\000\053\000\053\000\053\000\053\000\ + \053\000\053\000\053\000\053\000\053\000\053\000\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\053\000\053\000\053\000\ + \053\000\053\000\053\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\053\000\053\000\053\000\ + \053\000\053\000\053\000\255\255\255\255\079\000\255\255\025\000\ + \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ + \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ + \025\000\025\000\025\000\025\000\025\000\025\000\025\000\029\000\ + \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\255\255\255\255\255\255\255\255\029\000\ + \255\255\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\042\000\042\000\042\000\042\000\042\000\ + \042\000\042\000\042\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\057\000\057\000\057\000\057\000\057\000\057\000\057\000\ + \057\000\057\000\057\000\255\255\255\255\255\255\255\255\042\000\ + \255\255\255\255\057\000\057\000\057\000\057\000\057\000\057\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\042\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\042\000\ + \255\255\042\000\057\000\057\000\057\000\057\000\057\000\057\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\255\255\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\031\000\ + \029\000\029\000\029\000\029\000\029\000\029\000\029\000\029\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\255\255\255\255\255\255\255\255\031\000\ + \255\255\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\255\255\255\255\255\255\255\255\066\000\ + \066\000\255\255\255\255\066\000\255\255\255\255\255\255\255\255\ + \097\000\097\000\097\000\097\000\097\000\097\000\097\000\097\000\ + \097\000\097\000\255\255\255\255\255\255\255\255\066\000\255\255\ + \066\000\097\000\097\000\097\000\097\000\097\000\097\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\066\000\066\000\ + \066\000\066\000\066\000\066\000\066\000\066\000\066\000\066\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\097\000\097\000\097\000\097\000\097\000\097\000\255\255\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\255\255\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\255\255\ + \031\000\031\000\031\000\031\000\031\000\031\000\031\000\031\000\ + \046\000\061\000\046\000\255\255\061\000\061\000\061\000\046\000\ + \255\255\255\255\061\000\061\000\255\255\061\000\061\000\061\000\ + \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ + \046\000\046\000\061\000\255\255\061\000\061\000\061\000\061\000\ + \061\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \062\000\255\255\255\255\062\000\062\000\062\000\255\255\255\255\ + \255\255\062\000\062\000\255\255\062\000\062\000\062\000\255\255\ + \255\255\255\255\255\255\255\255\046\000\255\255\061\000\255\255\ + \255\255\062\000\046\000\062\000\062\000\062\000\062\000\062\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\046\000\255\255\ + \255\255\255\255\046\000\255\255\046\000\255\255\063\000\255\255\ + \046\000\063\000\063\000\063\000\061\000\255\255\061\000\063\000\ + \063\000\255\255\063\000\063\000\063\000\062\000\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\063\000\ + \255\255\063\000\063\000\063\000\063\000\063\000\066\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\064\000\255\255\255\255\ + \064\000\064\000\064\000\062\000\255\255\062\000\064\000\064\000\ + \255\255\064\000\064\000\064\000\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\063\000\255\255\255\255\064\000\255\255\ + \064\000\064\000\064\000\064\000\064\000\255\255\255\255\255\255\ + \065\000\255\255\255\255\065\000\065\000\065\000\255\255\255\255\ + \255\255\065\000\065\000\255\255\065\000\065\000\065\000\255\255\ + \255\255\063\000\255\255\063\000\255\255\255\255\255\255\255\255\ + \255\255\065\000\064\000\065\000\065\000\065\000\065\000\065\000\ + \102\000\102\000\102\000\102\000\102\000\102\000\102\000\102\000\ + \102\000\102\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\102\000\102\000\102\000\102\000\102\000\102\000\255\255\ + \064\000\255\255\064\000\255\255\255\255\065\000\255\255\255\255\ + \046\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\102\000\102\000\102\000\102\000\102\000\102\000\255\255\ + \255\255\255\255\255\255\065\000\255\255\065\000\076\000\076\000\ + \076\000\076\000\076\000\076\000\076\000\076\000\076\000\076\000\ + \076\000\076\000\076\000\076\000\076\000\076\000\076\000\076\000\ + \076\000\076\000\076\000\076\000\076\000\076\000\076\000\076\000\ + \076\000\076\000\076\000\076\000\076\000\076\000\076\000\114\000\ + \076\000\076\000\114\000\114\000\114\000\255\255\076\000\076\000\ + \114\000\114\000\076\000\114\000\114\000\114\000\108\000\108\000\ + \108\000\108\000\108\000\108\000\108\000\108\000\108\000\108\000\ + \114\000\076\000\114\000\114\000\114\000\114\000\114\000\108\000\ + \108\000\108\000\108\000\108\000\108\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\076\000\076\000\076\000\114\000\255\255\076\000\108\000\ + \108\000\108\000\108\000\108\000\108\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\076\000\114\000\076\000\114\000\076\000\076\000\076\000\ + \076\000\076\000\076\000\076\000\076\000\076\000\076\000\076\000\ + \076\000\076\000\076\000\076\000\076\000\076\000\076\000\076\000\ + \076\000\076\000\076\000\076\000\076\000\076\000\076\000\076\000\ + \076\000\076\000\076\000\076\000\076\000\076\000\076\000\076\000\ + \076\000\076\000\076\000\076\000\076\000\076\000\076\000\076\000\ + \076\000\076\000\076\000\076\000\076\000\076\000\076\000\076\000\ + \076\000\076\000\076\000\076\000\076\000\076\000\076\000\076\000\ + \076\000\076\000\076\000\076\000\076\000\076\000\113\000\113\000\ + \113\000\113\000\113\000\113\000\113\000\113\000\113\000\113\000\ + \077\000\255\255\255\255\077\000\255\255\255\255\255\255\113\000\ + \113\000\113\000\113\000\113\000\113\000\076\000\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \077\000\255\255\255\255\255\255\255\255\077\000\077\000\255\255\ + \077\000\255\255\255\255\255\255\255\255\255\255\255\255\113\000\ + \113\000\113\000\113\000\113\000\113\000\076\000\255\255\255\255\ + \255\255\255\255\077\000\255\255\255\255\255\255\076\000\077\000\ + \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ + \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ + \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ + \077\000\255\255\255\255\255\255\255\255\077\000\255\255\077\000\ + \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ + \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ + \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ + \077\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\077\000\077\000\ + \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ + \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ + \077\000\077\000\077\000\077\000\077\000\255\255\077\000\077\000\ + \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ + \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ + \077\000\077\000\077\000\077\000\077\000\077\000\077\000\077\000\ + \077\000\077\000\077\000\077\000\077\000\255\255\077\000\077\000\ + \077\000\077\000\077\000\077\000\077\000\077\000\077\000\081\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\255\255\255\255\255\255\255\255\081\000\ + \255\255\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\086\000\086\000\086\000\086\000\086\000\086\000\086\000\ + \086\000\086\000\086\000\086\000\086\000\086\000\086\000\086\000\ + \086\000\086\000\086\000\086\000\086\000\086\000\086\000\086\000\ + \086\000\086\000\086\000\255\255\255\255\255\255\255\255\086\000\ + \255\255\086\000\086\000\086\000\086\000\086\000\086\000\086\000\ + \086\000\086\000\086\000\086\000\086\000\086\000\086\000\086\000\ + \086\000\086\000\086\000\086\000\086\000\086\000\086\000\086\000\ + \086\000\086\000\086\000\255\255\255\255\255\255\255\255\255\255\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\255\255\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\255\255\ + \081\000\081\000\081\000\081\000\081\000\081\000\081\000\081\000\ + \086\000\086\000\086\000\086\000\086\000\086\000\086\000\086\000\ + \086\000\086\000\086\000\086\000\086\000\086\000\086\000\086\000\ + \086\000\086\000\086\000\086\000\086\000\086\000\086\000\255\255\ + \086\000\086\000\086\000\086\000\086\000\086\000\086\000\086\000\ + \086\000\086\000\086\000\086\000\086\000\086\000\086\000\086\000\ + \086\000\086\000\086\000\086\000\086\000\086\000\086\000\086\000\ + \086\000\086\000\086\000\086\000\086\000\086\000\086\000\255\255\ + \086\000\086\000\086\000\086\000\086\000\086\000\086\000\086\000\ + \087\000\087\000\087\000\087\000\087\000\087\000\087\000\087\000\ + \087\000\087\000\087\000\087\000\087\000\087\000\087\000\087\000\ + \087\000\087\000\087\000\087\000\087\000\087\000\087\000\087\000\ + \087\000\087\000\255\255\255\255\255\255\255\255\087\000\255\255\ + \087\000\087\000\087\000\087\000\087\000\087\000\087\000\087\000\ + \087\000\087\000\087\000\087\000\087\000\087\000\087\000\087\000\ + \087\000\087\000\087\000\087\000\087\000\087\000\087\000\087\000\ + \087\000\087\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\087\000\ + \087\000\087\000\087\000\087\000\087\000\087\000\087\000\087\000\ + \087\000\087\000\087\000\087\000\087\000\087\000\087\000\087\000\ + \087\000\087\000\087\000\087\000\087\000\087\000\255\255\087\000\ + \087\000\087\000\087\000\087\000\087\000\087\000\087\000\087\000\ + \087\000\087\000\087\000\087\000\087\000\087\000\087\000\087\000\ + \087\000\087\000\087\000\087\000\087\000\087\000\087\000\087\000\ + \087\000\087\000\087\000\087\000\087\000\087\000\088\000\087\000\ + \087\000\087\000\087\000\087\000\087\000\087\000\087\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\255\255\255\255\088\000\255\255\255\255\255\255\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\255\255\255\255\255\255\255\255\088\000\255\255\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\255\255\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\089\000\088\000\ + \088\000\088\000\088\000\088\000\088\000\088\000\088\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\255\255\255\255\089\000\255\255\255\255\255\255\255\255\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\255\255\255\255\255\255\255\255\089\000\255\255\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\255\255\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\255\255\089\000\ + \089\000\089\000\089\000\089\000\089\000\089\000\089\000\090\000\ + \255\255\090\000\255\255\255\255\106\000\255\255\090\000\106\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\090\000\ + \090\000\090\000\090\000\090\000\090\000\090\000\090\000\090\000\ + \090\000\255\255\106\000\255\255\106\000\255\255\255\255\255\255\ + \255\255\106\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\106\000\106\000\106\000\106\000\106\000\106\000\ + \106\000\106\000\106\000\106\000\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\090\000\255\255\255\255\255\255\255\255\ + \255\255\090\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\090\000\255\255\255\255\ + \255\255\090\000\255\255\090\000\255\255\255\255\106\000\090\000\ + \255\255\255\255\255\255\255\255\106\000\115\000\255\255\255\255\ + \115\000\115\000\115\000\255\255\255\255\255\255\115\000\115\000\ + \106\000\115\000\115\000\115\000\106\000\255\255\106\000\255\255\ + \255\255\255\255\106\000\255\255\255\255\255\255\115\000\255\255\ + \115\000\115\000\115\000\115\000\115\000\115\000\115\000\115\000\ + \115\000\115\000\115\000\115\000\115\000\115\000\115\000\115\000\ + \115\000\115\000\115\000\115\000\115\000\115\000\115\000\115\000\ + \115\000\115\000\115\000\115\000\115\000\115\000\115\000\255\255\ + \255\255\255\255\115\000\115\000\255\255\115\000\115\000\115\000\ + \115\000\115\000\115\000\115\000\115\000\115\000\115\000\115\000\ + \115\000\115\000\115\000\115\000\115\000\115\000\115\000\115\000\ + \115\000\115\000\115\000\115\000\115\000\115\000\115\000\255\255\ + \115\000\255\255\115\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\106\000\255\255\115\000\115\000\115\000\115\000\ + \115\000\115\000\115\000\115\000\115\000\115\000\115\000\115\000\ + \115\000\115\000\115\000\115\000\115\000\115\000\115\000\115\000\ + \115\000\115\000\115\000\255\255\115\000\115\000\115\000\115\000\ + \115\000\115\000\115\000\115\000\115\000\115\000\115\000\115\000\ + \115\000\115\000\115\000\115\000\115\000\115\000\115\000\115\000\ + \115\000\115\000\115\000\115\000\115\000\115\000\115\000\115\000\ + \115\000\115\000\115\000\255\255\115\000\115\000\115\000\115\000\ + \115\000\115\000\115\000\115\000\116\000\255\255\255\255\116\000\ + \116\000\116\000\255\255\255\255\255\255\116\000\116\000\255\255\ + \116\000\116\000\116\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\116\000\255\255\116\000\ + \116\000\116\000\116\000\116\000\255\255\255\255\255\255\255\255\ + \117\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\255\255\255\255\117\000\255\255\255\255\ + \255\255\116\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\255\255\255\255\255\255\116\000\ + \117\000\116\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \255\255\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \255\255\117\000\117\000\117\000\117\000\117\000\117\000\117\000\ + \117\000\118\000\255\255\255\255\118\000\118\000\118\000\255\255\ + \255\255\255\255\118\000\118\000\255\255\118\000\118\000\118\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\118\000\255\255\118\000\118\000\118\000\118\000\ + \118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \118\000\118\000\118\000\255\255\255\255\255\255\118\000\118\000\ + \255\255\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \118\000\118\000\118\000\255\255\118\000\255\255\118\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \118\000\118\000\118\000\118\000\118\000\118\000\118\000\255\255\ + \118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \118\000\118\000\118\000\118\000\118\000\118\000\118\000\255\255\ + \118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \119\000\255\255\255\255\119\000\119\000\119\000\255\255\255\255\ + \255\255\119\000\119\000\255\255\119\000\119\000\119\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\119\000\255\255\119\000\119\000\119\000\119\000\119\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\120\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\255\255\255\255\120\000\255\255\119\000\255\255\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\255\255\119\000\255\255\119\000\120\000\255\255\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \121\000\121\000\121\000\121\000\121\000\121\000\121\000\121\000\ + \121\000\121\000\121\000\121\000\121\000\121\000\121\000\121\000\ + \121\000\121\000\121\000\121\000\121\000\121\000\121\000\121\000\ + \121\000\121\000\255\255\255\255\255\255\255\255\121\000\255\255\ + \121\000\121\000\121\000\121\000\121\000\121\000\121\000\121\000\ + \121\000\121\000\121\000\121\000\121\000\121\000\121\000\121\000\ + \121\000\121\000\121\000\121\000\121\000\121\000\121\000\121\000\ + \121\000\121\000\255\255\255\255\255\255\255\255\255\255\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\255\255\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\255\255\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\121\000\ + \121\000\121\000\121\000\121\000\121\000\121\000\121\000\121\000\ + \121\000\121\000\121\000\121\000\121\000\121\000\121\000\121\000\ + \121\000\121\000\121\000\121\000\121\000\121\000\255\255\121\000\ + \121\000\121\000\121\000\121\000\121\000\121\000\121\000\121\000\ + \121\000\121\000\121\000\121\000\121\000\121\000\121\000\121\000\ + \121\000\121\000\121\000\121\000\121\000\121\000\121\000\121\000\ + \121\000\121\000\121\000\121\000\121\000\121\000\122\000\121\000\ + \121\000\121\000\121\000\121\000\121\000\121\000\121\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\255\255\255\255\122\000\255\255\255\255\255\255\255\255\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\255\255\255\255\255\255\255\255\122\000\255\255\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \128\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ + \128\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ + \128\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ + \128\000\128\000\255\255\255\255\255\255\255\255\128\000\255\255\ + \128\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ + \128\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ + \128\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ + \128\000\128\000\255\255\255\255\255\255\255\255\255\255\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\255\255\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\255\255\122\000\ + \122\000\122\000\122\000\122\000\122\000\122\000\122\000\128\000\ + \128\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ + \128\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ + \128\000\128\000\128\000\128\000\128\000\128\000\255\255\128\000\ + \128\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ + \128\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ + \128\000\128\000\128\000\128\000\128\000\128\000\128\000\128\000\ + \128\000\128\000\128\000\128\000\128\000\128\000\255\255\128\000\ + \128\000\128\000\128\000\128\000\128\000\128\000\128\000\129\000\ + \129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\ + \129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\ + \129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\ + \129\000\255\255\255\255\255\255\255\255\129\000\255\255\129\000\ + \129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\ + \129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\ + \129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\ + \129\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\129\000\129\000\ + \129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\ + \129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\ + \129\000\129\000\129\000\129\000\129\000\255\255\129\000\129\000\ + \129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\ + \129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\ + \129\000\129\000\129\000\129\000\129\000\129\000\129\000\129\000\ + \129\000\129\000\129\000\129\000\129\000\130\000\129\000\129\000\ + \129\000\129\000\129\000\129\000\129\000\129\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \255\255\255\255\130\000\255\255\255\255\255\255\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\255\255\255\255\255\255\255\255\130\000\255\255\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\255\255\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\131\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \255\255\255\255\131\000\255\255\255\255\255\255\255\255\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\255\255\255\255\255\255\255\255\131\000\255\255\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\255\255\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\255\255\131\000\131\000\ + \131\000\131\000\131\000\131\000\131\000\131\000\132\000\255\255\ + \255\255\132\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \132\000\255\255\132\000\132\000\132\000\132\000\132\000\132\000\ + \132\000\132\000\132\000\132\000\132\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\132\000\132\000\132\000\132\000\132\000\ + \132\000\132\000\132\000\132\000\132\000\132\000\132\000\132\000\ + \132\000\132\000\132\000\132\000\132\000\132\000\132\000\132\000\ + \132\000\132\000\132\000\132\000\132\000\255\255\255\255\255\255\ + \255\255\132\000\132\000\132\000\132\000\132\000\132\000\132\000\ + \132\000\132\000\132\000\132\000\132\000\132\000\132\000\132\000\ + \132\000\132\000\132\000\132\000\132\000\132\000\132\000\132\000\ + \132\000\132\000\132\000\132\000\132\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\132\000\132\000\132\000\132\000\132\000\132\000\ + \132\000\132\000\132\000\132\000\132\000\132\000\132\000\132\000\ + \132\000\132\000\132\000\132\000\132\000\132\000\132\000\132\000\ + \132\000\255\255\132\000\132\000\132\000\132\000\132\000\132\000\ + \132\000\132\000\132\000\132\000\132\000\132\000\132\000\132\000\ + \132\000\132\000\132\000\132\000\132\000\132\000\132\000\132\000\ + \132\000\132\000\132\000\132\000\132\000\132\000\132\000\132\000\ + \132\000\255\255\132\000\132\000\132\000\132\000\132\000\132\000\ + \132\000\132\000\132\000\134\000\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\134\000\134\000\134\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\134\000\134\000\134\000\255\255\ + \255\255\255\255\255\255\134\000\255\255\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\134\000\134\000\134\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\255\255\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\255\255\134\000\134\000\134\000\134\000\ + \134\000\134\000\134\000\134\000\135\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\135\000\255\255\135\000\135\000\135\000\ + \135\000\135\000\135\000\135\000\135\000\135\000\135\000\135\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\135\000\135\000\ + \135\000\135\000\135\000\135\000\135\000\135\000\135\000\135\000\ + \135\000\135\000\135\000\135\000\135\000\135\000\135\000\135\000\ + \135\000\135\000\135\000\135\000\135\000\135\000\135\000\135\000\ + \255\255\255\255\255\255\255\255\135\000\255\255\135\000\135\000\ + \135\000\135\000\135\000\135\000\135\000\135\000\135\000\135\000\ + \135\000\135\000\135\000\135\000\135\000\135\000\135\000\135\000\ + \135\000\135\000\135\000\135\000\135\000\135\000\135\000\135\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\135\000\135\000\135\000\ + \135\000\135\000\135\000\135\000\135\000\135\000\135\000\135\000\ + \135\000\135\000\135\000\135\000\135\000\135\000\135\000\135\000\ + \135\000\135\000\135\000\135\000\255\255\135\000\135\000\135\000\ + \135\000\135\000\135\000\135\000\135\000\135\000\135\000\135\000\ + \135\000\135\000\135\000\135\000\135\000\135\000\135\000\135\000\ + \135\000\135\000\135\000\135\000\135\000\135\000\135\000\135\000\ + \135\000\135\000\135\000\135\000\137\000\135\000\135\000\135\000\ + \135\000\135\000\135\000\135\000\135\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \255\255\255\255\255\255\255\255\137\000\255\255\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\141\000\141\000\ + \141\000\141\000\141\000\141\000\141\000\141\000\141\000\141\000\ + \141\000\141\000\141\000\141\000\141\000\141\000\141\000\141\000\ + \141\000\141\000\141\000\141\000\141\000\141\000\141\000\141\000\ + \255\255\255\255\255\255\255\255\141\000\255\255\141\000\141\000\ + \141\000\141\000\141\000\141\000\141\000\141\000\141\000\141\000\ + \141\000\141\000\141\000\141\000\141\000\141\000\141\000\141\000\ + \141\000\141\000\141\000\141\000\141\000\141\000\141\000\141\000\ + \255\255\255\255\255\255\255\255\255\255\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\255\255\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\255\255\137\000\137\000\137\000\ + \137\000\137\000\137\000\137\000\137\000\141\000\141\000\141\000\ + \141\000\141\000\141\000\141\000\141\000\141\000\141\000\141\000\ + \141\000\141\000\141\000\141\000\141\000\141\000\141\000\141\000\ + \141\000\141\000\141\000\141\000\255\255\141\000\141\000\141\000\ + \141\000\141\000\141\000\141\000\141\000\141\000\141\000\141\000\ + \141\000\141\000\141\000\141\000\141\000\141\000\141\000\141\000\ + \141\000\141\000\141\000\141\000\141\000\141\000\141\000\141\000\ + \141\000\141\000\141\000\141\000\255\255\141\000\141\000\141\000\ + \141\000\141\000\141\000\141\000\141\000\142\000\142\000\142\000\ + \142\000\142\000\142\000\142\000\142\000\142\000\142\000\142\000\ + \142\000\142\000\142\000\142\000\142\000\142\000\142\000\142\000\ + \142\000\142\000\142\000\142\000\142\000\142\000\142\000\255\255\ + \255\255\255\255\255\255\142\000\255\255\142\000\142\000\142\000\ + \142\000\142\000\142\000\142\000\142\000\142\000\142\000\142\000\ + \142\000\142\000\142\000\142\000\142\000\142\000\142\000\142\000\ + \142\000\142\000\142\000\142\000\142\000\142\000\142\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\142\000\142\000\142\000\142\000\ + \142\000\142\000\142\000\142\000\142\000\142\000\142\000\142\000\ + \142\000\142\000\142\000\142\000\142\000\142\000\142\000\142\000\ + \142\000\142\000\142\000\255\255\142\000\142\000\142\000\142\000\ + \142\000\142\000\142\000\142\000\142\000\142\000\142\000\142\000\ + \142\000\142\000\142\000\142\000\142\000\142\000\142\000\142\000\ + \142\000\142\000\142\000\142\000\142\000\142\000\142\000\142\000\ + \142\000\142\000\142\000\143\000\142\000\142\000\142\000\142\000\ + \142\000\142\000\142\000\142\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\255\255\255\255\ + \143\000\255\255\255\255\255\255\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\255\255\ + \255\255\255\255\255\255\143\000\255\255\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\255\255\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\144\000\143\000\143\000\143\000\143\000\ + \143\000\143\000\143\000\143\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\255\255\255\255\ + \144\000\255\255\255\255\255\255\255\255\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\255\255\ + \255\255\255\255\255\255\144\000\255\255\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\255\255\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\255\255\144\000\144\000\144\000\144\000\ + \144\000\144\000\144\000\144\000\255\255"; + Lexing.lex_base_code = + "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\010\000\036\000\000\000\012\000\000\000\000\000\ + \002\000\000\000\000\000\027\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\001\000\000\000\000\000\000\000\002\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\041\000\000\000\ + \249\000\000\000\000\000\039\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000"; + Lexing.lex_backtrk_code = + "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\012\000\000\000\000\000\000\000\ + \000\000\000\000\027\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\039\000\039\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000"; + Lexing.lex_default_code = + "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\019\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000"; + Lexing.lex_trans_code = + "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\001\000\000\000\036\000\036\000\000\000\036\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \001\000\000\000\000\000\001\000\022\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\007\000\001\000\000\000\000\000\ + \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ + \004\000\004\000\004\000\004\000\004\000\004\000\004\000\004\000\ + \004\000\004\000\004\000\004\000\001\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\004\000\004\000\004\000\004\000\ + \004\000\004\000\004\000\004\000\004\000\004\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\000\000\000\000\000\000\000\000\ + \036\000\000\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \000\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\000\000\000\000\000\000\000\000\ + \036\000\000\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \000\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \000\000\036\000\036\000\036\000\036\000\036\000\036\000\036\000\ + \036\000\000\000"; + Lexing.lex_check_code = + "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\014\000\071\000\106\000\110\000\071\000\106\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \014\000\255\255\071\000\000\000\072\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\066\000\067\000\255\255\255\255\ + \014\000\014\000\014\000\014\000\014\000\014\000\014\000\014\000\ + \014\000\014\000\066\000\066\000\066\000\066\000\066\000\066\000\ + \066\000\066\000\066\000\066\000\067\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\067\000\067\000\067\000\067\000\ + \067\000\067\000\067\000\067\000\067\000\067\000\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\118\000\118\000\118\000\118\000\118\000\118\000\ + \118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \118\000\118\000\118\000\118\000\255\255\255\255\255\255\255\255\ + \118\000\255\255\118\000\118\000\118\000\118\000\118\000\118\000\ + \118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \118\000\118\000\118\000\118\000\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \071\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \118\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \120\000\118\000\118\000\118\000\118\000\118\000\118\000\118\000\ + \118\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\255\255\255\255\255\255\255\255\ + \120\000\255\255\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \255\255\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \255\255\120\000\120\000\120\000\120\000\120\000\120\000\120\000\ + \120\000\255\255"; + Lexing.lex_code = + "\255\004\255\255\005\255\255\007\255\006\255\255\003\255\000\004\ + \001\005\255\007\255\255\006\255\007\255\255\000\004\001\005\003\ + \006\002\007\255\001\255\255\000\001\255"; + } + let rec token c lexbuf = + (lexbuf.Lexing.lex_mem <- Array.create 8 (-1); + __ocaml_lex_token_rec c lexbuf 0) + and __ocaml_lex_token_rec c lexbuf __ocaml_lex_state = + match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state + lexbuf + with + | 0 -> (update_loc c None 1 false 0; NEWLINE) + | 1 -> + let x = + Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos + lexbuf.Lexing.lex_curr_pos + in BLANKS x + | 2 -> + let x = + Lexing.sub_lexeme lexbuf + (lexbuf.Lexing.lex_start_pos + 1) + (lexbuf.Lexing.lex_curr_pos + (-1)) + in LABEL x + | 3 -> + let x = + Lexing.sub_lexeme lexbuf + (lexbuf.Lexing.lex_start_pos + 1) + (lexbuf.Lexing.lex_curr_pos + (-1)) + in OPTLABEL x + | 4 -> + let x = + Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos + lexbuf.Lexing.lex_curr_pos + in LIDENT x + | 5 -> + let x = + Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos + lexbuf.Lexing.lex_curr_pos + in UIDENT x + | 6 -> + let i = + Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos + lexbuf.Lexing.lex_curr_pos + in + (try INT (int_of_string i, i) + with + | Failure _ -> + err (Literal_overflow "int") (Loc.of_lexbuf lexbuf)) + | 7 -> + let f = + Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos + lexbuf.Lexing.lex_curr_pos + in + (try FLOAT (float_of_string f, f) + with + | Failure _ -> + err (Literal_overflow "float") + (Loc.of_lexbuf lexbuf)) + | 8 -> + let i = + Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos + (lexbuf.Lexing.lex_curr_pos + (-1)) + in + (try INT32 (Int32.of_string i, i) + with + | Failure _ -> + err (Literal_overflow "int32") + (Loc.of_lexbuf lexbuf)) + | 9 -> + let i = + Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos + (lexbuf.Lexing.lex_curr_pos + (-1)) + in + (try INT64 (Int64.of_string i, i) + with + | Failure _ -> + err (Literal_overflow "int64") + (Loc.of_lexbuf lexbuf)) + | 10 -> + let i = + Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos + (lexbuf.Lexing.lex_curr_pos + (-1)) + in + (try NATIVEINT (Nativeint.of_string i, i) + with + | Failure _ -> + err (Literal_overflow "nativeint") + (Loc.of_lexbuf lexbuf)) + | 11 -> + (with_curr_loc string c; + let s = buff_contents c in STRING (TokenEval.string s, s)) + | 12 -> + let x = + Lexing.sub_lexeme lexbuf + (lexbuf.Lexing.lex_start_pos + 1) + (lexbuf.Lexing.lex_curr_pos + (-1)) + in + (update_loc c None 1 false 1; CHAR (TokenEval.char x, x)) + | 13 -> + let x = + Lexing.sub_lexeme lexbuf + (lexbuf.Lexing.lex_start_pos + 1) + (lexbuf.Lexing.lex_curr_pos + (-1)) + in CHAR (TokenEval.char x, x) + | 14 -> + let c = + Lexing.sub_lexeme_char lexbuf + (lexbuf.Lexing.lex_start_pos + 2) + in + err (Illegal_escape (String.make 1 c)) + (Loc.of_lexbuf lexbuf) + | 15 -> + (store c; COMMENT (parse_nested comment (in_comment c))) + | 16 -> + (warn Comment_start (Loc.of_lexbuf lexbuf); + parse comment (in_comment c); + COMMENT (buff_contents c)) + | 17 -> + (warn Comment_not_end (Loc.of_lexbuf lexbuf); + move_start_p (-1) c; + SYMBOL "*") + | 18 -> + if quotations c + then mk_quotation quotation c "" "" 2 + else parse (symbolchar_star "<<") c + | 19 -> + if quotations c + then + QUOTATION + { + + q_name = ""; + q_loc = ""; + q_shift = 2; + q_contents = ""; + } + else parse (symbolchar_star "<<>>") c + | 20 -> + if quotations c + then with_curr_loc maybe_quotation_at c + else parse (symbolchar_star "<@") c + | 21 -> + if quotations c + then with_curr_loc maybe_quotation_colon c + else parse (symbolchar_star "<:") c + | 22 -> + let num = + Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(0) + lexbuf.Lexing.lex_mem.(1) + and name = + Lexing.sub_lexeme_opt lexbuf lexbuf.Lexing.lex_mem.(3) + lexbuf.Lexing.lex_mem.(2) in + let inum = int_of_string num + in + (update_loc c name inum true 0; + LINE_DIRECTIVE (inum, name)) + | 23 -> + let x = + Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos + lexbuf.Lexing.lex_curr_pos + in SYMBOL x + | 24 -> + if quotations c + then with_curr_loc dollar (shift 1 c) + else parse (symbolchar_star "$") c + | 25 -> + let x = + Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos + lexbuf.Lexing.lex_curr_pos + in SYMBOL x + | 26 -> + let x = + Lexing.sub_lexeme lexbuf + (lexbuf.Lexing.lex_start_pos + 1) + lexbuf.Lexing.lex_curr_pos + in ESCAPED_IDENT x + | 27 -> + 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) + | 28 -> + let c = + Lexing.sub_lexeme_char lexbuf lexbuf.Lexing.lex_start_pos + in err (Illegal_character c) (Loc.of_lexbuf lexbuf) + | __ocaml_lex_state -> + (lexbuf.Lexing.refill_buff lexbuf; + __ocaml_lex_token_rec c lexbuf __ocaml_lex_state) + and comment c lexbuf = __ocaml_lex_comment_rec c lexbuf 77 + and __ocaml_lex_comment_rec c lexbuf __ocaml_lex_state = + match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf + with + | 0 -> (store c; with_curr_loc comment c; parse comment c) + | 1 -> store c + | 2 -> + (store c; + if quotations c then with_curr_loc quotation c else (); + parse comment c) + | 3 -> store_parse comment c + | 4 -> + (store c; + (try with_curr_loc string c + with + | Loc.Exc_located (_, (Error.E Unterminated_string)) -> + err Unterminated_string_in_comment (loc c)); + Buffer.add_char c.buffer '"'; + parse comment c) + | 5 -> store_parse comment c + | 6 -> store_parse comment c + | 7 -> (update_loc c None 1 false 1; store_parse comment c) + | 8 -> store_parse comment c + | 9 -> store_parse comment c + | 10 -> store_parse comment c + | 11 -> store_parse comment c + | 12 -> err Unterminated_comment (loc c) + | 13 -> (update_loc c None 1 false 0; store_parse comment c) + | 14 -> store_parse comment c + | __ocaml_lex_state -> + (lexbuf.Lexing.refill_buff lexbuf; + __ocaml_lex_comment_rec c lexbuf __ocaml_lex_state) + and string c lexbuf = + (lexbuf.Lexing.lex_mem <- Array.create 2 (-1); + __ocaml_lex_string_rec c lexbuf 104) + and __ocaml_lex_string_rec c lexbuf __ocaml_lex_state = + match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state + lexbuf + with + | 0 -> set_start_p c + | 1 -> + let space = + Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(0) + lexbuf.Lexing.lex_curr_pos + in + (update_loc c None 1 false (String.length space); + store_parse string c) + | 2 -> store_parse string c + | 3 -> store_parse string c + | 4 -> store_parse string c + | 5 -> + let x = + Lexing.sub_lexeme_char lexbuf + (lexbuf.Lexing.lex_start_pos + 1) + in + if is_in_comment c + then store_parse string c + else + (warn (Illegal_escape (String.make 1 x)) + (Loc.of_lexbuf lexbuf); + store_parse string c) + | 6 -> (update_loc c None 1 false 0; store_parse string c) + | 7 -> err Unterminated_string (loc c) + | 8 -> store_parse string c + | __ocaml_lex_state -> + (lexbuf.Lexing.refill_buff lexbuf; + __ocaml_lex_string_rec c lexbuf __ocaml_lex_state) + and symbolchar_star beginning c lexbuf = + __ocaml_lex_symbolchar_star_rec beginning c lexbuf 114 + and + __ocaml_lex_symbolchar_star_rec beginning c lexbuf + __ocaml_lex_state = + match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf + with + | 0 -> + let tok = + Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos + lexbuf.Lexing.lex_curr_pos + in + (move_start_p (-String.length beginning) c; + SYMBOL (beginning ^ tok)) + | __ocaml_lex_state -> + (lexbuf.Lexing.refill_buff lexbuf; + __ocaml_lex_symbolchar_star_rec beginning c lexbuf + __ocaml_lex_state) + and maybe_quotation_at c lexbuf = + __ocaml_lex_maybe_quotation_at_rec c lexbuf 115 + and + __ocaml_lex_maybe_quotation_at_rec c lexbuf __ocaml_lex_state = + match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf + with + | 0 -> + let loc = + Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos + (lexbuf.Lexing.lex_curr_pos + (-1)) + in + mk_quotation quotation c "" loc (3 + (String.length loc)) + | 1 -> + let tok = + Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos + lexbuf.Lexing.lex_curr_pos + in SYMBOL ("<@" ^ tok) + | __ocaml_lex_state -> + (lexbuf.Lexing.refill_buff lexbuf; + __ocaml_lex_maybe_quotation_at_rec c lexbuf + __ocaml_lex_state) + and maybe_quotation_colon c lexbuf = + (lexbuf.Lexing.lex_mem <- Array.create 2 (-1); + __ocaml_lex_maybe_quotation_colon_rec c lexbuf 118) + and + __ocaml_lex_maybe_quotation_colon_rec c lexbuf + __ocaml_lex_state = + match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state + lexbuf + with + | 0 -> + let name = + Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos + (lexbuf.Lexing.lex_curr_pos + (-1)) + in + mk_quotation quotation c name "" + (3 + (String.length name)) + | 1 -> + let name = + Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos + lexbuf.Lexing.lex_mem.(0) + and loc = + Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_mem.(0) + 1) + (lexbuf.Lexing.lex_curr_pos + (-1)) + in + mk_quotation quotation c name loc + ((4 + (String.length loc)) + (String.length name)) + | 2 -> + let tok = + Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos + lexbuf.Lexing.lex_curr_pos + in SYMBOL ("<:" ^ tok) + | __ocaml_lex_state -> + (lexbuf.Lexing.refill_buff lexbuf; + __ocaml_lex_maybe_quotation_colon_rec c lexbuf + __ocaml_lex_state) + and quotation c lexbuf = __ocaml_lex_quotation_rec c lexbuf 124 + and __ocaml_lex_quotation_rec c lexbuf __ocaml_lex_state = + match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf + with + | 0 -> (store c; with_curr_loc quotation c; parse quotation c) + | 1 -> store c + | 2 -> err Unterminated_quotation (loc c) + | 3 -> (update_loc c None 1 false 0; store_parse quotation c) + | 4 -> store_parse quotation c + | __ocaml_lex_state -> + (lexbuf.Lexing.refill_buff lexbuf; + __ocaml_lex_quotation_rec c lexbuf __ocaml_lex_state) + and dollar c lexbuf = __ocaml_lex_dollar_rec c lexbuf 132 + and __ocaml_lex_dollar_rec c lexbuf __ocaml_lex_state = + match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf + with + | 0 -> (set_start_p c; ANTIQUOT ("", "")) + | 1 -> + let name = + Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos + (lexbuf.Lexing.lex_curr_pos + (-1)) + in + with_curr_loc (antiquot name) + (shift (1 + (String.length name)) c) + | 2 -> store_parse (antiquot "") c + | __ocaml_lex_state -> + (lexbuf.Lexing.refill_buff lexbuf; + __ocaml_lex_dollar_rec c lexbuf __ocaml_lex_state) + and antiquot name c lexbuf = + __ocaml_lex_antiquot_rec name c lexbuf 138 + and __ocaml_lex_antiquot_rec name c lexbuf __ocaml_lex_state = + match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf + with + | 0 -> (set_start_p c; ANTIQUOT (name, buff_contents c)) + | 1 -> err Unterminated_antiquot (loc c) + | 2 -> + (update_loc c None 1 false 0; + store_parse (antiquot name) c) + | 3 -> + (store c; + with_curr_loc quotation c; + parse (antiquot name) c) + | 4 -> store_parse (antiquot name) c + | __ocaml_lex_state -> + (lexbuf.Lexing.refill_buff lexbuf; + __ocaml_lex_antiquot_rec name c lexbuf __ocaml_lex_state) + 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; + 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 + end + module Camlp4Ast = + struct + module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = + struct + module Loc = Loc + module Ast = + struct + include Sig.MakeCamlp4Ast(Loc) + let 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_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" + module Meta = + struct + module type META_LOC = + sig + val meta_loc_patt : Loc.t -> Loc.t -> Ast.patt + val meta_loc_expr : Loc.t -> Loc.t -> Ast.expr + end + module MetaLoc = + struct + let meta_loc_patt _loc location = + let (a, b, c, d, e, f, g, h) = Loc.to_tuple location + in + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Loc"), + Ast.IdLid (_loc, "of_tuple"))), + Ast.PaTup (_loc, + Ast.PaCom (_loc, + Ast.PaStr (_loc, Ast.safe_string_escaped a), + Ast.PaCom (_loc, + Ast.PaCom (_loc, + Ast.PaCom (_loc, + Ast.PaCom (_loc, + Ast.PaCom (_loc, + Ast.PaCom (_loc, + Ast.PaInt (_loc, string_of_int b), + Ast.PaInt (_loc, string_of_int c)), + Ast.PaInt (_loc, string_of_int d)), + Ast.PaInt (_loc, string_of_int e)), + Ast.PaInt (_loc, string_of_int f)), + Ast.PaInt (_loc, string_of_int g)), + if h + then + Ast.PaId (_loc, Ast.IdUid (_loc, "True")) + else + Ast.PaId (_loc, Ast.IdUid (_loc, "False")))))) + let meta_loc_expr _loc location = + let (a, b, c, d, e, f, g, h) = Loc.to_tuple location + in + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Loc"), + Ast.IdLid (_loc, "of_tuple"))), + Ast.ExTup (_loc, + Ast.ExCom (_loc, + Ast.ExStr (_loc, Ast.safe_string_escaped a), + Ast.ExCom (_loc, + Ast.ExCom (_loc, + Ast.ExCom (_loc, + Ast.ExCom (_loc, + Ast.ExCom (_loc, + Ast.ExCom (_loc, + Ast.ExInt (_loc, string_of_int b), + Ast.ExInt (_loc, string_of_int c)), + Ast.ExInt (_loc, string_of_int d)), + Ast.ExInt (_loc, string_of_int e)), + Ast.ExInt (_loc, string_of_int f)), + Ast.ExInt (_loc, string_of_int g)), + if h + then + Ast.ExId (_loc, Ast.IdUid (_loc, "True")) + else + Ast.ExId (_loc, Ast.IdUid (_loc, "False")))))) + end + module MetaGhostLoc = + struct + let meta_loc_patt _loc _ = + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Loc"), + Ast.IdLid (_loc, "ghost"))) + let meta_loc_expr _loc _ = + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Loc"), + Ast.IdLid (_loc, "ghost"))) + end + module MetaLocVar = + struct + let meta_loc_patt _loc _ = + Ast.PaId (_loc, Ast.IdLid (_loc, !Loc.name)) + let meta_loc_expr _loc _ = + Ast.ExId (_loc, Ast.IdLid (_loc, !Loc.name)) + end + module Make (MetaLoc : META_LOC) = + struct + open MetaLoc + let meta_acc_Loc_t = meta_loc_expr + module Expr = + struct + let meta_string _loc s = Ast.ExStr (_loc, s) + let meta_int _loc s = Ast.ExInt (_loc, s) + let meta_float _loc s = Ast.ExFlo (_loc, s) + let meta_char _loc s = Ast.ExChr (_loc, s) + let meta_bool _loc = + function + | false -> + Ast.ExId (_loc, Ast.IdUid (_loc, "False")) + | true -> Ast.ExId (_loc, Ast.IdUid (_loc, "True")) + let rec meta_list mf_a _loc = + function + | [] -> Ast.ExId (_loc, Ast.IdUid (_loc, "[]")) + | x :: xs -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdUid (_loc, "::")), + mf_a _loc x), + meta_list mf_a _loc xs) + let rec meta_binding _loc = + function + | Ast.BiAnt (x0, x1) -> Ast.ExAnt (x0, x1) + | Ast.BiEq (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "BiEq"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_expr _loc x2) + | Ast.BiSem (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "BiSem"))), + meta_acc_Loc_t _loc x0), + meta_binding _loc x1), + meta_binding _loc x2) + | Ast.BiAnd (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "BiAnd"))), + meta_acc_Loc_t _loc x0), + meta_binding _loc x1), + meta_binding _loc x2) + | Ast.BiNil x0 -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "BiNil"))), + meta_acc_Loc_t _loc x0) + and meta_class_expr _loc = + function + | Ast.CeAnt (x0, x1) -> Ast.ExAnt (x0, x1) + | Ast.CeEq (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CeEq"))), + meta_acc_Loc_t _loc x0), + meta_class_expr _loc x1), + meta_class_expr _loc x2) + | Ast.CeAnd (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CeAnd"))), + meta_acc_Loc_t _loc x0), + meta_class_expr _loc x1), + meta_class_expr _loc x2) + | Ast.CeTyc (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CeTyc"))), + meta_acc_Loc_t _loc x0), + meta_class_expr _loc x1), + meta_class_type _loc x2) + | Ast.CeStr (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CeStr"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_class_str_item _loc x2) + | Ast.CeLet (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CeLet"))), + meta_acc_Loc_t _loc x0), + meta_meta_bool _loc x1), + meta_binding _loc x2), + meta_class_expr _loc x3) + | Ast.CeFun (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CeFun"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_class_expr _loc x2) + | Ast.CeCon (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CeCon"))), + meta_acc_Loc_t _loc x0), + meta_meta_bool _loc x1), + meta_ident _loc x2), + meta_ctyp _loc x3) + | Ast.CeApp (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CeApp"))), + meta_acc_Loc_t _loc x0), + meta_class_expr _loc x1), + meta_expr _loc x2) + | Ast.CeNil x0 -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CeNil"))), + meta_acc_Loc_t _loc x0) + and meta_class_sig_item _loc = + function + | Ast.CgAnt (x0, x1) -> Ast.ExAnt (x0, x1) + | Ast.CgVir (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CgVir"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_meta_bool _loc x2), + meta_ctyp _loc x3) + | Ast.CgVal (x0, x1, x2, x3, x4) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CgVal"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_meta_bool _loc x2), + meta_meta_bool _loc x3), + meta_ctyp _loc x4) + | Ast.CgMth (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CgMth"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_meta_bool _loc x2), + meta_ctyp _loc x3) + | Ast.CgInh (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CgInh"))), + meta_acc_Loc_t _loc x0), + meta_class_type _loc x1) + | Ast.CgSem (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CgSem"))), + meta_acc_Loc_t _loc x0), + meta_class_sig_item _loc x1), + meta_class_sig_item _loc x2) + | Ast.CgCtr (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CgCtr"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.CgNil x0 -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CgNil"))), + meta_acc_Loc_t _loc x0) + and meta_class_str_item _loc = + function + | Ast.CrAnt (x0, x1) -> Ast.ExAnt (x0, x1) + | Ast.CrVvr (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CrVvr"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_meta_bool _loc x2), + meta_ctyp _loc x3) + | Ast.CrVir (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CrVir"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_meta_bool _loc x2), + meta_ctyp _loc x3) + | Ast.CrVal (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CrVal"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_meta_bool _loc x2), + meta_expr _loc x3) + | Ast.CrMth (x0, x1, x2, x3, x4) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CrMth"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_meta_bool _loc x2), + meta_expr _loc x3), + meta_ctyp _loc x4) + | Ast.CrIni (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CrIni"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1) + | Ast.CrInh (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CrInh"))), + meta_acc_Loc_t _loc x0), + meta_class_expr _loc x1), + meta_string _loc x2) + | Ast.CrCtr (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CrCtr"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.CrSem (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CrSem"))), + meta_acc_Loc_t _loc x0), + meta_class_str_item _loc x1), + meta_class_str_item _loc x2) + | Ast.CrNil x0 -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CrNil"))), + meta_acc_Loc_t _loc x0) + and meta_class_type _loc = + function + | Ast.CtAnt (x0, x1) -> Ast.ExAnt (x0, x1) + | Ast.CtEq (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CtEq"))), + meta_acc_Loc_t _loc x0), + meta_class_type _loc x1), + meta_class_type _loc x2) + | Ast.CtCol (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CtCol"))), + meta_acc_Loc_t _loc x0), + meta_class_type _loc x1), + meta_class_type _loc x2) + | Ast.CtAnd (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CtAnd"))), + meta_acc_Loc_t _loc x0), + meta_class_type _loc x1), + meta_class_type _loc x2) + | Ast.CtSig (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CtSig"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_class_sig_item _loc x2) + | Ast.CtFun (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CtFun"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_class_type _loc x2) + | Ast.CtCon (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CtCon"))), + meta_acc_Loc_t _loc x0), + meta_meta_bool _loc x1), + meta_ident _loc x2), + meta_ctyp _loc x3) + | Ast.CtNil x0 -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CtNil"))), + meta_acc_Loc_t _loc x0) + and meta_ctyp _loc = + function + | Ast.TyAnt (x0, x1) -> Ast.ExAnt (x0, x1) + | Ast.TyOfAmp (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyOfAmp"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyAmp (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyAmp"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyVrnInfSup (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyVrnInfSup"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyVrnInf (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyVrnInf"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1) + | Ast.TyVrnSup (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyVrnSup"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1) + | Ast.TyVrnEq (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyVrnEq"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1) + | Ast.TySta (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TySta"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyTup (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyTup"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1) + | Ast.TyMut (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyMut"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1) + | Ast.TyPrv (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyPrv"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1) + | Ast.TyOr (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyOr"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyAnd (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyAnd"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyOf (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyOf"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TySum (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TySum"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1) + | Ast.TyCom (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyCom"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TySem (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TySem"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyCol (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyCol"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyRec (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyRec"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1) + | Ast.TyVrn (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyVrn"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.TyQuM (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyQuM"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.TyQuP (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyQuP"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.TyQuo (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyQuo"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.TyPol (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyPol"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyOlb (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyOlb"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_ctyp _loc x2) + | Ast.TyObj (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyObj"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_meta_bool _loc x2) + | Ast.TyDcl (x0, x1, x2, x3, x4) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyDcl"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_list meta_ctyp _loc x2), + meta_ctyp _loc x3), + meta_list + (fun _loc (x1, x2) -> + Ast.ExTup (_loc, + Ast.ExCom (_loc, meta_ctyp _loc x1, + meta_ctyp _loc x2))) + _loc x4) + | Ast.TyMan (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyMan"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyId (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyId"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1) + | Ast.TyLab (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyLab"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_ctyp _loc x2) + | Ast.TyCls (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyCls"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1) + | Ast.TyArr (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyArr"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyApp (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyApp"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyAny x0 -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyAny"))), + meta_acc_Loc_t _loc x0) + | Ast.TyAli (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyAli"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyNil x0 -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyNil"))), + meta_acc_Loc_t _loc x0) + and meta_expr _loc = + function + | Ast.ExWhi (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExWhi"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_expr _loc x2) + | Ast.ExVrn (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExVrn"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.ExTyc (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExTyc"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_ctyp _loc x2) + | Ast.ExCom (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExCom"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_expr _loc x2) + | Ast.ExTup (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExTup"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1) + | Ast.ExTry (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExTry"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_match_case _loc x2) + | Ast.ExStr (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExStr"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.ExSte (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExSte"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_expr _loc x2) + | Ast.ExSnd (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExSnd"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_string _loc x2) + | Ast.ExSeq (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExSeq"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1) + | Ast.ExRec (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExRec"))), + meta_acc_Loc_t _loc x0), + meta_binding _loc x1), + meta_expr _loc x2) + | Ast.ExOvr (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExOvr"))), + meta_acc_Loc_t _loc x0), + meta_binding _loc x1) + | Ast.ExOlb (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExOlb"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_expr _loc x2) + | Ast.ExObj (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExObj"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_class_str_item _loc x2) + | Ast.ExNew (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExNew"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1) + | Ast.ExMat (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExMat"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_match_case _loc x2) + | Ast.ExLmd (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExLmd"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_module_expr _loc x2), + meta_expr _loc x3) + | Ast.ExLet (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExLet"))), + meta_acc_Loc_t _loc x0), + meta_meta_bool _loc x1), + meta_binding _loc x2), + meta_expr _loc x3) + | Ast.ExLaz (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExLaz"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1) + | Ast.ExLab (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExLab"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_expr _loc x2) + | Ast.ExNativeInt (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExNativeInt"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.ExInt64 (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExInt64"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.ExInt32 (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExInt32"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.ExInt (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExInt"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.ExIfe (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExIfe"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_expr _loc x2), + meta_expr _loc x3) + | Ast.ExFun (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExFun"))), + meta_acc_Loc_t _loc x0), + meta_match_case _loc x1) + | Ast.ExFor (x0, x1, x2, x3, x4, x5) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExFor"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_expr _loc x2), + meta_expr _loc x3), + meta_meta_bool _loc x4), + meta_expr _loc x5) + | Ast.ExFlo (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExFlo"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.ExCoe (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExCoe"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_ctyp _loc x2), + meta_ctyp _loc x3) + | Ast.ExChr (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExChr"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.ExAss (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExAss"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_expr _loc x2) + | Ast.ExAsr (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExAsr"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1) + | Ast.ExAsf x0 -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExAsf"))), + meta_acc_Loc_t _loc x0) + | Ast.ExSem (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExSem"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_expr _loc x2) + | Ast.ExArr (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExArr"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1) + | Ast.ExAre (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExAre"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_expr _loc x2) + | Ast.ExApp (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExApp"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_expr _loc x2) + | Ast.ExAnt (x0, x1) -> Ast.ExAnt (x0, x1) + | Ast.ExAcc (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExAcc"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_expr _loc x2) + | Ast.ExId (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExId"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1) + | Ast.ExNil x0 -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExNil"))), + meta_acc_Loc_t _loc x0) + and meta_ident _loc = + function + | Ast.IdAnt (x0, x1) -> Ast.ExAnt (x0, x1) + | Ast.IdUid (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "IdUid"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.IdLid (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "IdLid"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.IdApp (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "IdApp"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1), + meta_ident _loc x2) + | Ast.IdAcc (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "IdAcc"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1), + meta_ident _loc x2) + and meta_match_case _loc = + function + | Ast.McAnt (x0, x1) -> Ast.ExAnt (x0, x1) + | Ast.McArr (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "McArr"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_expr _loc x2), + meta_expr _loc x3) + | Ast.McOr (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "McOr"))), + meta_acc_Loc_t _loc x0), + meta_match_case _loc x1), + meta_match_case _loc x2) + | Ast.McNil x0 -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "McNil"))), + meta_acc_Loc_t _loc x0) + and meta_meta_bool _loc = + function + | Ast.BAnt x0 -> Ast.ExAnt (_loc, x0) + | Ast.BFalse -> + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "BFalse"))) + | Ast.BTrue -> + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "BTrue"))) + and meta_meta_list mf_a _loc = + function + | Ast.LAnt x0 -> Ast.ExAnt (_loc, x0) + | Ast.LCons (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "LCons"))), + mf_a _loc x0), + meta_meta_list mf_a _loc x1) + | Ast.LNil -> + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "LNil"))) + and meta_meta_option mf_a _loc = + function + | Ast.OAnt x0 -> Ast.ExAnt (_loc, x0) + | Ast.OSome x0 -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "OSome"))), + mf_a _loc x0) + | Ast.ONone -> + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ONone"))) + and meta_module_binding _loc = + function + | Ast.MbAnt (x0, x1) -> Ast.ExAnt (x0, x1) + | Ast.MbCol (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MbCol"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_module_type _loc x2) + | Ast.MbColEq (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MbColEq"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_module_type _loc x2), + meta_module_expr _loc x3) + | Ast.MbAnd (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MbAnd"))), + meta_acc_Loc_t _loc x0), + meta_module_binding _loc x1), + meta_module_binding _loc x2) + | Ast.MbNil x0 -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MbNil"))), + meta_acc_Loc_t _loc x0) + and meta_module_expr _loc = + function + | Ast.MeAnt (x0, x1) -> Ast.ExAnt (x0, x1) + | Ast.MeTyc (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MeTyc"))), + meta_acc_Loc_t _loc x0), + meta_module_expr _loc x1), + meta_module_type _loc x2) + | Ast.MeStr (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MeStr"))), + meta_acc_Loc_t _loc x0), + meta_str_item _loc x1) + | Ast.MeFun (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MeFun"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_module_type _loc x2), + meta_module_expr _loc x3) + | Ast.MeApp (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MeApp"))), + meta_acc_Loc_t _loc x0), + meta_module_expr _loc x1), + meta_module_expr _loc x2) + | Ast.MeId (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MeId"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1) + and meta_module_type _loc = + function + | Ast.MtAnt (x0, x1) -> Ast.ExAnt (x0, x1) + | Ast.MtWit (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MtWit"))), + meta_acc_Loc_t _loc x0), + meta_module_type _loc x1), + meta_with_constr _loc x2) + | Ast.MtSig (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MtSig"))), + meta_acc_Loc_t _loc x0), + meta_sig_item _loc x1) + | Ast.MtQuo (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MtQuo"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.MtFun (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MtFun"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_module_type _loc x2), + meta_module_type _loc x3) + | Ast.MtId (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MtId"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1) + and meta_patt _loc = + function + | Ast.PaVrn (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaVrn"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.PaTyp (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaTyp"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1) + | Ast.PaTyc (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaTyc"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_ctyp _loc x2) + | Ast.PaTup (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaTup"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1) + | Ast.PaStr (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaStr"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.PaEq (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaEq"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_patt _loc x2) + | Ast.PaRec (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaRec"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1) + | Ast.PaRng (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaRng"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_patt _loc x2) + | Ast.PaOrp (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaOrp"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_patt _loc x2) + | Ast.PaOlbi (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaOlbi"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_patt _loc x2), + meta_expr _loc x3) + | Ast.PaOlb (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaOlb"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_patt _loc x2) + | Ast.PaLab (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaLab"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_patt _loc x2) + | Ast.PaFlo (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaFlo"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.PaNativeInt (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaNativeInt"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.PaInt64 (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaInt64"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.PaInt32 (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaInt32"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.PaInt (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaInt"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.PaChr (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaChr"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.PaSem (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaSem"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_patt _loc x2) + | Ast.PaCom (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaCom"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_patt _loc x2) + | Ast.PaArr (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaArr"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1) + | Ast.PaApp (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaApp"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_patt _loc x2) + | Ast.PaAny x0 -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaAny"))), + meta_acc_Loc_t _loc x0) + | Ast.PaAnt (x0, x1) -> Ast.ExAnt (x0, x1) + | Ast.PaAli (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaAli"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_patt _loc x2) + | Ast.PaId (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaId"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1) + | Ast.PaNil x0 -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaNil"))), + meta_acc_Loc_t _loc x0) + and meta_sig_item _loc = + function + | Ast.SgAnt (x0, x1) -> Ast.ExAnt (x0, x1) + | Ast.SgVal (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgVal"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_ctyp _loc x2) + | Ast.SgTyp (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgTyp"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1) + | Ast.SgOpn (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgOpn"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1) + | Ast.SgMty (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgMty"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_module_type _loc x2) + | Ast.SgRecMod (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgRecMod"))), + meta_acc_Loc_t _loc x0), + meta_module_binding _loc x1) + | Ast.SgMod (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgMod"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_module_type _loc x2) + | Ast.SgInc (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgInc"))), + meta_acc_Loc_t _loc x0), + meta_module_type _loc x1) + | Ast.SgExt (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgExt"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_ctyp _loc x2), + meta_meta_list meta_string _loc x3) + | Ast.SgExc (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgExc"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1) + | Ast.SgDir (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgDir"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_expr _loc x2) + | Ast.SgSem (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgSem"))), + meta_acc_Loc_t _loc x0), + meta_sig_item _loc x1), + meta_sig_item _loc x2) + | Ast.SgClt (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgClt"))), + meta_acc_Loc_t _loc x0), + meta_class_type _loc x1) + | Ast.SgCls (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgCls"))), + meta_acc_Loc_t _loc x0), + meta_class_type _loc x1) + | Ast.SgNil x0 -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgNil"))), + meta_acc_Loc_t _loc x0) + and meta_str_item _loc = + function + | Ast.StAnt (x0, x1) -> Ast.ExAnt (x0, x1) + | Ast.StVal (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StVal"))), + meta_acc_Loc_t _loc x0), + meta_meta_bool _loc x1), + meta_binding _loc x2) + | Ast.StTyp (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StTyp"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1) + | Ast.StOpn (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StOpn"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1) + | Ast.StMty (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StMty"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_module_type _loc x2) + | Ast.StRecMod (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StRecMod"))), + meta_acc_Loc_t _loc x0), + meta_module_binding _loc x1) + | Ast.StMod (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StMod"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_module_expr _loc x2) + | Ast.StInc (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StInc"))), + meta_acc_Loc_t _loc x0), + meta_module_expr _loc x1) + | Ast.StExt (x0, x1, x2, x3) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StExt"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_ctyp _loc x2), + meta_meta_list meta_string _loc x3) + | Ast.StExp (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StExp"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1) + | Ast.StExc (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StExc"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_meta_option meta_ident _loc x2) + | Ast.StDir (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StDir"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_expr _loc x2) + | Ast.StSem (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StSem"))), + meta_acc_Loc_t _loc x0), + meta_str_item _loc x1), + meta_str_item _loc x2) + | Ast.StClt (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StClt"))), + meta_acc_Loc_t _loc x0), + meta_class_type _loc x1) + | Ast.StCls (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StCls"))), + meta_acc_Loc_t _loc x0), + meta_class_expr _loc x1) + | Ast.StNil x0 -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StNil"))), + meta_acc_Loc_t _loc x0) + and meta_with_constr _loc = + function + | Ast.WcAnt (x0, x1) -> Ast.ExAnt (x0, x1) + | Ast.WcAnd (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "WcAnd"))), + meta_acc_Loc_t _loc x0), + meta_with_constr _loc x1), + meta_with_constr _loc x2) + | Ast.WcMod (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "WcMod"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1), + meta_ident _loc x2) + | Ast.WcTyp (x0, x1, x2) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "WcTyp"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.WcNil x0 -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "WcNil"))), + meta_acc_Loc_t _loc x0) + end + let meta_acc_Loc_t = meta_loc_patt + module Patt = + struct + let meta_string _loc s = Ast.PaStr (_loc, s) + let meta_int _loc s = Ast.PaInt (_loc, s) + let meta_float _loc s = Ast.PaFlo (_loc, s) + let meta_char _loc s = Ast.PaChr (_loc, s) + let meta_bool _loc = + function + | false -> + Ast.PaId (_loc, Ast.IdUid (_loc, "False")) + | true -> Ast.PaId (_loc, Ast.IdUid (_loc, "True")) + let rec meta_list mf_a _loc = + function + | [] -> Ast.PaId (_loc, Ast.IdUid (_loc, "[]")) + | x :: xs -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, Ast.IdUid (_loc, "::")), + mf_a _loc x), + meta_list mf_a _loc xs) + let rec meta_binding _loc = + function + | Ast.BiAnt (x0, x1) -> Ast.PaAnt (x0, x1) + | Ast.BiEq (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "BiEq"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_expr _loc x2) + | Ast.BiSem (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "BiSem"))), + meta_acc_Loc_t _loc x0), + meta_binding _loc x1), + meta_binding _loc x2) + | Ast.BiAnd (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "BiAnd"))), + meta_acc_Loc_t _loc x0), + meta_binding _loc x1), + meta_binding _loc x2) + | Ast.BiNil x0 -> + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "BiNil"))), + meta_acc_Loc_t _loc x0) + and meta_class_expr _loc = + function + | Ast.CeAnt (x0, x1) -> Ast.PaAnt (x0, x1) + | Ast.CeEq (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CeEq"))), + meta_acc_Loc_t _loc x0), + meta_class_expr _loc x1), + meta_class_expr _loc x2) + | Ast.CeAnd (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CeAnd"))), + meta_acc_Loc_t _loc x0), + meta_class_expr _loc x1), + meta_class_expr _loc x2) + | Ast.CeTyc (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CeTyc"))), + meta_acc_Loc_t _loc x0), + meta_class_expr _loc x1), + meta_class_type _loc x2) + | Ast.CeStr (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CeStr"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_class_str_item _loc x2) + | Ast.CeLet (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CeLet"))), + meta_acc_Loc_t _loc x0), + meta_meta_bool _loc x1), + meta_binding _loc x2), + meta_class_expr _loc x3) + | Ast.CeFun (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CeFun"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_class_expr _loc x2) + | Ast.CeCon (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CeCon"))), + meta_acc_Loc_t _loc x0), + meta_meta_bool _loc x1), + meta_ident _loc x2), + meta_ctyp _loc x3) + | Ast.CeApp (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CeApp"))), + meta_acc_Loc_t _loc x0), + meta_class_expr _loc x1), + meta_expr _loc x2) + | Ast.CeNil x0 -> + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CeNil"))), + meta_acc_Loc_t _loc x0) + and meta_class_sig_item _loc = + function + | Ast.CgAnt (x0, x1) -> Ast.PaAnt (x0, x1) + | Ast.CgVir (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CgVir"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_meta_bool _loc x2), + meta_ctyp _loc x3) + | Ast.CgVal (x0, x1, x2, x3, x4) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CgVal"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_meta_bool _loc x2), + meta_meta_bool _loc x3), + meta_ctyp _loc x4) + | Ast.CgMth (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CgMth"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_meta_bool _loc x2), + meta_ctyp _loc x3) + | Ast.CgInh (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CgInh"))), + meta_acc_Loc_t _loc x0), + meta_class_type _loc x1) + | Ast.CgSem (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CgSem"))), + meta_acc_Loc_t _loc x0), + meta_class_sig_item _loc x1), + meta_class_sig_item _loc x2) + | Ast.CgCtr (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CgCtr"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.CgNil x0 -> + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CgNil"))), + meta_acc_Loc_t _loc x0) + and meta_class_str_item _loc = + function + | Ast.CrAnt (x0, x1) -> Ast.PaAnt (x0, x1) + | Ast.CrVvr (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CrVvr"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_meta_bool _loc x2), + meta_ctyp _loc x3) + | Ast.CrVir (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CrVir"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_meta_bool _loc x2), + meta_ctyp _loc x3) + | Ast.CrVal (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CrVal"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_meta_bool _loc x2), + meta_expr _loc x3) + | Ast.CrMth (x0, x1, x2, x3, x4) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CrMth"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_meta_bool _loc x2), + meta_expr _loc x3), + meta_ctyp _loc x4) + | Ast.CrIni (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CrIni"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1) + | Ast.CrInh (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CrInh"))), + meta_acc_Loc_t _loc x0), + meta_class_expr _loc x1), + meta_string _loc x2) + | Ast.CrCtr (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CrCtr"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.CrSem (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CrSem"))), + meta_acc_Loc_t _loc x0), + meta_class_str_item _loc x1), + meta_class_str_item _loc x2) + | Ast.CrNil x0 -> + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CrNil"))), + meta_acc_Loc_t _loc x0) + and meta_class_type _loc = + function + | Ast.CtAnt (x0, x1) -> Ast.PaAnt (x0, x1) + | Ast.CtEq (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CtEq"))), + meta_acc_Loc_t _loc x0), + meta_class_type _loc x1), + meta_class_type _loc x2) + | Ast.CtCol (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CtCol"))), + meta_acc_Loc_t _loc x0), + meta_class_type _loc x1), + meta_class_type _loc x2) + | Ast.CtAnd (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CtAnd"))), + meta_acc_Loc_t _loc x0), + meta_class_type _loc x1), + meta_class_type _loc x2) + | Ast.CtSig (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CtSig"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_class_sig_item _loc x2) + | Ast.CtFun (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CtFun"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_class_type _loc x2) + | Ast.CtCon (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CtCon"))), + meta_acc_Loc_t _loc x0), + meta_meta_bool _loc x1), + meta_ident _loc x2), + meta_ctyp _loc x3) + | Ast.CtNil x0 -> + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CtNil"))), + meta_acc_Loc_t _loc x0) + and meta_ctyp _loc = + function + | Ast.TyAnt (x0, x1) -> Ast.PaAnt (x0, x1) + | Ast.TyOfAmp (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyOfAmp"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyAmp (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyAmp"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyVrnInfSup (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyVrnInfSup"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyVrnInf (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyVrnInf"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1) + | Ast.TyVrnSup (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyVrnSup"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1) + | Ast.TyVrnEq (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyVrnEq"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1) + | Ast.TySta (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TySta"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyTup (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyTup"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1) + | Ast.TyMut (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyMut"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1) + | Ast.TyPrv (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyPrv"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1) + | Ast.TyOr (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyOr"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyAnd (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyAnd"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyOf (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyOf"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TySum (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TySum"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1) + | Ast.TyCom (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyCom"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TySem (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TySem"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyCol (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyCol"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyRec (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyRec"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1) + | Ast.TyVrn (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyVrn"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.TyQuM (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyQuM"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.TyQuP (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyQuP"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.TyQuo (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyQuo"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.TyPol (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyPol"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyOlb (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyOlb"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_ctyp _loc x2) + | Ast.TyObj (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyObj"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_meta_bool _loc x2) + | Ast.TyDcl (x0, x1, x2, x3, x4) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyDcl"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_list meta_ctyp _loc x2), + meta_ctyp _loc x3), + meta_list + (fun _loc (x1, x2) -> + Ast.PaTup (_loc, + Ast.PaCom (_loc, meta_ctyp _loc x1, + meta_ctyp _loc x2))) + _loc x4) + | Ast.TyMan (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyMan"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyId (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyId"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1) + | Ast.TyLab (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyLab"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_ctyp _loc x2) + | Ast.TyCls (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyCls"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1) + | Ast.TyArr (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyArr"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyApp (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyApp"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyAny x0 -> + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyAny"))), + meta_acc_Loc_t _loc x0) + | Ast.TyAli (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyAli"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.TyNil x0 -> + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyNil"))), + meta_acc_Loc_t _loc x0) + and meta_expr _loc = + function + | Ast.ExWhi (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExWhi"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_expr _loc x2) + | Ast.ExVrn (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExVrn"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.ExTyc (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExTyc"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_ctyp _loc x2) + | Ast.ExCom (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExCom"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_expr _loc x2) + | Ast.ExTup (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExTup"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1) + | Ast.ExTry (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExTry"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_match_case _loc x2) + | Ast.ExStr (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExStr"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.ExSte (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExSte"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_expr _loc x2) + | Ast.ExSnd (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExSnd"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_string _loc x2) + | Ast.ExSeq (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExSeq"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1) + | Ast.ExRec (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExRec"))), + meta_acc_Loc_t _loc x0), + meta_binding _loc x1), + meta_expr _loc x2) + | Ast.ExOvr (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExOvr"))), + meta_acc_Loc_t _loc x0), + meta_binding _loc x1) + | Ast.ExOlb (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExOlb"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_expr _loc x2) + | Ast.ExObj (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExObj"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_class_str_item _loc x2) + | Ast.ExNew (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExNew"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1) + | Ast.ExMat (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExMat"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_match_case _loc x2) + | Ast.ExLmd (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExLmd"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_module_expr _loc x2), + meta_expr _loc x3) + | Ast.ExLet (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExLet"))), + meta_acc_Loc_t _loc x0), + meta_meta_bool _loc x1), + meta_binding _loc x2), + meta_expr _loc x3) + | Ast.ExLaz (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExLaz"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1) + | Ast.ExLab (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExLab"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_expr _loc x2) + | Ast.ExNativeInt (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExNativeInt"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.ExInt64 (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExInt64"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.ExInt32 (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExInt32"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.ExInt (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExInt"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.ExIfe (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExIfe"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_expr _loc x2), + meta_expr _loc x3) + | Ast.ExFun (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExFun"))), + meta_acc_Loc_t _loc x0), + meta_match_case _loc x1) + | Ast.ExFor (x0, x1, x2, x3, x4, x5) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExFor"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_expr _loc x2), + meta_expr _loc x3), + meta_meta_bool _loc x4), + meta_expr _loc x5) + | Ast.ExFlo (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExFlo"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.ExCoe (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExCoe"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_ctyp _loc x2), + meta_ctyp _loc x3) + | Ast.ExChr (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExChr"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.ExAss (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExAss"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_expr _loc x2) + | Ast.ExAsr (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExAsr"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1) + | Ast.ExAsf x0 -> + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExAsf"))), + meta_acc_Loc_t _loc x0) + | Ast.ExSem (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExSem"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_expr _loc x2) + | Ast.ExArr (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExArr"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1) + | Ast.ExAre (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExAre"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_expr _loc x2) + | Ast.ExApp (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExApp"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_expr _loc x2) + | Ast.ExAnt (x0, x1) -> Ast.PaAnt (x0, x1) + | Ast.ExAcc (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExAcc"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1), + meta_expr _loc x2) + | Ast.ExId (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExId"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1) + | Ast.ExNil x0 -> + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExNil"))), + meta_acc_Loc_t _loc x0) + and meta_ident _loc = + function + | Ast.IdAnt (x0, x1) -> Ast.PaAnt (x0, x1) + | Ast.IdUid (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "IdUid"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.IdLid (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "IdLid"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.IdApp (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "IdApp"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1), + meta_ident _loc x2) + | Ast.IdAcc (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "IdAcc"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1), + meta_ident _loc x2) + and meta_match_case _loc = + function + | Ast.McAnt (x0, x1) -> Ast.PaAnt (x0, x1) + | Ast.McArr (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "McArr"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_expr _loc x2), + meta_expr _loc x3) + | Ast.McOr (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "McOr"))), + meta_acc_Loc_t _loc x0), + meta_match_case _loc x1), + meta_match_case _loc x2) + | Ast.McNil x0 -> + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "McNil"))), + meta_acc_Loc_t _loc x0) + and meta_meta_bool _loc = + function + | Ast.BAnt x0 -> Ast.PaAnt (_loc, x0) + | Ast.BFalse -> + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "BFalse"))) + | Ast.BTrue -> + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "BTrue"))) + and meta_meta_list mf_a _loc = + function + | Ast.LAnt x0 -> Ast.PaAnt (_loc, x0) + | Ast.LCons (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "LCons"))), + mf_a _loc x0), + meta_meta_list mf_a _loc x1) + | Ast.LNil -> + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "LNil"))) + and meta_meta_option mf_a _loc = + function + | Ast.OAnt x0 -> Ast.PaAnt (_loc, x0) + | Ast.OSome x0 -> + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "OSome"))), + mf_a _loc x0) + | Ast.ONone -> + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ONone"))) + and meta_module_binding _loc = + function + | Ast.MbAnt (x0, x1) -> Ast.PaAnt (x0, x1) + | Ast.MbCol (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MbCol"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_module_type _loc x2) + | Ast.MbColEq (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MbColEq"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_module_type _loc x2), + meta_module_expr _loc x3) + | Ast.MbAnd (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MbAnd"))), + meta_acc_Loc_t _loc x0), + meta_module_binding _loc x1), + meta_module_binding _loc x2) + | Ast.MbNil x0 -> + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MbNil"))), + meta_acc_Loc_t _loc x0) + and meta_module_expr _loc = + function + | Ast.MeAnt (x0, x1) -> Ast.PaAnt (x0, x1) + | Ast.MeTyc (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MeTyc"))), + meta_acc_Loc_t _loc x0), + meta_module_expr _loc x1), + meta_module_type _loc x2) + | Ast.MeStr (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MeStr"))), + meta_acc_Loc_t _loc x0), + meta_str_item _loc x1) + | Ast.MeFun (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MeFun"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_module_type _loc x2), + meta_module_expr _loc x3) + | Ast.MeApp (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MeApp"))), + meta_acc_Loc_t _loc x0), + meta_module_expr _loc x1), + meta_module_expr _loc x2) + | Ast.MeId (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MeId"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1) + and meta_module_type _loc = + function + | Ast.MtAnt (x0, x1) -> Ast.PaAnt (x0, x1) + | Ast.MtWit (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MtWit"))), + meta_acc_Loc_t _loc x0), + meta_module_type _loc x1), + meta_with_constr _loc x2) + | Ast.MtSig (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MtSig"))), + meta_acc_Loc_t _loc x0), + meta_sig_item _loc x1) + | Ast.MtQuo (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MtQuo"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.MtFun (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MtFun"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_module_type _loc x2), + meta_module_type _loc x3) + | Ast.MtId (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MtId"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1) + and meta_patt _loc = + function + | Ast.PaVrn (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaVrn"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.PaTyp (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaTyp"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1) + | Ast.PaTyc (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaTyc"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_ctyp _loc x2) + | Ast.PaTup (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaTup"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1) + | Ast.PaStr (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaStr"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.PaEq (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaEq"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_patt _loc x2) + | Ast.PaRec (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaRec"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1) + | Ast.PaRng (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaRng"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_patt _loc x2) + | Ast.PaOrp (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaOrp"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_patt _loc x2) + | Ast.PaOlbi (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaOlbi"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_patt _loc x2), + meta_expr _loc x3) + | Ast.PaOlb (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaOlb"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_patt _loc x2) + | Ast.PaLab (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaLab"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_patt _loc x2) + | Ast.PaFlo (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaFlo"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.PaNativeInt (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaNativeInt"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.PaInt64 (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaInt64"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.PaInt32 (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaInt32"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.PaInt (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaInt"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.PaChr (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaChr"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1) + | Ast.PaSem (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaSem"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_patt _loc x2) + | Ast.PaCom (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaCom"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_patt _loc x2) + | Ast.PaArr (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaArr"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1) + | Ast.PaApp (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaApp"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_patt _loc x2) + | Ast.PaAny x0 -> + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaAny"))), + meta_acc_Loc_t _loc x0) + | Ast.PaAnt (x0, x1) -> Ast.PaAnt (x0, x1) + | Ast.PaAli (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaAli"))), + meta_acc_Loc_t _loc x0), + meta_patt _loc x1), + meta_patt _loc x2) + | Ast.PaId (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaId"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1) + | Ast.PaNil x0 -> + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaNil"))), + meta_acc_Loc_t _loc x0) + and meta_sig_item _loc = + function + | Ast.SgAnt (x0, x1) -> Ast.PaAnt (x0, x1) + | Ast.SgVal (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgVal"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_ctyp _loc x2) + | Ast.SgTyp (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgTyp"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1) + | Ast.SgOpn (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgOpn"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1) + | Ast.SgMty (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgMty"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_module_type _loc x2) + | Ast.SgRecMod (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgRecMod"))), + meta_acc_Loc_t _loc x0), + meta_module_binding _loc x1) + | Ast.SgMod (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgMod"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_module_type _loc x2) + | Ast.SgInc (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgInc"))), + meta_acc_Loc_t _loc x0), + meta_module_type _loc x1) + | Ast.SgExt (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgExt"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_ctyp _loc x2), + meta_meta_list meta_string _loc x3) + | Ast.SgExc (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgExc"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1) + | Ast.SgDir (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgDir"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_expr _loc x2) + | Ast.SgSem (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgSem"))), + meta_acc_Loc_t _loc x0), + meta_sig_item _loc x1), + meta_sig_item _loc x2) + | Ast.SgClt (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgClt"))), + meta_acc_Loc_t _loc x0), + meta_class_type _loc x1) + | Ast.SgCls (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgCls"))), + meta_acc_Loc_t _loc x0), + meta_class_type _loc x1) + | Ast.SgNil x0 -> + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgNil"))), + meta_acc_Loc_t _loc x0) + and meta_str_item _loc = + function + | Ast.StAnt (x0, x1) -> Ast.PaAnt (x0, x1) + | Ast.StVal (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StVal"))), + meta_acc_Loc_t _loc x0), + meta_meta_bool _loc x1), + meta_binding _loc x2) + | Ast.StTyp (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StTyp"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1) + | Ast.StOpn (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StOpn"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1) + | Ast.StMty (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StMty"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_module_type _loc x2) + | Ast.StRecMod (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StRecMod"))), + meta_acc_Loc_t _loc x0), + meta_module_binding _loc x1) + | Ast.StMod (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StMod"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_module_expr _loc x2) + | Ast.StInc (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StInc"))), + meta_acc_Loc_t _loc x0), + meta_module_expr _loc x1) + | Ast.StExt (x0, x1, x2, x3) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StExt"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_ctyp _loc x2), + meta_meta_list meta_string _loc x3) + | Ast.StExp (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StExp"))), + meta_acc_Loc_t _loc x0), + meta_expr _loc x1) + | Ast.StExc (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StExc"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_meta_option meta_ident _loc x2) + | Ast.StDir (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StDir"))), + meta_acc_Loc_t _loc x0), + meta_string _loc x1), + meta_expr _loc x2) + | Ast.StSem (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StSem"))), + meta_acc_Loc_t _loc x0), + meta_str_item _loc x1), + meta_str_item _loc x2) + | Ast.StClt (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StClt"))), + meta_acc_Loc_t _loc x0), + meta_class_type _loc x1) + | Ast.StCls (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StCls"))), + meta_acc_Loc_t _loc x0), + meta_class_expr _loc x1) + | Ast.StNil x0 -> + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StNil"))), + meta_acc_Loc_t _loc x0) + and meta_with_constr _loc = + function + | Ast.WcAnt (x0, x1) -> Ast.PaAnt (x0, x1) + | Ast.WcAnd (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "WcAnd"))), + meta_acc_Loc_t _loc x0), + meta_with_constr _loc x1), + meta_with_constr _loc x2) + | Ast.WcMod (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "WcMod"))), + meta_acc_Loc_t _loc x0), + meta_ident _loc x1), + meta_ident _loc x2) + | Ast.WcTyp (x0, x1, x2) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "WcTyp"))), + meta_acc_Loc_t _loc x0), + meta_ctyp _loc x1), + meta_ctyp _loc x2) + | Ast.WcNil x0 -> + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "WcNil"))), + meta_acc_Loc_t _loc x0) + end + end + end + class map = + object (o) + method string = fun x -> (x : string) + method int = fun x -> (x : int) + method float = fun x -> (x : float) + method bool = fun x -> (x : bool) + method list : 'a 'b. ('a -> 'b) -> 'a list -> 'b list = List. + map + method option : 'a 'b. ('a -> 'b) -> 'a option -> 'b option = + fun f -> function | None -> None | Some x -> Some (f x) + method array : 'a 'b. ('a -> 'b) -> 'a array -> 'b array = + Array.map + method ref : 'a 'b. ('a -> 'b) -> 'a ref -> 'b ref = + fun f { contents = x } -> { contents = f x; } + method _Loc_t : Loc.t -> Loc.t = fun x -> x + method with_constr : with_constr -> with_constr = + function + | WcNil _x0 -> WcNil (o#_Loc_t _x0) + | WcTyp (_x0, _x1, _x2) -> + WcTyp (o#_Loc_t _x0, o#ctyp _x1, o#ctyp _x2) + | WcMod (_x0, _x1, _x2) -> + WcMod (o#_Loc_t _x0, o#ident _x1, o#ident _x2) + | WcAnd (_x0, _x1, _x2) -> + WcAnd (o#_Loc_t _x0, o#with_constr _x1, + o#with_constr _x2) + | WcAnt (_x0, _x1) -> WcAnt (o#_Loc_t _x0, o#string _x1) + method str_item : str_item -> str_item = + function + | StNil _x0 -> StNil (o#_Loc_t _x0) + | StCls (_x0, _x1) -> + StCls (o#_Loc_t _x0, o#class_expr _x1) + | StClt (_x0, _x1) -> + StClt (o#_Loc_t _x0, o#class_type _x1) + | StSem (_x0, _x1, _x2) -> + StSem (o#_Loc_t _x0, o#str_item _x1, o#str_item _x2) + | StDir (_x0, _x1, _x2) -> + StDir (o#_Loc_t _x0, o#string _x1, o#expr _x2) + | StExc (_x0, _x1, _x2) -> + StExc (o#_Loc_t _x0, o#ctyp _x1, + o#meta_option o#ident _x2) + | StExp (_x0, _x1) -> StExp (o#_Loc_t _x0, o#expr _x1) + | StExt (_x0, _x1, _x2, _x3) -> + StExt (o#_Loc_t _x0, o#string _x1, o#ctyp _x2, + o#meta_list o#string _x3) + | StInc (_x0, _x1) -> + StInc (o#_Loc_t _x0, o#module_expr _x1) + | StMod (_x0, _x1, _x2) -> + StMod (o#_Loc_t _x0, o#string _x1, o#module_expr _x2) + | StRecMod (_x0, _x1) -> + StRecMod (o#_Loc_t _x0, o#module_binding _x1) + | StMty (_x0, _x1, _x2) -> + StMty (o#_Loc_t _x0, o#string _x1, o#module_type _x2) + | StOpn (_x0, _x1) -> StOpn (o#_Loc_t _x0, o#ident _x1) + | StTyp (_x0, _x1) -> StTyp (o#_Loc_t _x0, o#ctyp _x1) + | StVal (_x0, _x1, _x2) -> + StVal (o#_Loc_t _x0, o#meta_bool _x1, o#binding _x2) + | StAnt (_x0, _x1) -> StAnt (o#_Loc_t _x0, o#string _x1) + method sig_item : sig_item -> sig_item = + function + | SgNil _x0 -> SgNil (o#_Loc_t _x0) + | SgCls (_x0, _x1) -> + SgCls (o#_Loc_t _x0, o#class_type _x1) + | SgClt (_x0, _x1) -> + SgClt (o#_Loc_t _x0, o#class_type _x1) + | SgSem (_x0, _x1, _x2) -> + SgSem (o#_Loc_t _x0, o#sig_item _x1, o#sig_item _x2) + | SgDir (_x0, _x1, _x2) -> + SgDir (o#_Loc_t _x0, o#string _x1, o#expr _x2) + | SgExc (_x0, _x1) -> SgExc (o#_Loc_t _x0, o#ctyp _x1) + | SgExt (_x0, _x1, _x2, _x3) -> + SgExt (o#_Loc_t _x0, o#string _x1, o#ctyp _x2, + o#meta_list o#string _x3) + | SgInc (_x0, _x1) -> + SgInc (o#_Loc_t _x0, o#module_type _x1) + | SgMod (_x0, _x1, _x2) -> + SgMod (o#_Loc_t _x0, o#string _x1, o#module_type _x2) + | SgRecMod (_x0, _x1) -> + SgRecMod (o#_Loc_t _x0, o#module_binding _x1) + | SgMty (_x0, _x1, _x2) -> + SgMty (o#_Loc_t _x0, o#string _x1, o#module_type _x2) + | SgOpn (_x0, _x1) -> SgOpn (o#_Loc_t _x0, o#ident _x1) + | SgTyp (_x0, _x1) -> SgTyp (o#_Loc_t _x0, o#ctyp _x1) + | SgVal (_x0, _x1, _x2) -> + SgVal (o#_Loc_t _x0, o#string _x1, o#ctyp _x2) + | SgAnt (_x0, _x1) -> SgAnt (o#_Loc_t _x0, o#string _x1) + method patt : patt -> patt = + function + | PaNil _x0 -> PaNil (o#_Loc_t _x0) + | PaId (_x0, _x1) -> PaId (o#_Loc_t _x0, o#ident _x1) + | PaAli (_x0, _x1, _x2) -> + PaAli (o#_Loc_t _x0, o#patt _x1, o#patt _x2) + | PaAnt (_x0, _x1) -> PaAnt (o#_Loc_t _x0, o#string _x1) + | PaAny _x0 -> PaAny (o#_Loc_t _x0) + | PaApp (_x0, _x1, _x2) -> + PaApp (o#_Loc_t _x0, o#patt _x1, o#patt _x2) + | PaArr (_x0, _x1) -> PaArr (o#_Loc_t _x0, o#patt _x1) + | PaCom (_x0, _x1, _x2) -> + PaCom (o#_Loc_t _x0, o#patt _x1, o#patt _x2) + | PaSem (_x0, _x1, _x2) -> + PaSem (o#_Loc_t _x0, o#patt _x1, o#patt _x2) + | PaChr (_x0, _x1) -> PaChr (o#_Loc_t _x0, o#string _x1) + | PaInt (_x0, _x1) -> PaInt (o#_Loc_t _x0, o#string _x1) + | PaInt32 (_x0, _x1) -> + PaInt32 (o#_Loc_t _x0, o#string _x1) + | PaInt64 (_x0, _x1) -> + PaInt64 (o#_Loc_t _x0, o#string _x1) + | PaNativeInt (_x0, _x1) -> + PaNativeInt (o#_Loc_t _x0, o#string _x1) + | PaFlo (_x0, _x1) -> PaFlo (o#_Loc_t _x0, o#string _x1) + | PaLab (_x0, _x1, _x2) -> + PaLab (o#_Loc_t _x0, o#string _x1, o#patt _x2) + | PaOlb (_x0, _x1, _x2) -> + PaOlb (o#_Loc_t _x0, o#string _x1, o#patt _x2) + | PaOlbi (_x0, _x1, _x2, _x3) -> + PaOlbi (o#_Loc_t _x0, o#string _x1, o#patt _x2, + o#expr _x3) + | PaOrp (_x0, _x1, _x2) -> + PaOrp (o#_Loc_t _x0, o#patt _x1, o#patt _x2) + | PaRng (_x0, _x1, _x2) -> + PaRng (o#_Loc_t _x0, o#patt _x1, o#patt _x2) + | PaRec (_x0, _x1) -> PaRec (o#_Loc_t _x0, o#patt _x1) + | PaEq (_x0, _x1, _x2) -> + PaEq (o#_Loc_t _x0, o#patt _x1, o#patt _x2) + | PaStr (_x0, _x1) -> PaStr (o#_Loc_t _x0, o#string _x1) + | PaTup (_x0, _x1) -> PaTup (o#_Loc_t _x0, o#patt _x1) + | PaTyc (_x0, _x1, _x2) -> + PaTyc (o#_Loc_t _x0, o#patt _x1, o#ctyp _x2) + | PaTyp (_x0, _x1) -> PaTyp (o#_Loc_t _x0, o#ident _x1) + | PaVrn (_x0, _x1) -> PaVrn (o#_Loc_t _x0, o#string _x1) + method module_type : module_type -> module_type = + function + | MtId (_x0, _x1) -> MtId (o#_Loc_t _x0, o#ident _x1) + | MtFun (_x0, _x1, _x2, _x3) -> + MtFun (o#_Loc_t _x0, o#string _x1, o#module_type _x2, + o#module_type _x3) + | MtQuo (_x0, _x1) -> MtQuo (o#_Loc_t _x0, o#string _x1) + | MtSig (_x0, _x1) -> MtSig (o#_Loc_t _x0, o#sig_item _x1) + | MtWit (_x0, _x1, _x2) -> + MtWit (o#_Loc_t _x0, o#module_type _x1, + o#with_constr _x2) + | MtAnt (_x0, _x1) -> MtAnt (o#_Loc_t _x0, o#string _x1) + method module_expr : module_expr -> module_expr = + function + | MeId (_x0, _x1) -> MeId (o#_Loc_t _x0, o#ident _x1) + | MeApp (_x0, _x1, _x2) -> + MeApp (o#_Loc_t _x0, o#module_expr _x1, + o#module_expr _x2) + | MeFun (_x0, _x1, _x2, _x3) -> + MeFun (o#_Loc_t _x0, o#string _x1, o#module_type _x2, + o#module_expr _x3) + | MeStr (_x0, _x1) -> MeStr (o#_Loc_t _x0, o#str_item _x1) + | MeTyc (_x0, _x1, _x2) -> + MeTyc (o#_Loc_t _x0, o#module_expr _x1, + o#module_type _x2) + | MeAnt (_x0, _x1) -> MeAnt (o#_Loc_t _x0, o#string _x1) + method module_binding : module_binding -> module_binding = + function + | MbNil _x0 -> MbNil (o#_Loc_t _x0) + | MbAnd (_x0, _x1, _x2) -> + MbAnd (o#_Loc_t _x0, o#module_binding _x1, + o#module_binding _x2) + | MbColEq (_x0, _x1, _x2, _x3) -> + MbColEq (o#_Loc_t _x0, o#string _x1, o#module_type _x2, + o#module_expr _x3) + | MbCol (_x0, _x1, _x2) -> + MbCol (o#_Loc_t _x0, o#string _x1, o#module_type _x2) + | MbAnt (_x0, _x1) -> MbAnt (o#_Loc_t _x0, o#string _x1) + method meta_option : + 'a 'b. ('a -> 'b) -> 'a meta_option -> 'b meta_option = + fun _f_a -> + function + | ONone -> ONone + | OSome _x0 -> OSome (_f_a _x0) + | OAnt _x0 -> OAnt (o#string _x0) + method meta_list : + 'a 'b. ('a -> 'b) -> 'a meta_list -> 'b meta_list = + fun _f_a -> + function + | LNil -> LNil + | LCons (_x0, _x1) -> + LCons (_f_a _x0, o#meta_list _f_a _x1) + | LAnt _x0 -> LAnt (o#string _x0) + method meta_bool : meta_bool -> meta_bool = + function + | BTrue -> BTrue + | BFalse -> BFalse + | BAnt _x0 -> BAnt (o#string _x0) + method match_case : match_case -> match_case = + function + | McNil _x0 -> McNil (o#_Loc_t _x0) + | McOr (_x0, _x1, _x2) -> + McOr (o#_Loc_t _x0, o#match_case _x1, o#match_case _x2) + | McArr (_x0, _x1, _x2, _x3) -> + McArr (o#_Loc_t _x0, o#patt _x1, o#expr _x2, + o#expr _x3) + | McAnt (_x0, _x1) -> McAnt (o#_Loc_t _x0, o#string _x1) + method ident : ident -> ident = + function + | IdAcc (_x0, _x1, _x2) -> + IdAcc (o#_Loc_t _x0, o#ident _x1, o#ident _x2) + | IdApp (_x0, _x1, _x2) -> + IdApp (o#_Loc_t _x0, o#ident _x1, o#ident _x2) + | IdLid (_x0, _x1) -> IdLid (o#_Loc_t _x0, o#string _x1) + | IdUid (_x0, _x1) -> IdUid (o#_Loc_t _x0, o#string _x1) + | IdAnt (_x0, _x1) -> IdAnt (o#_Loc_t _x0, o#string _x1) + method expr : expr -> expr = + function + | ExNil _x0 -> ExNil (o#_Loc_t _x0) + | ExId (_x0, _x1) -> ExId (o#_Loc_t _x0, o#ident _x1) + | ExAcc (_x0, _x1, _x2) -> + ExAcc (o#_Loc_t _x0, o#expr _x1, o#expr _x2) + | ExAnt (_x0, _x1) -> ExAnt (o#_Loc_t _x0, o#string _x1) + | ExApp (_x0, _x1, _x2) -> + ExApp (o#_Loc_t _x0, o#expr _x1, o#expr _x2) + | ExAre (_x0, _x1, _x2) -> + ExAre (o#_Loc_t _x0, o#expr _x1, o#expr _x2) + | ExArr (_x0, _x1) -> ExArr (o#_Loc_t _x0, o#expr _x1) + | ExSem (_x0, _x1, _x2) -> + ExSem (o#_Loc_t _x0, o#expr _x1, o#expr _x2) + | ExAsf _x0 -> ExAsf (o#_Loc_t _x0) + | ExAsr (_x0, _x1) -> ExAsr (o#_Loc_t _x0, o#expr _x1) + | ExAss (_x0, _x1, _x2) -> + ExAss (o#_Loc_t _x0, o#expr _x1, o#expr _x2) + | ExChr (_x0, _x1) -> ExChr (o#_Loc_t _x0, o#string _x1) + | ExCoe (_x0, _x1, _x2, _x3) -> + ExCoe (o#_Loc_t _x0, o#expr _x1, o#ctyp _x2, + o#ctyp _x3) + | ExFlo (_x0, _x1) -> ExFlo (o#_Loc_t _x0, o#string _x1) + | ExFor (_x0, _x1, _x2, _x3, _x4, _x5) -> + ExFor (o#_Loc_t _x0, o#string _x1, o#expr _x2, + o#expr _x3, o#meta_bool _x4, o#expr _x5) + | ExFun (_x0, _x1) -> + ExFun (o#_Loc_t _x0, o#match_case _x1) + | ExIfe (_x0, _x1, _x2, _x3) -> + ExIfe (o#_Loc_t _x0, o#expr _x1, o#expr _x2, + o#expr _x3) + | ExInt (_x0, _x1) -> ExInt (o#_Loc_t _x0, o#string _x1) + | ExInt32 (_x0, _x1) -> + ExInt32 (o#_Loc_t _x0, o#string _x1) + | ExInt64 (_x0, _x1) -> + ExInt64 (o#_Loc_t _x0, o#string _x1) + | ExNativeInt (_x0, _x1) -> + ExNativeInt (o#_Loc_t _x0, o#string _x1) + | ExLab (_x0, _x1, _x2) -> + ExLab (o#_Loc_t _x0, o#string _x1, o#expr _x2) + | ExLaz (_x0, _x1) -> ExLaz (o#_Loc_t _x0, o#expr _x1) + | ExLet (_x0, _x1, _x2, _x3) -> + ExLet (o#_Loc_t _x0, o#meta_bool _x1, o#binding _x2, + o#expr _x3) + | ExLmd (_x0, _x1, _x2, _x3) -> + ExLmd (o#_Loc_t _x0, o#string _x1, o#module_expr _x2, + o#expr _x3) + | ExMat (_x0, _x1, _x2) -> + ExMat (o#_Loc_t _x0, o#expr _x1, o#match_case _x2) + | ExNew (_x0, _x1) -> ExNew (o#_Loc_t _x0, o#ident _x1) + | ExObj (_x0, _x1, _x2) -> + ExObj (o#_Loc_t _x0, o#patt _x1, o#class_str_item _x2) + | ExOlb (_x0, _x1, _x2) -> + ExOlb (o#_Loc_t _x0, o#string _x1, o#expr _x2) + | ExOvr (_x0, _x1) -> ExOvr (o#_Loc_t _x0, o#binding _x1) + | ExRec (_x0, _x1, _x2) -> + ExRec (o#_Loc_t _x0, o#binding _x1, o#expr _x2) + | ExSeq (_x0, _x1) -> ExSeq (o#_Loc_t _x0, o#expr _x1) + | ExSnd (_x0, _x1, _x2) -> + ExSnd (o#_Loc_t _x0, o#expr _x1, o#string _x2) + | ExSte (_x0, _x1, _x2) -> + ExSte (o#_Loc_t _x0, o#expr _x1, o#expr _x2) + | ExStr (_x0, _x1) -> ExStr (o#_Loc_t _x0, o#string _x1) + | ExTry (_x0, _x1, _x2) -> + ExTry (o#_Loc_t _x0, o#expr _x1, o#match_case _x2) + | ExTup (_x0, _x1) -> ExTup (o#_Loc_t _x0, o#expr _x1) + | ExCom (_x0, _x1, _x2) -> + ExCom (o#_Loc_t _x0, o#expr _x1, o#expr _x2) + | ExTyc (_x0, _x1, _x2) -> + ExTyc (o#_Loc_t _x0, o#expr _x1, o#ctyp _x2) + | ExVrn (_x0, _x1) -> ExVrn (o#_Loc_t _x0, o#string _x1) + | ExWhi (_x0, _x1, _x2) -> + ExWhi (o#_Loc_t _x0, o#expr _x1, o#expr _x2) + method ctyp : ctyp -> ctyp = + function + | TyNil _x0 -> TyNil (o#_Loc_t _x0) + | TyAli (_x0, _x1, _x2) -> + TyAli (o#_Loc_t _x0, o#ctyp _x1, o#ctyp _x2) + | TyAny _x0 -> TyAny (o#_Loc_t _x0) + | TyApp (_x0, _x1, _x2) -> + TyApp (o#_Loc_t _x0, o#ctyp _x1, o#ctyp _x2) + | TyArr (_x0, _x1, _x2) -> + TyArr (o#_Loc_t _x0, o#ctyp _x1, o#ctyp _x2) + | TyCls (_x0, _x1) -> TyCls (o#_Loc_t _x0, o#ident _x1) + | TyLab (_x0, _x1, _x2) -> + TyLab (o#_Loc_t _x0, o#string _x1, o#ctyp _x2) + | TyId (_x0, _x1) -> TyId (o#_Loc_t _x0, o#ident _x1) + | TyMan (_x0, _x1, _x2) -> + TyMan (o#_Loc_t _x0, o#ctyp _x1, o#ctyp _x2) + | TyDcl (_x0, _x1, _x2, _x3, _x4) -> + TyDcl (o#_Loc_t _x0, o#string _x1, o#list o#ctyp _x2, + o#ctyp _x3, + o#list + (fun (_x0, _x1) -> ((o#ctyp _x0), (o#ctyp _x1))) + _x4) + | TyObj (_x0, _x1, _x2) -> + TyObj (o#_Loc_t _x0, o#ctyp _x1, o#meta_bool _x2) + | TyOlb (_x0, _x1, _x2) -> + TyOlb (o#_Loc_t _x0, o#string _x1, o#ctyp _x2) + | TyPol (_x0, _x1, _x2) -> + TyPol (o#_Loc_t _x0, o#ctyp _x1, o#ctyp _x2) + | TyQuo (_x0, _x1) -> TyQuo (o#_Loc_t _x0, o#string _x1) + | TyQuP (_x0, _x1) -> TyQuP (o#_Loc_t _x0, o#string _x1) + | TyQuM (_x0, _x1) -> TyQuM (o#_Loc_t _x0, o#string _x1) + | TyVrn (_x0, _x1) -> TyVrn (o#_Loc_t _x0, o#string _x1) + | TyRec (_x0, _x1) -> TyRec (o#_Loc_t _x0, o#ctyp _x1) + | TyCol (_x0, _x1, _x2) -> + TyCol (o#_Loc_t _x0, o#ctyp _x1, o#ctyp _x2) + | TySem (_x0, _x1, _x2) -> + TySem (o#_Loc_t _x0, o#ctyp _x1, o#ctyp _x2) + | TyCom (_x0, _x1, _x2) -> + TyCom (o#_Loc_t _x0, o#ctyp _x1, o#ctyp _x2) + | TySum (_x0, _x1) -> TySum (o#_Loc_t _x0, o#ctyp _x1) + | TyOf (_x0, _x1, _x2) -> + TyOf (o#_Loc_t _x0, o#ctyp _x1, o#ctyp _x2) + | TyAnd (_x0, _x1, _x2) -> + TyAnd (o#_Loc_t _x0, o#ctyp _x1, o#ctyp _x2) + | TyOr (_x0, _x1, _x2) -> + TyOr (o#_Loc_t _x0, o#ctyp _x1, o#ctyp _x2) + | TyPrv (_x0, _x1) -> TyPrv (o#_Loc_t _x0, o#ctyp _x1) + | TyMut (_x0, _x1) -> TyMut (o#_Loc_t _x0, o#ctyp _x1) + | TyTup (_x0, _x1) -> TyTup (o#_Loc_t _x0, o#ctyp _x1) + | TySta (_x0, _x1, _x2) -> + TySta (o#_Loc_t _x0, o#ctyp _x1, o#ctyp _x2) + | TyVrnEq (_x0, _x1) -> TyVrnEq (o#_Loc_t _x0, o#ctyp _x1) + | TyVrnSup (_x0, _x1) -> + TyVrnSup (o#_Loc_t _x0, o#ctyp _x1) + | TyVrnInf (_x0, _x1) -> + TyVrnInf (o#_Loc_t _x0, o#ctyp _x1) + | TyVrnInfSup (_x0, _x1, _x2) -> + TyVrnInfSup (o#_Loc_t _x0, o#ctyp _x1, o#ctyp _x2) + | TyAmp (_x0, _x1, _x2) -> + TyAmp (o#_Loc_t _x0, o#ctyp _x1, o#ctyp _x2) + | TyOfAmp (_x0, _x1, _x2) -> + TyOfAmp (o#_Loc_t _x0, o#ctyp _x1, o#ctyp _x2) + | TyAnt (_x0, _x1) -> TyAnt (o#_Loc_t _x0, o#string _x1) + method class_type : class_type -> class_type = + function + | CtNil _x0 -> CtNil (o#_Loc_t _x0) + | CtCon (_x0, _x1, _x2, _x3) -> + CtCon (o#_Loc_t _x0, o#meta_bool _x1, o#ident _x2, + o#ctyp _x3) + | CtFun (_x0, _x1, _x2) -> + CtFun (o#_Loc_t _x0, o#ctyp _x1, o#class_type _x2) + | CtSig (_x0, _x1, _x2) -> + CtSig (o#_Loc_t _x0, o#ctyp _x1, o#class_sig_item _x2) + | CtAnd (_x0, _x1, _x2) -> + CtAnd (o#_Loc_t _x0, o#class_type _x1, + o#class_type _x2) + | CtCol (_x0, _x1, _x2) -> + CtCol (o#_Loc_t _x0, o#class_type _x1, + o#class_type _x2) + | CtEq (_x0, _x1, _x2) -> + CtEq (o#_Loc_t _x0, o#class_type _x1, o#class_type _x2) + | CtAnt (_x0, _x1) -> CtAnt (o#_Loc_t _x0, o#string _x1) + method class_str_item : class_str_item -> class_str_item = + function + | CrNil _x0 -> CrNil (o#_Loc_t _x0) + | CrSem (_x0, _x1, _x2) -> + CrSem (o#_Loc_t _x0, o#class_str_item _x1, + o#class_str_item _x2) + | CrCtr (_x0, _x1, _x2) -> + CrCtr (o#_Loc_t _x0, o#ctyp _x1, o#ctyp _x2) + | CrInh (_x0, _x1, _x2) -> + CrInh (o#_Loc_t _x0, o#class_expr _x1, o#string _x2) + | CrIni (_x0, _x1) -> CrIni (o#_Loc_t _x0, o#expr _x1) + | CrMth (_x0, _x1, _x2, _x3, _x4) -> + CrMth (o#_Loc_t _x0, o#string _x1, o#meta_bool _x2, + o#expr _x3, o#ctyp _x4) + | CrVal (_x0, _x1, _x2, _x3) -> + CrVal (o#_Loc_t _x0, o#string _x1, o#meta_bool _x2, + o#expr _x3) + | CrVir (_x0, _x1, _x2, _x3) -> + CrVir (o#_Loc_t _x0, o#string _x1, o#meta_bool _x2, + o#ctyp _x3) + | CrVvr (_x0, _x1, _x2, _x3) -> + CrVvr (o#_Loc_t _x0, o#string _x1, o#meta_bool _x2, + o#ctyp _x3) + | CrAnt (_x0, _x1) -> CrAnt (o#_Loc_t _x0, o#string _x1) + method class_sig_item : class_sig_item -> class_sig_item = + function + | CgNil _x0 -> CgNil (o#_Loc_t _x0) + | CgCtr (_x0, _x1, _x2) -> + CgCtr (o#_Loc_t _x0, o#ctyp _x1, o#ctyp _x2) + | CgSem (_x0, _x1, _x2) -> + CgSem (o#_Loc_t _x0, o#class_sig_item _x1, + o#class_sig_item _x2) + | CgInh (_x0, _x1) -> + CgInh (o#_Loc_t _x0, o#class_type _x1) + | CgMth (_x0, _x1, _x2, _x3) -> + CgMth (o#_Loc_t _x0, o#string _x1, o#meta_bool _x2, + o#ctyp _x3) + | CgVal (_x0, _x1, _x2, _x3, _x4) -> + CgVal (o#_Loc_t _x0, o#string _x1, o#meta_bool _x2, + o#meta_bool _x3, o#ctyp _x4) + | CgVir (_x0, _x1, _x2, _x3) -> + CgVir (o#_Loc_t _x0, o#string _x1, o#meta_bool _x2, + o#ctyp _x3) + | CgAnt (_x0, _x1) -> CgAnt (o#_Loc_t _x0, o#string _x1) + method class_expr : class_expr -> class_expr = + function + | CeNil _x0 -> CeNil (o#_Loc_t _x0) + | CeApp (_x0, _x1, _x2) -> + CeApp (o#_Loc_t _x0, o#class_expr _x1, o#expr _x2) + | CeCon (_x0, _x1, _x2, _x3) -> + CeCon (o#_Loc_t _x0, o#meta_bool _x1, o#ident _x2, + o#ctyp _x3) + | CeFun (_x0, _x1, _x2) -> + CeFun (o#_Loc_t _x0, o#patt _x1, o#class_expr _x2) + | CeLet (_x0, _x1, _x2, _x3) -> + CeLet (o#_Loc_t _x0, o#meta_bool _x1, o#binding _x2, + o#class_expr _x3) + | CeStr (_x0, _x1, _x2) -> + CeStr (o#_Loc_t _x0, o#patt _x1, o#class_str_item _x2) + | CeTyc (_x0, _x1, _x2) -> + CeTyc (o#_Loc_t _x0, o#class_expr _x1, + o#class_type _x2) + | CeAnd (_x0, _x1, _x2) -> + CeAnd (o#_Loc_t _x0, o#class_expr _x1, + o#class_expr _x2) + | CeEq (_x0, _x1, _x2) -> + CeEq (o#_Loc_t _x0, o#class_expr _x1, o#class_expr _x2) + | CeAnt (_x0, _x1) -> CeAnt (o#_Loc_t _x0, o#string _x1) + method binding : binding -> binding = + function + | BiNil _x0 -> BiNil (o#_Loc_t _x0) + | BiAnd (_x0, _x1, _x2) -> + BiAnd (o#_Loc_t _x0, o#binding _x1, o#binding _x2) + | BiSem (_x0, _x1, _x2) -> + BiSem (o#_Loc_t _x0, o#binding _x1, o#binding _x2) + | BiEq (_x0, _x1, _x2) -> + BiEq (o#_Loc_t _x0, o#patt _x1, o#expr _x2) + | BiAnt (_x0, _x1) -> BiAnt (o#_Loc_t _x0, o#string _x1) + end + class fold = + object ((o : 'self_type)) + method string = fun (_ : string) -> (o : 'self_type) + method int = fun (_ : int) -> (o : 'self_type) + method float = fun (_ : float) -> (o : 'self_type) + method bool = fun (_ : bool) -> (o : 'self_type) + method list : + 'a. + ('self_type -> 'a -> 'self_type) -> 'a list -> 'self_type = + fun f -> List.fold_left f o + method option : + 'a. + ('self_type -> 'a -> 'self_type) -> + 'a option -> 'self_type = + fun f -> function | None -> o | Some x -> f o x + method array : + 'a. + ('self_type -> 'a -> 'self_type) -> + 'a array -> 'self_type = + fun f -> Array.fold_left f o + method ref : + 'a. + ('self_type -> 'a -> 'self_type) -> 'a ref -> 'self_type = + fun f { contents = x } -> f o x + method _Loc_t : Loc.t -> 'self_type = fun _ -> o + method with_constr : with_constr -> 'self_type = + function + | WcNil _x0 -> o#_Loc_t _x0 + | WcTyp (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | WcMod (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ident _x1)#ident _x2 + | WcAnd (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#with_constr _x1)#with_constr _x2 + | WcAnt (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + method str_item : str_item -> 'self_type = + function + | StNil _x0 -> o#_Loc_t _x0 + | StCls (_x0, _x1) -> (o#_Loc_t _x0)#class_expr _x1 + | StClt (_x0, _x1) -> (o#_Loc_t _x0)#class_type _x1 + | StSem (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#str_item _x1)#str_item _x2 + | StDir (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#string _x1)#expr _x2 + | StExc (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ctyp _x1)#meta_option + (fun o -> o#ident) _x2 + | StExp (_x0, _x1) -> (o#_Loc_t _x0)#expr _x1 + | StExt (_x0, _x1, _x2, _x3) -> + (((o#_Loc_t _x0)#string _x1)#ctyp _x2)#meta_list + (fun o -> o#string) _x3 + | StInc (_x0, _x1) -> (o#_Loc_t _x0)#module_expr _x1 + | StMod (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#string _x1)#module_expr _x2 + | StRecMod (_x0, _x1) -> (o#_Loc_t _x0)#module_binding _x1 + | StMty (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#string _x1)#module_type _x2 + | StOpn (_x0, _x1) -> (o#_Loc_t _x0)#ident _x1 + | StTyp (_x0, _x1) -> (o#_Loc_t _x0)#ctyp _x1 + | StVal (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#meta_bool _x1)#binding _x2 + | StAnt (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + method sig_item : sig_item -> 'self_type = + function + | SgNil _x0 -> o#_Loc_t _x0 + | SgCls (_x0, _x1) -> (o#_Loc_t _x0)#class_type _x1 + | SgClt (_x0, _x1) -> (o#_Loc_t _x0)#class_type _x1 + | SgSem (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#sig_item _x1)#sig_item _x2 + | SgDir (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#string _x1)#expr _x2 + | SgExc (_x0, _x1) -> (o#_Loc_t _x0)#ctyp _x1 + | SgExt (_x0, _x1, _x2, _x3) -> + (((o#_Loc_t _x0)#string _x1)#ctyp _x2)#meta_list + (fun o -> o#string) _x3 + | SgInc (_x0, _x1) -> (o#_Loc_t _x0)#module_type _x1 + | SgMod (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#string _x1)#module_type _x2 + | SgRecMod (_x0, _x1) -> (o#_Loc_t _x0)#module_binding _x1 + | SgMty (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#string _x1)#module_type _x2 + | SgOpn (_x0, _x1) -> (o#_Loc_t _x0)#ident _x1 + | SgTyp (_x0, _x1) -> (o#_Loc_t _x0)#ctyp _x1 + | SgVal (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#string _x1)#ctyp _x2 + | SgAnt (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + method patt : patt -> 'self_type = + function + | PaNil _x0 -> o#_Loc_t _x0 + | PaId (_x0, _x1) -> (o#_Loc_t _x0)#ident _x1 + | PaAli (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#patt _x1)#patt _x2 + | PaAnt (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | PaAny _x0 -> o#_Loc_t _x0 + | PaApp (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#patt _x1)#patt _x2 + | PaArr (_x0, _x1) -> (o#_Loc_t _x0)#patt _x1 + | PaCom (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#patt _x1)#patt _x2 + | PaSem (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#patt _x1)#patt _x2 + | PaChr (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | PaInt (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | PaInt32 (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | PaInt64 (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | PaNativeInt (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | PaFlo (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | PaLab (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#string _x1)#patt _x2 + | PaOlb (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#string _x1)#patt _x2 + | PaOlbi (_x0, _x1, _x2, _x3) -> + (((o#_Loc_t _x0)#string _x1)#patt _x2)#expr _x3 + | PaOrp (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#patt _x1)#patt _x2 + | PaRng (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#patt _x1)#patt _x2 + | PaRec (_x0, _x1) -> (o#_Loc_t _x0)#patt _x1 + | PaEq (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#patt _x1)#patt _x2 + | PaStr (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | PaTup (_x0, _x1) -> (o#_Loc_t _x0)#patt _x1 + | PaTyc (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#patt _x1)#ctyp _x2 + | PaTyp (_x0, _x1) -> (o#_Loc_t _x0)#ident _x1 + | PaVrn (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + method module_type : module_type -> 'self_type = + function + | MtId (_x0, _x1) -> (o#_Loc_t _x0)#ident _x1 + | MtFun (_x0, _x1, _x2, _x3) -> + (((o#_Loc_t _x0)#string _x1)#module_type _x2)# + module_type _x3 + | MtQuo (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | MtSig (_x0, _x1) -> (o#_Loc_t _x0)#sig_item _x1 + | MtWit (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#module_type _x1)#with_constr _x2 + | MtAnt (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + method module_expr : module_expr -> 'self_type = + function + | MeId (_x0, _x1) -> (o#_Loc_t _x0)#ident _x1 + | MeApp (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#module_expr _x1)#module_expr _x2 + | MeFun (_x0, _x1, _x2, _x3) -> + (((o#_Loc_t _x0)#string _x1)#module_type _x2)# + module_expr _x3 + | MeStr (_x0, _x1) -> (o#_Loc_t _x0)#str_item _x1 + | MeTyc (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#module_expr _x1)#module_type _x2 + | MeAnt (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + method module_binding : module_binding -> 'self_type = + function + | MbNil _x0 -> o#_Loc_t _x0 + | MbAnd (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#module_binding _x1)#module_binding _x2 + | MbColEq (_x0, _x1, _x2, _x3) -> + (((o#_Loc_t _x0)#string _x1)#module_type _x2)# + module_expr _x3 + | MbCol (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#string _x1)#module_type _x2 + | MbAnt (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + method meta_option : + 'a. + ('self_type -> 'a -> 'self_type) -> + 'a meta_option -> 'self_type = + fun _f_a -> + function + | ONone -> o + | OSome _x0 -> _f_a o _x0 + | OAnt _x0 -> o#string _x0 + method meta_list : + 'a. + ('self_type -> 'a -> 'self_type) -> + 'a meta_list -> 'self_type = + fun _f_a -> + function + | LNil -> o + | LCons (_x0, _x1) -> + (_f_a o _x0)#meta_list (fun o -> _f_a o) _x1 + | LAnt _x0 -> o#string _x0 + method meta_bool : meta_bool -> 'self_type = + function + | BTrue -> o + | BFalse -> o + | BAnt _x0 -> o#string _x0 + method match_case : match_case -> 'self_type = + function + | McNil _x0 -> o#_Loc_t _x0 + | McOr (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#match_case _x1)#match_case _x2 + | McArr (_x0, _x1, _x2, _x3) -> + (((o#_Loc_t _x0)#patt _x1)#expr _x2)#expr _x3 + | McAnt (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + method ident : ident -> 'self_type = + function + | IdAcc (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ident _x1)#ident _x2 + | IdApp (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ident _x1)#ident _x2 + | IdLid (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | IdUid (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | IdAnt (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + method expr : expr -> 'self_type = + function + | ExNil _x0 -> o#_Loc_t _x0 + | ExId (_x0, _x1) -> (o#_Loc_t _x0)#ident _x1 + | ExAcc (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#expr _x1)#expr _x2 + | ExAnt (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | ExApp (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#expr _x1)#expr _x2 + | ExAre (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#expr _x1)#expr _x2 + | ExArr (_x0, _x1) -> (o#_Loc_t _x0)#expr _x1 + | ExSem (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#expr _x1)#expr _x2 + | ExAsf _x0 -> o#_Loc_t _x0 + | ExAsr (_x0, _x1) -> (o#_Loc_t _x0)#expr _x1 + | ExAss (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#expr _x1)#expr _x2 + | ExChr (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | ExCoe (_x0, _x1, _x2, _x3) -> + (((o#_Loc_t _x0)#expr _x1)#ctyp _x2)#ctyp _x3 + | ExFlo (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | ExFor (_x0, _x1, _x2, _x3, _x4, _x5) -> + (((((o#_Loc_t _x0)#string _x1)#expr _x2)#expr _x3)# + meta_bool _x4)# + expr _x5 + | ExFun (_x0, _x1) -> (o#_Loc_t _x0)#match_case _x1 + | ExIfe (_x0, _x1, _x2, _x3) -> + (((o#_Loc_t _x0)#expr _x1)#expr _x2)#expr _x3 + | ExInt (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | ExInt32 (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | ExInt64 (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | ExNativeInt (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | ExLab (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#string _x1)#expr _x2 + | ExLaz (_x0, _x1) -> (o#_Loc_t _x0)#expr _x1 + | ExLet (_x0, _x1, _x2, _x3) -> + (((o#_Loc_t _x0)#meta_bool _x1)#binding _x2)#expr _x3 + | ExLmd (_x0, _x1, _x2, _x3) -> + (((o#_Loc_t _x0)#string _x1)#module_expr _x2)#expr _x3 + | ExMat (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#expr _x1)#match_case _x2 + | ExNew (_x0, _x1) -> (o#_Loc_t _x0)#ident _x1 + | ExObj (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#patt _x1)#class_str_item _x2 + | ExOlb (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#string _x1)#expr _x2 + | ExOvr (_x0, _x1) -> (o#_Loc_t _x0)#binding _x1 + | ExRec (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#binding _x1)#expr _x2 + | ExSeq (_x0, _x1) -> (o#_Loc_t _x0)#expr _x1 + | ExSnd (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#expr _x1)#string _x2 + | ExSte (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#expr _x1)#expr _x2 + | ExStr (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | ExTry (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#expr _x1)#match_case _x2 + | ExTup (_x0, _x1) -> (o#_Loc_t _x0)#expr _x1 + | ExCom (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#expr _x1)#expr _x2 + | ExTyc (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#expr _x1)#ctyp _x2 + | ExVrn (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | ExWhi (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#expr _x1)#expr _x2 + method ctyp : ctyp -> 'self_type = + function + | TyNil _x0 -> o#_Loc_t _x0 + | TyAli (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyAny _x0 -> o#_Loc_t _x0 + | TyApp (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyArr (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyCls (_x0, _x1) -> (o#_Loc_t _x0)#ident _x1 + | TyLab (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#string _x1)#ctyp _x2 + | TyId (_x0, _x1) -> (o#_Loc_t _x0)#ident _x1 + | TyMan (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyDcl (_x0, _x1, _x2, _x3, _x4) -> + ((((o#_Loc_t _x0)#string _x1)#list (fun o -> o#ctyp) + _x2)# + ctyp _x3)# + list (fun o (_x0, _x1) -> (o#ctyp _x0)#ctyp _x1) _x4 + | TyObj (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ctyp _x1)#meta_bool _x2 + | TyOlb (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#string _x1)#ctyp _x2 + | TyPol (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyQuo (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | TyQuP (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | TyQuM (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | TyVrn (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + | TyRec (_x0, _x1) -> (o#_Loc_t _x0)#ctyp _x1 + | TyCol (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TySem (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyCom (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TySum (_x0, _x1) -> (o#_Loc_t _x0)#ctyp _x1 + | TyOf (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyAnd (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyOr (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyPrv (_x0, _x1) -> (o#_Loc_t _x0)#ctyp _x1 + | TyMut (_x0, _x1) -> (o#_Loc_t _x0)#ctyp _x1 + | TyTup (_x0, _x1) -> (o#_Loc_t _x0)#ctyp _x1 + | TySta (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyVrnEq (_x0, _x1) -> (o#_Loc_t _x0)#ctyp _x1 + | TyVrnSup (_x0, _x1) -> (o#_Loc_t _x0)#ctyp _x1 + | TyVrnInf (_x0, _x1) -> (o#_Loc_t _x0)#ctyp _x1 + | TyVrnInfSup (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyAmp (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyOfAmp (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyAnt (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + method class_type : class_type -> 'self_type = + function + | CtNil _x0 -> o#_Loc_t _x0 + | CtCon (_x0, _x1, _x2, _x3) -> + (((o#_Loc_t _x0)#meta_bool _x1)#ident _x2)#ctyp _x3 + | CtFun (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ctyp _x1)#class_type _x2 + | CtSig (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ctyp _x1)#class_sig_item _x2 + | CtAnd (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#class_type _x1)#class_type _x2 + | CtCol (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#class_type _x1)#class_type _x2 + | CtEq (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#class_type _x1)#class_type _x2 + | CtAnt (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + method class_str_item : class_str_item -> 'self_type = + function + | CrNil _x0 -> o#_Loc_t _x0 + | CrSem (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#class_str_item _x1)#class_str_item _x2 + | CrCtr (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | CrInh (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#class_expr _x1)#string _x2 + | CrIni (_x0, _x1) -> (o#_Loc_t _x0)#expr _x1 + | CrMth (_x0, _x1, _x2, _x3, _x4) -> + ((((o#_Loc_t _x0)#string _x1)#meta_bool _x2)#expr _x3)# + ctyp _x4 + | CrVal (_x0, _x1, _x2, _x3) -> + (((o#_Loc_t _x0)#string _x1)#meta_bool _x2)#expr _x3 + | CrVir (_x0, _x1, _x2, _x3) -> + (((o#_Loc_t _x0)#string _x1)#meta_bool _x2)#ctyp _x3 + | CrVvr (_x0, _x1, _x2, _x3) -> + (((o#_Loc_t _x0)#string _x1)#meta_bool _x2)#ctyp _x3 + | CrAnt (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + method class_sig_item : class_sig_item -> 'self_type = + function + | CgNil _x0 -> o#_Loc_t _x0 + | CgCtr (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | CgSem (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#class_sig_item _x1)#class_sig_item _x2 + | CgInh (_x0, _x1) -> (o#_Loc_t _x0)#class_type _x1 + | CgMth (_x0, _x1, _x2, _x3) -> + (((o#_Loc_t _x0)#string _x1)#meta_bool _x2)#ctyp _x3 + | CgVal (_x0, _x1, _x2, _x3, _x4) -> + ((((o#_Loc_t _x0)#string _x1)#meta_bool _x2)#meta_bool + _x3)# + ctyp _x4 + | CgVir (_x0, _x1, _x2, _x3) -> + (((o#_Loc_t _x0)#string _x1)#meta_bool _x2)#ctyp _x3 + | CgAnt (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + method class_expr : class_expr -> 'self_type = + function + | CeNil _x0 -> o#_Loc_t _x0 + | CeApp (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#class_expr _x1)#expr _x2 + | CeCon (_x0, _x1, _x2, _x3) -> + (((o#_Loc_t _x0)#meta_bool _x1)#ident _x2)#ctyp _x3 + | CeFun (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#patt _x1)#class_expr _x2 + | CeLet (_x0, _x1, _x2, _x3) -> + (((o#_Loc_t _x0)#meta_bool _x1)#binding _x2)#class_expr + _x3 + | CeStr (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#patt _x1)#class_str_item _x2 + | CeTyc (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#class_expr _x1)#class_type _x2 + | CeAnd (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#class_expr _x1)#class_expr _x2 + | CeEq (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#class_expr _x1)#class_expr _x2 + | CeAnt (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + method binding : binding -> 'self_type = + function + | BiNil _x0 -> o#_Loc_t _x0 + | BiAnd (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#binding _x1)#binding _x2 + | BiSem (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#binding _x1)#binding _x2 + | BiEq (_x0, _x1, _x2) -> + ((o#_Loc_t _x0)#patt _x1)#expr _x2 + | BiAnt (_x0, _x1) -> (o#_Loc_t _x0)#string _x1 + end + class c_expr f = + object inherit map as super + method expr = fun x -> f (super#expr x) + end + class c_patt f = + object inherit map as super + method patt = fun x -> f (super#patt x) + end + class c_ctyp f = + object inherit map as super + method ctyp = fun x -> f (super#ctyp x) + end + class c_str_item f = + object inherit map as super + method str_item = fun x -> f (super#str_item x) + end + class c_sig_item f = + object inherit map as super + method sig_item = fun x -> f (super#sig_item x) + end + class c_loc f = + object inherit map as super + method _Loc_t = fun x -> f (super#_Loc_t x) + end + let map_patt f ast = (new c_patt f)#patt ast + let map_loc f ast = (new c_loc f)#_Loc_t ast + let map_sig_item f ast = (new c_sig_item f)#sig_item ast + let map_str_item f ast = (new c_str_item f)#str_item ast + let map_ctyp f ast = (new c_ctyp f)#ctyp ast + let map_expr f ast = (new c_expr f)#expr ast + let ghost = Loc.ghost + let rec is_module_longident = + function + | Ast.IdAcc (_, _, i) -> is_module_longident i + | Ast.IdApp (_, i1, i2) -> + (is_module_longident i1) && (is_module_longident i2) + | Ast.IdUid (_, _) -> true + | _ -> false + let rec is_irrefut_patt = + function + | Ast.PaId (_, (Ast.IdLid (_, _))) -> true + | Ast.PaId (_, (Ast.IdUid (_, "()"))) -> true + | Ast.PaAny _ -> true + | Ast.PaAli (_, x, y) -> + (is_irrefut_patt x) && (is_irrefut_patt y) + | Ast.PaRec (_, p) -> is_irrefut_patt p + | Ast.PaEq (_, (Ast.PaId (_, (Ast.IdLid (_, _)))), p) -> + is_irrefut_patt p + | Ast.PaSem (_, p1, p2) -> + (is_irrefut_patt p1) && (is_irrefut_patt p2) + | Ast.PaCom (_, p1, p2) -> + (is_irrefut_patt p1) && (is_irrefut_patt p2) + | Ast.PaTyc (_, p, _) -> is_irrefut_patt p + | Ast.PaTup (_, pl) -> is_irrefut_patt pl + | Ast.PaOlb (_, _, (Ast.PaNil _)) -> true + | Ast.PaOlb (_, _, p) -> is_irrefut_patt p + | Ast.PaOlbi (_, _, p, _) -> is_irrefut_patt p + | Ast.PaLab (_, _, (Ast.PaNil _)) -> true + | Ast.PaLab (_, _, p) -> is_irrefut_patt p + | _ -> false + let rec is_constructor = + function + | Ast.IdAcc (_, _, i) -> is_constructor i + | Ast.IdUid (_, _) -> true + | Ast.IdLid (_, _) | Ast.IdApp (_, _, _) -> false + | Ast.IdAnt (_, _) -> assert false + let is_patt_constructor = + function + | Ast.PaId (_, i) -> is_constructor i + | Ast.PaVrn (_, _) -> true + | _ -> false + let rec is_expr_constructor = + function + | Ast.ExId (_, i) -> is_constructor i + | Ast.ExAcc (_, e1, e2) -> + (is_expr_constructor e1) && (is_expr_constructor e2) + | Ast.ExVrn (_, _) -> true + | _ -> false + let ident_of_expr = + let error () = + invalid_arg + "ident_of_expr: this expression is not an identifier" in + let rec self = + function + | Ast.ExApp (_loc, e1, e2) -> + Ast.IdApp (_loc, self e1, self e2) + | Ast.ExAcc (_loc, e1, e2) -> + Ast.IdAcc (_loc, self e1, self e2) + | Ast.ExId (_, (Ast.IdLid (_, _))) -> error () + | Ast.ExId (_, i) -> + if is_module_longident i then i else error () + | _ -> error () + in + function + | Ast.ExId (_, i) -> i + | Ast.ExApp (_, _, _) -> error () + | t -> self t + let ident_of_ctyp = + let error () = + invalid_arg "ident_of_ctyp: this type is not an identifier" in + let rec self = + function + | Ast.TyApp (_loc, t1, t2) -> + Ast.IdApp (_loc, self t1, self t2) + | Ast.TyId (_, (Ast.IdLid (_, _))) -> error () + | Ast.TyId (_, i) -> + if is_module_longident i then i else error () + | _ -> error () + in function | Ast.TyId (_, i) -> i | t -> self t + let rec tyOr_of_list = + function + | [] -> Ast.TyNil ghost + | [ t ] -> t + | t :: ts -> + let _loc = loc_of_ctyp t + in Ast.TyOr (_loc, t, tyOr_of_list ts) + let rec tyAnd_of_list = + function + | [] -> Ast.TyNil ghost + | [ t ] -> t + | t :: ts -> + let _loc = loc_of_ctyp t + in Ast.TyAnd (_loc, t, tyAnd_of_list ts) + let rec tySem_of_list = + function + | [] -> Ast.TyNil ghost + | [ t ] -> t + | t :: ts -> + let _loc = loc_of_ctyp t + in Ast.TySem (_loc, t, tySem_of_list ts) + let rec stSem_of_list = + function + | [] -> Ast.StNil ghost + | [ t ] -> t + | t :: ts -> + let _loc = loc_of_str_item t + in Ast.StSem (_loc, t, stSem_of_list ts) + let rec sgSem_of_list = + function + | [] -> Ast.SgNil ghost + | [ t ] -> t + | t :: ts -> + let _loc = loc_of_sig_item t + in Ast.SgSem (_loc, t, sgSem_of_list ts) + let rec biAnd_of_list = + function + | [] -> Ast.BiNil ghost + | [ b ] -> b + | b :: bs -> + let _loc = loc_of_binding b + in Ast.BiAnd (_loc, b, biAnd_of_list bs) + let rec wcAnd_of_list = + function + | [] -> Ast.WcNil ghost + | [ w ] -> w + | w :: ws -> + let _loc = loc_of_with_constr w + in Ast.WcAnd (_loc, w, wcAnd_of_list ws) + let rec idAcc_of_list = + function + | [] -> assert false + | [ i ] -> i + | i :: is -> + let _loc = loc_of_ident i + in Ast.IdAcc (_loc, i, idAcc_of_list is) + let rec idApp_of_list = + function + | [] -> assert false + | [ i ] -> i + | i :: is -> + let _loc = loc_of_ident i + in Ast.IdApp (_loc, i, idApp_of_list is) + let rec mcOr_of_list = + function + | [] -> Ast.McNil ghost + | [ x ] -> x + | x :: xs -> + let _loc = loc_of_match_case x + in Ast.McOr (_loc, x, mcOr_of_list xs) + let rec mbAnd_of_list = + function + | [] -> Ast.MbNil ghost + | [ x ] -> x + | x :: xs -> + let _loc = loc_of_module_binding x + in Ast.MbAnd (_loc, x, mbAnd_of_list xs) + let rec meApp_of_list = + function + | [] -> assert false + | [ x ] -> x + | x :: xs -> + let _loc = loc_of_module_expr x + in Ast.MeApp (_loc, x, meApp_of_list xs) + let rec ceAnd_of_list = + function + | [] -> Ast.CeNil ghost + | [ x ] -> x + | x :: xs -> + let _loc = loc_of_class_expr x + in Ast.CeAnd (_loc, x, ceAnd_of_list xs) + let rec ctAnd_of_list = + function + | [] -> Ast.CtNil ghost + | [ x ] -> x + | x :: xs -> + let _loc = loc_of_class_type x + in Ast.CtAnd (_loc, x, ctAnd_of_list xs) + let rec cgSem_of_list = + function + | [] -> Ast.CgNil ghost + | [ x ] -> x + | x :: xs -> + let _loc = loc_of_class_sig_item x + in Ast.CgSem (_loc, x, cgSem_of_list xs) + let rec crSem_of_list = + function + | [] -> Ast.CrNil ghost + | [ x ] -> x + | x :: xs -> + let _loc = loc_of_class_str_item x + in Ast.CrSem (_loc, x, crSem_of_list xs) + let rec paSem_of_list = + function + | [] -> Ast.PaNil ghost + | [ x ] -> x + | x :: xs -> + let _loc = loc_of_patt x + in Ast.PaSem (_loc, x, paSem_of_list xs) + let rec paCom_of_list = + function + | [] -> Ast.PaNil ghost + | [ x ] -> x + | x :: xs -> + let _loc = loc_of_patt x + in Ast.PaCom (_loc, x, paCom_of_list xs) + let rec biSem_of_list = + function + | [] -> Ast.BiNil ghost + | [ x ] -> x + | x :: xs -> + let _loc = loc_of_binding x + in Ast.BiSem (_loc, x, biSem_of_list xs) + let rec exSem_of_list = + function + | [] -> Ast.ExNil ghost + | [ x ] -> x + | x :: xs -> + let _loc = loc_of_expr x + in Ast.ExSem (_loc, x, exSem_of_list xs) + let rec exCom_of_list = + function + | [] -> Ast.ExNil ghost + | [ x ] -> x + | x :: xs -> + let _loc = loc_of_expr x + in Ast.ExCom (_loc, x, exCom_of_list xs) + let ty_of_stl = + function + | (_loc, s, []) -> Ast.TyId (_loc, Ast.IdUid (_loc, s)) + | (_loc, s, tl) -> + Ast.TyOf (_loc, Ast.TyId (_loc, Ast.IdUid (_loc, s)), + tyAnd_of_list tl) + let ty_of_sbt = + function + | (_loc, s, true, t) -> + Ast.TyCol (_loc, Ast.TyId (_loc, Ast.IdLid (_loc, s)), + Ast.TyMut (_loc, t)) + | (_loc, s, false, t) -> + Ast.TyCol (_loc, Ast.TyId (_loc, Ast.IdLid (_loc, s)), t) + let bi_of_pe (p, e) = + let _loc = loc_of_patt p in Ast.BiEq (_loc, p, e) + let sum_type_of_list l = tyOr_of_list (List.map ty_of_stl l) + let record_type_of_list l = tySem_of_list (List.map ty_of_sbt l) + let binding_of_pel l = biAnd_of_list (List.map bi_of_pe l) + let rec pel_of_binding = + function + | Ast.BiAnd (_, b1, b2) -> + (pel_of_binding b1) @ (pel_of_binding b2) + | Ast.BiEq (_, p, e) -> [ (p, e) ] + | Ast.BiSem (_, b1, b2) -> + (pel_of_binding b1) @ (pel_of_binding b2) + | _ -> assert false + let rec list_of_binding x acc = + match x with + | Ast.BiAnd (_, b1, b2) | Ast.BiSem (_, b1, b2) -> + list_of_binding b1 (list_of_binding b2 acc) + | t -> t :: acc + let rec list_of_with_constr x acc = + match x with + | Ast.WcAnd (_, w1, w2) -> + list_of_with_constr w1 (list_of_with_constr w2 acc) + | t -> t :: acc + let rec list_of_ctyp x acc = + match x with + | Ast.TyNil _ -> acc + | Ast.TyAmp (_, x, y) | Ast.TyCom (_, x, y) | + Ast.TySta (_, x, y) | Ast.TySem (_, x, y) | + Ast.TyAnd (_, x, y) | Ast.TyOr (_, x, y) -> + list_of_ctyp x (list_of_ctyp y acc) + | x -> x :: acc + let rec list_of_patt x acc = + match x with + | Ast.PaNil _ -> acc + | Ast.PaCom (_, x, y) | Ast.PaSem (_, x, y) -> + list_of_patt x (list_of_patt y acc) + | x -> x :: acc + let rec list_of_expr x acc = + match x with + | Ast.ExNil _ -> acc + | Ast.ExCom (_, x, y) | Ast.ExSem (_, x, y) -> + list_of_expr x (list_of_expr y acc) + | x -> x :: acc + let rec list_of_str_item x acc = + match x with + | Ast.StNil _ -> acc + | Ast.StSem (_, x, y) -> + list_of_str_item x (list_of_str_item y acc) + | x -> x :: acc + let rec list_of_sig_item x acc = + match x with + | Ast.SgNil _ -> acc + | Ast.SgSem (_, x, y) -> + list_of_sig_item x (list_of_sig_item y acc) + | x -> x :: acc + let rec list_of_class_sig_item x acc = + match x with + | Ast.CgNil _ -> acc + | Ast.CgSem (_, x, y) -> + list_of_class_sig_item x (list_of_class_sig_item y acc) + | x -> x :: acc + let rec list_of_class_str_item x acc = + match x with + | Ast.CrNil _ -> acc + | Ast.CrSem (_, x, y) -> + list_of_class_str_item x (list_of_class_str_item y acc) + | x -> x :: acc + let rec list_of_class_type x acc = + match x with + | Ast.CtAnd (_, x, y) -> + list_of_class_type x (list_of_class_type y acc) + | x -> x :: acc + let rec list_of_class_expr x acc = + match x with + | Ast.CeAnd (_, x, y) -> + list_of_class_expr x (list_of_class_expr y acc) + | x -> x :: acc + let rec list_of_module_expr x acc = + match x with + | Ast.MeApp (_, x, y) -> + list_of_module_expr x (list_of_module_expr y acc) + | x -> x :: acc + let rec list_of_match_case x acc = + match x with + | Ast.McNil _ -> acc + | Ast.McOr (_, x, y) -> + list_of_match_case x (list_of_match_case y acc) + | x -> x :: acc + let rec list_of_ident x acc = + match x with + | Ast.IdAcc (_, x, y) | Ast.IdApp (_, x, y) -> + list_of_ident x (list_of_ident y acc) + | x -> x :: acc + let rec list_of_module_binding x acc = + match x with + | Ast.MbAnd (_, x, y) -> + list_of_module_binding x (list_of_module_binding y acc) + | x -> x :: acc + end + end + module Quotation = + struct + module Make (Ast : Sig.Ast) : Sig.Quotation with module Ast = Ast = + struct + module Ast = Ast + module Loc = Ast.Loc + open Format + open Sig + type 'a expand_fun = Loc.t -> string option -> string -> 'a + type expander = + | ExStr of (bool -> string expand_fun) + | ExAst of Ast.expr expand_fun * Ast.patt expand_fun + let expanders_table = ref [] + let default = ref "" + let translate = ref (fun x -> x) + let expander_name name = + match !translate name with | "" -> !default | name -> name + let find name = List.assoc (expander_name name) !expanders_table + let add name f = expanders_table := (name, f) :: !expanders_table + let dump_file = ref None + module Error = + struct + type error = + | Finding | Expanding | ParsingResult of Loc.t * string + | Locating + type t = (string * error * exn) + exception E of t + let print ppf (name, ctx, exn) = + let name = if name = "" then !default else name in + let pp x = fprintf ppf "@?@[<2>While %s %S:" x name in + let () = + match ctx with + | Finding -> + (pp "finding quotation"; + fprintf ppf " available quotations are:\n@[<2>"; + List.iter (fun (s, _) -> fprintf ppf "%s@ " s) + !expanders_table; + fprintf ppf "@]") + | Expanding -> pp "expanding quotation" + | Locating -> pp "parsing" + | ParsingResult (loc, str) -> + let () = pp "parsing result of quotation" + in + (match !dump_file with + | Some dump_file -> + let () = fprintf ppf " dumping result...\n" + in + (try + let oc = open_out_bin dump_file + in + (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)) + 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 + let to_string x = + let b = Buffer.create 50 in + let () = bprintf b "%a" print x in Buffer.contents b + end + let _ = let module M = ErrorHandler.Register(Error) in () + open Error + let expand_quotation loc expander quot = + 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), Expanding, exc)) + in raise (Loc.Exc_located (iloc, exc1)) + | exc -> + let exc1 = Error.E (((quot.q_name), Expanding, exc)) + in raise (Loc.Exc_located (loc, exc1)) + let parse_quotation_result parse loc quot str = + try parse loc str + with + | Loc.Exc_located (iloc, (Error.E ((n, Expanding, exc)))) -> + let ctx = ParsingResult (iloc, quot.q_contents) in + let exc1 = Error.E ((n, 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), ctx, exc)) + in raise (Loc.Exc_located (iloc, exc1)) + let handle_quotation loc proj in_expr parse quotation = + let name = quotation.q_name in + let expander = + try find name + with | (Loc.Exc_located (_, (Error.E _)) as exc) -> raise exc + | Loc.Exc_located (qloc, exc) -> + raise + (Loc.Exc_located (qloc, Error.E ((name, Finding, exc)))) + | exc -> + raise + (Loc.Exc_located (loc, Error.E ((name, Finding, exc)))) in + let loc = Loc.join (Loc.move `start quotation.q_shift loc) + in + match expander with + | ExStr f -> + let new_str = expand_quotation loc (f in_expr) quotation + in parse_quotation_result parse loc quotation new_str + | ExAst (fe, fp) -> + expand_quotation loc (proj (fe, fp)) quotation + let expand_expr parse loc x = + handle_quotation loc fst true parse x + let expand_patt parse loc x = + handle_quotation loc snd false parse x + end + end + module AstFilters = + struct + module Make (Ast : Sig.Camlp4Ast) : + Sig.AstFilters with module Ast = Ast = + struct + module Ast = Ast + type 'a filter = 'a -> 'a + let interf_filters = Queue.create () + let fold_interf_filters f i = Queue.fold f i interf_filters + let implem_filters = Queue.create () + let fold_implem_filters f i = Queue.fold f i implem_filters + let register_sig_item_filter f = Queue.add f interf_filters + let register_str_item_filter f = Queue.add f implem_filters + end + end + module Camlp4Ast2OCamlAst : + sig + module Make (Camlp4Ast : Sig.Camlp4Ast) : + sig + open Camlp4Ast + val sig_item : sig_item -> Parsetree.signature + val str_item : str_item -> Parsetree.structure + val phrase : str_item -> Parsetree.toplevel_phrase + end + end = + struct + module Make (Ast : Sig.Camlp4Ast) = + struct + open Format + open Parsetree + open Longident + open Asttypes + open Ast + let constructors_arity () = !Camlp4_config.constructors_arity + let error loc str = Loc.raise loc (Failure str) + let char_of_char_token loc s = + try Token.Eval.char s + with | (Failure _ as exn) -> Loc.raise loc exn + let string_of_string_token loc s = + try Token.Eval.string s + with | (Failure _ as exn) -> Loc.raise loc exn + let mkloc = Loc.to_ocaml_location + let mkghloc loc = Loc.to_ocaml_location (Loc.ghostify loc) + let mktyp loc d = { ptyp_desc = d; ptyp_loc = mkloc loc; } + let mkpat loc d = { ppat_desc = d; ppat_loc = mkloc loc; } + let mkghpat loc d = { ppat_desc = d; ppat_loc = mkghloc loc; } + let mkexp loc d = { pexp_desc = d; pexp_loc = mkloc loc; } + let mkmty loc d = { pmty_desc = d; pmty_loc = mkloc loc; } + let mksig loc d = { psig_desc = d; psig_loc = mkloc loc; } + let mkmod loc d = { pmod_desc = d; pmod_loc = mkloc loc; } + let mkstr loc d = { pstr_desc = d; pstr_loc = mkloc loc; } + let mkfield loc d = { pfield_desc = d; pfield_loc = mkloc loc; } + let mkcty loc d = { pcty_desc = d; pcty_loc = mkloc loc; } + let mkpcl loc d = { pcl_desc = d; pcl_loc = mkloc loc; } + let mkpolytype t = + match t.ptyp_desc with + | Ptyp_poly (_, _) -> t + | _ -> { (t) with ptyp_desc = Ptyp_poly ([], t); } + let mb2b = + function + | Ast.BTrue -> true + | Ast.BFalse -> false + | Ast.BAnt _ -> assert false + let mkvirtual m = if mb2b m then Virtual else Concrete + let lident s = Lident s + let ldot l s = Ldot (l, s) + let lapply l s = Lapply (l, s) + let conv_con = + let t = Hashtbl.create 73 + in + (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) + let conv_lab = + let t = Hashtbl.create 73 + in + (List.iter (fun (s, s') -> Hashtbl.add t s s') + [ ("val", "contents") ]; + fun s -> try Hashtbl.find t s with | Not_found -> s) + let array_function str name = + ldot (lident str) + (if !Camlp4_config.unsafe then "unsafe_" ^ name else name) + let mkrf = + function + | Ast.BTrue -> Recursive + | Ast.BFalse -> Nonrecursive + | Ast.BAnt _ -> assert false + let mkli s = + let rec loop f = + function + | i :: il -> loop (fun s -> ldot (f i) s) il + | [] -> f s + in loop (fun s -> lident s) + let rec ctyp_fa al = + function + | TyApp (_, f, a) -> ctyp_fa (a :: al) f + | f -> (f, al) + let ident_tag ?(conv_lid = fun x -> x) i = + let rec self i acc = + match i with + | Ast.IdAcc (_, i1, i2) -> self i2 (Some (self i1 acc)) + | Ast.IdApp (_, 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) + | Ast.IdUid (_, 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) + | Ast.IdLid (_, 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 + let ident ?conv_lid i = fst (ident_tag ?conv_lid i) + let long_lident msg i = + match ident_tag i with + | (i, `lident) -> i + | _ -> error (loc_of_ident i) msg + let long_type_ident = long_lident "invalid long identifier type" + let long_class_ident = long_lident "invalid class name" + let long_uident ?(conv_con = fun x -> x) i = + match ident_tag i with + | (Ldot (i, s), `uident) -> ldot i (conv_con s) + | (Lident s, `uident) -> lident (conv_con s) + | (i, `app) -> i + | _ -> error (loc_of_ident i) "uppercase identifier expected" + let rec ctyp_long_id_prefix t = + match t with + | Ast.TyId (_, i) -> ident i + | Ast.TyApp (_, 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" + let ctyp_long_id t = + match t with + | Ast.TyId (_, 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" + let rec ty_var_list_of_ctyp = + function + | Ast.TyApp (_, t1, t2) -> + (ty_var_list_of_ctyp t1) @ (ty_var_list_of_ctyp t2) + | Ast.TyQuo (_, s) -> [ s ] + | _ -> assert false + let rec ctyp = + function + | 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 (lab, ctyp t1, ctyp t2)) + | TyArr (loc, (TyOlb (loc1, lab, t1)), t2) -> + let t1 = + TyApp (loc1, Ast.TyId (loc1, Ast.IdLid (loc1, "option")), + t1) + in mktyp loc (Ptyp_arrow ("?" ^ lab, ctyp t1, ctyp t2)) + | TyArr (loc, t1, t2) -> + mktyp loc (Ptyp_arrow ("", ctyp t1, ctyp t2)) + | Ast.TyObj (loc, (Ast.TyNil _), Ast.BFalse) -> + mktyp loc (Ptyp_object []) + | Ast.TyObj (loc, (Ast.TyNil _), Ast.BTrue) -> + mktyp loc (Ptyp_object [ mkfield loc Pfield_var ]) + | Ast.TyObj (loc, fl, Ast.BFalse) -> + mktyp loc (Ptyp_object (meth_list fl [])) + | Ast.TyObj (loc, fl, Ast.BTrue) -> + mktyp loc + (Ptyp_object (meth_list fl [ mkfield loc Pfield_var ])) + | TyCls (loc, id) -> mktyp loc (Ptyp_class (ident id, [], [])) + | 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" + | Ast.TyTup (loc, (Ast.TySta (_, t1, t2))) -> + mktyp loc + (Ptyp_tuple + (List.map ctyp (list_of_ctyp t1 (list_of_ctyp t2 [])))) + | Ast.TyVrnEq (loc, t) -> + mktyp loc (Ptyp_variant (row_field t, true, None)) + | Ast.TyVrnSup (loc, t) -> + mktyp loc (Ptyp_variant (row_field t, false, None)) + | Ast.TyVrnInf (loc, t) -> + mktyp loc (Ptyp_variant (row_field t, true, Some [])) + | Ast.TyVrnInfSup (loc, t, t') -> + mktyp loc + (Ptyp_variant (row_field t, true, Some (name_tags t'))) + | TyAnt (loc, _) -> error loc "antiquotation not allowed here" + | TyOfAmp (_, _, _) | TyAmp (_, _, _) | TySta (_, _, _) | + TyCom (_, _, _) | TyVrn (_, _) | TyQuM (_, _) | + TyQuP (_, _) | TyDcl (_, _, _, _, _) | + TyObj (_, _, (BAnt _)) | TyNil _ | TyTup (_, _) -> + assert false + and row_field = + function + | Ast.TyVrn (_, i) -> [ Rtag (i, true, []) ] + | Ast.TyOfAmp (_, (Ast.TyVrn (_, i)), t) -> + [ Rtag (i, true, List.map ctyp (list_of_ctyp t [])) ] + | Ast.TyOf (_, (Ast.TyVrn (_, i)), t) -> + [ Rtag (i, false, List.map ctyp (list_of_ctyp t [])) ] + | Ast.TyOr (_, t1, t2) -> (row_field t1) @ (row_field t2) + | t -> [ Rinherit (ctyp t) ] + and name_tags = + function + | Ast.TyApp (_, t1, t2) -> (name_tags t1) @ (name_tags t2) + | Ast.TyVrn (_, s) -> [ s ] + | _ -> assert false + and meth_list fl acc = + match fl with + | Ast.TySem (_, t1, t2) -> meth_list t1 (meth_list t2 acc) + | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (_, lab)))), t) -> + (mkfield loc (Pfield (lab, mkpolytype (ctyp t)))) :: acc + | _ -> assert false + let mktype loc tl cl tk tm = + let (params, variance) = List.split tl + in + { + + ptype_params = params; + ptype_cstrs = cl; + ptype_kind = tk; + ptype_manifest = tm; + ptype_loc = mkloc loc; + ptype_variance = variance; + } + let mkprivate' m = if m then Private else Public + let mkprivate m = mkprivate' (mb2b m) + let mktrecord = + function + | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (_, s)))), + (Ast.TyMut (_, t))) -> + (s, Mutable, (mkpolytype (ctyp t)), (mkloc loc)) + | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (_, s)))), t) -> + (s, Immutable, (mkpolytype (ctyp t)), (mkloc loc)) + | _ -> assert false + let mkvariant = + function + | Ast.TyId (loc, (Ast.IdUid (_, s))) -> + ((conv_con s), [], (mkloc loc)) + | Ast.TyOf (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), t) -> + ((conv_con s), (List.map ctyp (list_of_ctyp t [])), + (mkloc loc)) + | _ -> assert false + let rec type_decl tl cl loc m pflag = + function + | TyMan (_, t1, t2) -> + type_decl tl cl loc (Some (ctyp t1)) pflag t2 + | TyPrv (_, t) -> type_decl tl cl loc m true t + | TyRec (_, t) -> + mktype loc tl cl + (Ptype_record (List.map mktrecord (list_of_ctyp t []), + mkprivate' pflag)) + m + | TySum (_, t) -> + mktype loc tl cl + (Ptype_variant (List.map mkvariant (list_of_ctyp t []), + mkprivate' pflag)) + m + | t -> + if m <> None + then + error loc "only one manifest type allowed by definition" + else + (let m = + match t with + | TyQuo (_, s) -> + if List.mem_assoc s tl + then Some (ctyp t) + else None + | _ -> Some (ctyp t) in + let k = if pflag then Ptype_private else Ptype_abstract + in mktype loc tl cl k m) + let type_decl tl cl t = + type_decl tl cl (loc_of_ctyp t) None false t + let mkvalue_desc t p = { pval_type = ctyp t; pval_prim = p; } + let rec list_of_meta_list = + function + | Ast.LNil -> [] + | Ast.LCons (x, xs) -> x :: (list_of_meta_list xs) + | Ast.LAnt _ -> assert false + let mkmutable m = if mb2b m then Mutable else Immutable + let paolab lab p = + match (lab, p) with + | ("", + (Ast.PaId (_, (Ast.IdLid (_, i))) | + Ast.PaTyc (_, (Ast.PaId (_, (Ast.IdLid (_, i)))), _))) + -> i + | ("", p) -> error (loc_of_patt p) "bad ast in label" + | _ -> lab + let opt_private_ctyp = + function + | Ast.TyPrv (_, t) -> (Ptype_private, (ctyp t)) + | t -> (Ptype_abstract, (ctyp t)) + let rec type_parameters t acc = + match t with + | Ast.TyApp (_, t1, t2) -> + type_parameters t1 (type_parameters t2 acc) + | Ast.TyQuP (_, s) -> (s, (true, false)) :: acc + | Ast.TyQuM (_, s) -> (s, (false, true)) :: acc + | Ast.TyQuo (_, s) -> (s, (false, false)) :: acc + | _ -> assert false + let rec class_parameters t acc = + match t with + | Ast.TyCom (_, t1, t2) -> + class_parameters t1 (class_parameters t2 acc) + | Ast.TyQuP (_, s) -> (s, (true, false)) :: acc + | Ast.TyQuM (_, s) -> (s, (false, true)) :: acc + | Ast.TyQuo (_, s) -> (s, (false, false)) :: acc + | _ -> assert false + let rec type_parameters_and_type_name t acc = + match t with + | Ast.TyApp (_, t1, t2) -> + type_parameters_and_type_name t1 (type_parameters t2 acc) + | Ast.TyId (_, i) -> ((ident i), acc) + | _ -> assert false + let rec mkwithc wc acc = + match wc with + | WcNil _ -> acc + | WcTyp (loc, id_tpl, ct) -> + let (id, tpl) = type_parameters_and_type_name id_tpl [] in + let (params, variance) = List.split tpl in + let (kind, ct) = opt_private_ctyp ct + in + (id, + (Pwith_type + { + + ptype_params = params; + ptype_cstrs = []; + ptype_kind = kind; + ptype_manifest = Some ct; + ptype_loc = mkloc loc; + ptype_variance = variance; + })) :: + acc + | WcMod (_, i1, i2) -> + ((long_uident i1), (Pwith_module (long_uident i2))) :: acc + | Ast.WcAnd (_, wc1, wc2) -> mkwithc wc1 (mkwithc wc2 acc) + | Ast.WcAnt (loc, _) -> + error loc "bad with constraint (antiquotation)" + let rec patt_fa al = + function + | PaApp (_, f, a) -> patt_fa (a :: al) f + | f -> (f, al) + let rec deep_mkrangepat loc c1 c2 = + if c1 = c2 + then mkghpat loc (Ppat_constant (Const_char c1)) + else + mkghpat loc + (Ppat_or (mkghpat loc (Ppat_constant (Const_char c1)), + deep_mkrangepat loc (Char.chr ((Char.code c1) + 1)) c2)) + let rec mkrangepat loc c1 c2 = + if c1 > c2 + then mkrangepat loc c2 c1 + else + if c1 = c2 + then mkpat loc (Ppat_constant (Const_char c1)) + else + mkpat loc + (Ppat_or (mkghpat loc (Ppat_constant (Const_char c1)), + deep_mkrangepat loc (Char.chr ((Char.code c1) + 1)) c2)) + let rec patt = + function + | Ast.PaId (loc, (Ast.IdLid (_, s))) -> mkpat loc (Ppat_var s) + | Ast.PaId (loc, i) -> + let p = + Ppat_construct (long_uident ~conv_con i, None, + constructors_arity ()) + in mkpat loc p + | PaAli (loc, p1, p2) -> + let (p, i) = + (match (p1, p2) with + | (p, Ast.PaId (_, (Ast.IdLid (_, s)))) -> (p, s) + | (Ast.PaId (_, (Ast.IdLid (_, s))), p) -> (p, s) + | _ -> error loc "invalid alias pattern") + in mkpat loc (Ppat_alias (patt p, i)) + | PaAnt (loc, _) -> error loc "antiquotation not allowed here" + | PaAny loc -> mkpat loc Ppat_any + | Ast.PaApp (loc, (Ast.PaId (_, (Ast.IdUid (_, s)))), + (Ast.PaTup (_, (Ast.PaAny loc_any)))) -> + mkpat loc + (Ppat_construct (lident (conv_con s), + Some (mkpat loc_any Ppat_any), false)) + | (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, _) -> + if constructors_arity () + then + mkpat loc + (Ppat_construct (li, + Some (mkpat loc (Ppat_tuple al)), true)) + else + (let a = + match al with + | [ a ] -> a + | _ -> mkpat loc (Ppat_tuple al) + in mkpat loc (Ppat_construct (li, Some a, false))) + | Ppat_variant (s, None) -> + let a = + if constructors_arity () + then mkpat loc (Ppat_tuple al) + else + (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 (Const_char (char_of_char_token loc s))) + | PaInt (loc, s) -> + let i = + (try int_of_string s + with + | Failure _ -> + error loc + "Integer literal exceeds the range of representable integers of type int") + in mkpat loc (Ppat_constant (Const_int i)) + | PaInt32 (loc, s) -> + let i32 = + (try Int32.of_string s + with + | Failure _ -> + error loc + "Integer literal exceeds the range of representable integers of type int32") + in mkpat loc (Ppat_constant (Const_int32 i32)) + | PaInt64 (loc, s) -> + let i64 = + (try Int64.of_string s + with + | Failure _ -> + error loc + "Integer literal exceeds the range of representable integers of type int64") + in mkpat loc (Ppat_constant (Const_int64 i64)) + | PaNativeInt (loc, s) -> + let nati = + (try Nativeint.of_string s + with + | Failure _ -> + error loc + "Integer literal exceeds the range of representable integers of type nativeint") + in mkpat loc (Ppat_constant (Const_nativeint nati)) + | PaFlo (loc, s) -> mkpat loc (Ppat_constant (Const_float s)) + | 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) -> + mkpat loc + (Ppat_record (List.map mklabpat (list_of_patt p []))) + | PaStr (loc, s) -> + mkpat loc + (Ppat_constant + (Const_string (string_of_string_token loc s))) + | Ast.PaTup (loc, (Ast.PaCom (_, p1, p2))) -> + mkpat loc + (Ppat_tuple + (List.map patt (list_of_patt p1 (list_of_patt p2 [])))) + | Ast.PaTup (loc, _) -> error loc "singleton tuple pattern" + | PaTyc (loc, p, t) -> + mkpat loc (Ppat_constraint (patt p, ctyp t)) + | PaTyp (loc, i) -> mkpat loc (Ppat_type (long_type_ident i)) + | PaVrn (loc, s) -> mkpat loc (Ppat_variant (s, None)) + | (PaEq (_, _, _) | PaSem (_, _, _) | PaCom (_, _, _) | PaNil _ + as p) -> error (loc_of_patt p) "invalid pattern" + and mklabpat = + function + | Ast.PaEq (_, (Ast.PaId (_, i)), p) -> + ((ident ~conv_lid: conv_lab i), (patt p)) + | p -> error (loc_of_patt p) "invalid pattern" + let rec expr_fa al = + function + | ExApp (_, f, a) -> expr_fa (a :: al) f + | f -> (f, al) + let rec class_expr_fa al = + function + | CeApp (_, ce, a) -> class_expr_fa (a :: al) ce + | ce -> (ce, al) + let rec sep_expr_acc l = + function + | ExAcc (_, e1, e2) -> sep_expr_acc (sep_expr_acc l e2) e1 + | (Ast.ExId (loc, (Ast.IdUid (_, s))) as e) -> + (match l with + | [] -> [ (loc, [], e) ] + | (loc', sl, e) :: l -> + ((Loc.merge loc loc'), (s :: sl), e) :: l) + | Ast.ExId (_, ((Ast.IdAcc (_, _, _) as i))) -> + let rec normalize_acc = + (function + | Ast.IdAcc (_loc, i1, i2) -> + Ast.ExAcc (_loc, normalize_acc i1, normalize_acc i2) + | Ast.IdApp (_loc, i1, i2) -> + Ast.ExApp (_loc, normalize_acc i1, normalize_acc i2) + | (Ast.IdAnt (_loc, _) | Ast.IdUid (_loc, _) | + Ast.IdLid (_loc, _) + as i) -> Ast.ExId (_loc, i)) + in sep_expr_acc l (normalize_acc i) + | e -> ((loc_of_expr e), [], e) :: l + let list_of_opt_ctyp ot acc = + match ot with | Ast.TyNil _ -> acc | t -> list_of_ctyp t acc + let rec expr = + function + | Ast.ExAcc (loc, x, (Ast.ExId (_, (Ast.IdLid (_, "val"))))) -> + mkexp loc + (Pexp_apply (mkexp loc (Pexp_ident (Lident "!")), + [ ("", (expr x)) ])) + | (ExAcc (loc, _, _) | Ast.ExId (loc, (Ast.IdAcc (_, _, _))) as + e) -> + let (e, l) = + (match sep_expr_acc [] e with + | (loc, ml, Ast.ExId (_, (Ast.IdUid (_, s)))) :: l -> + let ca = constructors_arity () + in + ((mkexp loc (Pexp_construct (mkli s ml, None, ca))), + l) + | (loc, ml, Ast.ExId (_, (Ast.IdLid (_, s)))) :: l -> + ((mkexp loc (Pexp_ident (mkli s ml))), l) + | (_, [], e) :: l -> ((expr e), l) + | _ -> error loc "bad ast in expression") in + let (_, e) = + List.fold_left + (fun (loc_bp, e1) (loc_ep, ml, e2) -> + match e2 with + | Ast.ExId (_, (Ast.IdLid (_, s))) -> + let loc = Loc.merge loc_bp loc_ep + in + (loc, + (mkexp loc + (Pexp_field (e1, mkli (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 + if constructors_arity () + then + mkexp loc + (Pexp_construct (li, + Some (mkexp loc (Pexp_tuple al)), true)) + else + (let a = + match al with + | [ a ] -> a + | _ -> mkexp loc (Pexp_tuple al) + in + mkexp loc + (Pexp_construct (li, Some a, false))) + | Pexp_variant (s, None) -> + let al = List.map snd al in + let a = + if constructors_arity () + then mkexp loc (Pexp_tuple al) + else + (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 "Array" "get")), + [ ("", (expr e1)); ("", (expr e2)) ])) + | ExArr (loc, e) -> + mkexp loc (Pexp_array (List.map expr (list_of_expr e []))) + | ExAsf loc -> mkexp loc Pexp_assertfalse + | ExAss (loc, e, v) -> + let e = + (match e with + | Ast.ExAcc (loc, x, + (Ast.ExId (_, (Ast.IdLid (_, "val"))))) -> + Pexp_apply (mkexp loc (Pexp_ident (Lident ":=")), + [ ("", (expr x)); ("", (expr v)) ]) + | ExAcc (loc, _, _) -> + (match (expr e).pexp_desc with + | Pexp_field (e, lab) -> + Pexp_setfield (e, lab, expr v) + | _ -> error loc "bad record access") + | ExAre (_, e1, e2) -> + Pexp_apply + (mkexp loc + (Pexp_ident (array_function "Array" "set")), + [ ("", (expr e1)); ("", (expr e2)); ("", (expr v)) ]) + | Ast.ExId (_, (Ast.IdLid (_, lab))) -> + Pexp_setinstvar (lab, expr v) + | ExSte (_, e1, e2) -> + Pexp_apply + (mkexp loc + (Pexp_ident (array_function "String" "set")), + [ ("", (expr e1)); ("", (expr e2)); ("", (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 (Const_char (char_of_char_token loc s))) + | ExCoe (loc, e, t1, t2) -> + let t1 = + (match t1 with | Ast.TyNil _ -> None | t -> Some (ctyp t)) + in mkexp loc (Pexp_constraint (expr e, t1, Some (ctyp t2))) + | ExFlo (loc, s) -> mkexp loc (Pexp_constant (Const_float s)) + | ExFor (loc, i, e1, e2, df, el) -> + let e3 = ExSeq (loc, el) in + let df = if mb2b df then Upto else Downto + in mkexp loc (Pexp_for (i, expr e1, expr e2, df, expr e3)) + | Ast.ExFun (loc, (Ast.McArr (_, (PaLab (_, lab, po)), w, e))) + -> + mkexp loc + (Pexp_function (lab, None, + [ ((patt_of_lab loc lab po), (when_expr e w)) ])) + | Ast.ExFun (loc, + (Ast.McArr (_, (PaOlbi (_, lab, p, e1)), w, e2))) -> + let lab = paolab lab p + in + mkexp loc + (Pexp_function ("?" ^ lab, Some (expr e1), + [ ((patt p), (when_expr e2 w)) ])) + | Ast.ExFun (loc, (Ast.McArr (_, (PaOlb (_, lab, p)), w, e))) + -> + let lab = paolab lab p + in + mkexp loc + (Pexp_function ("?" ^ lab, None, + [ ((patt_of_lab loc lab p), (when_expr e w)) ])) + | ExFun (loc, a) -> + mkexp loc (Pexp_function ("", None, match_case a [])) + | ExIfe (loc, e1, e2, e3) -> + mkexp loc + (Pexp_ifthenelse (expr e1, expr e2, Some (expr e3))) + | ExInt (loc, s) -> + let i = + (try int_of_string s + with + | Failure _ -> + error loc + "Integer literal exceeds the range of representable integers of type int") + in mkexp loc (Pexp_constant (Const_int i)) + | ExInt32 (loc, s) -> + let i32 = + (try Int32.of_string s + with + | Failure _ -> + error loc + "Integer literal exceeds the range of representable integers of type int32") + in mkexp loc (Pexp_constant (Const_int32 i32)) + | ExInt64 (loc, s) -> + let i64 = + (try Int64.of_string s + with + | Failure _ -> + error loc + "Integer literal exceeds the range of representable integers of type int64") + in mkexp loc (Pexp_constant (Const_int64 i64)) + | ExNativeInt (loc, s) -> + let nati = + (try Nativeint.of_string s + with + | Failure _ -> + error loc + "Integer literal exceeds the range of representable integers of type nativeint") + in mkexp loc (Pexp_constant (Const_nativeint nati)) + | ExLab (loc, _, _) -> + error loc "labeled expression not allowed here" + | ExLaz (loc, e) -> mkexp loc (Pexp_lazy (expr e)) + | ExLet (loc, rf, bi, e) -> + mkexp loc (Pexp_let (mkrf rf, binding bi [], expr e)) + | ExLmd (loc, i, me, e) -> + mkexp loc (Pexp_letmodule (i, module_expr me, expr e)) + | 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 | Ast.PaNil _ -> Ast.PaAny loc | p -> p) in + let cil = class_str_item cfl [] + in mkexp loc (Pexp_object (((patt p), 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 + | Ast.BiNil _ -> error loc "empty record" + | _ -> + let eo = + (match eo with + | Ast.ExNil _ -> None + | e -> Some (expr e)) + in mkexp loc (Pexp_record (mklabexp lel [], eo))) + | ExSeq (_loc, e) -> + let rec loop = + (function + | [] -> expr (Ast.ExId (_loc, Ast.IdUid (_loc, "()"))) + | [ 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, s)) + | ExSte (loc, e1, e2) -> + mkexp loc + (Pexp_apply + (mkexp loc + (Pexp_ident (array_function "String" "get")), + [ ("", (expr e1)); ("", (expr e2)) ])) + | ExStr (loc, s) -> + mkexp loc + (Pexp_constant + (Const_string (string_of_string_token loc s))) + | ExTry (loc, e, a) -> + mkexp loc (Pexp_try (expr e, match_case a [])) + | Ast.ExTup (loc, (Ast.ExCom (_, e1, e2))) -> + mkexp loc + (Pexp_tuple + (List.map expr (list_of_expr e1 (list_of_expr e2 [])))) + | Ast.ExTup (loc, _) -> error loc "singleton tuple" + | ExTyc (loc, e, t) -> + mkexp loc (Pexp_constraint (expr e, Some (ctyp t), None)) + | Ast.ExId (loc, (Ast.IdUid (_, "()"))) -> + mkexp loc (Pexp_construct (lident "()", None, true)) + | Ast.ExId (loc, (Ast.IdLid (_, s))) -> + mkexp loc (Pexp_ident (lident s)) + | Ast.ExId (loc, (Ast.IdUid (_, s))) -> + mkexp loc + (Pexp_construct (lident (conv_con s), None, true)) + | ExVrn (loc, s) -> mkexp loc (Pexp_variant (s, None)) + | ExWhi (loc, e1, el) -> + let e2 = ExSeq (loc, el) + in mkexp loc (Pexp_while (expr e1, expr e2)) + | Ast.ExCom (loc, _, _) -> + error loc "expr, expr: not allowed here" + | Ast.ExSem (loc, _, _) -> + error loc + "expr; expr: not allowed here, use do {...} or [|...|] to surround them" + | (ExId (_, _) | ExNil _ as e) -> + error (loc_of_expr e) "invalid expr" + and patt_of_lab _loc lab = + function + | Ast.PaNil _ -> patt (Ast.PaId (_loc, Ast.IdLid (_loc, lab))) + | p -> patt p + and expr_of_lab _loc lab = + function + | Ast.ExNil _ -> expr (Ast.ExId (_loc, Ast.IdLid (_loc, lab))) + | e -> expr e + and label_expr = + function + | ExLab (loc, lab, eo) -> (lab, (expr_of_lab loc lab eo)) + | ExOlb (loc, lab, eo) -> + (("?" ^ lab), (expr_of_lab loc lab eo)) + | e -> ("", (expr e)) + and binding x acc = + match x with + | Ast.BiAnd (_, x, y) | Ast.BiSem (_, x, y) -> + binding x (binding y acc) + | Ast.BiEq (_, p, e) -> ((patt p), (expr e)) :: acc + | Ast.BiNil _ -> acc + | _ -> assert false + and match_case x acc = + match x with + | Ast.McOr (_, x, y) -> match_case x (match_case y acc) + | Ast.McArr (_, p, w, e) -> ((patt p), (when_expr e w)) :: acc + | Ast.McNil _ -> acc + | _ -> assert false + and when_expr e w = + match w with + | Ast.ExNil _ -> expr e + | w -> mkexp (loc_of_expr w) (Pexp_when (expr w, expr e)) + and mklabexp x acc = + match x with + | Ast.BiAnd (_, x, y) | Ast.BiSem (_, x, y) -> + mklabexp x (mklabexp y acc) + | Ast.BiEq (_, (Ast.PaId (_, i)), e) -> + ((ident ~conv_lid: conv_lab i), (expr e)) :: acc + | _ -> assert false + and mkideexp x acc = + match x with + | Ast.BiAnd (_, x, y) | Ast.BiSem (_, x, y) -> + mkideexp x (mkideexp y acc) + | Ast.BiEq (_, (Ast.PaId (_, (Ast.IdLid (_, s)))), e) -> + (s, (expr e)) :: acc + | _ -> assert false + and mktype_decl x acc = + match x with + | Ast.TyAnd (_, x, y) -> mktype_decl x (mktype_decl y acc) + | Ast.TyDcl (_, c, tl, td, cl) -> + 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 + (c, + (type_decl (List.fold_right type_parameters tl []) cl td)) :: + acc + | _ -> assert false + and module_type = + function + | MtId (loc, i) -> mkmty loc (Pmty_ident (long_uident i)) + | MtFun (loc, n, nt, mt) -> + mkmty loc + (Pmty_functor (n, module_type nt, module_type mt)) + | MtQuo (loc, _) -> + error loc "abstract module type not allowed here" + | MtSig (loc, sl) -> + mkmty loc (Pmty_signature (sig_item sl [])) + | MtWit (loc, mt, wc) -> + mkmty loc (Pmty_with (module_type mt, mkwithc wc [])) + | Ast.MtAnt (_, _) -> assert false + and sig_item s l = + match s with + | Ast.SgNil _ -> 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 + | Ast.SgSem (_, sg1, sg2) -> sig_item sg1 (sig_item sg2 l) + | SgDir (_, _, _) -> l + | Ast.SgExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s))))) -> + (mksig loc (Psig_exception (conv_con s, []))) :: l + | Ast.SgExc (loc, + (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, s)))), t))) -> + (mksig loc + (Psig_exception (conv_con s, + List.map ctyp (list_of_ctyp t [])))) :: + l + | SgExc (_, _) -> assert false + | SgExt (loc, n, t, sl) -> + (mksig loc + (Psig_value (n, mkvalue_desc t (list_of_meta_list sl)))) :: + l + | SgInc (loc, mt) -> + (mksig loc (Psig_include (module_type mt))) :: l + | SgMod (loc, n, mt) -> + (mksig loc (Psig_module (n, module_type mt))) :: l + | SgRecMod (loc, mb) -> + (mksig loc (Psig_recmodule (module_sig_binding mb []))) :: + l + | SgMty (loc, n, mt) -> + let si = + (match mt with + | MtQuo (_, _) -> Pmodtype_abstract + | _ -> Pmodtype_manifest (module_type mt)) + in (mksig loc (Psig_modtype (n, si))) :: l + | SgOpn (loc, id) -> + (mksig loc (Psig_open (long_uident id))) :: l + | SgTyp (loc, tdl) -> + (mksig loc (Psig_type (mktype_decl tdl []))) :: l + | SgVal (loc, n, t) -> + (mksig loc (Psig_value (n, mkvalue_desc t []))) :: l + | Ast.SgAnt (loc, _) -> error loc "antiquotation in sig_item" + and module_sig_binding x acc = + match x with + | Ast.MbAnd (_, x, y) -> + module_sig_binding x (module_sig_binding y acc) + | Ast.MbCol (_, s, mt) -> (s, (module_type mt)) :: acc + | _ -> assert false + and module_str_binding x acc = + match x with + | Ast.MbAnd (_, x, y) -> + module_str_binding x (module_str_binding y acc) + | Ast.MbColEq (_, s, mt, me) -> + (s, (module_type mt), (module_expr me)) :: acc + | _ -> assert false + and module_expr = + function + | MeId (loc, i) -> mkmod loc (Pmod_ident (long_uident i)) + | MeApp (loc, me1, me2) -> + mkmod loc (Pmod_apply (module_expr me1, module_expr me2)) + | MeFun (loc, n, mt, me) -> + mkmod loc + (Pmod_functor (n, module_type mt, module_expr me)) + | MeStr (loc, sl) -> + mkmod loc (Pmod_structure (str_item sl [])) + | MeTyc (loc, me, mt) -> + mkmod loc + (Pmod_constraint (module_expr me, module_type mt)) + | Ast.MeAnt (loc, _) -> + error loc "antiquotation in module_expr" + and str_item s l = + match s with + | Ast.StNil _ -> 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 + | Ast.StSem (_, st1, st2) -> str_item st1 (str_item st2 l) + | StDir (_, _, _) -> l + | Ast.StExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), Ast. + ONone) -> + (mkstr loc (Pstr_exception (conv_con s, []))) :: l + | Ast.StExc (loc, + (Ast.TyOf (_, (Ast.TyId (_, (Ast.IdUid (_, s)))), t)), Ast. + ONone) -> + (mkstr loc + (Pstr_exception (conv_con s, + List.map ctyp (list_of_ctyp t [])))) :: + l + | Ast.StExc (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), + (Ast.OSome i)) -> + (mkstr loc (Pstr_exn_rebind (conv_con s, ident i))) :: l + | StExc (_, _, _) -> assert false + | StExp (loc, e) -> (mkstr loc (Pstr_eval (expr e))) :: l + | StExt (loc, n, t, sl) -> + (mkstr loc + (Pstr_primitive (n, + mkvalue_desc t (list_of_meta_list sl)))) :: + l + | StInc (loc, me) -> + (mkstr loc (Pstr_include (module_expr me))) :: l + | StMod (loc, n, me) -> + (mkstr loc (Pstr_module (n, module_expr me))) :: l + | StRecMod (loc, mb) -> + (mkstr loc (Pstr_recmodule (module_str_binding mb []))) :: + l + | StMty (loc, n, mt) -> + (mkstr loc (Pstr_modtype (n, module_type mt))) :: l + | StOpn (loc, id) -> + (mkstr loc (Pstr_open (long_uident id))) :: l + | StTyp (loc, tdl) -> + (mkstr loc (Pstr_type (mktype_decl tdl []))) :: l + | StVal (loc, rf, bi) -> + (mkstr loc (Pstr_value (mkrf rf, binding bi []))) :: l + | Ast.StAnt (loc, _) -> error loc "antiquotation in str_item" + and class_type = + function + | CtCon (loc, Ast.BFalse, 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_fun (lab, ctyp t, class_type ct)) + | CtFun (loc, (TyOlb (loc1, lab, t)), ct) -> + let t = + TyApp (loc1, Ast.TyId (loc1, Ast.IdLid (loc1, "option")), + t) + in mkcty loc (Pcty_fun ("?" ^ lab, ctyp t, class_type ct)) + | CtFun (loc, t, ct) -> + mkcty loc (Pcty_fun ("", ctyp t, class_type ct)) + | CtSig (loc, t_o, ctfl) -> + let t = + (match t_o with | Ast.TyNil _ -> Ast.TyAny loc | t -> t) in + let cil = class_sig_item ctfl [] + in mkcty loc (Pcty_signature (((ctyp t), cil))) + | CtCon (loc, _, _, _) -> + error loc "invalid virtual class inside a class type" + | CtAnt (_, _) | CtEq (_, _, _) | CtCol (_, _, _) | + CtAnd (_, _, _) | CtNil _ -> assert false + and class_info_class_expr ci = + match ci with + | CeEq (_, (CeCon (loc, vir, (IdLid (_, name)), params)), ce) + -> + let (loc_params, (params, variance)) = + (match params with + | Ast.TyNil _ -> (loc, ([], [])) + | t -> + ((loc_of_ctyp t), + (List.split (class_parameters t [])))) + in + { + + pci_virt = if mb2b vir then Virtual else Concrete; + pci_params = (params, (mkloc loc_params)); + pci_name = name; + pci_expr = class_expr ce; + pci_loc = mkloc loc; + pci_variance = variance; + } + | ce -> error (loc_of_class_expr ce) "bad class definition" + and class_info_class_type ci = + match ci with + | CtEq (_, (CtCon (loc, vir, (IdLid (_, name)), params)), ct) | + CtCol (_, (CtCon (loc, vir, (IdLid (_, name)), params)), + ct) + -> + let (loc_params, (params, variance)) = + (match params with + | Ast.TyNil _ -> (loc, ([], [])) + | t -> + ((loc_of_ctyp t), + (List.split (class_parameters t [])))) + in + { + + pci_virt = if mb2b vir then Virtual else Concrete; + pci_params = (params, (mkloc loc_params)); + pci_name = name; + pci_expr = class_type ct; + pci_loc = mkloc loc; + pci_variance = variance; + } + | ct -> + error (loc_of_class_type ct) + "bad class/class type declaration/definition" + and class_sig_item c l = + match c with + | Ast.CgNil _ -> l + | CgCtr (loc, t1, t2) -> + (Pctf_cstr (((ctyp t1), (ctyp t2), (mkloc loc)))) :: l + | Ast.CgSem (_, csg1, csg2) -> + class_sig_item csg1 (class_sig_item csg2 l) + | CgInh (_, ct) -> (Pctf_inher (class_type ct)) :: l + | CgMth (loc, s, pf, t) -> + (Pctf_meth + ((s, (mkprivate pf), (mkpolytype (ctyp t)), (mkloc loc)))) :: + l + | CgVal (loc, s, b, v, t) -> + (Pctf_val + ((s, (mkmutable b), (mkvirtual v), (ctyp t), + (mkloc loc)))) :: + l + | CgVir (loc, s, b, t) -> + (Pctf_virt + ((s, (mkprivate b), (mkpolytype (ctyp t)), (mkloc loc)))) :: + l + | CgAnt (_, _) -> assert false + and class_expr = + function + | (CeApp (loc, _, _) as c) -> + let (ce, el) = class_expr_fa [] c in + let el = List.map label_expr el + in mkpcl loc (Pcl_apply (class_expr ce, el)) + | CeCon (loc, Ast.BFalse, id, tl) -> + mkpcl loc + (Pcl_constr (long_class_ident id, + List.map ctyp (list_of_opt_ctyp tl []))) + | CeFun (loc, (PaLab (_, lab, po)), ce) -> + mkpcl loc + (Pcl_fun (lab, None, patt_of_lab loc lab po, + class_expr ce)) + | CeFun (loc, (PaOlbi (_, lab, p, e)), ce) -> + let lab = paolab lab p + in + mkpcl loc + (Pcl_fun ("?" ^ lab, Some (expr e), patt p, + class_expr ce)) + | CeFun (loc, (PaOlb (_, lab, p)), ce) -> + let lab = paolab lab p + in + mkpcl loc + (Pcl_fun ("?" ^ lab, None, patt_of_lab loc lab p, + class_expr ce)) + | CeFun (loc, p, ce) -> + mkpcl loc (Pcl_fun ("", None, patt p, class_expr ce)) + | CeLet (loc, rf, bi, ce) -> + mkpcl loc (Pcl_let (mkrf rf, binding bi [], class_expr ce)) + | CeStr (loc, po, cfl) -> + let p = + (match po with | Ast.PaNil _ -> Ast.PaAny loc | p -> p) in + let cil = class_str_item cfl [] + in mkpcl loc (Pcl_structure (((patt p), cil))) + | CeTyc (loc, ce, ct) -> + mkpcl loc (Pcl_constraint (class_expr ce, class_type ct)) + | CeCon (loc, _, _, _) -> + error loc "invalid virtual class inside a class expression" + | CeAnt (_, _) | CeEq (_, _, _) | CeAnd (_, _, _) | CeNil _ -> + assert false + and class_str_item c l = + match c with + | CrNil _ -> l + | CrCtr (loc, t1, t2) -> + (Pcf_cstr (((ctyp t1), (ctyp t2), (mkloc loc)))) :: l + | Ast.CrSem (_, cst1, cst2) -> + class_str_item cst1 (class_str_item cst2 l) + | CrInh (_, ce, "") -> (Pcf_inher (class_expr ce, None)) :: l + | CrInh (_, ce, pb) -> + (Pcf_inher (class_expr ce, Some pb)) :: l + | CrIni (_, e) -> (Pcf_init (expr e)) :: l + | CrMth (loc, s, b, e, t) -> + let t = + (match t with + | Ast.TyNil _ -> None + | t -> Some (mkpolytype (ctyp t))) in + let e = mkexp loc (Pexp_poly (expr e, t)) + in (Pcf_meth ((s, (mkprivate b), e, (mkloc loc)))) :: l + | CrVal (loc, s, b, e) -> + (Pcf_val ((s, (mkmutable b), (expr e), (mkloc loc)))) :: l + | CrVir (loc, s, b, t) -> + (Pcf_virt + ((s, (mkprivate b), (mkpolytype (ctyp t)), (mkloc loc)))) :: + l + | CrVvr (loc, s, b, t) -> + (Pcf_valvirt ((s, (mkmutable b), (ctyp t), (mkloc loc)))) :: + l + | CrAnt (_, _) -> assert false + let sig_item ast = sig_item ast [] + let str_item ast = str_item ast [] + let directive = + function + | Ast.ExNil _ -> Pdir_none + | ExStr (_, s) -> Pdir_string s + | ExInt (_, i) -> Pdir_int (int_of_string i) + | Ast.ExId (_, (Ast.IdUid (_, "True"))) -> Pdir_bool true + | Ast.ExId (_, (Ast.IdUid (_, "False"))) -> Pdir_bool false + | e -> Pdir_ident (ident (ident_of_expr e)) + let phrase = + function + | StDir (_, d, dp) -> Ptop_dir (d, directive dp) + | si -> Ptop_def (str_item si) + end + end + module CleanAst = + struct + module Make (Ast : Sig.Camlp4Ast) = + struct + class clean_ast = + object (self) + inherit Ast.map as super + method with_constr = + function + | Ast.WcAnd (_, (Ast.WcNil _), wc) | + Ast.WcAnd (_, wc, (Ast.WcNil _)) -> self#with_constr wc + | wc -> super#with_constr wc + method expr = + function + | Ast.ExLet (_, _, (Ast.BiNil _), e) | + Ast.ExRec (_, (Ast.BiNil _), e) | + Ast.ExCom (_, (Ast.ExNil _), e) | + Ast.ExCom (_, e, (Ast.ExNil _)) | + Ast.ExSem (_, (Ast.ExNil _), e) | + Ast.ExSem (_, e, (Ast.ExNil _)) -> self#expr e + | e -> super#expr e + method patt = + function + | Ast.PaAli (_, p, (Ast.PaNil _)) | + Ast.PaOrp (_, (Ast.PaNil _), p) | + Ast.PaOrp (_, p, (Ast.PaNil _)) | + Ast.PaCom (_, (Ast.PaNil _), p) | + Ast.PaCom (_, p, (Ast.PaNil _)) | + Ast.PaSem (_, (Ast.PaNil _), p) | + Ast.PaSem (_, p, (Ast.PaNil _)) -> self#patt p + | p -> super#patt p + method match_case = + function + | Ast.McOr (_, (Ast.McNil _), mc) | + Ast.McOr (_, mc, (Ast.McNil _)) -> self#match_case mc + | mc -> super#match_case mc + method binding = + function + | Ast.BiAnd (_, (Ast.BiNil _), bi) | + Ast.BiAnd (_, bi, (Ast.BiNil _)) | + Ast.BiSem (_, (Ast.BiNil _), bi) | + Ast.BiSem (_, bi, (Ast.BiNil _)) -> self#binding bi + | bi -> super#binding bi + method module_binding = + function + | Ast.MbAnd (_, (Ast.MbNil _), mb) | + Ast.MbAnd (_, mb, (Ast.MbNil _)) -> + self#module_binding mb + | mb -> super#module_binding mb + method ctyp = + function + | Ast.TyPol (_, (Ast.TyNil _), t) | + Ast.TyAli (_, (Ast.TyNil _), t) | + Ast.TyAli (_, t, (Ast.TyNil _)) | + Ast.TyArr (_, t, (Ast.TyNil _)) | + Ast.TyArr (_, (Ast.TyNil _), t) | + Ast.TyOr (_, (Ast.TyNil _), t) | + Ast.TyOr (_, t, (Ast.TyNil _)) | + Ast.TyOf (_, t, (Ast.TyNil _)) | + Ast.TyAnd (_, (Ast.TyNil _), t) | + Ast.TyAnd (_, t, (Ast.TyNil _)) | + Ast.TySem (_, t, (Ast.TyNil _)) | + Ast.TySem (_, (Ast.TyNil _), t) | + Ast.TyCom (_, (Ast.TyNil _), t) | + Ast.TyCom (_, t, (Ast.TyNil _)) | + Ast.TyAmp (_, t, (Ast.TyNil _)) | + Ast.TyAmp (_, (Ast.TyNil _), t) | + Ast.TySta (_, (Ast.TyNil _), t) | + Ast.TySta (_, t, (Ast.TyNil _)) -> self#ctyp t + | t -> super#ctyp t + method sig_item = + function + | Ast.SgSem (_, (Ast.SgNil _), sg) | + Ast.SgSem (_, sg, (Ast.SgNil _)) -> self#sig_item sg + | sg -> super#sig_item sg + method str_item = + function + | Ast.StSem (_, (Ast.StNil _), st) | + Ast.StSem (_, st, (Ast.StNil _)) -> self#str_item st + | st -> super#str_item st + method module_type = + function + | Ast.MtWit (_, mt, (Ast.WcNil _)) -> self#module_type mt + | mt -> super#module_type mt + method class_expr = + function + | Ast.CeAnd (_, (Ast.CeNil _), ce) | + Ast.CeAnd (_, ce, (Ast.CeNil _)) -> self#class_expr ce + | ce -> super#class_expr ce + method class_type = + function + | Ast.CtAnd (_, (Ast.CtNil _), ct) | + Ast.CtAnd (_, ct, (Ast.CtNil _)) -> self#class_type ct + | ct -> super#class_type ct + method class_sig_item = + function + | Ast.CgSem (_, (Ast.CgNil _), csg) | + Ast.CgSem (_, csg, (Ast.CgNil _)) -> + self#class_sig_item csg + | csg -> super#class_sig_item csg + method class_str_item = + function + | Ast.CrSem (_, (Ast.CrNil _), cst) | + Ast.CrSem (_, cst, (Ast.CrNil _)) -> + self#class_str_item cst + | cst -> super#class_str_item cst + end + end + end + module CommentFilter : + sig + module Make (Token : Sig.Camlp4Token) : + sig + open Token + type t + val mk : unit -> t + val define : Token.Filter.t -> t -> unit + val filter : + t -> (Token.t * Loc.t) Stream.t -> (Token.t * Loc.t) Stream.t + val take_list : t -> (string * Loc.t) list + val take_stream : t -> (string * Loc.t) Stream.t + end + end = + struct + module Make (Token : Sig.Camlp4Token) = + struct + open Token + type t = + (((string * Loc.t) Stream.t) * ((string * Loc.t) Queue.t)) + let mk () = + let q = Queue.create () in + let f _ = try Some (Queue.take q) with | Queue.Empty -> None + in ((Stream.from f), q) + let filter (_, q) = + let rec self (__strm : _ Stream.t) = + match Stream.peek __strm with + | Some ((Sig.COMMENT x, loc)) -> + (Stream.junk __strm; + let xs = __strm in (Queue.add (x, loc) q; self xs)) + | Some x -> + (Stream.junk __strm; + let xs = __strm + in Stream.icons x (Stream.slazy (fun _ -> self xs))) + | _ -> Stream.sempty + in self + let take_list (_, q) = + let rec self accu = + if Queue.is_empty q + then accu + else self ((Queue.take q) :: accu) + in self [] + let take_stream = fst + let define token_fiter comments_strm = + Token.Filter.define_filter token_fiter + (fun previous strm -> previous (filter comments_strm strm)) + end + end + module DynLoader : sig include Sig.DynLoader end = + struct + type t = string Queue.t + exception Error of string * string + let include_dir x y = Queue.add y x + let fold_load_path x f acc = Queue.fold (fun x y -> f y x) acc x + let mk ?(ocaml_stdlib = true) ?(camlp4_stdlib = true) () = + let q = Queue.create () + in + (if ocaml_stdlib + then include_dir q Camlp4_config.ocaml_standard_library + else (); + if camlp4_stdlib + then + (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) + let 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 -> + function + | 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) + let load = + let _initialized = ref false + in + fun _path file -> + raise + (Error (file, "native-code program cannot do a dynamic load")) + end + module EmptyError : sig include Sig.Error end = + struct + type t = unit + exception E of t + let print _ = assert false + let to_string _ = assert false + end + module EmptyPrinter : + sig module Make (Ast : Sig.Ast) : Sig.Printer with module Ast = Ast end = + struct + module Make (Ast : Sig.Ast) = + struct + module Ast = Ast + let print_interf ?input_file:(_) ?output_file:(_) _ = + failwith "No interface printer" + let print_implem ?input_file:(_) ?output_file:(_) _ = + failwith "No implementation printer" + end + end + module FreeVars : + sig + module Make (Ast : Sig.Camlp4Ast) : + sig + module S : Set.S with type elt = string + val fold_binding_vars : + (string -> 'accu -> 'accu) -> Ast.binding -> 'accu -> 'accu + class ['accu] c_fold_pattern_vars : + (string -> 'accu -> 'accu) -> + 'accu -> + object inherit Ast.fold val acc : 'accu method acc : 'accu + end + val fold_pattern_vars : + (string -> 'accu -> 'accu) -> Ast.patt -> 'accu -> 'accu + class ['accu] fold_free_vars : + (string -> 'accu -> 'accu) -> + ?env_init: S.t -> + 'accu -> + object ('self_type) + inherit Ast.fold + val free : 'accu + val env : S.t + method free : 'accu + method set_env : S.t -> 'self_type + method add_atom : string -> 'self_type + method add_patt : Ast.patt -> 'self_type + method add_binding : Ast.binding -> 'self_type + end + val free_vars : S.t -> Ast.expr -> S.t + end + end = + struct + module Make (Ast : Sig.Camlp4Ast) = + struct + module S = Set.Make(String) + let rec fold_binding_vars f bi acc = + match bi with + | Ast.BiAnd (_, bi1, bi2) | Ast.BiSem (_, bi1, bi2) -> + fold_binding_vars f bi1 (fold_binding_vars f bi2 acc) + | Ast.BiEq (_, (Ast.PaId (_, (Ast.IdLid (_, i)))), _) -> + f i acc + | _ -> assert false + class ['accu] c_fold_pattern_vars f init = + object (o) + inherit Ast.fold as super + val acc = init + method acc : 'accu = acc + method patt = + function + | Ast.PaId (_, (Ast.IdLid (_, s))) | + Ast.PaLab (_, s, (Ast.PaNil _)) | + Ast.PaOlb (_, s, (Ast.PaNil _)) -> + {< acc = f s acc; >} + | Ast.PaEq (_, (Ast.PaId (_, (Ast.IdLid (_, _)))), p) -> + o#patt p + | p -> super#patt p + end + let fold_pattern_vars f p init = + ((new c_fold_pattern_vars f init)#patt p)#acc + class ['accu] fold_free_vars (f : string -> 'accu -> 'accu) + ?(env_init = S.empty) free_init = + object (o) + inherit Ast.fold as super + val free = (free_init : 'accu) + val env = (env_init : S.t) + method free = free + method set_env = fun env -> {< env = env; >} + method add_atom = fun s -> {< env = S.add s env; >} + method add_patt = + fun p -> {< env = fold_pattern_vars S.add p env; >} + method add_binding = + fun bi -> {< env = fold_binding_vars S.add bi env; >} + method expr = + function + | Ast.ExId (_, (Ast.IdLid (_, s))) | + Ast.ExLab (_, s, (Ast.ExNil _)) | + Ast.ExOlb (_, s, (Ast.ExNil _)) -> + if S.mem s env then o else {< free = f s free; >} + | Ast.ExLet (_, Ast.BFalse, bi, e) -> + (((o#add_binding bi)#expr e)#set_env env)#binding bi + | Ast.ExLet (_, Ast.BTrue, bi, e) -> + (((o#add_binding bi)#expr e)#binding bi)#set_env env + | Ast.ExFor (_, s, e1, e2, _, e3) -> + ((((o#expr e1)#expr e2)#add_atom s)#expr e3)#set_env + env + | Ast.ExId (_, _) | Ast.ExNew (_, _) -> o + | Ast.ExObj (_, p, cst) -> + ((o#add_patt p)#class_str_item cst)#set_env env + | e -> super#expr e + method match_case = + function + | Ast.McArr (_, p, e1, e2) -> + (((o#add_patt p)#expr e1)#expr e2)#set_env env + | m -> super#match_case m + method str_item = + function + | Ast.StExt (_, s, t, _) -> (o#ctyp t)#add_atom s + | Ast.StVal (_, Ast.BFalse, bi) -> + (o#binding bi)#add_binding bi + | Ast.StVal (_, Ast.BTrue, bi) -> + (o#add_binding bi)#binding bi + | st -> super#str_item st + method class_expr = + function + | Ast.CeFun (_, p, ce) -> + ((o#add_patt p)#class_expr ce)#set_env env + | Ast.CeLet (_, Ast.BFalse, bi, ce) -> + (((o#binding bi)#add_binding bi)#class_expr ce)#set_env + env + | Ast.CeLet (_, Ast.BTrue, bi, ce) -> + (((o#add_binding bi)#binding bi)#class_expr ce)#set_env + env + | Ast.CeStr (_, p, cst) -> + ((o#add_patt p)#class_str_item cst)#set_env env + | ce -> super#class_expr ce + method class_str_item = + function + | (Ast.CrInh (_, _, "") as cst) -> super#class_str_item cst + | Ast.CrInh (_, ce, s) -> (o#class_expr ce)#add_atom s + | Ast.CrVal (_, s, _, e) -> (o#expr e)#add_atom s + | Ast.CrVvr (_, s, _, t) -> (o#ctyp t)#add_atom s + | cst -> super#class_str_item cst + method module_expr = + function + | Ast.MeStr (_, st) -> (o#str_item st)#set_env env + | me -> super#module_expr me + end + let free_vars env_init e = + let fold = new fold_free_vars S.add ~env_init S.empty + in (fold#expr e)#free + end + end + module Grammar = + struct + module Context = + struct + module type S = + sig + module Token : Sig.Token + open Token + type t + val call_with_ctx : + (Token.t * Loc.t) Stream.t -> (t -> 'a) -> 'a + val loc_bp : t -> Loc.t + val loc_ep : t -> Loc.t + val stream : t -> (Token.t * Loc.t) Stream.t + val peek_nth : t -> int -> (Token.t * Loc.t) option + val njunk : t -> int -> unit + val junk : (Token.t * Loc.t) Stream.t -> unit + val bp : (Token.t * Loc.t) Stream.t -> Loc.t + end + module Make (Token : Sig.Token) : S with module Token = Token = + struct + module Token = Token + open Token + type t = + { mutable strm : (Token.t * Loc.t) Stream.t; + mutable loc : Loc.t + } + let loc_bp c = + match Stream.peek c.strm with + | None -> Loc.ghost + | Some ((_, loc)) -> loc + let loc_ep c = c.loc + let set_loc c = + match Stream.peek c.strm with + | Some ((_, loc)) -> c.loc <- loc + | None -> () + let mk strm = + match Stream.peek strm with + | Some ((_, loc)) -> { strm = strm; loc = loc; } + | None -> { strm = strm; loc = Loc.ghost; } + let stream c = c.strm + let peek_nth c n = + let list = Stream.npeek n c.strm in + let rec loop list n = + match (list, n) with + | ((((_, loc) as x)) :: _, 1) -> (c.loc <- loc; Some x) + | (_ :: l, n) -> loop l (n - 1) + | ([], _) -> None + in loop list n + let njunk c n = + (for i = 1 to n do Stream.junk c.strm done; set_loc c) + let streams = ref [] + let mk strm = + let c = mk strm in + let () = streams := (strm, c) :: !streams in c + let junk strm = + (set_loc (List.assq strm !streams); Stream.junk strm) + let bp strm = loc_bp (List.assq strm !streams) + let call_with_ctx strm f = + let streams_v = !streams in + let r = + try f (mk strm) + with | exc -> (streams := streams_v; raise exc) + in (streams := streams_v; r) + end + end + module Structure = + struct + 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 Context : Context.S with module Token = Token + module Action : Sig.Grammar.Action + type gram = + { gfilter : Token.Filter.t; + gkeywords : (string, int ref) Hashtbl.t; + glexer : + Loc.t -> char Stream.t -> (Token.t * Loc.t) Stream.t; + warning_verbose : bool ref; error_verbose : bool ref + } + type efun = + Context.t -> (Token.t * Loc.t) Stream.t -> Action.t + type token_pattern = ((Token.t -> bool) * string) + type internal_entry = + { egram : gram; ename : string; + mutable estart : int -> efun; + mutable econtinue : int -> Loc.t -> Action.t -> efun; + mutable edesc : desc + } + and desc = + | Dlevels of level list + | Dparser of ((Token.t * Loc.t) Stream.t -> Action.t) + and level = + { assoc : assoc; lname : string option; lsuffix : tree; + lprefix : tree + } + and symbol = + | Smeta of string * symbol list * Action.t + | Snterm of internal_entry + | Snterml of internal_entry * string | Slist0 of symbol + | Slist0sep of symbol * symbol | Slist1 of symbol + | Slist1sep of symbol * symbol | Sopt of symbol | Sself + | Snext | Stoken of token_pattern | Skeyword of string + | Stree of tree + and tree = + | Node of node | LocAct of Action.t * Action.t list + | DeadEnd + and node = + { node : symbol; son : tree; brother : tree + } + type production_rule = ((symbol list) * Action.t) + type single_extend_statment = + ((string option) * (assoc option) * (production_rule list)) + type extend_statment = + ((position option) * (single_extend_statment list)) + type delete_statment = symbol list + type ('a, 'b, 'c) fold = + internal_entry -> + symbol list -> ('a Stream.t -> 'b) -> 'a Stream.t -> 'c + type ('a, 'b, 'c) foldsep = + internal_entry -> + symbol list -> + ('a Stream.t -> 'b) -> + ('a Stream.t -> unit) -> 'a Stream.t -> 'c + val get_filter : gram -> Token.Filter.t + val using : gram -> string -> unit + val 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 + let mk = Obj.repr + let get = Obj.obj + let getf = Obj.obj + let getf2 = Obj.obj + end + module Lexer = Lexer + type gram = + { gfilter : Token.Filter.t; + gkeywords : (string, int ref) Hashtbl.t; + glexer : + Loc.t -> char Stream.t -> (Token.t * Loc.t) Stream.t; + warning_verbose : bool ref; error_verbose : bool ref + } + module Context = Context.Make(Token) + type efun = + Context.t -> (Token.t * Loc.t) Stream.t -> Action.t + type token_pattern = ((Token.t -> bool) * string) + type internal_entry = + { egram : gram; ename : string; + mutable estart : int -> efun; + mutable econtinue : int -> Loc.t -> Action.t -> efun; + mutable edesc : desc + } + and desc = + | Dlevels of level list + | Dparser of ((Token.t * Loc.t) Stream.t -> Action.t) + and level = + { assoc : assoc; lname : string option; lsuffix : tree; + lprefix : tree + } + and symbol = + | Smeta of string * symbol list * Action.t + | Snterm of internal_entry + | Snterml of internal_entry * string | Slist0 of symbol + | Slist0sep of symbol * symbol | Slist1 of symbol + | Slist1sep of symbol * symbol | Sopt of symbol | Sself + | Snext | Stoken of token_pattern | Skeyword of string + | Stree of tree + and tree = + | Node of node | LocAct of Action.t * Action.t list + | DeadEnd + and node = + { node : symbol; son : tree; brother : tree + } + type production_rule = ((symbol list) * Action.t) + type single_extend_statment = + ((string option) * (assoc option) * (production_rule list)) + type extend_statment = + ((position option) * (single_extend_statment list)) + type delete_statment = symbol list + type ('a, 'b, 'c) fold = + internal_entry -> + symbol list -> ('a Stream.t -> 'b) -> 'a Stream.t -> 'c + type ('a, 'b, 'c) foldsep = + internal_entry -> + symbol list -> + ('a Stream.t -> 'b) -> + ('a Stream.t -> unit) -> 'a Stream.t -> 'c + let get_filter g = g.gfilter + type 'a not_filtered = 'a + let using { gkeywords = table; gfilter = filter } kwd = + let r = + try Hashtbl.find table kwd + with + | Not_found -> + let r = ref 0 in (Hashtbl.add table kwd r; r) + in (Token.Filter.keyword_added filter kwd (!r = 0); incr r) + let removing { gkeywords = table; gfilter = filter } kwd = + let r = Hashtbl.find table kwd in + let () = decr r + in + if !r = 0 + then + (Token.Filter.keyword_removed filter kwd; + Hashtbl.remove table kwd) + else () + end + end + module Search = + struct + module Make (Structure : Structure.S) = + struct + open Structure + let tree_in_entry prev_symb tree = + function + | Dlevels levels -> + let rec search_levels = + (function + | [] -> 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 _ | 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) + | Stree t -> + (match search_tree t with + | Some t -> Some (Stree t) + | None -> None) + | _ -> None) + in search_levels levels + | Dparser _ -> tree + end + end + module Tools = + struct + module Make (Structure : Structure.S) = + struct + open Structure + let empty_entry ename _ _ _ = + raise (Stream.Error ("entry [" ^ (ename ^ "] is empty"))) + let is_level_labelled n lev = + match lev.lname with | Some n1 -> n = n1 | None -> false + let warning_verbose = ref true + let 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)) + let is_antiquot s = + let len = String.length s in (len > 1) && (s.[0] = '$') + let eq_Stoken_ids s1 s2 = + (not (is_antiquot s1)) && + ((not (is_antiquot s2)) && (s1 = s2)) + let 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) -> eq_symbols s1 s2 + | (Slist0sep (s1, sep1), Slist0sep (s2, sep2)) -> + (eq_symbols s1 s2) && (eq_symbols sep1 sep2) + | (Slist1 s1, Slist1 s2) -> eq_symbols s1 s2 + | (Slist1sep (s1, sep1), Slist1sep (s2, sep2)) -> + (eq_symbols s1 s2) && (eq_symbols sep1 sep2) + | (Sopt s1, Sopt s2) -> eq_symbols s1 s2 + | (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 + let 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) -> eq_symbol s1 s2 + | (Slist0sep (s1, sep1), Slist0sep (s2, sep2)) -> + (eq_symbol s1 s2) && (eq_symbol sep1 sep2) + | (Slist1 s1, Slist1 s2) -> eq_symbol s1 s2 + | (Slist1sep (s1, sep1), Slist1sep (s2, sep2)) -> + (eq_symbol s1 s2) && (eq_symbol sep1 sep2) + | (Sopt s1, Sopt s2) -> eq_symbol s1 s2 + | (Stree _, Stree _) -> false + | (Stoken ((_, s1)), Stoken ((_, s2))) -> + eq_Stoken_ids s1 s2 + | _ -> s1 = s2 + end + end + module Print : + sig + module Make (Structure : Structure.S) : + sig + val flatten_tree : + Structure.tree -> (Structure.symbol list) list + val print_symbol : + Format.formatter -> Structure.symbol -> unit + val print_meta : + Format.formatter -> string -> Structure.symbol list -> unit + val print_symbol1 : + Format.formatter -> Structure.symbol -> unit + val print_rule : + Format.formatter -> Structure.symbol list -> unit + val print_level : + Format.formatter -> + (Format.formatter -> unit -> unit) -> + (Structure.symbol list) list -> unit + val levels : Format.formatter -> Structure.level list -> unit + val entry : + Format.formatter -> Structure.internal_entry -> unit + end + module MakeDump (Structure : Structure.S) : + sig + val print_symbol : + Format.formatter -> Structure.symbol -> unit + val print_meta : + Format.formatter -> string -> Structure.symbol list -> unit + val print_symbol1 : + Format.formatter -> Structure.symbol -> unit + val print_rule : + Format.formatter -> Structure.symbol list -> unit + val print_level : + Format.formatter -> + (Format.formatter -> unit -> unit) -> + (Structure.symbol list) list -> unit + val levels : Format.formatter -> Structure.level list -> unit + val entry : + Format.formatter -> Structure.internal_entry -> unit + end + end = + struct + module Make (Structure : Structure.S) = + struct + open Structure + open Format + open Sig.Grammar + let rec flatten_tree = + function + | DeadEnd -> [] + | LocAct (_, _) -> [ [] ] + | Node { node = n; brother = b; son = s } -> + (List.map (fun l -> n :: l) (flatten_tree s)) @ + (flatten_tree b) + let rec print_symbol ppf = + function + | 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 + | 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 = + let rec loop i = + function + | [] -> () + | s :: sl -> + let j = + (try String.index_from n i ' ' + with | Not_found -> String.length n) + in + (fprintf ppf "%s %a" (String.sub n i (j - i)) + print_symbol1 s; + if sl = [] + then () + else + (fprintf ppf " "; + loop (min (j + 1) (String.length n)) sl)) + in loop 0 sl + and print_symbol1 ppf = + function + | 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 _ + as s) -> fprintf ppf "(%a)" print_symbol s + and print_rule ppf symbols = + (fprintf ppf "@["; + let _ = + List.fold_left + (fun sep symbol -> + (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 = + (fprintf ppf "@[[ "; + let _ = + List.fold_left + (fun sep rule -> + (fprintf ppf "%t%a" sep print_rule rule; + fun ppf -> fprintf ppf "%a| " pp_print_space ())) + (fun _ -> ()) rules + in fprintf ppf " ]@]") + let levels ppf elev = + let _ = + List.fold_left + (fun sep lev -> + let rules = + (List.map (fun t -> Sself :: t) + (flatten_tree lev.lsuffix)) + @ (flatten_tree lev.lprefix) + in + (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 () + let entry ppf e = + (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 * brothers list + let rec print_tree ppf tree = + let rec get_brothers acc = + function + | 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 + (function + | Bro (n, xs) -> + (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 = + function + | [] -> List.rev acc + | [ Bro (n, x) ] -> get_children (n :: acc) x + | _ -> raise Exit + in print_brothers ppf (get_brothers [] tree) + and print_symbol ppf = + function + | 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 + | 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 = + let rec loop i = + function + | [] -> () + | s :: sl -> + let j = + (try String.index_from n i ' ' + with | Not_found -> String.length n) + in + (fprintf ppf "%s %a" (String.sub n i (j - i)) + print_symbol1 s; + if sl = [] + then () + else + (fprintf ppf " "; + loop (min (j + 1) (String.length n)) sl)) + in loop 0 sl + and print_symbol1 ppf = + function + | 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 _ + as s) -> fprintf ppf "(%a)" print_symbol s + and print_rule ppf symbols = + (fprintf ppf "@["; + let _ = + List.fold_left + (fun sep symbol -> + (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 = + (fprintf ppf "@[[ "; + let _ = + List.fold_left + (fun sep rule -> + (fprintf ppf "%t%a" sep print_rule rule; + fun ppf -> fprintf ppf "%a| " pp_print_space ())) + (fun _ -> ()) rules + in fprintf ppf " ]@]") + let levels ppf elev = + let _ = + List.fold_left + (fun sep lev -> + (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 () + let entry ppf e = + (fprintf ppf "@[%s: [ " e.ename; + (match e.edesc with + | Dlevels elev -> levels ppf elev + | Dparser _ -> fprintf ppf ""); + fprintf ppf " ]@]") + end + end + module Failed = + struct + 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 + let rec name_of_symbol entry = + function + | Snterm e -> "[" ^ (e.ename ^ "]") + | Snterml (e, l) -> + "[" ^ (e.ename ^ (" level " ^ (l ^ "]"))) + | Sself | Snext -> "[" ^ (entry.ename ^ "]") + | Stoken ((_, descr)) -> descr + | Skeyword kwd -> "\"" ^ (kwd ^ "\"") + | _ -> "???" + let rec name_of_symbol_failed entry = + function + | Slist0 s -> name_of_symbol_failed entry s + | Slist0sep (s, _) -> name_of_symbol_failed entry s + | Slist1 s -> name_of_symbol_failed entry s + | Slist1sep (s, _) -> name_of_symbol_failed entry s + | Sopt 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 = + function + | 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 (_, _) -> "???" + let magic _s x = Obj.magic x + let 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"))) + | Sopt _ | Stree _ -> txt ^ " expected" + | _ -> + txt ^ + (" expected after " ^ + (name_of_symbol entry prev_symb)) + in + (if !(entry.egram.error_verbose) + then + (let tree = + Search.tree_in_entry prev_symb tree entry.edesc in + let ppf = err_formatter + in + (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 ^ "])"))) + let 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 + let symb_failed_txt e s1 s2 = symb_failed e 0 s1 s2 + end + end + module Parser = + struct + 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 Stream = + struct + include Stream + let junk strm = Context.junk strm + let count strm = Context.bp strm + end + let add_loc c bp parse_fun strm = + let x = parse_fun c strm in + let ep = Context.loc_ep c in + let loc = Loc.merge bp ep in (x, loc) + let level_number entry lab = + let rec lookup levn = + function + | [] -> 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 + let strict_parsing = ref false + let strict_parsing_warning = ref false + let rec top_symb entry = + function + | Sself | Snext -> Snterm entry + | Snterml (e, _) -> Snterm e + | Slist1sep (s, sep) -> Slist1sep (top_symb entry s, sep) + | _ -> raise Stream.Failure + let top_tree entry = + function + | Node { node = s; brother = bro; son = son } -> + Node + { node = top_symb entry s; brother = bro; son = son; + } + | LocAct (_, _) | DeadEnd -> raise Stream.Failure + let entry_of_symb entry = + function + | Sself | Snext -> entry + | Snterm e -> e + | Snterml (e, _) -> e + | _ -> raise Stream.Failure + let continue entry loc a s c son p1 (__strm : _ Stream.t) = + let a = + (entry_of_symb entry s).econtinue 0 loc a c __strm in + let act = + try p1 __strm + with + | Stream.Failure -> + raise + (Stream.Error (Failed.tree_failed entry a s son)) + in Action.mk (fun _ -> Action.getf act a) + let skip_if_empty c bp p strm = + if (Context.loc_ep c) == bp + then Action.mk (fun _ -> p strm) + else raise Stream.Failure + let do_recover parser_of_tree entry nlevn alevn loc a s c son + (__strm : _ Stream.t) = + try + parser_of_tree entry nlevn alevn (top_tree entry son) c + __strm + with + | Stream.Failure -> + (try + skip_if_empty c loc + (fun (__strm : _ Stream.t) -> raise Stream.Failure) + __strm + with + | Stream.Failure -> + continue entry loc a s c son + (parser_of_tree entry nlevn alevn son c) __strm) + let recover parser_of_tree entry nlevn alevn loc a s c son + strm = + if !strict_parsing + then + raise (Stream.Error (Failed.tree_failed entry a s son)) + else + (let _ = + if !strict_parsing_warning + then + (let msg = Failed.tree_failed entry a s son + in + (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)) + else () + in + do_recover parser_of_tree entry nlevn alevn loc a s c + son strm) + let rec parser_of_tree entry nlevn alevn = + function + | DeadEnd -> + (fun _ (__strm : _ Stream.t) -> raise Stream.Failure) + | LocAct (act, _) -> (fun _ (__strm : _ Stream.t) -> act) + | Node + { + node = Sself; + son = LocAct (act, _); + brother = DeadEnd + } -> + (fun c (__strm : _ Stream.t) -> + let a = entry.estart alevn c __strm + in Action.getf act a) + | Node { node = Sself; son = LocAct (act, _); brother = bro + } -> + let p2 = parser_of_tree entry nlevn alevn bro + in + (fun c (__strm : _ Stream.t) -> + match try Some (entry.estart alevn c __strm) + with | Stream.Failure -> None + with + | Some a -> Action.getf act a + | _ -> p2 c __strm) + | 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 c (__strm : _ Stream.t) -> + let bp = Stream.count __strm in + let a = ps c __strm in + let act = + try p1 c bp a __strm + with + | Stream.Failure -> + raise (Stream.Error "") + in 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 c (__strm : _ Stream.t) -> + let bp = Stream.count __strm + in + match try Some (ps c __strm) + with | Stream.Failure -> None + with + | Some a -> + let act = + (try p1 c bp a __strm + with + | Stream.Failure -> + raise (Stream.Error "")) + in Action.getf act a + | _ -> p2 c __strm) + | 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 + (fun c (__strm : _ Stream.t) -> + try p1 c __strm + with | Stream.Failure -> p2 c __strm)) + and + parser_cont p1 entry nlevn alevn s son c loc a + (__strm : _ Stream.t) = + try p1 c __strm + with + | Stream.Failure -> + (try + recover parser_of_tree entry nlevn alevn loc a s c + son __strm + with + | Stream.Failure -> + raise + (Stream.Error (Failed.tree_failed entry a s son))) + and parser_of_token_list p1 tokl = + let rec loop n = + function + | Stoken ((tematch, _)) :: tokl -> + (match tokl with + | [] -> + let ps c _ = + (match Context.peek_nth c n with + | Some ((tok, _)) when tematch tok -> + (Context.njunk c n; Action.mk tok) + | _ -> raise Stream.Failure) + in + (fun c (__strm : _ Stream.t) -> + let bp = Stream.count __strm in + let a = ps c __strm in + let act = + try p1 c bp a __strm + with + | Stream.Failure -> + raise (Stream.Error "") + in Action.getf act a) + | _ -> + let ps c _ = + (match Context.peek_nth c n with + | Some ((tok, _)) when tematch tok -> tok + | _ -> raise Stream.Failure) in + let p1 = loop (n + 1) tokl + in + (fun c (__strm : _ Stream.t) -> + let tok = ps c __strm in + let s = __strm in + let act = p1 c s in Action.getf act tok)) + | Skeyword kwd :: tokl -> + (match tokl with + | [] -> + let ps c _ = + (match Context.peek_nth c n with + | Some ((tok, _)) when + Token.match_keyword kwd tok -> + (Context.njunk c n; Action.mk tok) + | _ -> raise Stream.Failure) + in + (fun c (__strm : _ Stream.t) -> + let bp = Stream.count __strm in + let a = ps c __strm in + let act = + try p1 c bp a __strm + with + | Stream.Failure -> + raise (Stream.Error "") + in Action.getf act a) + | _ -> + let ps c _ = + (match Context.peek_nth c n with + | Some ((tok, _)) when + Token.match_keyword kwd tok -> tok + | _ -> raise Stream.Failure) in + let p1 = loop (n + 1) tokl + in + (fun c (__strm : _ Stream.t) -> + let tok = ps c __strm in + let s = __strm in + let act = p1 c s in Action.getf act tok)) + | _ -> invalid_arg "parser_of_token_list" + in loop 1 tokl + and parser_of_symbol entry nlevn = + function + | Smeta (_, symbl, act) -> + let act = Obj.magic act entry symbl in + let pl = List.map (parser_of_symbol entry nlevn) symbl + in + (fun c -> + Obj.magic + (List.fold_left + (fun act p -> Obj.magic act (p c)) act pl)) + | Slist0 s -> + let ps = parser_of_symbol entry nlevn s in + let rec loop c al (__strm : _ Stream.t) = + (match try Some (ps c __strm) + with | Stream.Failure -> None + with + | Some a -> loop c (a :: al) __strm + | _ -> al) + in + (fun c (__strm : _ Stream.t) -> + let a = loop c [] __strm in 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 c al (__strm : _ Stream.t) = + (match try Some (pt c __strm) + with | Stream.Failure -> None + with + | Some v -> + let a = + (try ps c __strm + with + | Stream.Failure -> + raise + (Stream.Error + (Failed.symb_failed entry v sep symb))) + in kont c (a :: al) __strm + | _ -> al) + in + (fun c (__strm : _ Stream.t) -> + match try Some (ps c __strm) + with | Stream.Failure -> None + with + | Some a -> + let s = __strm + in Action.mk (List.rev (kont c [ a ] s)) + | _ -> Action.mk []) + | Slist1 s -> + let ps = parser_of_symbol entry nlevn s in + let rec loop c al (__strm : _ Stream.t) = + (match try Some (ps c __strm) + with | Stream.Failure -> None + with + | Some a -> loop c (a :: al) __strm + | _ -> al) + in + (fun c (__strm : _ Stream.t) -> + let a = ps c __strm in + let s = __strm + in Action.mk (List.rev (loop c [ 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 c al (__strm : _ Stream.t) = + (match try Some (pt c __strm) + with | Stream.Failure -> None + with + | Some v -> + let a = + (try ps c __strm + with + | Stream.Failure -> + (try parse_top_symb' entry symb c __strm + with + | Stream.Failure -> + raise + (Stream.Error + (Failed.symb_failed entry v sep + symb)))) + in kont c (a :: al) __strm + | _ -> al) + in + (fun c (__strm : _ Stream.t) -> + let a = ps c __strm in + let s = __strm + in Action.mk (List.rev (kont c [ a ] s))) + | Sopt s -> + let ps = parser_of_symbol entry nlevn s + in + (fun c (__strm : _ Stream.t) -> + match try Some (ps c __strm) + with | Stream.Failure -> None + with + | Some a -> Action.mk (Some a) + | _ -> Action.mk None) + | Stree t -> + let pt = parser_of_tree entry 1 0 t + in + (fun c (__strm : _ Stream.t) -> + let bp = Stream.count __strm in + let (act, loc) = add_loc c bp pt __strm + in Action.getf act loc) + | Snterm e -> + (fun c (__strm : _ Stream.t) -> e.estart 0 c __strm) + | Snterml (e, l) -> + (fun c (__strm : _ Stream.t) -> + e.estart (level_number e l) c __strm) + | Sself -> + (fun c (__strm : _ Stream.t) -> entry.estart 0 c __strm) + | Snext -> + (fun c (__strm : _ Stream.t) -> + entry.estart nlevn c __strm) + | Skeyword kwd -> + (fun _ (__strm : _ Stream.t) -> + match Stream.peek __strm with + | Some ((tok, _)) when Token.match_keyword kwd tok + -> (Stream.junk __strm; Action.mk tok) + | _ -> raise Stream.Failure) + | Stoken ((f, _)) -> + (fun _ (__strm : _ Stream.t) -> + match Stream.peek __strm with + | Some ((tok, _)) when f tok -> + (Stream.junk __strm; Action.mk tok) + | _ -> raise Stream.Failure) + and parse_top_symb' entry symb c = + parser_of_symbol entry 0 (top_symb entry symb) c + and parse_top_symb entry symb strm = + Context.call_with_ctx strm + (fun c -> parse_top_symb' entry symb c (Context.stream c)) + let rec start_parser_of_levels entry clevn = + function + | [] -> + (fun _ _ (__strm : _ Stream.t) -> raise Stream.Failure) + | 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 c (__strm : _ Stream.t) -> + let bp = Stream.count __strm in + let (act, loc) = + add_loc c bp p2 __strm in + let strm = __strm in + let a = Action.getf act loc + in entry.econtinue levn loc a c strm) + | _ -> + (fun levn c strm -> + if levn > clevn + then p1 levn c strm + else + (let (__strm : _ Stream.t) = strm in + let bp = Stream.count __strm + in + match try + Some + (add_loc c bp p2 __strm) + with + | Stream.Failure -> None + with + | Some ((act, loc)) -> + let a = Action.getf act loc + in + entry.econtinue levn loc a + c strm + | _ -> p1 levn c __strm)))) + let start_parser_of_entry entry = + match entry.edesc with + | Dlevels [] -> Tools.empty_entry entry.ename + | Dlevels elev -> start_parser_of_levels entry 0 elev + | Dparser p -> (fun _ _ strm -> p strm) + let rec continue_parser_of_levels entry clevn = + function + | [] -> + (fun _ _ _ _ (__strm : _ Stream.t) -> + raise Stream.Failure) + | 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 c levn bp a strm -> + if levn > clevn + then p1 c levn bp a strm + else + (let (__strm : _ Stream.t) = strm in + let bp = Stream.count __strm + in + try p1 c levn bp a __strm + with + | Stream.Failure -> + let (act, loc) = + add_loc c bp p2 __strm in + let a = Action.getf2 act a loc + in + entry.econtinue levn loc a c + strm))) + let continue_parser_of_entry entry = + match entry.edesc with + | Dlevels elev -> + let p = continue_parser_of_levels entry 0 elev + in + (fun levn bp a c (__strm : _ Stream.t) -> + try p c levn bp a __strm + with | Stream.Failure -> a) + | Dparser _ -> + (fun _ _ _ _ (__strm : _ Stream.t) -> + raise Stream.Failure) + end + end + module Insert = + struct + module Make (Structure : Structure.S) = + struct + module Tools = Tools.Make(Structure) + module Parser = Parser.Make(Structure) + open Structure + open Format + open Sig.Grammar + let is_before s1 s2 = + match (s1, s2) with + | ((Skeyword _ | Stoken _), (Skeyword _ | Stoken _)) -> + false + | ((Skeyword _ | Stoken _), _) -> true + | _ -> false + let rec derive_eps = + function + | Slist0 _ -> true + | Slist0sep (_, _) -> true + | Sopt _ -> true + | Stree t -> tree_derive_eps t + | Smeta (_, _, _) | Slist1 _ | Slist1sep (_, _) | Snterm _ + | Snterml (_, _) | Snext | Sself | Stoken _ | + Skeyword _ -> false + and tree_derive_eps = + function + | LocAct (_, _) -> true + | Node { node = s; brother = bro; son = son } -> + ((derive_eps s) && (tree_derive_eps son)) || + (tree_derive_eps bro) + | DeadEnd -> false + let empty_lev lname assoc = + let assoc = match assoc with | Some a -> a | None -> LeftA + in + { + + assoc = assoc; + lname = lname; + lsuffix = DeadEnd; + lprefix = DeadEnd; + } + let change_lev entry lev n lname assoc = + let a = + match assoc with + | None -> lev.assoc + | Some a -> + (if + (a <> lev.assoc) && !(entry.egram.warning_verbose) + then + (eprintf + " Changing associativity of level \"%s\"\n" + n; + flush stderr) + else (); + a) + in + ((match lname with + | Some n -> + if + (lname <> lev.lname) && + !(entry.egram.warning_verbose) + then + (eprintf " Level label \"%s\" ignored\n" n; + flush stderr) + else () + | None -> ()); + { + + assoc = a; + lname = lev.lname; + lsuffix = lev.lsuffix; + lprefix = lev.lprefix; + }) + let change_to_self entry = + function | Snterm e when e == entry -> Sself | x -> x + let get_level entry position levs = + match position with + | Some First -> ([], empty_lev, levs) + | Some Last -> (levs, empty_lev, []) + | Some (Level n) -> + let rec get = + (function + | [] -> + (eprintf + "No level labelled \"%s\" in entry \"%s\"\n" + n entry.ename; + flush 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 = + (function + | [] -> + (eprintf + "No level labelled \"%s\" in entry \"%s\"\n" + n entry.ename; + flush 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 = + (function + | [] -> + (eprintf + "No level labelled \"%s\" in entry \"%s\"\n" + n entry.ename; + flush 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, [])) + let rec check_gram entry = + function + | Snterm e -> + if e.egram != entry.egram + then + (eprintf + "\ + Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" + entry.ename e.ename; + flush stderr; + failwith "Grammar.extend error") + else () + | Snterml (e, _) -> + if e.egram != entry.egram + then + (eprintf + "\ + Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" + entry.ename e.ename; + flush stderr; + failwith "Grammar.extend error") + else () + | Smeta (_, sl, _) -> List.iter (check_gram entry) sl + | Slist0sep (s, t) -> + (check_gram entry t; check_gram entry s) + | Slist1sep (s, t) -> + (check_gram entry t; check_gram entry s) + | Slist0 s -> check_gram entry s + | Slist1 s -> check_gram entry s + | Sopt s -> check_gram entry s + | Stree t -> tree_check_gram entry t + | Snext | Sself | Stoken _ | Skeyword _ -> () + and tree_check_gram entry = + function + | Node { node = n; brother = bro; son = son } -> + (check_gram entry n; + tree_check_gram entry bro; + tree_check_gram entry son) + | LocAct (_, _) | DeadEnd -> () + let get_initial = + function + | Sself :: symbols -> (true, symbols) + | symbols -> (false, symbols) + let insert_tokens gram symbols = + let rec insert = + function + | Smeta (_, sl, _) -> List.iter insert sl + | Slist0 s -> insert s + | Slist1 s -> insert s + | Slist0sep (s, t) -> (insert s; insert t) + | Slist1sep (s, t) -> (insert s; insert t) + | Sopt s -> insert s + | Stree t -> tinsert t + | Skeyword kwd -> using gram kwd + | Snterm _ | Snterml (_, _) | Snext | Sself | Stoken _ -> + () + and tinsert = + function + | Node { node = s; brother = bro; son = son } -> + (insert s; tinsert bro; tinsert son) + | LocAct (_, _) | DeadEnd -> () + in List.iter insert symbols + let 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) + 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 + and insert_new = + function + | s :: sl -> + Node + { + + node = s; + son = insert_new sl; + brother = DeadEnd; + } + | [] -> LocAct (action, []) + in insert gsymbols tree + let insert_level entry e1 symbols action slev = + 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; + } + let levels_of_rules entry position rules = + let elev = + match entry.edesc with + | Dlevels elev -> elev + | Dparser _ -> + (eprintf "Error: entry not extensible: \"%s\"\n" + entry.ename; + flush 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 + (List.iter (check_gram entry) symbols; + let (e1, symbols) = + get_initial symbols + in + (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)) + let extend entry (position, rules) = + let elev = levels_of_rules entry position rules + in + (entry.edesc <- Dlevels elev; + entry.estart <- + (fun lev c strm -> + let f = Parser.start_parser_of_entry entry + in (entry.estart <- f; f lev c strm)); + entry.econtinue <- + fun lev bp a c strm -> + let f = Parser.continue_parser_of_entry entry + in (entry.econtinue <- f; f lev bp a c strm)) + end + end + module Delete = + struct + module Make (Structure : Structure.S) = + struct + module Tools = Tools.Make(Structure) + module Parser = Parser.Make(Structure) + open Structure + let 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 + let rec decr_keyw_use gram = + function + | Skeyword kwd -> removing gram kwd + | Smeta (_, sl, _) -> List.iter (decr_keyw_use gram) sl + | Slist0 s -> decr_keyw_use gram s + | Slist1 s -> decr_keyw_use gram s + | Slist0sep (s1, s2) -> + (decr_keyw_use gram s1; decr_keyw_use gram s2) + | Slist1sep (s1, s2) -> + (decr_keyw_use gram s1; decr_keyw_use gram s2) + | Sopt s -> decr_keyw_use gram s + | Stree t -> decr_keyw_use_in_tree gram t + | Sself | Snext | Snterm _ | Snterml (_, _) | Stoken _ -> + () + and decr_keyw_use_in_tree gram = + function + | DeadEnd | LocAct (_, _) -> () + | Node n -> + (decr_keyw_use gram n.node; + decr_keyw_use_in_tree gram n.son; + decr_keyw_use_in_tree gram n.brother) + let rec delete_rule_in_suffix entry symbols = + function + | lev :: levs -> + (match delete_rule_in_tree entry symbols lev.lsuffix + with + | Some ((dsl, t)) -> + ((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 Not_found + let rec delete_rule_in_prefix entry symbols = + function + | lev :: levs -> + (match delete_rule_in_tree entry symbols lev.lprefix + with + | Some ((dsl, t)) -> + ((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 Not_found + let 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 + let delete_rule entry sl = + match entry.edesc with + | Dlevels levs -> + let levs = delete_rule_in_level_list entry sl levs + in + (entry.edesc <- Dlevels levs; + entry.estart <- + (fun lev c strm -> + let f = Parser.start_parser_of_entry entry + in (entry.estart <- f; f lev c strm)); + entry.econtinue <- + (fun lev bp a c strm -> + let f = Parser.continue_parser_of_entry entry + in (entry.econtinue <- f; f lev bp a c strm))) + | Dparser _ -> () + end + end + module Fold : + sig + module Make (Structure : Structure.S) : + sig + open Structure + val sfold0 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold + val sfold1 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) fold + val sfold0sep : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) foldsep + end + end = + struct + module Make (Structure : Structure.S) = + struct + open Structure + open Format + module Parse = Parser.Make(Structure) + module Fail = Failed.Make(Structure) + open Sig.Grammar + module Stream = + struct + include Stream + let junk strm = Context.junk strm + let count strm = Context.bp strm + end + let sfold0 f e _entry _symbl psymb = + let rec fold accu (__strm : _ Stream.t) = + match try Some (psymb __strm) + with | Stream.Failure -> None + with + | Some a -> fold (f a accu) __strm + | _ -> accu + in fun (__strm : _ Stream.t) -> fold e __strm + let sfold1 f e _entry _symbl psymb = + let rec fold accu (__strm : _ Stream.t) = + match try Some (psymb __strm) + with | Stream.Failure -> None + with + | Some a -> fold (f a accu) __strm + | _ -> accu + in + fun (__strm : _ Stream.t) -> + let a = psymb __strm + in + try fold (f a e) __strm + with | Stream.Failure -> raise (Stream.Error "") + let sfold0sep f e entry symbl psymb psep = + let failed = + function + | [ symb; sep ] -> Fail.symb_failed_txt entry sep symb + | _ -> "failed" in + let rec kont accu (__strm : _ Stream.t) = + match try Some (psep __strm) + with | Stream.Failure -> None + with + | Some () -> + let a = + (try psymb __strm + with + | Stream.Failure -> + raise (Stream.Error (failed symbl))) + in kont (f a accu) __strm + | _ -> accu + in + fun (__strm : _ Stream.t) -> + match try Some (psymb __strm) + with | Stream.Failure -> None + with + | Some a -> kont (f a e) __strm + | _ -> e + let sfold1sep f e entry symbl psymb psep = + let failed = + function + | [ symb; sep ] -> Fail.symb_failed_txt entry sep symb + | _ -> "failed" in + let parse_top = + function + | [ symb; _ ] -> Parse.parse_top_symb entry symb + | _ -> raise Stream.Failure in + let rec kont accu (__strm : _ Stream.t) = + match try Some (psep __strm) + with | Stream.Failure -> None + with + | Some () -> + let a = + (try + try psymb __strm + with + | Stream.Failure -> + let a = + (try parse_top symbl __strm + with + | Stream.Failure -> + raise (Stream.Error (failed symbl))) + in Obj.magic a + with | Stream.Failure -> raise (Stream.Error "")) + in kont (f a accu) __strm + | _ -> accu + in + fun (__strm : _ Stream.t) -> + let a = psymb __strm in kont (f a e) __strm + end + end + module Entry = + struct + 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 + type 'a t = internal_entry + let name e = e.ename + let print ppf e = fprintf ppf "%a@\n" Print.entry e + let dump ppf e = fprintf ppf "%a@\n" Dump.entry e + let mk g n = + { + + egram = g; + ename = n; + estart = Tools.empty_entry n; + econtinue = + (fun _ _ _ _ (__strm : _ Stream.t) -> + raise Stream.Failure); + edesc = Dlevels []; + } + let action_parse entry ts : Action.t = + Context.call_with_ctx ts + (fun c -> + try entry.estart 0 c (Context.stream c) + with + | Stream.Failure -> + Loc.raise (Context.loc_ep c) + (Stream.Error + ("illegal begin of " ^ entry.ename)) + | (Loc.Exc_located (_, _) as exc) -> raise exc + | exc -> Loc.raise (Context.loc_ep c) exc) + let lex entry loc cs = entry.egram.glexer loc cs + let lex_string entry loc str = + lex entry loc (Stream.of_string str) + let filter entry ts = + Token.Filter.filter (get_filter entry.egram) ts + let parse_tokens_after_filter entry ts = + Action.get (action_parse entry ts) + let parse_tokens_before_filter entry ts = + parse_tokens_after_filter entry (filter entry ts) + let parse entry loc cs = + parse_tokens_before_filter entry (lex entry loc cs) + let parse_string entry loc str = + parse_tokens_before_filter entry (lex_string entry loc str) + let of_parser g n (p : (Token.t * Loc.t) Stream.t -> 'a) : + 'a t = + { + + egram = g; + ename = n; + estart = (fun _ _ ts -> Action.mk (p ts)); + econtinue = + (fun _ _ _ _ (__strm : _ Stream.t) -> + raise Stream.Failure); + edesc = Dparser (fun ts -> Action.mk (p ts)); + } + let setup_parser e (p : (Token.t * Loc.t) Stream.t -> 'a) = + let f ts = Action.mk (p ts) + in + (e.estart <- (fun _ _ -> f); + e.econtinue <- + (fun _ _ _ _ (__strm : _ Stream.t) -> + raise Stream.Failure); + e.edesc <- Dparser f) + let clear e = + (e.estart <- + (fun _ _ (__strm : _ Stream.t) -> raise Stream.Failure); + e.econtinue <- + (fun _ _ _ _ (__strm : _ Stream.t) -> + raise Stream.Failure); + e.edesc <- Dlevels []) + let obj x = x + end + end + module Static = + struct + 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) + include Structure + let gram = + let gkeywords = Hashtbl.create 301 + in + { + + gkeywords = gkeywords; + gfilter = Token.Filter.mk (Hashtbl.mem gkeywords); + glexer = Lexer.mk (); + warning_verbose = ref true; + error_verbose = Camlp4_config.verbose; + } + module Entry = + struct + module E = Entry.Make(Structure) + type 'a t = 'a E.t + let mk = E.mk gram + let of_parser name strm = E.of_parser gram name strm + let setup_parser = E.setup_parser + let name = E.name + let print = E.print + let clear = E.clear + let dump = E.dump + let obj x = x + end + let get_filter () = gram.gfilter + let lex loc cs = gram.glexer loc cs + let lex_string loc str = lex loc (Stream.of_string str) + let filter ts = Token.Filter.filter gram.gfilter ts + let parse_tokens_after_filter entry ts = + Entry.E.parse_tokens_after_filter entry ts + let parse_tokens_before_filter entry ts = + parse_tokens_after_filter entry (filter ts) + let parse entry loc cs = + parse_tokens_before_filter entry (lex loc cs) + let parse_string entry loc str = + parse_tokens_before_filter entry (lex_string loc str) + let delete_rule = Delete.delete_rule + let srules e rl = + let t = + List.fold_left + (fun tree (symbols, action) -> + Insert.insert_tree e symbols action tree) + DeadEnd rl + in Stree t + let sfold0 = Fold.sfold0 + let sfold1 = Fold.sfold1 + let sfold0sep = Fold.sfold0sep + let extend = Insert.extend + end + end + module Dynamic = + struct + 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) + include Structure + let mk () = + let gkeywords = Hashtbl.create 301 + in + { + + gkeywords = gkeywords; + gfilter = Token.Filter.mk (Hashtbl.mem gkeywords); + glexer = Lexer.mk (); + warning_verbose = ref true; + error_verbose = Camlp4_config.verbose; + } + let get_filter g = g.gfilter + let lex g loc cs = g.glexer loc cs + let lex_string g loc str = lex g loc (Stream.of_string str) + let filter g ts = Token.Filter.filter g.gfilter ts + let parse_tokens_after_filter entry ts = + Entry.parse_tokens_after_filter entry ts + let parse_tokens_before_filter entry ts = + parse_tokens_after_filter entry (filter entry.egram ts) + let parse entry loc cs = + parse_tokens_before_filter entry (lex entry.egram loc cs) + let parse_string entry loc str = + parse_tokens_before_filter entry + (lex_string entry.egram loc str) + let delete_rule = Delete.delete_rule + let srules e rl = + let t = + List.fold_left + (fun tree (symbols, action) -> + Insert.insert_tree e symbols action tree) + DeadEnd rl + in Stree t + let sfold0 = Fold.sfold0 + let sfold1 = Fold.sfold1 + let sfold0sep = Fold.sfold0sep + let extend = Insert.extend + end + end + end + end +module Printers = + struct + module DumpCamlp4Ast : + sig + module Id : Sig.Id + module Make (Syntax : Sig.Syntax) : + Sig.Printer with module Ast = Syntax.Ast + end = + struct + module Id = + struct + let name = "Camlp4Printers.DumpCamlp4Ast" + let version = + "$Id: Camlp4.ml,v 1.3 2007/02/26 16:43:01 ertai Exp $" + end + module Make (Syntax : Sig.Syntax) : + Sig.Printer with module Ast = Syntax.Ast = + struct + include Syntax + let with_open_out_file x f = + match x with + | Some file -> + let oc = open_out_bin file + in (f oc; flush oc; close_out oc) + | None -> + (set_binary_mode_out stdout true; f stdout; flush stdout) + let dump_ast magic ast oc = + (output_string oc magic; output_value oc ast) + let print_interf ?input_file:(_) ?output_file ast = + with_open_out_file output_file + (dump_ast Camlp4_config.camlp4_ast_intf_magic_number ast) + let print_implem ?input_file:(_) ?output_file ast = + with_open_out_file output_file + (dump_ast Camlp4_config.camlp4_ast_impl_magic_number ast) + end + end + module DumpOCamlAst : + sig + module Id : Sig.Id + module Make (Syntax : Sig.Camlp4Syntax) : + Sig.Printer with module Ast = Syntax.Ast + end = + struct + module Id : Sig.Id = + struct + let name = "Camlp4Printers.DumpOCamlAst" + let version = + "$Id: Camlp4.ml,v 1.3 2007/02/26 16:43:01 ertai Exp $" + end + module Make (Syntax : Sig.Camlp4Syntax) : + Sig.Printer with module Ast = Syntax.Ast = + struct + include Syntax + module Ast2pt = Struct.Camlp4Ast2OCamlAst.Make(Ast) + let with_open_out_file x f = + match x with + | Some file -> + let oc = open_out_bin file + in (f oc; flush oc; close_out oc) + | None -> + (set_binary_mode_out stdout true; f stdout; flush stdout) + let dump_pt magic fname pt oc = + (output_string oc magic; + output_value oc (if fname = "-" then "" else fname); + output_value oc pt) + let 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) + let 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 + end + module Null : + sig + module Id : Sig.Id + module Make (Syntax : Sig.Syntax) : + Sig.Printer with module Ast = Syntax.Ast + end = + struct + module Id = + struct + let name = "Camlp4.Printers.Null" + let version = + "$Id: Camlp4.ml,v 1.3 2007/02/26 16:43:01 ertai Exp $" + end + module Make (Syntax : Sig.Syntax) = + struct + include Syntax + let print_interf ?input_file:(_) ?output_file:(_) _ = () + let print_implem ?input_file:(_) ?output_file:(_) _ = () + end + end + module OCaml : + sig + module Id : Sig.Id + module Make (Syntax : Sig.Camlp4Syntax) : + sig + open Format + include Sig.Camlp4Syntax with module Loc = Syntax.Loc + and module Warning = Syntax.Warning + and module Token = Syntax.Token and module Ast = Syntax.Ast + and module Gram = Syntax.Gram + val list' : + (formatter -> 'a -> unit) -> + ('b, formatter, unit) format -> + (unit, formatter, unit) format -> + formatter -> 'a list -> unit + val list : + (formatter -> 'a -> unit) -> + ('b, formatter, unit) format -> formatter -> 'a list -> unit + val lex_string : string -> Token.t + val is_infix : string -> bool + val is_keyword : string -> bool + val ocaml_char : string -> string + val get_expr_args : + Ast.expr -> Ast.expr list -> (Ast.expr * (Ast.expr list)) + val get_patt_args : + Ast.patt -> Ast.patt list -> (Ast.patt * (Ast.patt list)) + val get_ctyp_args : + Ast.ctyp -> Ast.ctyp list -> (Ast.ctyp * (Ast.ctyp list)) + val expr_fun_args : Ast.expr -> ((Ast.patt list) * Ast.expr) + 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 + val pipe : bool + val semi : bool + val semisep : string + val value_val : string + val value_let : string + 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 expr : formatter -> Ast.expr -> unit + method expr_list : formatter -> Ast.expr list -> unit + method expr_list_cons : + bool -> formatter -> Ast.expr -> unit + method functor_arg : + formatter -> (string * Ast.module_type) -> unit + method functor_args : + formatter -> (string * Ast.module_type) list -> unit + method ident : formatter -> Ast.ident -> unit + method intlike : formatter -> string -> unit + method binding : formatter -> Ast.binding -> unit + method record_binding : + formatter -> Ast.binding -> unit + method match_case : formatter -> Ast.match_case -> unit + method match_case_aux : + formatter -> Ast.match_case -> unit + method mk_expr_list : + Ast.expr -> ((Ast.expr list) * (Ast.expr option)) + method mk_patt_list : + Ast.patt -> ((Ast.patt list) * (Ast.patt option)) + method module_expr : + formatter -> Ast.module_expr -> unit + method module_expr_get_functor_args : + (string * Ast.module_type) list -> + Ast.module_expr -> + (((string * Ast.module_type) list) * Ast. + module_expr * (Ast.module_type option)) + method module_rec_binding : + formatter -> Ast.module_binding -> unit + method module_type : + formatter -> Ast.module_type -> unit + method mutable_flag : + formatter -> Ast.meta_bool -> unit + method direction_flag : + formatter -> Ast.meta_bool -> unit + method rec_flag : formatter -> Ast.meta_bool -> unit + method flag : + formatter -> Ast.meta_bool -> string -> unit + method node : formatter -> 'b -> ('b -> Loc.t) -> unit + method object_dup : + formatter -> (string * Ast.expr) list -> 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_expr_fun_args : + formatter -> (Ast.patt * 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.meta_bool -> unit + method virtual_flag : + formatter -> Ast.meta_bool -> unit + method quoted_string : formatter -> string -> unit + method raise_match_failure : formatter -> Loc.t -> unit + method reset : 'a + method reset_semi : 'a + method semisep : string + method set_comments : bool -> 'a + method set_curry_constr : bool -> 'a + method set_loc_and_comments : 'a + method set_semisep : string -> 'a + method simple_ctyp : formatter -> Ast.ctyp -> unit + method simple_expr : formatter -> Ast.expr -> unit + method simple_patt : formatter -> Ast.patt -> unit + method seq : formatter -> Ast.expr -> unit + method string : formatter -> string -> unit + method sum_type : formatter -> Ast.ctyp -> unit + method type_params : formatter -> Ast.ctyp list -> unit + method class_params : formatter -> Ast.ctyp -> unit + method under_pipe : 'a + method under_semi : 'a + method var : formatter -> string -> unit + method with_constraint : + formatter -> Ast.with_constr -> unit + end + val with_outfile : + string option -> (formatter -> 'a -> unit) -> 'a -> unit + val print : + string option -> + (printer -> formatter -> 'a -> unit) -> 'a -> unit + val print_interf : + ?input_file: string -> + ?output_file: string -> Ast.sig_item -> unit + val print_implem : + ?input_file: string -> + ?output_file: string -> Ast.str_item -> unit + end + module MakeMore (Syntax : Sig.Camlp4Syntax) : + Sig.Printer with module Ast = Syntax.Ast + end = + struct + open Format + module Id = + struct + let name = "Camlp4.Printers.OCaml" + let version = + "$Id: Camlp4.ml,v 1.3 2007/02/26 16:43:01 ertai Exp $" + end + module Make (Syntax : Sig.Camlp4Syntax) = + struct + include Syntax + let pp = fprintf + let cut f = fprintf f "@ " + let list' elt sep sep' f = + let rec loop = + function + | [] -> () + | x :: xs -> (pp f sep; elt f x; pp f sep'; loop xs) + in + function + | [] -> () + | [ x ] -> (elt f x; pp f sep') + | x :: xs -> (elt f x; pp f sep'; loop xs) + let list elt sep f = + let rec loop = + function | [] -> () | x :: xs -> (pp f sep; elt f x; loop xs) + in + function + | [] -> () + | [ x ] -> elt f x + | x :: xs -> (elt f x; loop xs) + let rec list_of_meta_list = + function + | Ast.LNil -> [] + | Ast.LCons (x, xs) -> x :: (list_of_meta_list xs) + | Ast.LAnt x -> assert false + let 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) + let comment_filter = CommentFilter.mk () + let _ = CommentFilter.define (Gram.get_filter ()) comment_filter + module StringSet = Set.Make(String) + let is_infix = + let infixes = + List.fold_right StringSet.add + [ "=="; "!="; "+"; "-"; "+."; "-."; "*"; "*."; "/"; "/."; + "**"; "="; "<>"; "<"; ">"; "<="; ">="; "^"; "^^"; "@"; + "&&"; "||"; "asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; + "mod"; "or" ] + StringSet.empty + in fun s -> StringSet.mem s infixes + let is_keyword = + let keywords = + List.fold_right StringSet.add + [ "and"; "as"; "assert"; "asr"; "begin"; "class"; + "constraint"; "do"; "done"; "downto"; "else"; "end"; + "exception"; "external"; "false"; "for"; "fun"; + "function"; "functor"; "if"; "in"; "include"; "inherit"; + "initializer"; "land"; "lazy"; "let"; "lor"; "lsl"; + "lsr"; "lxor"; "match"; "method"; "mod"; "module"; + "mutable"; "new"; "object"; "of"; "open"; "or"; "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 _ = let module M = ErrorHandler.Register(Lexer.Error) in () + open Sig + let lexer s = + Lexer.from_string ~quotations: !Camlp4_config.quotations Loc. + ghost s + let lex_string str = + try + let (__strm : _ Stream.t) = lexer str + in + match Stream.peek __strm with + | Some ((tok, _)) -> + (Stream.junk __strm; + (match Stream.peek __strm with + | Some ((EOI, _)) -> (Stream.junk __strm; tok) + | _ -> raise (Stream.Error ""))) + | _ -> raise Stream.Failure + with + | Stream.Failure -> + 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)) + let ocaml_char = function | "'" -> "\\'" | c -> c + let rec get_expr_args a al = + match a with + | Ast.ExApp (_, a1, a2) -> get_expr_args a1 (a2 :: al) + | _ -> (a, al) + let rec get_patt_args a al = + match a with + | Ast.PaApp (_, a1, a2) -> get_patt_args a1 (a2 :: al) + | _ -> (a, al) + let rec get_ctyp_args a al = + match a with + | Ast.TyApp (_, a1, a2) -> get_ctyp_args a1 (a2 :: al) + | _ -> (a, al) + let is_irrefut_patt = Ast.is_irrefut_patt + let rec expr_fun_args = + function + | (Ast.ExFun (_, (Ast.McArr (_, p, (Ast.ExNil _), e))) as ge) + -> + if is_irrefut_patt p + then (let (pl, e) = expr_fun_args e in ((p :: pl), e)) + else ([], ge) + | ge -> ([], ge) + let rec class_expr_fun_args = + function + | (Ast.CeFun (_, 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) + let rec do_print_comments_before loc f (__strm : _ Stream.t) = + match Stream.peek __strm with + | Some ((comm, comm_loc)) when Loc.strictly_before comm_loc loc + -> + (Stream.junk __strm; + let s = __strm in + 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) + val pipe = false + val semi = false + method under_pipe = {< pipe = true; >} + method under_semi = {< semi = true; >} + method reset_semi = {< semi = false; >} + method reset = {< pipe = false; semi = false; >} + val semisep = ";;" + val andsep = + ("@]@ @[<2>and@ " : (unit, formatter, unit) format) + val value_val = "val" + val value_let = "let" + val mode = if comments then `comments else `no_comments + val curry_constr = init_curry_constr + val var_conversion = false + method semisep = semisep + method set_semisep = fun s -> {< semisep = s; >} + method set_comments = + fun b -> + {< mode = if b then `comments else `no_comments; >} + method set_loc_and_comments = + {< mode = `loc_and_comments; >} + method set_curry_constr = fun b -> {< curry_constr = b; >} + method print_comments_before = + fun loc f -> + match mode with + | `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 = + fun f -> + function + | "" -> 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 + | 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 = + fun f -> + function + | [] -> () + | [ x ] -> pp f "%a@ " o#ctyp x + | l -> pp f "@[<1>(%a)@]@ " (list o#ctyp ",@ ") l + method class_params = + fun f -> + function + | Ast.TyCom (_, t1, t2) -> + pp f "@[<1>%a,@ %a@]" o#class_params t1 + o#class_params t2 + | x -> o#ctyp f x + method mutable_flag = fun f b -> o#flag f b "mutable" + method rec_flag = fun f b -> o#flag f b "rec" + method virtual_flag = fun f b -> o#flag f b "virtual" + method private_flag = fun f b -> o#flag f b "private" + method flag = + fun f b n -> + match b with + | Ast.BTrue -> (pp_print_string f n; pp f "@ ") + | Ast.BFalse -> () + | Ast.BAnt s -> o#anti f s + method anti = fun f s -> pp f "$%s$" s + method seq = + fun f -> + function + | Ast.ExSem (_, e1, e2) -> + pp f "%a;@ %a" o#under_semi#seq e1 o#seq e2 + | Ast.ExSeq (_, e) -> o#seq f e + | e -> o#expr f e + method match_case = + fun f -> + function + | Ast.McNil _loc -> + pp f "@[<2>_@ ->@ %a@]" o#raise_match_failure _loc + | a -> o#match_case_aux f a + method match_case_aux = + fun f -> + function + | Ast.McNil _ -> () + | Ast.McAnt (_, s) -> o#anti f s + | Ast.McOr (_, a1, a2) -> + pp f "%a%a" o#match_case_aux a1 o#match_case_aux a2 + | Ast.McArr (_, p, (Ast.ExNil _), e) -> + pp f "@ | @[<2>%a@ ->@ %a@]" o#patt p + o#under_pipe#expr e + | Ast.McArr (_, p, w, e) -> + pp f "@ | @[<2>%a@ when@ %a@ ->@ %a@]" o#patt p + o#under_pipe#expr w o#under_pipe#expr e + method binding = + fun f bi -> + let () = o#node f bi Ast.loc_of_binding + in + match bi with + | Ast.BiNil _ -> () + | Ast.BiAnd (_, b1, b2) -> + (o#binding f b1; pp f andsep; o#binding f b2) + | Ast.BiEq (_, p, e) -> + let (pl, e) = + (match p with + | Ast.PaTyc (_, _, _) -> ([], e) + | _ -> expr_fun_args e) + in + (match (p, e) with + | (Ast.PaId (_, (Ast.IdLid (_, _))), + Ast.ExTyc (_, e, t)) -> + pp f "%a :@ %a =@ %a" + (list o#simple_patt "@ ") (p :: pl) + o#ctyp t o#expr e + | _ -> + pp f "%a @[<0>%a=@]@ %a" o#simple_patt p + (list' o#simple_patt "" "@ ") pl o#expr e) + | Ast.BiSem (_, _, _) -> assert false + | Ast.BiAnt (_, s) -> o#anti f s + method record_binding = + fun f bi -> + let () = o#node f bi Ast.loc_of_binding + in + match bi with + | Ast.BiNil _ -> () + | Ast.BiEq (_, p, e) -> + pp f "@ @[<2>%a =@ %a@];" o#simple_patt p o#expr e + | Ast.BiSem (_, b1, b2) -> + (o#under_semi#record_binding f b1; + o#under_semi#record_binding f b2) + | Ast.BiAnd (_, _, _) -> assert false + | Ast.BiAnt (_, s) -> o#anti f s + method object_dup = + fun f -> + list + (fun f (s, e) -> + pp f "@[<2>%a =@ %a@]" o#var s o#expr e) + ";@ " f + method mk_patt_list = + function + | Ast.PaApp (_, + (Ast.PaApp (_, (Ast.PaId (_, (Ast.IdUid (_, "::")))), + p1)), + p2) -> + let (pl, c) = o#mk_patt_list p2 in ((p1 :: pl), c) + | Ast.PaId (_, (Ast.IdUid (_, "[]"))) -> ([], None) + | p -> ([], (Some p)) + method mk_expr_list = + function + | Ast.ExApp (_, + (Ast.ExApp (_, (Ast.ExId (_, (Ast.IdUid (_, "::")))), + e1)), + e2) -> + let (el, c) = o#mk_expr_list e2 in ((e1 :: el), c) + | Ast.ExId (_, (Ast.IdUid (_, "[]"))) -> ([], None) + | e -> ([], (Some e)) + method expr_list = + fun f -> + function + | [] -> pp f "[]" + | [ e ] -> pp f "[ %a ]" o#expr e + | el -> pp f "@[<2>[ %a@] ]" (list o#expr ";@ ") el + method expr_list_cons = + fun 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#dot_expr " ::@ ") + (el @ [ x ]) + method patt_expr_fun_args = + fun f (p, e) -> + let (pl, e) = expr_fun_args e + in + pp f "%a@ ->@ %a" (list o#patt "@ ") (p :: pl) o#expr e + method patt_class_expr_fun_args = + fun f (p, ce) -> + let (pl, ce) = class_expr_fun_args ce + in + pp f "%a =@]@ %a" (list o#patt "@ ") (p :: pl) + o#class_expr ce + method constrain = + fun f (t1, t2) -> + pp f "@[<2>constraint@ %a =@ %a@]" o#ctyp t1 o#ctyp t2 + method sum_type = + fun f t -> (pp_print_string f "| "; o#ctyp f t) + method string = fun f -> pp f "%s" + method quoted_string = fun f -> pp f "%S" + method intlike = + fun f s -> + if s.[0] = '-' then pp f "(%s)" s else pp f "%s" s + method module_expr_get_functor_args = + fun accu -> + function + | Ast.MeFun (_, s, mt, me) -> + o#module_expr_get_functor_args ((s, mt) :: accu) me + | Ast.MeTyc (_, me, mt) -> + ((List.rev accu), me, (Some mt)) + | me -> ((List.rev accu), me, None) + method functor_args = fun f -> list o#functor_arg "@ " f + method functor_arg = + fun f (s, mt) -> + pp f "@[<2>(%a :@ %a)@]" o#var s o#module_type mt + method module_rec_binding = + fun f -> + function + | Ast.MbNil _ -> () + | Ast.MbColEq (_, s, mt, me) -> + pp f "@[<2>%a :@ %a =@ %a@]" o#var s o#module_type mt + o#module_expr me + | Ast.MbCol (_, s, mt) -> + pp f "@[<2>%a :@ %a@]" o#var s o#module_type mt + | Ast.MbAnd (_, mb1, mb2) -> + (o#module_rec_binding f mb1; + pp f andsep; + o#module_rec_binding f mb2) + | Ast.MbAnt (_, s) -> o#anti f s + method class_declaration = + fun f -> + function + | Ast.CeTyc (_, ce, ct) -> + pp f "%a :@ %a" o#class_expr ce o#class_type ct + | ce -> o#class_expr f ce + method raise_match_failure = + fun f _loc -> + let n = Loc.file_name _loc in + let l = Loc.start_line _loc in + let c = (Loc.start_off _loc) - (Loc.start_bol _loc) + in + o#expr f + (Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "raise")), + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdUid (_loc, "Match_failure")), + Ast.ExStr (_loc, Ast.safe_string_escaped n)), + Ast.ExInt (_loc, string_of_int l)), + Ast.ExInt (_loc, string_of_int c)))) + method node : 'a. formatter -> 'a -> ('a -> Loc.t) -> unit = + fun f node loc_of_node -> + o#print_comments_before (loc_of_node node) f + method ident = + fun f i -> + let () = o#node f i Ast.loc_of_ident + in + match i with + | Ast.IdAcc (_, i1, i2) -> + pp f "%a.@,%a" o#ident i1 o#ident i2 + | Ast.IdApp (_, i1, i2) -> + pp f "%a@,(%a)" o#ident i1 o#ident i2 + | Ast.IdAnt (_, s) -> o#anti f s + | Ast.IdLid (_, s) | Ast.IdUid (_, s) -> o#var f s + method private var_ident = + {< var_conversion = true; >}#ident + method expr = + fun f e -> + let () = o#node f e Ast.loc_of_expr + in + match e with + | (Ast.ExLet (_, _, _, _) | Ast.ExLmd (_, _, _, _) as + e) when semi -> pp f "(%a)" o#reset#expr e + | (Ast.ExMat (_, _, _) | Ast.ExTry (_, _, _) | + Ast.ExFun (_, _) + as e) when pipe || semi -> + pp f "(%a)" o#reset#expr e + | Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, "~-")))), + x) -> pp f "@[<2>-@,%a@]" o#expr x + | Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, "~-.")))), + x) -> pp f "@[<2>-.@,%a@]" o#expr x + | Ast.ExApp (_, + (Ast.ExApp (_, + (Ast.ExId (_, (Ast.IdUid (_, "::")))), _)), + _) -> o#expr_list_cons false f e + | Ast.ExApp (_loc, + (Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, n)))), + x)), + y) when is_infix n -> + pp f "@[<2>%a@ %s@ %a@]" o#dot_expr x n o#dot_expr + y + | Ast.ExApp (_, x, y) -> + let (a, al) = get_expr_args x [ y ] + in + if + (not curry_constr) && + (Ast.is_expr_constructor a) + then + (match al with + | [ Ast.ExTup (_, _) ] -> + pp f "@[<2>%a@ (%a)@]" o#dot_expr x + o#expr y + | [ _ ] -> + pp f "@[<2>%a@ %a@]" o#dot_expr x + o#dot_expr y + | al -> + pp f "@[<2>%a@ (%a)@]" o#dot_expr a + (list o#under_pipe#expr ",@ ") al) + else + pp f "@[<2>%a@]" (list o#dot_expr "@ ") + (a :: al) + | Ast.ExAss (_, + (Ast.ExAcc (_, e1, + (Ast.ExId (_, (Ast.IdLid (_, "val")))))), + e2) -> pp f "@[<2>%a :=@ %a@]" o#expr e1 o#expr e2 + | Ast.ExAss (_, e1, e2) -> + pp f "@[<2>%a@ <-@ %a@]" o#expr e1 o#expr e2 + | Ast.ExFun (loc, (Ast.McNil _)) -> + pp f "@[<2>fun@ _@ ->@ %a@]" o#raise_match_failure + loc + | Ast.ExFun (_, (Ast.McArr (_, p, (Ast.ExNil _), e))) + when is_irrefut_patt p -> + pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (p, e) + | Ast.ExFun (_, a) -> + pp f "@[function%a@]" o#match_case a + | Ast.ExIfe (_, e1, e2, 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 + | Ast.ExLaz (_, e) -> + pp f "@[<2>lazy@ %a@]" o#simple_expr e + | Ast.ExLet (_, r, bi, e) -> + (match e with + | Ast.ExLet (_, _, _, _) -> + 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.ExMat (_, e, a) -> + pp f "@[@[@[<2>match %a@]@ with@]%a@]" + o#expr e o#match_case a + | Ast.ExTry (_, e, a) -> + pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" + o#expr e o#match_case a + | Ast.ExAsf _ -> pp f "@[<2>assert@ false@]" + | Ast.ExAsr (_, e) -> pp f "@[<2>assert@ %a@]" o#expr e + | Ast.ExLmd (_, s, me, e) -> + pp f "@[<2>let module %a =@ %a@]@ @[<2>in@ %a@]" + o#var s o#module_expr me o#expr e + | e -> o#dot_expr f e + method dot_expr = + fun f e -> + let () = o#node f e Ast.loc_of_expr + in + match e with + | Ast.ExAcc (_, e, + (Ast.ExId (_, (Ast.IdLid (_, "val"))))) -> + pp f "@[<2>!@,%a@]" o#simple_expr e + | Ast.ExAcc (_, e1, e2) -> + pp f "@[<2>%a.@,%a@]" o#dot_expr e1 o#dot_expr e2 + | Ast.ExAre (_, e1, e2) -> + pp f "@[<2>%a.@,(%a)@]" o#dot_expr e1 o#expr e2 + | Ast.ExSte (_, e1, e2) -> + pp f "%a.@[<1>[@,%a@]@,]" o#dot_expr e1 o#expr e2 + | Ast.ExSnd (_, e, s) -> + pp f "@[<2>%a#@,%s@]" o#dot_expr e s + | e -> o#simple_expr f e + method simple_expr = + fun f e -> + let () = o#node f e Ast.loc_of_expr + in + match e with + | Ast.ExNil _ -> () + | Ast.ExSeq (_, e) -> pp f "@[(%a)@]" o#seq e + | Ast.ExApp (_, + (Ast.ExApp (_, + (Ast.ExId (_, (Ast.IdUid (_, "::")))), _)), + _) -> o#expr_list_cons true f e + | Ast.ExTup (_, e) -> pp f "@[<1>(%a)@]" o#expr e + | Ast.ExArr (_, e) -> + pp f "@[<0>@[<2>[|@ %a@]@ |]@]" o#under_semi#expr e + | Ast.ExCoe (_, e, (Ast.TyNil _), t) -> + pp f "@[<2>(%a :>@ %a)@]" o#expr e o#ctyp t + | Ast.ExCoe (_, e, t1, t2) -> + pp f "@[<2>(%a :@ %a :>@ %a)@]" o#expr e o#ctyp t1 + o#ctyp t2 + | Ast.ExTyc (_, e, t) -> + pp f "@[<2>(%a :@ %a)@]" o#expr e o#ctyp t + | Ast.ExAnt (_, s) -> o#anti f s + | Ast.ExFor (_, s, e1, e2, df, e3) -> + pp f + "@[@[@[<2>for %a =@ %a@ %a@ %a@ do@]@ %a@]@ done@]" + o#var s o#expr e1 o#direction_flag df o#expr e2 + o#seq e3 + | Ast.ExInt (_, s) -> pp f "%a" o#intlike s + | Ast.ExNativeInt (_, s) -> pp f "%an" o#intlike s + | Ast.ExInt64 (_, s) -> pp f "%aL" o#intlike s + | Ast.ExInt32 (_, s) -> pp f "%al" o#intlike s + | Ast.ExFlo (_, s) -> pp f "%s" s + | Ast.ExChr (_, s) -> pp f "'%s'" (ocaml_char s) + | Ast.ExId (_, i) -> o#var_ident f i + | Ast.ExRec (_, b, (Ast.ExNil _)) -> + pp f "@[@[{@ %a@]@ }@]" o#record_binding + b + | Ast.ExRec (_, b, e) -> + pp f "@[@[{@ (%a)@ with@ %a@]@ }@]" + o#expr e o#record_binding b + | Ast.ExStr (_, s) -> pp f "\"%s\"" s + | Ast.ExWhi (_, e1, e2) -> + pp f "@[<2>while@ %a@ do@ %a@ done@]" o#expr e1 + o#seq e2 + | Ast.ExLab (_, s, (Ast.ExNil _)) -> pp f "~%s" s + | Ast.ExLab (_, s, e) -> + pp f "@[<2>~%s:@ %a@]" s o#dot_expr e + | Ast.ExOlb (_, s, (Ast.ExNil _)) -> pp f "?%s" s + | Ast.ExOlb (_, s, e) -> + pp f "@[<2>?%s:@ %a@]" s o#dot_expr e + | Ast.ExVrn (_, s) -> pp f "`%a" o#var s + | Ast.ExOvr (_, b) -> + pp f "@[@[{<@ %a@]@ >}@]" + o#record_binding b + | Ast.ExObj (_, (Ast.PaNil _), cst) -> + pp f "@[@[object@ %a@]@ end@]" + o#class_str_item cst + | Ast.ExObj (_, (Ast.PaTyc (_, p, t)), cst) -> + pp f + "@[@[object @[<1>(%a :@ %a)@]@ %a@]@ end@]" + o#patt p o#ctyp t o#class_str_item cst + | Ast.ExObj (_, p, cst) -> + pp f + "@[@[object @[<2>(%a)@]@ %a@]@ end@]" + o#patt p o#class_str_item cst + | Ast.ExNew (_, i) -> pp f "@[<2>new@ %a@]" o#ident i + | Ast.ExCom (_, e1, e2) -> + pp f "%a,@ %a" o#simple_expr e1 o#simple_expr e2 + | Ast.ExSem (_, e1, e2) -> + pp f "%a;@ %a" o#under_semi#expr e1 o#expr e2 + | Ast.ExApp (_, _, _) | Ast.ExAcc (_, _, _) | + Ast.ExAre (_, _, _) | Ast.ExSte (_, _, _) | + Ast.ExAss (_, _, _) | Ast.ExSnd (_, _, _) | + Ast.ExFun (_, _) | Ast.ExMat (_, _, _) | + Ast.ExTry (_, _, _) | Ast.ExIfe (_, _, _, _) | + Ast.ExLet (_, _, _, _) | Ast.ExLmd (_, _, _, _) | + Ast.ExAsr (_, _) | Ast.ExAsf _ | Ast.ExLaz (_, _) + -> pp f "(%a)" o#reset#expr e + method direction_flag = + fun f b -> + match b with + | Ast.BTrue -> pp_print_string f "to" + | Ast.BFalse -> pp_print_string f "downto" + | Ast.BAnt s -> o#anti f s + method patt = + fun f p -> + let () = o#node f p Ast.loc_of_patt + in + match p with + | Ast.PaAli (_, p1, p2) -> + pp f "@[<1>(%a@ as@ %a)@]" o#patt p1 o#patt p2 + | Ast.PaEq (_, p1, p2) -> + pp f "@[<2>%a =@ %a@]" o#patt p1 o#patt p2 + | Ast.PaSem (_, p1, p2) -> + pp f "%a;@ %a" o#patt p1 o#patt p2 + | p -> o#patt1 f p + method patt1 = + fun f -> + function + | Ast.PaOrp (_, p1, p2) -> + pp f "@[<2>%a@ |@ %a@]" o#patt1 p1 o#patt2 p2 + | p -> o#patt2 f p + method patt2 = fun f p -> o#patt3 f p + method patt3 = + fun f -> + function + | Ast.PaRng (_, p1, p2) -> + pp f "@[<2>%a@ ..@ %a@]" o#patt3 p1 o#patt4 p2 + | Ast.PaCom (_, p1, p2) -> + pp f "%a,@ %a" o#patt3 p1 o#patt3 p2 + | p -> o#patt4 f p + method patt4 = + fun f -> + function + | (Ast.PaApp (_, + (Ast.PaApp (_, + (Ast.PaId (_, (Ast.IdUid (_, "::")))), _)), + _) + 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 = + fun f -> + function + | (Ast.PaApp (_, + (Ast.PaApp (_, + (Ast.PaId (_, (Ast.IdUid (_, "::")))), _)), + _) + as p) -> o#simple_patt f p + | Ast.PaApp (_, x, y) -> + let (a, al) = get_patt_args x [ y ] + in + if + (not curry_constr) && (Ast.is_patt_constructor a) + then + (match al with + | [ Ast.PaTup (_, _) ] -> + 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) + else + pp f "@[<2>%a@]" (list o#simple_patt "@ ") + (a :: al) + | p -> o#simple_patt f p + method simple_patt = + fun f p -> + let () = o#node f p Ast.loc_of_patt + in + match p with + | Ast.PaNil _ -> () + | Ast.PaId (_, i) -> o#var_ident f i + | Ast.PaAnt (_, s) -> o#anti f s + | Ast.PaAny _ -> pp f "_" + | Ast.PaTup (_, p) -> pp f "@[<1>(%a)@]" o#patt3 p + | Ast.PaRec (_, p) -> pp f "@[{@ %a@]@ }" o#patt p + | Ast.PaStr (_, s) -> pp f "\"%s\"" s + | Ast.PaTyc (_, p, t) -> + pp f "@[<1>(%a :@ %a)@]" o#patt p o#ctyp t + | Ast.PaNativeInt (_, s) -> pp f "%an" o#intlike s + | Ast.PaInt64 (_, s) -> pp f "%aL" o#intlike s + | Ast.PaInt32 (_, s) -> pp f "%al" o#intlike s + | Ast.PaInt (_, s) -> pp f "%a" o#intlike s + | Ast.PaFlo (_, s) -> pp f "%s" s + | Ast.PaChr (_, s) -> pp f "'%s'" (ocaml_char s) + | Ast.PaLab (_, s, (Ast.PaNil _)) -> pp f "~%s" s + | Ast.PaVrn (_, s) -> pp f "`%a" o#var s + | Ast.PaTyp (_, i) -> pp f "@[<2>#%a@]" o#ident i + | Ast.PaArr (_, p) -> pp f "@[<2>[|@ %a@]@ |]" o#patt p + | Ast.PaLab (_, s, p) -> + pp f "@[<2>~%s:@ (%a)@]" s o#patt p + | Ast.PaOlb (_, s, (Ast.PaNil _)) -> pp f "?%s" s + | Ast.PaOlb (_, "", p) -> pp f "@[<2>?(%a)@]" o#patt p + | Ast.PaOlb (_, s, p) -> + pp f "@[<2>?%s:@,@[<1>(%a)@]@]" s o#patt p + | Ast.PaOlbi (_, "", p, e) -> + pp f "@[<2>?(%a =@ %a)@]" o#patt p o#expr e + | Ast.PaOlbi (_, s, p, e) -> + pp f "@[<2>?%s:@,@[<1>(%a =@ %a)@]@]" s o#patt p + o#expr e + | (Ast.PaApp (_, _, _) | Ast.PaAli (_, _, _) | + Ast.PaOrp (_, _, _) | Ast.PaRng (_, _, _) | + Ast.PaCom (_, _, _) | Ast.PaSem (_, _, _) | + Ast.PaEq (_, _, _) + as p) -> pp f "@[<1>(%a)@]" o#patt p + method simple_ctyp = + fun f t -> + let () = o#node f t Ast.loc_of_ctyp + in + match t with + | Ast.TyId (_, i) -> o#ident f i + | Ast.TyAnt (_, s) -> o#anti f s + | Ast.TyAny _ -> pp f "_" + | Ast.TyLab (_, s, t) -> + pp f "@[<2>%s:@ %a@]" s o#simple_ctyp t + | Ast.TyOlb (_, s, t) -> + pp f "@[<2>?%s:@ %a@]" s o#simple_ctyp t + | Ast.TyObj (_, (Ast.TyNil _), Ast.BFalse) -> + pp f "< >" + | Ast.TyObj (_, (Ast.TyNil _), Ast.BTrue) -> + pp f "< .. >" + | Ast.TyObj (_, t, Ast.BTrue) -> + pp f "@[<0>@[<2><@ %a@ ..@]@ >@]" o#ctyp t + | Ast.TyObj (_, t, Ast.BFalse) -> + pp f "@[<0>@[<2><@ %a@]@ >@]" o#ctyp t + | Ast.TyQuo (_, s) -> pp f "'%a" o#var s + | Ast.TyRec (_, t) -> pp f "@[<2>{@ %a@]@ }" o#ctyp t + | Ast.TySum (_, t) -> pp f "@[<0>%a@]" o#sum_type t + | Ast.TyTup (_, t) -> pp f "@[<1>(%a)@]" o#ctyp t + | Ast.TyVrnEq (_, t) -> pp f "@[<2>[@ %a@]@ ]" o#ctyp t + | Ast.TyVrnInf (_, t) -> + pp f "@[<2>[<@ %a@]@,]" o#ctyp t + | Ast.TyVrnInfSup (_, t1, t2) -> + pp f "@[<2>[<@ %a@ >@ %a@]@ ]" o#ctyp t1 o#ctyp t2 + | Ast.TyVrnSup (_, t) -> + pp f "@[<2>[>@ %a@]@,]" o#ctyp t + | Ast.TyCls (_, i) -> pp f "@[<2>#%a@]" o#ident i + | Ast.TyMan (_, t1, t2) -> + pp f "@[<2>%a =@ %a@]" o#simple_ctyp t1 + o#simple_ctyp t2 + | Ast.TyVrn (_, s) -> pp f "`%a" o#var s + | Ast.TySta (_, t1, t2) -> + pp f "%a *@ %a" o#simple_ctyp t1 o#simple_ctyp t2 + | t -> pp f "@[<1>(%a)@]" o#ctyp t + method ctyp = + fun f t -> + let () = o#node f t Ast.loc_of_ctyp + in + match t with + | Ast.TyAli (_, t1, t2) -> + pp f "@[<2>%a@ as@ %a@]" o#simple_ctyp t1 + o#simple_ctyp t2 + | Ast.TyArr (_, t1, t2) -> + pp f "@[<2>%a@ ->@ %a@]" o#ctyp1 t1 o#ctyp t2 + | Ast.TyQuP (_, s) -> pp f "+'%a" o#var s + | Ast.TyQuM (_, s) -> pp f "-'%a" o#var s + | Ast.TyOr (_, t1, t2) -> + pp f "%a@ | %a" o#ctyp t1 o#ctyp t2 + | Ast.TyCol (_, t1, (Ast.TyMut (_, t2))) -> + pp f "@[mutable@ %a :@ %a@]" o#ctyp t1 o#ctyp t2 + | Ast.TyCol (_, t1, t2) -> + pp f "@[<2>%a :@ %a@]" o#ctyp t1 o#ctyp t2 + | Ast.TySem (_, t1, t2) -> + pp f "%a;@ %a" o#ctyp t1 o#ctyp t2 + | Ast.TyOf (_, t, (Ast.TyNil _)) -> o#ctyp f t + | Ast.TyOf (_, t1, t2) -> + pp f "@[%a@ @[<3>of@ %a@]@]" o#ctyp t1 + o#constructor_type t2 + | Ast.TyOfAmp (_, t1, t2) -> + pp f "@[%a@ @[<3>of &@ %a@]@]" o#ctyp t1 + o#constructor_type t2 + | Ast.TyAnd (_, t1, t2) -> + pp f "%a@ and %a" o#ctyp t1 o#ctyp t2 + | Ast.TyMut (_, t) -> + pp f "@[<2>mutable@ %a@]" o#ctyp t + | Ast.TyAmp (_, t1, t2) -> + pp f "%a@ &@ %a" o#ctyp t1 o#ctyp t2 + | Ast.TyDcl (_, tn, tp, te, cl) -> + (pp f "@[<2>%a%a@]" o#type_params tp o#var tn; + (match te with + | Ast.TyQuo (_, s) when + not + (List.exists + (function + | Ast.TyQuo (_, s') -> s = s' + | _ -> false) + tp) + -> () + | _ -> pp f " =@ %a" o#ctyp te); + if cl <> [] + then pp f "@ %a" (list o#constrain "@ ") cl + else ()) + | t -> o#ctyp1 f t + method ctyp1 = + fun f -> + function + | Ast.TyApp (_, 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) + | Ast.TyPol (_, t1, t2) -> + let (a, al) = get_ctyp_args t1 [] + in + pp f "@[<2>%a.@ %a@]" (list o#ctyp "@ ") (a :: al) + o#ctyp t2 + | Ast.TyPrv (_, t) -> + pp f "@[private@ %a@]" o#simple_ctyp t + | t -> o#simple_ctyp f t + method constructor_type = + fun f t -> + match t with + | Ast.TyAnd (loc, t1, t2) -> + let () = o#node f t (fun _ -> loc) + in + pp f "%a@ * %a" o#constructor_type t1 + o#constructor_type t2 + | Ast.TyArr (_, _, _) -> pp f "(%a)" o#ctyp t + | t -> o#ctyp f t + method sig_item = + fun f sg -> + let () = o#node f sg Ast.loc_of_sig_item + in + match sg with + | Ast.SgNil _ -> () + | Ast.SgSem (_, sg, (Ast.SgNil _)) | + Ast.SgSem (_, (Ast.SgNil _), sg) -> o#sig_item f sg + | Ast.SgSem (_, sg1, sg2) -> + (o#sig_item f sg1; cut f; o#sig_item f sg2) + | Ast.SgExc (_, t) -> + pp f "@[<2>exception@ %a%s@]" o#ctyp t semisep + | Ast.SgExt (_, s, t, sl) -> + pp f "@[<2>external@ %a :@ %a =@ %a%s@]" o#var s + o#ctyp t (meta_list o#quoted_string "@ ") sl + semisep + | Ast.SgMod (_, s1, (Ast.MtFun (_, s2, mt1, mt2))) -> + let rec loop accu = + (function + | Ast.MtFun (_, 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%s@]" + o#var s1 o#functor_args al o#module_type mt + semisep + | Ast.SgMod (_, s, mt) -> + pp f "@[<2>module %a :@ %a%s@]" o#var s + o#module_type mt semisep + | Ast.SgMty (_, s, mt) -> + pp f "@[<2>module type %a =@ %a%s@]" o#var s + o#module_type mt semisep + | Ast.SgOpn (_, sl) -> + pp f "@[<2>open@ %a%s@]" o#ident sl semisep + | Ast.SgTyp (_, t) -> + pp f "@[@[type %a@]%s@]" o#ctyp t semisep + | Ast.SgVal (_, s, t) -> + pp f "@[<2>%s %a :@ %a%s@]" value_val o#var s + o#ctyp t semisep + | Ast.SgInc (_, mt) -> + pp f "@[<2>include@ %a%s@]" o#module_type mt + semisep + | Ast.SgClt (_, ct) -> + pp f "@[<2>class type %a%s@]" o#class_type ct + semisep + | Ast.SgCls (_, ce) -> + pp f "@[<2>class %a%s@]" o#class_type ce semisep + | Ast.SgRecMod (_, mb) -> + pp f "@[<2>module rec %a%s@]" o#module_rec_binding + mb semisep + | Ast.SgDir (_, _, _) -> () + | Ast.SgAnt (_, s) -> pp f "%a%s" o#anti s semisep + method str_item = + fun f st -> + let () = o#node f st Ast.loc_of_str_item + in + match st with + | Ast.StNil _ -> () + | Ast.StSem (_, st, (Ast.StNil _)) | + Ast.StSem (_, (Ast.StNil _), st) -> o#str_item f st + | Ast.StSem (_, st1, st2) -> + (o#str_item f st1; cut f; o#str_item f st2) + | Ast.StExc (_, t, Ast.ONone) -> + pp f "@[<2>exception@ %a%s@]" o#ctyp t semisep + | Ast.StExc (_, t, (Ast.OSome sl)) -> + pp f "@[<2>exception@ %a =@ %a%s@]" o#ctyp t + o#ident sl semisep + | Ast.StExt (_, s, t, sl) -> + pp f "@[<2>external@ %a :@ %a =@ %a%s@]" o#var s + o#ctyp t (meta_list o#quoted_string "@ ") sl + semisep + | Ast.StMod (_, s1, (Ast.MeFun (_, 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%s@]" + 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%s@]" + o#var s1 o#functor_args al o#module_expr me + semisep) + | Ast.StMod (_, s, (Ast.MeTyc (_, me, mt))) -> + pp f "@[<2>module %a :@ %a =@ %a%s@]" o#var s + o#module_type mt o#module_expr me semisep + | Ast.StMod (_, s, me) -> + pp f "@[<2>module %a =@ %a%s@]" o#var s + o#module_expr me semisep + | Ast.StMty (_, s, mt) -> + pp f "@[<2>module type %a =@ %a%s@]" o#var s + o#module_type mt semisep + | Ast.StOpn (_, sl) -> + pp f "@[<2>open@ %a%s@]" o#ident sl semisep + | Ast.StTyp (_, t) -> + pp f "@[@[type %a@]%s@]" o#ctyp t semisep + | Ast.StVal (_, r, bi) -> + pp f "@[<2>%s %a%a%s@]" value_let o#rec_flag r + o#binding bi semisep + | Ast.StExp (_, e) -> + pp f "@[<2>let _ =@ %a%s@]" o#expr e semisep + | Ast.StInc (_, me) -> + pp f "@[<2>include@ %a%s@]" o#module_expr me + semisep + | Ast.StClt (_, ct) -> + pp f "@[<2>class type %a%s@]" o#class_type ct + semisep + | Ast.StCls (_, ce) -> + pp f "@[class %a%s@]" o#class_declaration ce + semisep + | Ast.StRecMod (_, mb) -> + pp f "@[<2>module rec %a%s@]" o#module_rec_binding + mb semisep + | Ast.StDir (_, _, _) -> () + | Ast.StAnt (_, s) -> pp f "%a%s" o#anti s semisep + | Ast.StExc (_, _, (Ast.OAnt _)) -> assert false + method module_type = + fun f mt -> + let () = o#node f mt Ast.loc_of_module_type + in + match mt with + | Ast.MtId (_, i) -> o#ident f i + | Ast.MtAnt (_, s) -> o#anti f s + | Ast.MtFun (_, s, mt1, mt2) -> + pp f "@[<2>functor@ @[<1>(%a :@ %a)@]@ ->@ %a@]" + o#var s o#module_type mt1 o#module_type mt2 + | Ast.MtQuo (_, s) -> pp f "'%a" o#var s + | Ast.MtSig (_, sg) -> + pp f "@[@[sig@ %a@]@ end@]" o#sig_item sg + | Ast.MtWit (_, mt, wc) -> + pp f "@[<2>%a@ with@ %a@]" o#module_type mt + o#with_constraint wc + method with_constraint = + fun f wc -> + let () = o#node f wc Ast.loc_of_with_constr + in + match wc with + | Ast.WcNil _ -> () + | Ast.WcTyp (_, t1, t2) -> + pp f "@[<2>type@ %a =@ %a@]" o#ctyp t1 o#ctyp t2 + | Ast.WcMod (_, i1, i2) -> + pp f "@[<2>module@ %a =@ %a@]" o#ident i1 o#ident + i2 + | Ast.WcAnd (_, wc1, wc2) -> + (o#with_constraint f wc1; + pp f andsep; + o#with_constraint f wc2) + | Ast.WcAnt (_, s) -> o#anti f s + method module_expr = + fun f me -> + let () = o#node f me Ast.loc_of_module_expr + in + match me with + | Ast.MeId (_, i) -> o#ident f i + | Ast.MeAnt (_, s) -> o#anti f s + | Ast.MeApp (_, me1, me2) -> + pp f "@[<2>%a@,(%a)@]" o#module_expr me1 + o#module_expr me2 + | Ast.MeFun (_, s, mt, me) -> + pp f "@[<2>functor@ @[<1>(%a :@ %a)@]@ ->@ %a@]" + o#var s o#module_type mt o#module_expr me + | Ast.MeStr (_, st) -> + pp f "@[@[struct@ %a@]@ end@]" o#str_item + st + | Ast.MeTyc (_, (Ast.MeStr (_, st)), + (Ast.MtSig (_, sg))) -> + pp f + "@[<2>@[struct@ %a@]@ end :@ @[sig@ %a@]@ end@]" + o#str_item st o#sig_item sg + | Ast.MeTyc (_, me, mt) -> + pp f "@[<1>(%a :@ %a)@]" o#module_expr me + o#module_type mt + method class_expr = + fun f ce -> + let () = o#node f ce Ast.loc_of_class_expr + in + match ce with + | Ast.CeApp (_, ce, e) -> + pp f "@[<2>%a@ %a@]" o#class_expr ce o#expr e + | Ast.CeCon (_, Ast.BFalse, i, (Ast.TyNil _)) -> + pp f "@[<2>%a@]" o#ident i + | Ast.CeCon (_, Ast.BFalse, i, t) -> + pp f "@[<2>@[<1>[%a]@]@ %a@]" o#class_params t + o#ident i + | Ast.CeCon (_, Ast.BTrue, i, (Ast.TyNil _)) -> + pp f "@[<2>virtual@ %a@]" o#ident i + | Ast.CeCon (_, Ast.BTrue, i, t) -> + pp f "@[<2>virtual@ @[<1>[%a]@]@ %a@]" + o#class_params t o#ident i + | Ast.CeFun (_, p, ce) -> + pp f "@[<2>fun@ %a@ ->@ %a@]" o#patt p o#class_expr + ce + | Ast.CeLet (_, r, bi, ce) -> + pp f "@[<2>let %a%a@]@ @[<2>in@ %a@]" o#rec_flag r + o#binding bi o#class_expr ce + | Ast.CeStr (_, (Ast.PaNil _), cst) -> + pp f "@[@[object %a@]@ end@]" + o#class_str_item cst + | Ast.CeStr (_, p, cst) -> + pp f + "@[@[object @[<1>(%a)@]@ %a@]@ end@]" + o#patt p o#class_str_item cst + | Ast.CeTyc (_, ce, ct) -> + pp f "@[<1>(%a :@ %a)@]" o#class_expr ce + o#class_type ct + | Ast.CeAnt (_, s) -> o#anti f s + | Ast.CeAnd (_, ce1, ce2) -> + (o#class_expr f ce1; + pp f andsep; + o#class_expr f ce2) + | Ast.CeEq (_, ce1, (Ast.CeFun (_, p, ce2))) when + is_irrefut_patt p -> + pp f "@[<2>%a@ %a" o#class_expr ce1 + o#patt_class_expr_fun_args (p, ce2) + | Ast.CeEq (_, ce1, ce2) -> + pp f "@[<2>%a =@]@ %a" o#class_expr ce1 + o#class_expr ce2 + | _ -> assert false + method class_type = + fun f ct -> + let () = o#node f ct Ast.loc_of_class_type + in + match ct with + | Ast.CtCon (_, Ast.BFalse, i, (Ast.TyNil _)) -> + pp f "@[<2>%a@]" o#ident i + | Ast.CtCon (_, Ast.BFalse, i, t) -> + pp f "@[<2>[@,%a@]@,]@ %a" o#class_params t + o#ident i + | Ast.CtCon (_, Ast.BTrue, i, (Ast.TyNil _)) -> + pp f "@[<2>virtual@ %a@]" o#ident i + | Ast.CtCon (_, Ast.BTrue, i, t) -> + pp f "@[<2>virtual@ [@,%a@]@,]@ %a" o#class_params + t o#ident i + | Ast.CtFun (_, t, ct) -> + pp f "@[<2>%a@ ->@ %a@]" o#simple_ctyp t + o#class_type ct + | Ast.CtSig (_, (Ast.TyNil _), csg) -> + pp f "@[@[object@ %a@]@ end@]" + o#class_sig_item csg + | Ast.CtSig (_, t, csg) -> + pp f + "@[@[object @[<1>(%a)@]@ %a@]@ end@]" + o#ctyp t o#class_sig_item csg + | Ast.CtAnt (_, s) -> o#anti f s + | Ast.CtAnd (_, ct1, ct2) -> + (o#class_type f ct1; + pp f andsep; + o#class_type f ct2) + | Ast.CtCol (_, ct1, ct2) -> + pp f "%a :@ %a" o#class_type ct1 o#class_type ct2 + | Ast.CtEq (_, ct1, ct2) -> + pp f "%a =@ %a" o#class_type ct1 o#class_type ct2 + | _ -> assert false + method class_sig_item = + fun f csg -> + let () = o#node f csg Ast.loc_of_class_sig_item + in + match csg with + | Ast.CgNil _ -> () + | Ast.CgSem (_, csg, (Ast.CgNil _)) | + Ast.CgSem (_, (Ast.CgNil _), csg) -> + o#class_sig_item f csg + | Ast.CgSem (_, csg1, csg2) -> + (o#class_sig_item f csg1; + cut f; + o#class_sig_item f csg2) + | Ast.CgCtr (_, t1, t2) -> + pp f "@[<2>type@ %a =@ %a%s@]" o#ctyp t1 o#ctyp t2 + semisep + | Ast.CgInh (_, ct) -> + pp f "@[<2>inherit@ %a%s@]" o#class_type ct semisep + | Ast.CgMth (_, s, pr, t) -> + pp f "@[<2>method %a%a :@ %a%s@]" o#private_flag pr + o#var s o#ctyp t semisep + | Ast.CgVir (_, s, pr, t) -> + pp f "@[<2>method virtual %a%a :@ %a%s@]" + o#private_flag pr o#var s o#ctyp t semisep + | Ast.CgVal (_, s, mu, vi, t) -> + pp f "@[<2>%s %a%a%a :@ %a%s@]" value_val + o#mutable_flag mu o#virtual_flag vi o#var s + o#ctyp t semisep + | Ast.CgAnt (_, s) -> pp f "%a%s" o#anti s semisep + method class_str_item = + fun f cst -> + let () = o#node f cst Ast.loc_of_class_str_item + in + match cst with + | Ast.CrNil _ -> () + | Ast.CrSem (_, cst, (Ast.CrNil _)) | + Ast.CrSem (_, (Ast.CrNil _), cst) -> + o#class_str_item f cst + | Ast.CrSem (_, cst1, cst2) -> + (o#class_str_item f cst1; + cut f; + o#class_str_item f cst2) + | Ast.CrCtr (_, t1, t2) -> + pp f "@[<2>type %a =@ %a%s@]" o#ctyp t1 o#ctyp t2 + semisep + | Ast.CrInh (_, ce, "") -> + pp f "@[<2>inherit@ %a%s@]" o#class_expr ce semisep + | Ast.CrInh (_, ce, s) -> + pp f "@[<2>inherit@ %a as@ %a%s@]" o#class_expr ce + o#var s semisep + | Ast.CrIni (_, e) -> + pp f "@[<2>initializer@ %a%s@]" o#expr e semisep + | Ast.CrMth (_, s, pr, e, (Ast.TyNil _)) -> + pp f "@[<2>method %a%a =@ %a%s@]" o#private_flag pr + o#var s o#expr e semisep + | Ast.CrMth (_, s, pr, e, t) -> + pp f "@[<2>method %a%a :@ %a =@ %a%s@]" + o#private_flag pr o#var s o#ctyp t o#expr e + semisep + | Ast.CrVir (_, s, pr, t) -> + pp f "@[<2>method virtual@ %a%a :@ %a%s@]" + o#private_flag pr o#var s o#ctyp t semisep + | Ast.CrVvr (_, s, mu, t) -> + pp f "@[<2>%s virtual %a%a :@ %a%s@]" value_val + o#mutable_flag mu o#var s o#ctyp t semisep + | Ast.CrVal (_, s, mu, e) -> + pp f "@[<2>%s %a%a =@ %a%s@]" value_val + o#mutable_flag mu o#var s o#expr e semisep + | Ast.CrAnt (_, s) -> pp f "%a%s" o#anti s semisep + method implem = + fun f st -> + match st with + | Ast.StExp (_, e) -> + pp f "@[<0>%a%s@]@." o#expr e semisep + | st -> pp f "@[%a@]@." o#str_item st + method interf = fun f sg -> pp f "@[%a@]@." o#sig_item sg + end + let with_outfile output_file fct arg = + let call close f = + ((try fct f arg with | exn -> (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 + let print output_file fct = + let o = new printer () in with_outfile output_file (fct o) + let print_interf ?input_file:(_) ?output_file sg = + print output_file (fun o -> o#interf) sg + let print_implem ?input_file:(_) ?output_file st = + print output_file (fun o -> o#implem) st + end + module MakeMore (Syntax : Sig.Camlp4Syntax) : + Sig.Printer with module Ast = Syntax.Ast = + struct + include Make(Syntax) + let semisep = ref false + let margin = ref 78 + let comments = ref true + let locations = ref false + let curry_constr = ref false + let print output_file fct = + let o = + new printer ~comments: !comments ~curry_constr: !curry_constr + () in + let o = + if !semisep then o#set_semisep ";;" else o#set_semisep "" in + let o = if !locations then o#set_loc_and_comments else o + in + with_outfile output_file + (fun f -> + let () = Format.pp_set_margin f !margin + in Format.fprintf f "@[%a@]@." (fct o)) + let print_interf ?input_file:(_) ?output_file sg = + print output_file (fun o -> o#interf) sg + let print_implem ?input_file:(_) ?output_file st = + print output_file (fun o -> o#implem) st + let _ = + Options.add "-l" (Arg.Int (fun i -> margin := i)) + " line length for pretty printing." + let _ = + Options.add "-ss" (Arg.Set semisep) "Print double semicolons." + let _ = + Options.add "-curry-constr" (Arg.Set curry_constr) + "Use currified constructors." + let _ = + Options.add "-no_ss" (Arg.Clear semisep) + "Do not print double semicolons (default)." + let _ = + Options.add "-no_comments" (Arg.Clear comments) + "Do not add comments." + let _ = + Options.add "-add_locations" (Arg.Set locations) + "Add locations as comment." + end + end + module OCamlr : + sig + module Id : Sig.Id + module Make (Syntax : Sig.Camlp4Syntax) : + sig + open Format + include Sig.Camlp4Syntax with module Loc = Syntax.Loc + and module Warning = Syntax.Warning + and module Token = Syntax.Token and module Ast = Syntax.Ast + and module Gram = Syntax.Gram + class printer : + ?curry_constr: bool -> + ?comments: bool -> + unit -> object ('a) inherit OCaml.Make(Syntax).printer end + val with_outfile : + string option -> (formatter -> 'a -> unit) -> 'a -> unit + val print : + string option -> + (printer -> formatter -> 'a -> unit) -> 'a -> unit + val print_interf : + ?input_file: string -> + ?output_file: string -> Ast.sig_item -> unit + val print_implem : + ?input_file: string -> + ?output_file: string -> Ast.str_item -> unit + end + module MakeMore (Syntax : Sig.Camlp4Syntax) : + Sig.Printer with module Ast = Syntax.Ast + end = + struct + open Format + module Id = + struct + let name = "Camlp4.Printers.OCamlr" + let version = + "$Id: Camlp4.ml,v 1.3 2007/02/26 16:43:01 ertai Exp $" + end + module Make (Syntax : Sig.Camlp4Syntax) = + struct + include Syntax + open Sig + module PP_o = OCaml.Make(Syntax) + open PP_o + let pp = fprintf + class printer ?curry_constr:(init_curry_constr = true) + ?(comments = true) () = + object (o) + inherit + PP_o.printer ~curry_constr: init_curry_constr ~comments () as + super + val semisep = ";" + val andsep = + ("@]@ @[<2>and@ " : (unit, formatter, unit) format) + val value_val = "value" + val value_let = "value" + val mode = if comments then `comments else `no_comments + val curry_constr = init_curry_constr + val first_match_case = true + method under_pipe = o + method under_semi = o + method reset_semi = o + method reset = o + method private unset_first_match_case = + {< first_match_case = false; >} + method private set_first_match_case = + {< first_match_case = true; >} + method seq = + fun f e -> + let rec self right f e = + let go_right = self right + and go_left = self false + in + match e with + | Ast.ExLet (_, r, bi, 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 + | Ast.ExSeq (_, e) -> go_right f e + | Ast.ExSem (_, e1, e2) -> + (pp f "%a;@ " go_left e1; + (match (right, e2) with + | (true, Ast.ExLet (_, r, bi, 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 = + fun f -> + function + | "" -> 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 = + fun f -> + function + | [] -> () + | [ x ] -> pp f "@ %a" o#ctyp x + | l -> pp f "@ @[<1>%a@]" (list o#ctyp "@ ") l + method match_case = + fun f -> + function + | Ast.McNil _ -> pp f "@ []" + | m -> + pp f "@ [ %a ]" o#set_first_match_case#match_case_aux + m + method match_case_aux = + fun f -> + function + | Ast.McNil _ -> () + | Ast.McAnt (_, s) -> o#anti f s + | Ast.McOr (_, a1, a2) -> + pp f "%a%a" o#match_case_aux a1 + o#unset_first_match_case#match_case_aux a2 + | Ast.McArr (_, p, (Ast.ExNil _), e) -> + let () = if first_match_case then () else pp f "@ | " + in + pp f "@[<2>%a@ ->@ %a@]" o#patt p o#under_pipe#expr + e + | Ast.McArr (_, p, 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 = fun f t -> pp f "@[[ %a ]@]" o#ctyp t + method ident = + fun f i -> + let () = o#node f i Ast.loc_of_ident + in + match i with + | Ast.IdApp (_, i1, i2) -> + pp f "%a@ %a" o#dot_ident i1 o#dot_ident i2 + | i -> o#dot_ident f i + method private dot_ident = + fun f i -> + let () = o#node f i Ast.loc_of_ident + in + match i with + | Ast.IdAcc (_, i1, i2) -> + pp f "%a.@,%a" o#dot_ident i1 o#dot_ident i2 + | Ast.IdAnt (_, s) -> o#anti f s + | Ast.IdLid (_, s) | Ast.IdUid (_, s) -> o#var f s + | i -> pp f "(%a)" o#ident i + method patt4 = + fun f -> + function + | (Ast.PaApp (_, + (Ast.PaApp (_, + (Ast.PaId (_, (Ast.IdUid (_, "::")))), _)), + _) + 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 = + fun _ 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 = + fun f e -> + let () = o#node f e Ast.loc_of_expr + in + match e with + | Ast.ExAss (_, e1, e2) -> + pp f "@[<2>%a@ :=@ %a@]" o#expr e1 o#expr e2 + | Ast.ExFun (_, (Ast.McArr (_, p, (Ast.ExNil _), e))) + when Ast.is_irrefut_patt p -> + pp f "@[<2>fun@ %a@]" o#patt_expr_fun_args (p, e) + | Ast.ExFun (_, a) -> + pp f "@[fun%a@]" o#match_case a + | Ast.ExAsf _ -> pp f "@[<2>assert@ False@]" + | e -> super#expr f e + method dot_expr = + fun f e -> + let () = o#node f e Ast.loc_of_expr + in + match e with + | Ast.ExAcc (_, e, + (Ast.ExId (_, (Ast.IdLid (_, "val"))))) -> + pp f "@[<2>%a.@,val@]" o#simple_expr e + | e -> super#dot_expr f e + method simple_expr = + fun f e -> + let () = o#node f e Ast.loc_of_expr + in + match e with + | Ast.ExFor (_, s, e1, e2, Ast.BTrue, e3) -> + pp f + "@[@[@[<2>for %a@ =@ %a@ to@ %a@ do {@]@ %a@]@ }@]" + o#var s o#expr e1 o#expr e2 o#seq e3 + | Ast.ExFor (_, s, e1, e2, Ast.BFalse, e3) -> + pp f + "@[@[@[<2>for %a@ =@ %a@ downto@ %a@ do {@]@ %a@]@ }@]" + o#var s o#expr e1 o#expr e2 o#seq e3 + | Ast.ExWhi (_, e1, e2) -> + pp f "@[<2>while@ %a@ do {@ %a@ }@]" o#expr e1 + o#seq e2 + | Ast.ExSeq (_, e) -> + pp f "@[@[do {@ %a@]@ }@]" o#seq e + | e -> super#simple_expr f e + method ctyp = + fun f t -> + let () = o#node f t Ast.loc_of_ctyp + in + match t with + | Ast.TyDcl (_, tn, tp, te, cl) -> + (pp f "@[<2>%a%a@]" o#var tn o#type_params tp; + (match te with + | Ast.TyQuo (_, s) when + not + (List.exists + (function + | Ast.TyQuo (_, s') -> s = s' + | _ -> false) + tp) + -> () + | _ -> pp f " =@ %a" o#ctyp te); + if cl <> [] + then pp f "@ %a" (list o#constrain "@ ") cl + else ()) + | Ast.TyCol (_, t1, (Ast.TyMut (_, t2))) -> + pp f "@[%a :@ mutable %a@]" o#ctyp t1 o#ctyp t2 + | t -> super#ctyp f t + method simple_ctyp = + fun f t -> + let () = o#node f t Ast.loc_of_ctyp + in + match t with + | Ast.TyVrnEq (_, t) -> + pp f "@[<2>[ =@ %a@]@ ]" o#ctyp t + | Ast.TyVrnInf (_, t) -> + pp f "@[<2>[ <@ %a@]@,]" o#ctyp t + | Ast.TyVrnInfSup (_, t1, t2) -> + pp f "@[<2>[ <@ %a@ >@ %a@]@ ]" o#ctyp t1 o#ctyp t2 + | Ast.TyVrnSup (_, t) -> + pp f "@[<2>[ >@ %a@]@,]" o#ctyp t + | Ast.TyMan (_, t1, t2) -> + pp f "@[<2>%a@ ==@ %a@]" o#simple_ctyp t1 + o#simple_ctyp t2 + | Ast.TyLab (_, s, t) -> + pp f "@[<2>~%s:@ %a@]" s o#simple_ctyp t + | t -> super#simple_ctyp f t + method ctyp1 = + fun f -> + function + | Ast.TyApp (_, 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)) + | Ast.TyPol (_, 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 = + fun f t -> + match t with + | Ast.TyAnd (loc, t1, 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 = + fun f st -> + match st with + | Ast.StExp (_, e) -> pp f "@[<2>%a%s@]" o#expr e semisep + | st -> super#str_item f st + method module_expr = + fun f me -> + let () = o#node f me Ast.loc_of_module_expr + in + match me with + | Ast.MeApp (_, me1, me2) -> + pp f "@[<2>%a@,(%a)@]" o#module_expr me1 + o#module_expr me2 + | me -> super#module_expr f me + method implem = fun f st -> pp f "@[%a@]@." o#str_item st + method class_type = + fun f ct -> + let () = o#node f ct Ast.loc_of_class_type + in + match ct with + | Ast.CtFun (_, t, ct) -> + pp f "@[<2>[ %a ] ->@ %a@]" o#simple_ctyp t + o#class_type ct + | Ast.CtCon (_, Ast.BFalse, i, (Ast.TyNil _)) -> + pp f "@[<2>%a@]" o#ident i + | Ast.CtCon (_, Ast.BFalse, i, t) -> + pp f "@[<2>%a [@,%a@]@,]" o#ident i o#class_params + t + | Ast.CtCon (_, Ast.BTrue, i, (Ast.TyNil _)) -> + pp f "@[<2>virtual@ %a@]" o#ident i + | Ast.CtCon (_, Ast.BTrue, i, t) -> + pp f "@[<2>virtual@ %a@ [@,%a@]@,]" o#ident i + o#class_params t + | ct -> super#class_type f ct + method class_expr = + fun f ce -> + let () = o#node f ce Ast.loc_of_class_expr + in + match ce with + | Ast.CeCon (_, Ast.BFalse, i, (Ast.TyNil _)) -> + pp f "@[<2>%a@]" o#ident i + | Ast.CeCon (_, Ast.BFalse, i, t) -> + pp f "@[<2>%a@ @[<1>[%a]@]@]" o#ident i + o#class_params t + | Ast.CeCon (_, Ast.BTrue, i, (Ast.TyNil _)) -> + pp f "@[<2>virtual@ %a@]" o#ident i + | Ast.CeCon (_, Ast.BTrue, i, t) -> + pp f "@[<2>virtual@ %a@ @[<1>[%a]@]@]" o#ident i + o#ctyp t + | ce -> super#class_expr f ce + end + let with_outfile = with_outfile + let print = print + let print_interf = print_interf + let print_implem = print_implem + end + module MakeMore (Syntax : Sig.Camlp4Syntax) : + Sig.Printer with module Ast = Syntax.Ast = + struct + include Make(Syntax) + let margin = ref 78 + let comments = ref true + let locations = ref false + let curry_constr = ref true + let print output_file fct = + let o = + new printer ~comments: !comments ~curry_constr: !curry_constr + () in + let o = if !locations then o#set_loc_and_comments else o + in + with_outfile output_file + (fun f -> + let () = Format.pp_set_margin f !margin + in Format.fprintf f "@[%a@]@." (fct o)) + let print_interf ?input_file:(_) ?output_file sg = + print output_file (fun o -> o#interf) sg + let print_implem ?input_file:(_) ?output_file st = + print output_file (fun o -> o#implem) st + let _ = + Options.add "-l" (Arg.Int (fun i -> margin := i)) + " line length for pretty printing." + let _ = + Options.add "-no_comments" (Arg.Clear comments) + "Do not add comments." + let _ = + Options.add "-add_locations" (Arg.Set locations) + "Add locations as comment." + end + end + end +module OCamlInitSyntax = + struct + module Make + (Warning : Sig.Warning) + (Ast : Sig.Camlp4Ast with module Loc = Warning.Loc) + (Gram : + Sig.Grammar.Static with module Loc = Warning.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 AntiquotSyntax.Ast = Sig.Camlp4AstToAst(Ast) + and module Quotation = Quotation = + struct + module Warning = Warning + module Loc = Ast.Loc + module Ast = Ast + module Gram = Gram + module Token = Gram.Token + open Sig + let a_CHAR = Gram.Entry.mk "a_CHAR" + let a_FLOAT = Gram.Entry.mk "a_FLOAT" + let a_INT = Gram.Entry.mk "a_INT" + let a_INT32 = Gram.Entry.mk "a_INT32" + let a_INT64 = Gram.Entry.mk "a_INT64" + let a_LABEL = Gram.Entry.mk "a_LABEL" + let a_LIDENT = Gram.Entry.mk "a_LIDENT" + let a_LIDENT_or_operator = Gram.Entry.mk "a_LIDENT_or_operator" + let a_NATIVEINT = Gram.Entry.mk "a_NATIVEINT" + let a_OPTLABEL = Gram.Entry.mk "a_OPTLABEL" + let a_STRING = Gram.Entry.mk "a_STRING" + let a_UIDENT = Gram.Entry.mk "a_UIDENT" + let a_ident = Gram.Entry.mk "a_ident" + let amp_ctyp = Gram.Entry.mk "amp_ctyp" + let and_ctyp = Gram.Entry.mk "and_ctyp" + let match_case = Gram.Entry.mk "match_case" + let match_case0 = Gram.Entry.mk "match_case0" + let binding = Gram.Entry.mk "binding" + let class_declaration = Gram.Entry.mk "class_declaration" + let class_description = Gram.Entry.mk "class_description" + let class_expr = Gram.Entry.mk "class_expr" + let class_fun_binding = Gram.Entry.mk "class_fun_binding" + let class_fun_def = Gram.Entry.mk "class_fun_def" + let class_info_for_class_expr = + Gram.Entry.mk "class_info_for_class_expr" + let class_info_for_class_type = + Gram.Entry.mk "class_info_for_class_type" + let class_longident = Gram.Entry.mk "class_longident" + let class_longident_and_param = + Gram.Entry.mk "class_longident_and_param" + let class_name_and_param = Gram.Entry.mk "class_name_and_param" + let class_sig_item = Gram.Entry.mk "class_sig_item" + let class_signature = Gram.Entry.mk "class_signature" + let class_str_item = Gram.Entry.mk "class_str_item" + let class_structure = Gram.Entry.mk "class_structure" + let class_type = Gram.Entry.mk "class_type" + let class_type_declaration = Gram.Entry.mk "class_type_declaration" + let class_type_longident = Gram.Entry.mk "class_type_longident" + let class_type_longident_and_param = + Gram.Entry.mk "class_type_longident_and_param" + let class_type_plus = Gram.Entry.mk "class_type_plus" + let comma_ctyp = Gram.Entry.mk "comma_ctyp" + let comma_expr = Gram.Entry.mk "comma_expr" + let comma_ipatt = Gram.Entry.mk "comma_ipatt" + let comma_patt = Gram.Entry.mk "comma_patt" + let comma_type_parameter = Gram.Entry.mk "comma_type_parameter" + let constrain = Gram.Entry.mk "constrain" + let constructor_arg_list = Gram.Entry.mk "constructor_arg_list" + let constructor_declaration = Gram.Entry.mk "constructor_declaration" + let constructor_declarations = + Gram.Entry.mk "constructor_declarations" + let ctyp = Gram.Entry.mk "ctyp" + let cvalue_binding = Gram.Entry.mk "cvalue_binding" + let direction_flag = Gram.Entry.mk "direction_flag" + let dummy = Gram.Entry.mk "dummy" + let entry_eoi = Gram.Entry.mk "entry_eoi" + let eq_expr = Gram.Entry.mk "eq_expr" + let expr = Gram.Entry.mk "expr" + let expr_eoi = Gram.Entry.mk "expr_eoi" + let field = Gram.Entry.mk "field" + let field_expr = Gram.Entry.mk "field_expr" + let fun_binding = Gram.Entry.mk "fun_binding" + let fun_def = Gram.Entry.mk "fun_def" + let ident = Gram.Entry.mk "ident" + let implem = Gram.Entry.mk "implem" + let interf = Gram.Entry.mk "interf" + let ipatt = Gram.Entry.mk "ipatt" + let ipatt_tcon = Gram.Entry.mk "ipatt_tcon" + let label = Gram.Entry.mk "label" + let label_declaration = Gram.Entry.mk "label_declaration" + let label_expr = Gram.Entry.mk "label_expr" + let label_ipatt = Gram.Entry.mk "label_ipatt" + let label_longident = Gram.Entry.mk "label_longident" + let label_patt = Gram.Entry.mk "label_patt" + let labeled_ipatt = Gram.Entry.mk "labeled_ipatt" + let let_binding = Gram.Entry.mk "let_binding" + let meth_list = Gram.Entry.mk "meth_list" + let module_binding = Gram.Entry.mk "module_binding" + let module_binding0 = Gram.Entry.mk "module_binding0" + let module_declaration = Gram.Entry.mk "module_declaration" + let module_expr = Gram.Entry.mk "module_expr" + let module_longident = Gram.Entry.mk "module_longident" + let module_longident_with_app = + Gram.Entry.mk "module_longident_with_app" + let module_rec_declaration = Gram.Entry.mk "module_rec_declaration" + let module_type = Gram.Entry.mk "module_type" + let more_ctyp = Gram.Entry.mk "more_ctyp" + let name_tags = Gram.Entry.mk "name_tags" + let opt_as_lident = Gram.Entry.mk "opt_as_lident" + let opt_class_self_patt = Gram.Entry.mk "opt_class_self_patt" + let opt_class_self_type = Gram.Entry.mk "opt_class_self_type" + let opt_class_signature = Gram.Entry.mk "opt_class_signature" + let opt_class_structure = Gram.Entry.mk "opt_class_structure" + let opt_comma_ctyp = Gram.Entry.mk "opt_comma_ctyp" + let opt_dot_dot = Gram.Entry.mk "opt_dot_dot" + let opt_eq_ctyp = Gram.Entry.mk "opt_eq_ctyp" + let opt_expr = Gram.Entry.mk "opt_expr" + let opt_meth_list = Gram.Entry.mk "opt_meth_list" + let opt_mutable = Gram.Entry.mk "opt_mutable" + let opt_polyt = Gram.Entry.mk "opt_polyt" + let opt_private = Gram.Entry.mk "opt_private" + let opt_rec = Gram.Entry.mk "opt_rec" + let opt_sig_items = Gram.Entry.mk "opt_sig_items" + let opt_str_items = Gram.Entry.mk "opt_str_items" + let opt_virtual = Gram.Entry.mk "opt_virtual" + let opt_when_expr = Gram.Entry.mk "opt_when_expr" + let patt = Gram.Entry.mk "patt" + let patt_as_patt_opt = Gram.Entry.mk "patt_as_patt_opt" + let patt_eoi = Gram.Entry.mk "patt_eoi" + let patt_tcon = Gram.Entry.mk "patt_tcon" + let phrase = Gram.Entry.mk "phrase" + let pipe_ctyp = Gram.Entry.mk "pipe_ctyp" + let poly_type = Gram.Entry.mk "poly_type" + let row_field = Gram.Entry.mk "row_field" + let sem_ctyp = Gram.Entry.mk "sem_ctyp" + let sem_expr = Gram.Entry.mk "sem_expr" + let sem_expr_for_list = Gram.Entry.mk "sem_expr_for_list" + let sem_patt = Gram.Entry.mk "sem_patt" + let sem_patt_for_list = Gram.Entry.mk "sem_patt_for_list" + let semi = Gram.Entry.mk "semi" + let sequence = Gram.Entry.mk "sequence" + let sig_item = Gram.Entry.mk "sig_item" + let sig_items = Gram.Entry.mk "sig_items" + let star_ctyp = Gram.Entry.mk "star_ctyp" + let str_item = Gram.Entry.mk "str_item" + let str_items = Gram.Entry.mk "str_items" + let top_phrase = Gram.Entry.mk "top_phrase" + let type_constraint = Gram.Entry.mk "type_constraint" + let type_declaration = Gram.Entry.mk "type_declaration" + let type_ident_and_parameters = + Gram.Entry.mk "type_ident_and_parameters" + let type_kind = Gram.Entry.mk "type_kind" + let type_longident = Gram.Entry.mk "type_longident" + let type_longident_and_parameters = + Gram.Entry.mk "type_longident_and_parameters" + let type_parameter = Gram.Entry.mk "type_parameter" + let type_parameters = Gram.Entry.mk "type_parameters" + let typevars = Gram.Entry.mk "typevars" + let use_file = Gram.Entry.mk "use_file" + let val_longident = Gram.Entry.mk "val_longident" + let value_let = Gram.Entry.mk "value_let" + let value_val = Gram.Entry.mk "value_val" + let with_constr = Gram.Entry.mk "with_constr" + let expr_quot = Gram.Entry.mk "quotation of expression" + let patt_quot = Gram.Entry.mk "quotation of pattern" + let ctyp_quot = Gram.Entry.mk "quotation of type" + let str_item_quot = Gram.Entry.mk "quotation of structure item" + let sig_item_quot = Gram.Entry.mk "quotation of signature item" + let class_str_item_quot = + Gram.Entry.mk "quotation of class structure item" + let class_sig_item_quot = + Gram.Entry.mk "quotation of class signature item" + let module_expr_quot = Gram.Entry.mk "quotation of module expression" + let module_type_quot = Gram.Entry.mk "quotation of module type" + let class_type_quot = Gram.Entry.mk "quotation of class type" + let class_expr_quot = Gram.Entry.mk "quotation of class expression" + let with_constr_quot = Gram.Entry.mk "quotation of with constraint" + let binding_quot = Gram.Entry.mk "quotation of binding" + let match_case_quot = + Gram.Entry.mk "quotation of match_case (try/match/function case)" + let module_binding_quot = + Gram.Entry.mk "quotation of module rec binding" + let ident_quot = Gram.Entry.mk "quotation of identifier" + let _ = + Gram.extend (top_phrase : 'top_phrase Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | EOI -> true | _ -> false), "EOI")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) -> + match __camlp4_0 with + | EOI -> (None : 'top_phrase) + | _ -> assert false))) ]) ])) + ()) + module AntiquotSyntax = + struct + module Loc = Ast.Loc + module Ast = Sig.Camlp4AstToAst(Ast) + module Gram = Gram + let antiquot_expr = Gram.Entry.mk "antiquot_expr" + let antiquot_patt = Gram.Entry.mk "antiquot_patt" + let _ = + (Gram.extend (antiquot_expr : 'antiquot_expr Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Stoken + (((function | EOI -> true | _ -> false), + "EOI")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (x : 'expr) + (_loc : Loc.t) -> + match __camlp4_0 with + | EOI -> (x : 'antiquot_expr) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (antiquot_patt : 'antiquot_patt Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Stoken + (((function | EOI -> true | _ -> false), + "EOI")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (x : 'patt) + (_loc : Loc.t) -> + match __camlp4_0 with + | EOI -> (x : 'antiquot_patt) + | _ -> assert false))) ]) ])) + ())) + let parse_expr loc str = Gram.parse_string antiquot_expr loc str + let parse_patt loc str = Gram.parse_string antiquot_patt loc str + end + module Quotation = Quotation + module Parser = + struct + module Ast = Ast + let 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 + let parse_implem ?(directive_handler = fun _ -> None) _loc cs = + let l = wrap directive_handler (Gram.parse implem) _loc cs + in Ast.stSem_of_list l + let parse_interf ?(directive_handler = fun _ -> None) _loc cs = + let l = wrap directive_handler (Gram.parse interf) _loc cs + in Ast.sgSem_of_list l + end + module Printer = Struct.EmptyPrinter.Make(Ast) + end + end +module PreCast : + sig + 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 * string + | INT32 of int32 * string | INT64 of int64 * string + | NATIVEINT of nativeint * string | FLOAT of float * string + | CHAR of char * string | STRING of string * string | LABEL of string + | OPTLABEL of string | QUOTATION of Sig.quotation + | ANTIQUOT of string * string | COMMENT of string | BLANKS of string + | NEWLINE | LINE_DIRECTIVE of int * string option | EOI + module Id : Sig.Id + module Loc : Sig.Loc + module Warning : Sig.Warning with module Loc = 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 Warning = Warning and module Token = Token + and module Ast = Ast and module Gram = Gram + and module Quotation = Quotation + module Printers : + sig + module OCaml : Sig.Printer with module Ast = Sig.Camlp4AstToAst(Ast) + module OCamlr : Sig.Printer with module Ast = Sig.Camlp4AstToAst(Ast) + module DumpOCamlAst : + Sig.Printer with module Ast = Sig.Camlp4AstToAst(Ast) + module DumpCamlp4Ast : + Sig.Printer with module Ast = Sig.Camlp4AstToAst(Ast) + module Null : Sig.Printer with module Ast = Sig.Camlp4AstToAst(Ast) + 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 + end = + struct + module Id = + struct + let name = "Camlp4.PreCast" + let version = "$Id: Camlp4.ml,v 1.3 2007/02/26 16:43:01 ertai Exp $" + 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 * string + | INT32 of int32 * string | INT64 of int64 * string + | NATIVEINT of nativeint * string | FLOAT of float * string + | CHAR of char * string | STRING of string * string | LABEL of string + | OPTLABEL of string | QUOTATION of Sig.quotation + | ANTIQUOT of string * string | COMMENT of string | BLANKS of string + | NEWLINE | LINE_DIRECTIVE of int * string option | EOI + module Loc = Struct.Loc + module Warning = Struct.Warning.Make(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(Warning)(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 DumpOCamlAst = Printers.DumpOCamlAst.Make(Syntax) + module DumpCamlp4Ast = Printers.DumpCamlp4Ast.Make(Syntax) + module Null = Printers.Null.Make(Syntax) + end + end +module Register : + sig + 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 + type 'a parser_fun = + ?directive_handler: ('a -> 'a option) -> + PreCast.Loc.t -> char Stream.t -> 'a + val register_str_item_parser : PreCast.Ast.str_item parser_fun -> unit + val register_sig_item_parser : PreCast.Ast.sig_item parser_fun -> unit + val register_parser : + PreCast.Ast.str_item parser_fun -> + PreCast.Ast.sig_item parser_fun -> unit + module Parser + (Id : Sig.Id) + (Maker : functor (Ast : Sig.Ast) -> Sig.Parser with module Ast = Ast) : + sig end + module OCamlParser + (Id : Sig.Id) + (Maker : + functor (Ast : Sig.Camlp4Ast) -> Sig.Parser with module Ast = Ast) : + sig end + module OCamlPreCastParser + (Id : Sig.Id) (Parser : Sig.Parser with module Ast = PreCast.Ast) : + sig end + type 'a printer_fun = + ?input_file: string -> ?output_file: string -> 'a -> unit + val register_str_item_printer : PreCast.Ast.str_item printer_fun -> unit + val register_sig_item_printer : PreCast.Ast.sig_item printer_fun -> unit + val register_printer : + PreCast.Ast.str_item printer_fun -> + PreCast.Ast.sig_item printer_fun -> unit + module Printer + (Id : Sig.Id) + (Maker : + functor (Syn : Sig.Syntax) -> Sig.Printer with module Ast = Syn.Ast) : + sig end + module OCamlPrinter + (Id : Sig.Id) + (Maker : + functor (Syn : Sig.Camlp4Syntax) -> + Sig.Printer with module Ast = Syn.Ast) : + sig end + module OCamlPreCastPrinter + (Id : Sig.Id) (Printer : Sig.Printer with module Ast = PreCast.Ast) : + sig end + module AstFilter + (Id : Sig.Id) (Maker : functor (F : Sig.AstFilters) -> sig end) : + sig end + val declare_dyn_module : string -> (unit -> unit) -> unit + val iter_and_take_callbacks : ((string * (unit -> unit)) -> unit) -> unit + module CurrentParser : Sig.Parser with module Ast = PreCast.Ast + module CurrentPrinter : Sig.Printer with module Ast = PreCast.Ast + val enable_ocaml_printer : unit -> unit + val enable_ocamlr_printer : unit -> unit + val enable_null_printer : unit -> unit + val enable_dump_ocaml_ast_printer : unit -> unit + val enable_dump_camlp4_ast_printer : unit -> unit + end = + struct + module PP = Printers + open PreCast + type 'a parser_fun = + ?directive_handler: ('a -> 'a option) -> + PreCast.Loc.t -> char Stream.t -> 'a + type 'a printer_fun = + ?input_file: string -> ?output_file: string -> 'a -> unit + let sig_item_parser = + ref (fun ?directive_handler:(_) _ _ -> failwith "No interface parser") + let str_item_parser = + ref + (fun ?directive_handler:(_) _ _ -> + failwith "No implementation parser") + let sig_item_printer = + ref + (fun ?input_file:(_) ?output_file:(_) _ -> + failwith "No interface printer") + let str_item_printer = + ref + (fun ?input_file:(_) ?output_file:(_) _ -> + failwith "No implementation printer") + let callbacks = Queue.create () + let iter_and_take_callbacks f = + let rec loop () = loop (f (Queue.take callbacks)) + in try loop () with | Queue.Empty -> () + let declare_dyn_module m f = Queue.add (m, f) callbacks + let register_str_item_parser f = str_item_parser := f + let register_sig_item_parser f = sig_item_parser := f + let register_parser f g = (str_item_parser := f; sig_item_parser := g) + let register_str_item_printer f = str_item_printer := f + let register_sig_item_printer f = sig_item_printer := f + let register_printer f g = (str_item_printer := f; sig_item_printer := g) + module Plugin + (Id : Sig.Id) (Maker : functor (Unit : sig end) -> sig end) = + struct + let _ = + declare_dyn_module Id.name + (fun _ -> let module M = Maker(struct end) in ()) + end + module SyntaxExtension (Id : Sig.Id) (Maker : Sig.SyntaxExtension) = + struct + let _ = + 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 + let _ = + 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 + let _ = + 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 with module Ast = Syn.Ast) = + struct + let _ = + 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 with module Ast = Syn.Ast) = + struct + let _ = + 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 with module Ast = PreCast.Ast) = + struct + let _ = + 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 with module Ast = Ast) = + struct + let _ = + 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 with module Ast = Ast) = + struct + let _ = + 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 with module Ast = PreCast.Ast) = + struct + let _ = + 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 + let _ = + declare_dyn_module Id.name + (fun _ -> let module M = Maker(AstFilters) in ()) + end + let _ = let module M = Syntax.Parser + in + (sig_item_parser := M.parse_interf; + str_item_parser := M.parse_implem) + module CurrentParser = + struct + module Ast = Ast + let parse_interf ?directive_handler loc strm = + !sig_item_parser ?directive_handler loc strm + let parse_implem ?directive_handler loc strm = + !str_item_parser ?directive_handler loc strm + end + module CurrentPrinter = + struct + module Ast = Ast + let print_interf ?input_file ?output_file ast = + !sig_item_printer ?input_file ?output_file ast + let print_implem ?input_file ?output_file ast = + !str_item_printer ?input_file ?output_file ast + end + let enable_ocaml_printer () = + let module M = OCamlPrinter(PP.OCaml.Id)(PP.OCaml.MakeMore) in () + let enable_ocamlr_printer () = + let module M = OCamlPrinter(PP.OCamlr.Id)(PP.OCamlr.MakeMore) in () + let enable_dump_ocaml_ast_printer () = + let module M = OCamlPrinter(PP.DumpOCamlAst.Id)(PP.DumpOCamlAst.Make) + in () + let enable_dump_camlp4_ast_printer () = + let module M = Printer(PP.DumpCamlp4Ast.Id)(PP.DumpCamlp4Ast.Make) + in () + let enable_null_printer () = + let module M = Printer(PP.Null.Id)(PP.Null.Make) in () + end + diff --git a/camlp4/boot/Camlp4.ml4 b/camlp4/boot/Camlp4.ml4 new file mode 100644 index 00000000..597f4291 --- /dev/null +++ b/camlp4/boot/Camlp4.ml4 @@ -0,0 +1,79 @@ +module Debug : sig INCLUDE "camlp4/Camlp4/Debug.mli"; end = struct INCLUDE "camlp4/Camlp4/Debug.ml"; end; +module Options : sig INCLUDE "camlp4/Camlp4/Options.mli"; end = struct INCLUDE "camlp4/Camlp4/Options.ml"; end; +module Sig = struct INCLUDE "camlp4/Camlp4/Sig.ml"; end; +module ErrorHandler : sig INCLUDE "camlp4/Camlp4/ErrorHandler.mli"; end = struct INCLUDE "camlp4/Camlp4/ErrorHandler.ml"; end; + +module Struct = struct + module Loc : + sig INCLUDE "camlp4/Camlp4/Struct/Loc.mli"; end = + struct INCLUDE "camlp4/Camlp4/Struct/Loc.ml"; end; + module Warning = struct INCLUDE "camlp4/Camlp4/Struct/Warning.ml"; end; + module Token : + sig INCLUDE "camlp4/Camlp4/Struct/Token.mli"; end = + struct INCLUDE "camlp4/Camlp4/Struct/Token.ml"; end; + module Lexer = struct INCLUDE "camlp4/boot/Lexer.ml"; end; + module Camlp4Ast = struct INCLUDE "camlp4/Camlp4/Struct/Camlp4Ast.ml"; end; + module Quotation = struct INCLUDE "camlp4/Camlp4/Struct/Quotation.ml"; end; + module AstFilters = struct INCLUDE "camlp4/Camlp4/Struct/AstFilters.ml"; end; + module Camlp4Ast2OCamlAst : + sig INCLUDE "camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli"; end = + struct INCLUDE "camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml"; end; + module CleanAst = struct INCLUDE "camlp4/Camlp4/Struct/CleanAst.ml"; end; + module CommentFilter : + sig INCLUDE "camlp4/Camlp4/Struct/CommentFilter.mli"; end = + struct INCLUDE "camlp4/Camlp4/Struct/CommentFilter.ml"; end; + module DynLoader : + sig INCLUDE "camlp4/Camlp4/Struct/DynLoader.mli"; end = + struct INCLUDE "camlp4/Camlp4/Struct/DynLoader.ml"; end; + module EmptyError : + sig INCLUDE "camlp4/Camlp4/Struct/EmptyError.mli"; end = + struct INCLUDE "camlp4/Camlp4/Struct/EmptyError.ml"; end; + module EmptyPrinter : + sig INCLUDE "camlp4/Camlp4/Struct/EmptyPrinter.mli"; end = + struct INCLUDE "camlp4/Camlp4/Struct/EmptyPrinter.ml"; end; + module FreeVars : + sig INCLUDE "camlp4/Camlp4/Struct/FreeVars.mli"; end = + struct INCLUDE "camlp4/Camlp4/Struct/FreeVars.ml"; end; + module Grammar = struct + module Context = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Context.ml"; end; + module Structure = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Structure.ml"; end; + module Search = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Search.ml"; end; + (* module Find = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Find.ml"; end; *) + module Tools = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Tools.ml"; end; + module Print : + sig INCLUDE "camlp4/Camlp4/Struct/Grammar/Print.mli"; end = + struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Print.ml"; end; + module Failed = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Failed.ml"; end; + module Parser = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Parser.ml"; end; + module Insert = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Insert.ml"; end; + module Delete = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Delete.ml"; end; + module Fold : + sig INCLUDE "camlp4/Camlp4/Struct/Grammar/Fold.mli"; end = + struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Fold.ml"; end; + module Entry = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Entry.ml"; end; + module Static = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Static.ml"; end; + module Dynamic = struct INCLUDE "camlp4/Camlp4/Struct/Grammar/Dynamic.ml"; end; + end; +end; + +module Printers = struct + module DumpCamlp4Ast : + sig INCLUDE "camlp4/Camlp4/Printers/DumpCamlp4Ast.mli"; end = + struct INCLUDE "camlp4/Camlp4/Printers/DumpCamlp4Ast.ml"; end; + module DumpOCamlAst : + sig INCLUDE "camlp4/Camlp4/Printers/DumpOCamlAst.mli"; end = + struct INCLUDE "camlp4/Camlp4/Printers/DumpOCamlAst.ml"; end; + module Null : + sig INCLUDE "camlp4/Camlp4/Printers/Null.mli"; end = + struct INCLUDE "camlp4/Camlp4/Printers/Null.ml"; end; + module OCaml : + sig INCLUDE "camlp4/Camlp4/Printers/OCaml.mli"; end = + struct INCLUDE "camlp4/Camlp4/Printers/OCaml.ml"; end; + module OCamlr : + sig INCLUDE "camlp4/Camlp4/Printers/OCamlr.mli"; end = + struct INCLUDE "camlp4/Camlp4/Printers/OCamlr.ml"; end; +end; + +module OCamlInitSyntax = struct INCLUDE "camlp4/Camlp4/OCamlInitSyntax.ml"; end; +module PreCast : sig INCLUDE "camlp4/Camlp4/PreCast.mli"; end = struct INCLUDE "camlp4/Camlp4/PreCast.ml"; end; +module Register : sig INCLUDE "camlp4/Camlp4/Register.mli"; end = struct INCLUDE "camlp4/Camlp4/Register.ml"; end; diff --git a/camlp4/boot/Camlp4Ast.ml b/camlp4/boot/Camlp4Ast.ml new file mode 100644 index 00000000..91b3d51c --- /dev/null +++ b/camlp4/boot/Camlp4Ast.ml @@ -0,0 +1,4948 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) +(* 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_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"; + 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 + Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Loc") + (Ast.IdLid _loc "of_tuple"))) + (Ast.PaTup _loc + (Ast.PaCom _loc + (Ast.PaStr _loc (Ast.safe_string_escaped a)) + (Ast.PaCom _loc + (Ast.PaCom _loc + (Ast.PaCom _loc + (Ast.PaCom _loc + (Ast.PaCom _loc + (Ast.PaCom _loc + (Ast.PaInt _loc (string_of_int b)) + (Ast.PaInt _loc (string_of_int c))) + (Ast.PaInt _loc (string_of_int d))) + (Ast.PaInt _loc (string_of_int e))) + (Ast.PaInt _loc (string_of_int f))) + (Ast.PaInt _loc (string_of_int g))) + (if h + then Ast.PaId _loc (Ast.IdUid _loc "True") + else Ast.PaId _loc (Ast.IdUid _loc "False"))))); + value meta_loc_expr _loc location = + let (a, b, c, d, e, f, g, h) = Loc.to_tuple location + in + Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Loc") + (Ast.IdLid _loc "of_tuple"))) + (Ast.ExTup _loc + (Ast.ExCom _loc + (Ast.ExStr _loc (Ast.safe_string_escaped a)) + (Ast.ExCom _loc + (Ast.ExCom _loc + (Ast.ExCom _loc + (Ast.ExCom _loc + (Ast.ExCom _loc + (Ast.ExCom _loc + (Ast.ExInt _loc (string_of_int b)) + (Ast.ExInt _loc (string_of_int c))) + (Ast.ExInt _loc (string_of_int d))) + (Ast.ExInt _loc (string_of_int e))) + (Ast.ExInt _loc (string_of_int f))) + (Ast.ExInt _loc (string_of_int g))) + (if h + then Ast.ExId _loc (Ast.IdUid _loc "True") + else Ast.ExId _loc (Ast.IdUid _loc "False"))))); + end; + module MetaGhostLoc = + struct + value meta_loc_patt _loc _ = + Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Loc") + (Ast.IdLid _loc "ghost")); + value meta_loc_expr _loc _ = + Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Loc") + (Ast.IdLid _loc "ghost")); + end; + module MetaLocVar = + struct + value meta_loc_patt _loc _ = + Ast.PaId _loc (Ast.IdLid _loc Loc.name.val); + value meta_loc_expr _loc _ = + Ast.ExId _loc (Ast.IdLid _loc Loc.name.val); + end; + module Make (MetaLoc : META_LOC) = + struct + open MetaLoc; + value meta_acc_Loc_t = meta_loc_expr; + module Expr = + struct + value meta_string _loc s = Ast.ExStr _loc s; + value meta_int _loc s = Ast.ExInt _loc s; + value meta_float _loc s = Ast.ExFlo _loc s; + value meta_char _loc s = Ast.ExChr _loc s; + value meta_bool _loc = + fun + [ False -> Ast.ExId _loc (Ast.IdUid _loc "False") + | True -> Ast.ExId _loc (Ast.IdUid _loc "True") ]; + value rec meta_list mf_a _loc = + fun + [ [] -> Ast.ExId _loc (Ast.IdUid _loc "[]") + | [ x :: xs ] -> + Ast.ExApp _loc + (Ast.ExApp _loc (Ast.ExId _loc (Ast.IdUid _loc "::")) + (mf_a _loc x)) + (meta_list mf_a _loc xs) ]; + value rec meta_binding _loc = + fun + [ Ast.BiAnt x0 x1 -> Ast.ExAnt x0 x1 + | Ast.BiEq x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "BiEq"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_expr _loc x2) + | Ast.BiSem x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "BiSem"))) + (meta_acc_Loc_t _loc x0)) + (meta_binding _loc x1)) + (meta_binding _loc x2) + | Ast.BiAnd x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "BiAnd"))) + (meta_acc_Loc_t _loc x0)) + (meta_binding _loc x1)) + (meta_binding _loc x2) + | Ast.BiNil x0 -> + Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "BiNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_class_expr _loc = + fun + [ Ast.CeAnt x0 x1 -> Ast.ExAnt x0 x1 + | Ast.CeEq x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CeEq"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_expr _loc x1)) + (meta_class_expr _loc x2) + | Ast.CeAnd x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CeAnd"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_expr _loc x1)) + (meta_class_expr _loc x2) + | Ast.CeTyc x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CeTyc"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_expr _loc x1)) + (meta_class_type _loc x2) + | Ast.CeStr x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CeStr"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_class_str_item _loc x2) + | Ast.CeLet x0 x1 x2 x3 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CeLet"))) + (meta_acc_Loc_t _loc x0)) + (meta_meta_bool _loc x1)) + (meta_binding _loc x2)) + (meta_class_expr _loc x3) + | Ast.CeFun x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CeFun"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_class_expr _loc x2) + | Ast.CeCon x0 x1 x2 x3 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CeCon"))) + (meta_acc_Loc_t _loc x0)) + (meta_meta_bool _loc x1)) + (meta_ident _loc x2)) + (meta_ctyp _loc x3) + | Ast.CeApp x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CeApp"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_expr _loc x1)) + (meta_expr _loc x2) + | Ast.CeNil x0 -> + Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CeNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_class_sig_item _loc = + fun + [ Ast.CgAnt x0 x1 -> Ast.ExAnt x0 x1 + | Ast.CgVir x0 x1 x2 x3 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CgVir"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_meta_bool _loc x2)) + (meta_ctyp _loc x3) + | Ast.CgVal x0 x1 x2 x3 x4 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CgVal"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_meta_bool _loc x2)) + (meta_meta_bool _loc x3)) + (meta_ctyp _loc x4) + | Ast.CgMth x0 x1 x2 x3 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CgMth"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_meta_bool _loc x2)) + (meta_ctyp _loc x3) + | Ast.CgInh x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CgInh"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_type _loc x1) + | Ast.CgSem x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CgSem"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_sig_item _loc x1)) + (meta_class_sig_item _loc x2) + | Ast.CgCtr x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CgCtr"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.CgNil x0 -> + Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CgNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_class_str_item _loc = + fun + [ Ast.CrAnt x0 x1 -> Ast.ExAnt x0 x1 + | Ast.CrVvr x0 x1 x2 x3 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CrVvr"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_meta_bool _loc x2)) + (meta_ctyp _loc x3) + | Ast.CrVir x0 x1 x2 x3 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CrVir"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_meta_bool _loc x2)) + (meta_ctyp _loc x3) + | Ast.CrVal x0 x1 x2 x3 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CrVal"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_meta_bool _loc x2)) + (meta_expr _loc x3) + | Ast.CrMth x0 x1 x2 x3 x4 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CrMth"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_meta_bool _loc x2)) + (meta_expr _loc x3)) + (meta_ctyp _loc x4) + | Ast.CrIni x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CrIni"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1) + | Ast.CrInh x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CrInh"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_expr _loc x1)) + (meta_string _loc x2) + | Ast.CrCtr x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CrCtr"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.CrSem x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CrSem"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_str_item _loc x1)) + (meta_class_str_item _loc x2) + | Ast.CrNil x0 -> + Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CrNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_class_type _loc = + fun + [ Ast.CtAnt x0 x1 -> Ast.ExAnt x0 x1 + | Ast.CtEq x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CtEq"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_type _loc x1)) + (meta_class_type _loc x2) + | Ast.CtCol x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CtCol"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_type _loc x1)) + (meta_class_type _loc x2) + | Ast.CtAnd x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CtAnd"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_type _loc x1)) + (meta_class_type _loc x2) + | Ast.CtSig x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CtSig"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_class_sig_item _loc x2) + | Ast.CtFun x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CtFun"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_class_type _loc x2) + | Ast.CtCon x0 x1 x2 x3 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CtCon"))) + (meta_acc_Loc_t _loc x0)) + (meta_meta_bool _loc x1)) + (meta_ident _loc x2)) + (meta_ctyp _loc x3) + | Ast.CtNil x0 -> + Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CtNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_ctyp _loc = + fun + [ Ast.TyAnt x0 x1 -> Ast.ExAnt x0 x1 + | Ast.TyOfAmp x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyOfAmp"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyAmp x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyAmp"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyVrnInfSup x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyVrnInfSup"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyVrnInf x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyVrnInf"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1) + | Ast.TyVrnSup x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyVrnSup"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1) + | Ast.TyVrnEq x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyVrnEq"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1) + | Ast.TySta x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TySta"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyTup x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyTup"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1) + | Ast.TyMut x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyMut"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1) + | Ast.TyPrv x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyPrv"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1) + | Ast.TyOr x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyOr"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyAnd x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyAnd"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyOf x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyOf"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TySum x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TySum"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1) + | Ast.TyCom x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyCom"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TySem x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TySem"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyCol x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyCol"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyRec x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyRec"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1) + | Ast.TyVrn x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyVrn"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.TyQuM x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyQuM"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.TyQuP x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyQuP"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.TyQuo x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyQuo"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.TyPol x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyPol"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyOlb x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyOlb"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyObj x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyObj"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_meta_bool _loc x2) + | Ast.TyDcl x0 x1 x2 x3 x4 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyDcl"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_list meta_ctyp _loc x2)) + (meta_ctyp _loc x3)) + (meta_list + (fun _loc (x1, x2) -> + Ast.ExTup _loc + (Ast.ExCom _loc (meta_ctyp _loc x1) + (meta_ctyp _loc x2))) + _loc x4) + | Ast.TyMan x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyMan"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyId x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyId"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1) + | Ast.TyLab x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyLab"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyCls x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyCls"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1) + | Ast.TyArr x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyArr"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyApp x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyApp"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyAny x0 -> + Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyAny"))) + (meta_acc_Loc_t _loc x0) + | Ast.TyAli x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyAli"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyNil x0 -> + Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_expr _loc = + fun + [ Ast.ExWhi x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExWhi"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_expr _loc x2) + | Ast.ExVrn x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExVrn"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.ExTyc x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExTyc"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_ctyp _loc x2) + | Ast.ExCom x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExCom"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_expr _loc x2) + | Ast.ExTup x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExTup"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1) + | Ast.ExTry x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExTry"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_match_case _loc x2) + | Ast.ExStr x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExStr"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.ExSte x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExSte"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_expr _loc x2) + | Ast.ExSnd x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExSnd"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_string _loc x2) + | Ast.ExSeq x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExSeq"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1) + | Ast.ExRec x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExRec"))) + (meta_acc_Loc_t _loc x0)) + (meta_binding _loc x1)) + (meta_expr _loc x2) + | Ast.ExOvr x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExOvr"))) + (meta_acc_Loc_t _loc x0)) + (meta_binding _loc x1) + | Ast.ExOlb x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExOlb"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_expr _loc x2) + | Ast.ExObj x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExObj"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_class_str_item _loc x2) + | Ast.ExNew x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExNew"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1) + | Ast.ExMat x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExMat"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_match_case _loc x2) + | Ast.ExLmd x0 x1 x2 x3 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExLmd"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_module_expr _loc x2)) + (meta_expr _loc x3) + | Ast.ExLet x0 x1 x2 x3 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExLet"))) + (meta_acc_Loc_t _loc x0)) + (meta_meta_bool _loc x1)) + (meta_binding _loc x2)) + (meta_expr _loc x3) + | Ast.ExLaz x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExLaz"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1) + | Ast.ExLab x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExLab"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_expr _loc x2) + | Ast.ExNativeInt x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExNativeInt"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.ExInt64 x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExInt64"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.ExInt32 x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExInt32"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.ExInt x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExInt"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.ExIfe x0 x1 x2 x3 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExIfe"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_expr _loc x2)) + (meta_expr _loc x3) + | Ast.ExFun x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExFun"))) + (meta_acc_Loc_t _loc x0)) + (meta_match_case _loc x1) + | Ast.ExFor x0 x1 x2 x3 x4 x5 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc + (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExFor"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_expr _loc x2)) + (meta_expr _loc x3)) + (meta_meta_bool _loc x4)) + (meta_expr _loc x5) + | Ast.ExFlo x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExFlo"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.ExCoe x0 x1 x2 x3 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExCoe"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_ctyp _loc x2)) + (meta_ctyp _loc x3) + | Ast.ExChr x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExChr"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.ExAss x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExAss"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_expr _loc x2) + | Ast.ExAsr x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExAsr"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1) + | Ast.ExAsf x0 -> + Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExAsf"))) + (meta_acc_Loc_t _loc x0) + | Ast.ExSem x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExSem"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_expr _loc x2) + | Ast.ExArr x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExArr"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1) + | Ast.ExAre x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExAre"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_expr _loc x2) + | Ast.ExApp x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExApp"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_expr _loc x2) + | Ast.ExAnt x0 x1 -> Ast.ExAnt x0 x1 + | Ast.ExAcc x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExAcc"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_expr _loc x2) + | Ast.ExId x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExId"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1) + | Ast.ExNil x0 -> + Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_ident _loc = + fun + [ Ast.IdAnt x0 x1 -> Ast.ExAnt x0 x1 + | Ast.IdUid x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "IdUid"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.IdLid x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "IdLid"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.IdApp x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "IdApp"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1)) + (meta_ident _loc x2) + | Ast.IdAcc x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "IdAcc"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1)) + (meta_ident _loc x2) ] + and meta_match_case _loc = + fun + [ Ast.McAnt x0 x1 -> Ast.ExAnt x0 x1 + | Ast.McArr x0 x1 x2 x3 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "McArr"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_expr _loc x2)) + (meta_expr _loc x3) + | Ast.McOr x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "McOr"))) + (meta_acc_Loc_t _loc x0)) + (meta_match_case _loc x1)) + (meta_match_case _loc x2) + | Ast.McNil x0 -> + Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "McNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_meta_bool _loc = + fun + [ Ast.BAnt x0 -> Ast.ExAnt _loc x0 + | Ast.BFalse -> + Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "BFalse")) + | Ast.BTrue -> + Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "BTrue")) ] + and meta_meta_list mf_a _loc = + fun + [ Ast.LAnt x0 -> Ast.ExAnt _loc x0 + | Ast.LCons x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "LCons"))) + (mf_a _loc x0)) + (meta_meta_list mf_a _loc x1) + | Ast.LNil -> + Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "LNil")) ] + and meta_meta_option mf_a _loc = + fun + [ Ast.OAnt x0 -> Ast.ExAnt _loc x0 + | Ast.OSome x0 -> + Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "OSome"))) + (mf_a _loc x0) + | Ast.ONone -> + Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ONone")) ] + and meta_module_binding _loc = + fun + [ Ast.MbAnt x0 x1 -> Ast.ExAnt x0 x1 + | Ast.MbCol x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MbCol"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_module_type _loc x2) + | Ast.MbColEq x0 x1 x2 x3 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MbColEq"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_module_type _loc x2)) + (meta_module_expr _loc x3) + | Ast.MbAnd x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MbAnd"))) + (meta_acc_Loc_t _loc x0)) + (meta_module_binding _loc x1)) + (meta_module_binding _loc x2) + | Ast.MbNil x0 -> + Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MbNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_module_expr _loc = + fun + [ Ast.MeAnt x0 x1 -> Ast.ExAnt x0 x1 + | Ast.MeTyc x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MeTyc"))) + (meta_acc_Loc_t _loc x0)) + (meta_module_expr _loc x1)) + (meta_module_type _loc x2) + | Ast.MeStr x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MeStr"))) + (meta_acc_Loc_t _loc x0)) + (meta_str_item _loc x1) + | Ast.MeFun x0 x1 x2 x3 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MeFun"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_module_type _loc x2)) + (meta_module_expr _loc x3) + | Ast.MeApp x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MeApp"))) + (meta_acc_Loc_t _loc x0)) + (meta_module_expr _loc x1)) + (meta_module_expr _loc x2) + | Ast.MeId x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MeId"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1) ] + and meta_module_type _loc = + fun + [ Ast.MtAnt x0 x1 -> Ast.ExAnt x0 x1 + | Ast.MtWit x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MtWit"))) + (meta_acc_Loc_t _loc x0)) + (meta_module_type _loc x1)) + (meta_with_constr _loc x2) + | Ast.MtSig x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MtSig"))) + (meta_acc_Loc_t _loc x0)) + (meta_sig_item _loc x1) + | Ast.MtQuo x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MtQuo"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.MtFun x0 x1 x2 x3 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MtFun"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_module_type _loc x2)) + (meta_module_type _loc x3) + | Ast.MtId x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MtId"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1) ] + and meta_patt _loc = + fun + [ Ast.PaVrn x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaVrn"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.PaTyp x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaTyp"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1) + | Ast.PaTyc x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaTyc"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_ctyp _loc x2) + | Ast.PaTup x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaTup"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1) + | Ast.PaStr x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaStr"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.PaEq x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaEq"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_patt _loc x2) + | Ast.PaRec x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaRec"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1) + | Ast.PaRng x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaRng"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_patt _loc x2) + | Ast.PaOrp x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaOrp"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_patt _loc x2) + | Ast.PaOlbi x0 x1 x2 x3 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaOlbi"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_patt _loc x2)) + (meta_expr _loc x3) + | Ast.PaOlb x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaOlb"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_patt _loc x2) + | Ast.PaLab x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaLab"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_patt _loc x2) + | Ast.PaFlo x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaFlo"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.PaNativeInt x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaNativeInt"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.PaInt64 x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaInt64"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.PaInt32 x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaInt32"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.PaInt x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaInt"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.PaChr x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaChr"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.PaSem x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaSem"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_patt _loc x2) + | Ast.PaCom x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaCom"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_patt _loc x2) + | Ast.PaArr x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaArr"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1) + | Ast.PaApp x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaApp"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_patt _loc x2) + | Ast.PaAny x0 -> + Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaAny"))) + (meta_acc_Loc_t _loc x0) + | Ast.PaAnt x0 x1 -> Ast.ExAnt x0 x1 + | Ast.PaAli x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaAli"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_patt _loc x2) + | Ast.PaId x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaId"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1) + | Ast.PaNil x0 -> + Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_sig_item _loc = + fun + [ Ast.SgAnt x0 x1 -> Ast.ExAnt x0 x1 + | Ast.SgVal x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgVal"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_ctyp _loc x2) + | Ast.SgTyp x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgTyp"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1) + | Ast.SgOpn x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgOpn"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1) + | Ast.SgMty x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgMty"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_module_type _loc x2) + | Ast.SgRecMod x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgRecMod"))) + (meta_acc_Loc_t _loc x0)) + (meta_module_binding _loc x1) + | Ast.SgMod x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgMod"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_module_type _loc x2) + | Ast.SgInc x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgInc"))) + (meta_acc_Loc_t _loc x0)) + (meta_module_type _loc x1) + | Ast.SgExt x0 x1 x2 x3 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgExt"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_ctyp _loc x2)) + (meta_meta_list meta_string _loc x3) + | Ast.SgExc x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgExc"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1) + | Ast.SgDir x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgDir"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_expr _loc x2) + | Ast.SgSem x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgSem"))) + (meta_acc_Loc_t _loc x0)) + (meta_sig_item _loc x1)) + (meta_sig_item _loc x2) + | Ast.SgClt x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgClt"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_type _loc x1) + | Ast.SgCls x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgCls"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_type _loc x1) + | Ast.SgNil x0 -> + Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_str_item _loc = + fun + [ Ast.StAnt x0 x1 -> Ast.ExAnt x0 x1 + | Ast.StVal x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StVal"))) + (meta_acc_Loc_t _loc x0)) + (meta_meta_bool _loc x1)) + (meta_binding _loc x2) + | Ast.StTyp x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StTyp"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1) + | Ast.StOpn x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StOpn"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1) + | Ast.StMty x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StMty"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_module_type _loc x2) + | Ast.StRecMod x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StRecMod"))) + (meta_acc_Loc_t _loc x0)) + (meta_module_binding _loc x1) + | Ast.StMod x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StMod"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_module_expr _loc x2) + | Ast.StInc x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StInc"))) + (meta_acc_Loc_t _loc x0)) + (meta_module_expr _loc x1) + | Ast.StExt x0 x1 x2 x3 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StExt"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_ctyp _loc x2)) + (meta_meta_list meta_string _loc x3) + | Ast.StExp x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StExp"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1) + | Ast.StExc x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StExc"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_meta_option meta_ident _loc x2) + | Ast.StDir x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StDir"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_expr _loc x2) + | Ast.StSem x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StSem"))) + (meta_acc_Loc_t _loc x0)) + (meta_str_item _loc x1)) + (meta_str_item _loc x2) + | Ast.StClt x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StClt"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_type _loc x1) + | Ast.StCls x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StCls"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_expr _loc x1) + | Ast.StNil x0 -> + Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_with_constr _loc = + fun + [ Ast.WcAnt x0 x1 -> Ast.ExAnt x0 x1 + | Ast.WcAnd x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "WcAnd"))) + (meta_acc_Loc_t _loc x0)) + (meta_with_constr _loc x1)) + (meta_with_constr _loc x2) + | Ast.WcMod x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "WcMod"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1)) + (meta_ident _loc x2) + | Ast.WcTyp x0 x1 x2 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "WcTyp"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.WcNil x0 -> + Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "WcNil"))) + (meta_acc_Loc_t _loc x0) ]; + end; + value meta_acc_Loc_t = meta_loc_patt; + module Patt = + struct + value meta_string _loc s = Ast.PaStr _loc s; + value meta_int _loc s = Ast.PaInt _loc s; + value meta_float _loc s = Ast.PaFlo _loc s; + value meta_char _loc s = Ast.PaChr _loc s; + value meta_bool _loc = + fun + [ False -> Ast.PaId _loc (Ast.IdUid _loc "False") + | True -> Ast.PaId _loc (Ast.IdUid _loc "True") ]; + value rec meta_list mf_a _loc = + fun + [ [] -> Ast.PaId _loc (Ast.IdUid _loc "[]") + | [ x :: xs ] -> + Ast.PaApp _loc + (Ast.PaApp _loc (Ast.PaId _loc (Ast.IdUid _loc "::")) + (mf_a _loc x)) + (meta_list mf_a _loc xs) ]; + value rec meta_binding _loc = + fun + [ Ast.BiAnt x0 x1 -> Ast.PaAnt x0 x1 + | Ast.BiEq x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "BiEq"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_expr _loc x2) + | Ast.BiSem x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "BiSem"))) + (meta_acc_Loc_t _loc x0)) + (meta_binding _loc x1)) + (meta_binding _loc x2) + | Ast.BiAnd x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "BiAnd"))) + (meta_acc_Loc_t _loc x0)) + (meta_binding _loc x1)) + (meta_binding _loc x2) + | Ast.BiNil x0 -> + Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "BiNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_class_expr _loc = + fun + [ Ast.CeAnt x0 x1 -> Ast.PaAnt x0 x1 + | Ast.CeEq x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CeEq"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_expr _loc x1)) + (meta_class_expr _loc x2) + | Ast.CeAnd x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CeAnd"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_expr _loc x1)) + (meta_class_expr _loc x2) + | Ast.CeTyc x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CeTyc"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_expr _loc x1)) + (meta_class_type _loc x2) + | Ast.CeStr x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CeStr"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_class_str_item _loc x2) + | Ast.CeLet x0 x1 x2 x3 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CeLet"))) + (meta_acc_Loc_t _loc x0)) + (meta_meta_bool _loc x1)) + (meta_binding _loc x2)) + (meta_class_expr _loc x3) + | Ast.CeFun x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CeFun"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_class_expr _loc x2) + | Ast.CeCon x0 x1 x2 x3 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CeCon"))) + (meta_acc_Loc_t _loc x0)) + (meta_meta_bool _loc x1)) + (meta_ident _loc x2)) + (meta_ctyp _loc x3) + | Ast.CeApp x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CeApp"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_expr _loc x1)) + (meta_expr _loc x2) + | Ast.CeNil x0 -> + Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CeNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_class_sig_item _loc = + fun + [ Ast.CgAnt x0 x1 -> Ast.PaAnt x0 x1 + | Ast.CgVir x0 x1 x2 x3 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CgVir"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_meta_bool _loc x2)) + (meta_ctyp _loc x3) + | Ast.CgVal x0 x1 x2 x3 x4 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CgVal"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_meta_bool _loc x2)) + (meta_meta_bool _loc x3)) + (meta_ctyp _loc x4) + | Ast.CgMth x0 x1 x2 x3 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CgMth"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_meta_bool _loc x2)) + (meta_ctyp _loc x3) + | Ast.CgInh x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CgInh"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_type _loc x1) + | Ast.CgSem x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CgSem"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_sig_item _loc x1)) + (meta_class_sig_item _loc x2) + | Ast.CgCtr x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CgCtr"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.CgNil x0 -> + Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CgNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_class_str_item _loc = + fun + [ Ast.CrAnt x0 x1 -> Ast.PaAnt x0 x1 + | Ast.CrVvr x0 x1 x2 x3 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CrVvr"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_meta_bool _loc x2)) + (meta_ctyp _loc x3) + | Ast.CrVir x0 x1 x2 x3 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CrVir"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_meta_bool _loc x2)) + (meta_ctyp _loc x3) + | Ast.CrVal x0 x1 x2 x3 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CrVal"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_meta_bool _loc x2)) + (meta_expr _loc x3) + | Ast.CrMth x0 x1 x2 x3 x4 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CrMth"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_meta_bool _loc x2)) + (meta_expr _loc x3)) + (meta_ctyp _loc x4) + | Ast.CrIni x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CrIni"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1) + | Ast.CrInh x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CrInh"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_expr _loc x1)) + (meta_string _loc x2) + | Ast.CrCtr x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CrCtr"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.CrSem x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CrSem"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_str_item _loc x1)) + (meta_class_str_item _loc x2) + | Ast.CrNil x0 -> + Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CrNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_class_type _loc = + fun + [ Ast.CtAnt x0 x1 -> Ast.PaAnt x0 x1 + | Ast.CtEq x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CtEq"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_type _loc x1)) + (meta_class_type _loc x2) + | Ast.CtCol x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CtCol"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_type _loc x1)) + (meta_class_type _loc x2) + | Ast.CtAnd x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CtAnd"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_type _loc x1)) + (meta_class_type _loc x2) + | Ast.CtSig x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CtSig"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_class_sig_item _loc x2) + | Ast.CtFun x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CtFun"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_class_type _loc x2) + | Ast.CtCon x0 x1 x2 x3 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CtCon"))) + (meta_acc_Loc_t _loc x0)) + (meta_meta_bool _loc x1)) + (meta_ident _loc x2)) + (meta_ctyp _loc x3) + | Ast.CtNil x0 -> + Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "CtNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_ctyp _loc = + fun + [ Ast.TyAnt x0 x1 -> Ast.PaAnt x0 x1 + | Ast.TyOfAmp x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyOfAmp"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyAmp x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyAmp"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyVrnInfSup x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyVrnInfSup"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyVrnInf x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyVrnInf"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1) + | Ast.TyVrnSup x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyVrnSup"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1) + | Ast.TyVrnEq x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyVrnEq"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1) + | Ast.TySta x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TySta"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyTup x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyTup"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1) + | Ast.TyMut x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyMut"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1) + | Ast.TyPrv x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyPrv"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1) + | Ast.TyOr x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyOr"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyAnd x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyAnd"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyOf x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyOf"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TySum x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TySum"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1) + | Ast.TyCom x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyCom"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TySem x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TySem"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyCol x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyCol"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyRec x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyRec"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1) + | Ast.TyVrn x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyVrn"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.TyQuM x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyQuM"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.TyQuP x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyQuP"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.TyQuo x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyQuo"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.TyPol x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyPol"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyOlb x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyOlb"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyObj x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyObj"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_meta_bool _loc x2) + | Ast.TyDcl x0 x1 x2 x3 x4 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyDcl"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_list meta_ctyp _loc x2)) + (meta_ctyp _loc x3)) + (meta_list + (fun _loc (x1, x2) -> + Ast.PaTup _loc + (Ast.PaCom _loc (meta_ctyp _loc x1) + (meta_ctyp _loc x2))) + _loc x4) + | Ast.TyMan x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyMan"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyId x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyId"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1) + | Ast.TyLab x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyLab"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyCls x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyCls"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1) + | Ast.TyArr x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyArr"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyApp x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyApp"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyAny x0 -> + Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyAny"))) + (meta_acc_Loc_t _loc x0) + | Ast.TyAli x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyAli"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.TyNil x0 -> + Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "TyNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_expr _loc = + fun + [ Ast.ExWhi x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExWhi"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_expr _loc x2) + | Ast.ExVrn x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExVrn"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.ExTyc x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExTyc"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_ctyp _loc x2) + | Ast.ExCom x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExCom"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_expr _loc x2) + | Ast.ExTup x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExTup"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1) + | Ast.ExTry x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExTry"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_match_case _loc x2) + | Ast.ExStr x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExStr"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.ExSte x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExSte"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_expr _loc x2) + | Ast.ExSnd x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExSnd"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_string _loc x2) + | Ast.ExSeq x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExSeq"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1) + | Ast.ExRec x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExRec"))) + (meta_acc_Loc_t _loc x0)) + (meta_binding _loc x1)) + (meta_expr _loc x2) + | Ast.ExOvr x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExOvr"))) + (meta_acc_Loc_t _loc x0)) + (meta_binding _loc x1) + | Ast.ExOlb x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExOlb"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_expr _loc x2) + | Ast.ExObj x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExObj"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_class_str_item _loc x2) + | Ast.ExNew x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExNew"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1) + | Ast.ExMat x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExMat"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_match_case _loc x2) + | Ast.ExLmd x0 x1 x2 x3 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExLmd"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_module_expr _loc x2)) + (meta_expr _loc x3) + | Ast.ExLet x0 x1 x2 x3 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExLet"))) + (meta_acc_Loc_t _loc x0)) + (meta_meta_bool _loc x1)) + (meta_binding _loc x2)) + (meta_expr _loc x3) + | Ast.ExLaz x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExLaz"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1) + | Ast.ExLab x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExLab"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_expr _loc x2) + | Ast.ExNativeInt x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExNativeInt"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.ExInt64 x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExInt64"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.ExInt32 x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExInt32"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.ExInt x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExInt"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.ExIfe x0 x1 x2 x3 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExIfe"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_expr _loc x2)) + (meta_expr _loc x3) + | Ast.ExFun x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExFun"))) + (meta_acc_Loc_t _loc x0)) + (meta_match_case _loc x1) + | Ast.ExFor x0 x1 x2 x3 x4 x5 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc + (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExFor"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_expr _loc x2)) + (meta_expr _loc x3)) + (meta_meta_bool _loc x4)) + (meta_expr _loc x5) + | Ast.ExFlo x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExFlo"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.ExCoe x0 x1 x2 x3 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExCoe"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_ctyp _loc x2)) + (meta_ctyp _loc x3) + | Ast.ExChr x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExChr"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.ExAss x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExAss"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_expr _loc x2) + | Ast.ExAsr x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExAsr"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1) + | Ast.ExAsf x0 -> + Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExAsf"))) + (meta_acc_Loc_t _loc x0) + | Ast.ExSem x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExSem"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_expr _loc x2) + | Ast.ExArr x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExArr"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1) + | Ast.ExAre x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExAre"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_expr _loc x2) + | Ast.ExApp x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExApp"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_expr _loc x2) + | Ast.ExAnt x0 x1 -> Ast.PaAnt x0 x1 + | Ast.ExAcc x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExAcc"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1)) + (meta_expr _loc x2) + | Ast.ExId x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExId"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1) + | Ast.ExNil x0 -> + Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ExNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_ident _loc = + fun + [ Ast.IdAnt x0 x1 -> Ast.PaAnt x0 x1 + | Ast.IdUid x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "IdUid"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.IdLid x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "IdLid"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.IdApp x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "IdApp"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1)) + (meta_ident _loc x2) + | Ast.IdAcc x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "IdAcc"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1)) + (meta_ident _loc x2) ] + and meta_match_case _loc = + fun + [ Ast.McAnt x0 x1 -> Ast.PaAnt x0 x1 + | Ast.McArr x0 x1 x2 x3 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "McArr"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_expr _loc x2)) + (meta_expr _loc x3) + | Ast.McOr x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "McOr"))) + (meta_acc_Loc_t _loc x0)) + (meta_match_case _loc x1)) + (meta_match_case _loc x2) + | Ast.McNil x0 -> + Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "McNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_meta_bool _loc = + fun + [ Ast.BAnt x0 -> Ast.PaAnt _loc x0 + | Ast.BFalse -> + Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "BFalse")) + | Ast.BTrue -> + Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "BTrue")) ] + and meta_meta_list mf_a _loc = + fun + [ Ast.LAnt x0 -> Ast.PaAnt _loc x0 + | Ast.LCons x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "LCons"))) + (mf_a _loc x0)) + (meta_meta_list mf_a _loc x1) + | Ast.LNil -> + Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "LNil")) ] + and meta_meta_option mf_a _loc = + fun + [ Ast.OAnt x0 -> Ast.PaAnt _loc x0 + | Ast.OSome x0 -> + Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "OSome"))) + (mf_a _loc x0) + | Ast.ONone -> + Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "ONone")) ] + and meta_module_binding _loc = + fun + [ Ast.MbAnt x0 x1 -> Ast.PaAnt x0 x1 + | Ast.MbCol x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MbCol"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_module_type _loc x2) + | Ast.MbColEq x0 x1 x2 x3 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MbColEq"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_module_type _loc x2)) + (meta_module_expr _loc x3) + | Ast.MbAnd x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MbAnd"))) + (meta_acc_Loc_t _loc x0)) + (meta_module_binding _loc x1)) + (meta_module_binding _loc x2) + | Ast.MbNil x0 -> + Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MbNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_module_expr _loc = + fun + [ Ast.MeAnt x0 x1 -> Ast.PaAnt x0 x1 + | Ast.MeTyc x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MeTyc"))) + (meta_acc_Loc_t _loc x0)) + (meta_module_expr _loc x1)) + (meta_module_type _loc x2) + | Ast.MeStr x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MeStr"))) + (meta_acc_Loc_t _loc x0)) + (meta_str_item _loc x1) + | Ast.MeFun x0 x1 x2 x3 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MeFun"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_module_type _loc x2)) + (meta_module_expr _loc x3) + | Ast.MeApp x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MeApp"))) + (meta_acc_Loc_t _loc x0)) + (meta_module_expr _loc x1)) + (meta_module_expr _loc x2) + | Ast.MeId x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MeId"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1) ] + and meta_module_type _loc = + fun + [ Ast.MtAnt x0 x1 -> Ast.PaAnt x0 x1 + | Ast.MtWit x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MtWit"))) + (meta_acc_Loc_t _loc x0)) + (meta_module_type _loc x1)) + (meta_with_constr _loc x2) + | Ast.MtSig x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MtSig"))) + (meta_acc_Loc_t _loc x0)) + (meta_sig_item _loc x1) + | Ast.MtQuo x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MtQuo"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.MtFun x0 x1 x2 x3 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MtFun"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_module_type _loc x2)) + (meta_module_type _loc x3) + | Ast.MtId x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "MtId"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1) ] + and meta_patt _loc = + fun + [ Ast.PaVrn x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaVrn"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.PaTyp x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaTyp"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1) + | Ast.PaTyc x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaTyc"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_ctyp _loc x2) + | Ast.PaTup x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaTup"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1) + | Ast.PaStr x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaStr"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.PaEq x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaEq"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_patt _loc x2) + | Ast.PaRec x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaRec"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1) + | Ast.PaRng x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaRng"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_patt _loc x2) + | Ast.PaOrp x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaOrp"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_patt _loc x2) + | Ast.PaOlbi x0 x1 x2 x3 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaOlbi"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_patt _loc x2)) + (meta_expr _loc x3) + | Ast.PaOlb x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaOlb"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_patt _loc x2) + | Ast.PaLab x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaLab"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_patt _loc x2) + | Ast.PaFlo x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaFlo"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.PaNativeInt x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaNativeInt"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.PaInt64 x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaInt64"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.PaInt32 x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaInt32"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.PaInt x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaInt"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.PaChr x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaChr"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1) + | Ast.PaSem x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaSem"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_patt _loc x2) + | Ast.PaCom x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaCom"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_patt _loc x2) + | Ast.PaArr x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaArr"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1) + | Ast.PaApp x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaApp"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_patt _loc x2) + | Ast.PaAny x0 -> + Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaAny"))) + (meta_acc_Loc_t _loc x0) + | Ast.PaAnt x0 x1 -> Ast.PaAnt x0 x1 + | Ast.PaAli x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaAli"))) + (meta_acc_Loc_t _loc x0)) + (meta_patt _loc x1)) + (meta_patt _loc x2) + | Ast.PaId x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaId"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1) + | Ast.PaNil x0 -> + Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_sig_item _loc = + fun + [ Ast.SgAnt x0 x1 -> Ast.PaAnt x0 x1 + | Ast.SgVal x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgVal"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_ctyp _loc x2) + | Ast.SgTyp x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgTyp"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1) + | Ast.SgOpn x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgOpn"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1) + | Ast.SgMty x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgMty"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_module_type _loc x2) + | Ast.SgRecMod x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgRecMod"))) + (meta_acc_Loc_t _loc x0)) + (meta_module_binding _loc x1) + | Ast.SgMod x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgMod"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_module_type _loc x2) + | Ast.SgInc x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgInc"))) + (meta_acc_Loc_t _loc x0)) + (meta_module_type _loc x1) + | Ast.SgExt x0 x1 x2 x3 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgExt"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_ctyp _loc x2)) + (meta_meta_list meta_string _loc x3) + | Ast.SgExc x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgExc"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1) + | Ast.SgDir x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgDir"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_expr _loc x2) + | Ast.SgSem x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgSem"))) + (meta_acc_Loc_t _loc x0)) + (meta_sig_item _loc x1)) + (meta_sig_item _loc x2) + | Ast.SgClt x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgClt"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_type _loc x1) + | Ast.SgCls x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgCls"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_type _loc x1) + | Ast.SgNil x0 -> + Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "SgNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_str_item _loc = + fun + [ Ast.StAnt x0 x1 -> Ast.PaAnt x0 x1 + | Ast.StVal x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StVal"))) + (meta_acc_Loc_t _loc x0)) + (meta_meta_bool _loc x1)) + (meta_binding _loc x2) + | Ast.StTyp x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StTyp"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1) + | Ast.StOpn x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StOpn"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1) + | Ast.StMty x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StMty"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_module_type _loc x2) + | Ast.StRecMod x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StRecMod"))) + (meta_acc_Loc_t _loc x0)) + (meta_module_binding _loc x1) + | Ast.StMod x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StMod"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_module_expr _loc x2) + | Ast.StInc x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StInc"))) + (meta_acc_Loc_t _loc x0)) + (meta_module_expr _loc x1) + | Ast.StExt x0 x1 x2 x3 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StExt"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_ctyp _loc x2)) + (meta_meta_list meta_string _loc x3) + | Ast.StExp x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StExp"))) + (meta_acc_Loc_t _loc x0)) + (meta_expr _loc x1) + | Ast.StExc x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StExc"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_meta_option meta_ident _loc x2) + | Ast.StDir x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StDir"))) + (meta_acc_Loc_t _loc x0)) + (meta_string _loc x1)) + (meta_expr _loc x2) + | Ast.StSem x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StSem"))) + (meta_acc_Loc_t _loc x0)) + (meta_str_item _loc x1)) + (meta_str_item _loc x2) + | Ast.StClt x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StClt"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_type _loc x1) + | Ast.StCls x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StCls"))) + (meta_acc_Loc_t _loc x0)) + (meta_class_expr _loc x1) + | Ast.StNil x0 -> + Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "StNil"))) + (meta_acc_Loc_t _loc x0) ] + and meta_with_constr _loc = + fun + [ Ast.WcAnt x0 x1 -> Ast.PaAnt x0 x1 + | Ast.WcAnd x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "WcAnd"))) + (meta_acc_Loc_t _loc x0)) + (meta_with_constr _loc x1)) + (meta_with_constr _loc x2) + | Ast.WcMod x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "WcMod"))) + (meta_acc_Loc_t _loc x0)) + (meta_ident _loc x1)) + (meta_ident _loc x2) + | Ast.WcTyp x0 x1 x2 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "WcTyp"))) + (meta_acc_Loc_t _loc x0)) + (meta_ctyp _loc x1)) + (meta_ctyp _loc x2) + | Ast.WcNil x0 -> + Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "WcNil"))) + (meta_acc_Loc_t _loc x0) ]; + end; + end; + end; + class map = + object (o) + method string = fun x -> (x : string); + method int = fun x -> (x : int); + method float = fun x -> (x : float); + method bool = fun x -> (x : bool); + method list : ! 'a 'b. ('a -> 'b) -> list 'a -> list 'b = List.map; + method option : ! 'a 'b. ('a -> 'b) -> option 'a -> option 'b = + fun f -> fun [ None -> None | Some x -> Some (f x) ]; + method array : ! 'a 'b. ('a -> 'b) -> array 'a -> array 'b = Array. + map; + method ref : ! 'a 'b. ('a -> 'b) -> ref 'a -> ref 'b = + fun f { \val = x } -> { \val = f x; }; + method _Loc_t : Loc.t -> Loc.t = fun x -> x; + method with_constr : with_constr -> with_constr = + fun + [ WcNil _x0 -> WcNil (o#_Loc_t _x0) + | WcTyp _x0 _x1 _x2 -> + WcTyp (o#_Loc_t _x0) (o#ctyp _x1) (o#ctyp _x2) + | WcMod _x0 _x1 _x2 -> + WcMod (o#_Loc_t _x0) (o#ident _x1) (o#ident _x2) + | WcAnd _x0 _x1 _x2 -> + WcAnd (o#_Loc_t _x0) (o#with_constr _x1) (o#with_constr _x2) + | WcAnt _x0 _x1 -> WcAnt (o#_Loc_t _x0) (o#string _x1) ]; + method str_item : str_item -> str_item = + fun + [ StNil _x0 -> StNil (o#_Loc_t _x0) + | StCls _x0 _x1 -> StCls (o#_Loc_t _x0) (o#class_expr _x1) + | StClt _x0 _x1 -> StClt (o#_Loc_t _x0) (o#class_type _x1) + | StSem _x0 _x1 _x2 -> + StSem (o#_Loc_t _x0) (o#str_item _x1) (o#str_item _x2) + | StDir _x0 _x1 _x2 -> + StDir (o#_Loc_t _x0) (o#string _x1) (o#expr _x2) + | StExc _x0 _x1 _x2 -> + StExc (o#_Loc_t _x0) (o#ctyp _x1) (o#meta_option o#ident _x2) + | StExp _x0 _x1 -> StExp (o#_Loc_t _x0) (o#expr _x1) + | StExt _x0 _x1 _x2 _x3 -> + StExt (o#_Loc_t _x0) (o#string _x1) (o#ctyp _x2) + (o#meta_list o#string _x3) + | StInc _x0 _x1 -> StInc (o#_Loc_t _x0) (o#module_expr _x1) + | StMod _x0 _x1 _x2 -> + StMod (o#_Loc_t _x0) (o#string _x1) (o#module_expr _x2) + | StRecMod _x0 _x1 -> + StRecMod (o#_Loc_t _x0) (o#module_binding _x1) + | StMty _x0 _x1 _x2 -> + StMty (o#_Loc_t _x0) (o#string _x1) (o#module_type _x2) + | StOpn _x0 _x1 -> StOpn (o#_Loc_t _x0) (o#ident _x1) + | StTyp _x0 _x1 -> StTyp (o#_Loc_t _x0) (o#ctyp _x1) + | StVal _x0 _x1 _x2 -> + StVal (o#_Loc_t _x0) (o#meta_bool _x1) (o#binding _x2) + | StAnt _x0 _x1 -> StAnt (o#_Loc_t _x0) (o#string _x1) ]; + method sig_item : sig_item -> sig_item = + fun + [ SgNil _x0 -> SgNil (o#_Loc_t _x0) + | SgCls _x0 _x1 -> SgCls (o#_Loc_t _x0) (o#class_type _x1) + | SgClt _x0 _x1 -> SgClt (o#_Loc_t _x0) (o#class_type _x1) + | SgSem _x0 _x1 _x2 -> + SgSem (o#_Loc_t _x0) (o#sig_item _x1) (o#sig_item _x2) + | SgDir _x0 _x1 _x2 -> + SgDir (o#_Loc_t _x0) (o#string _x1) (o#expr _x2) + | SgExc _x0 _x1 -> SgExc (o#_Loc_t _x0) (o#ctyp _x1) + | SgExt _x0 _x1 _x2 _x3 -> + SgExt (o#_Loc_t _x0) (o#string _x1) (o#ctyp _x2) + (o#meta_list o#string _x3) + | SgInc _x0 _x1 -> SgInc (o#_Loc_t _x0) (o#module_type _x1) + | SgMod _x0 _x1 _x2 -> + SgMod (o#_Loc_t _x0) (o#string _x1) (o#module_type _x2) + | SgRecMod _x0 _x1 -> + SgRecMod (o#_Loc_t _x0) (o#module_binding _x1) + | SgMty _x0 _x1 _x2 -> + SgMty (o#_Loc_t _x0) (o#string _x1) (o#module_type _x2) + | SgOpn _x0 _x1 -> SgOpn (o#_Loc_t _x0) (o#ident _x1) + | SgTyp _x0 _x1 -> SgTyp (o#_Loc_t _x0) (o#ctyp _x1) + | SgVal _x0 _x1 _x2 -> + SgVal (o#_Loc_t _x0) (o#string _x1) (o#ctyp _x2) + | SgAnt _x0 _x1 -> SgAnt (o#_Loc_t _x0) (o#string _x1) ]; + method patt : patt -> patt = + fun + [ PaNil _x0 -> PaNil (o#_Loc_t _x0) + | PaId _x0 _x1 -> PaId (o#_Loc_t _x0) (o#ident _x1) + | PaAli _x0 _x1 _x2 -> + PaAli (o#_Loc_t _x0) (o#patt _x1) (o#patt _x2) + | PaAnt _x0 _x1 -> PaAnt (o#_Loc_t _x0) (o#string _x1) + | PaAny _x0 -> PaAny (o#_Loc_t _x0) + | PaApp _x0 _x1 _x2 -> + PaApp (o#_Loc_t _x0) (o#patt _x1) (o#patt _x2) + | PaArr _x0 _x1 -> PaArr (o#_Loc_t _x0) (o#patt _x1) + | PaCom _x0 _x1 _x2 -> + PaCom (o#_Loc_t _x0) (o#patt _x1) (o#patt _x2) + | PaSem _x0 _x1 _x2 -> + PaSem (o#_Loc_t _x0) (o#patt _x1) (o#patt _x2) + | PaChr _x0 _x1 -> PaChr (o#_Loc_t _x0) (o#string _x1) + | PaInt _x0 _x1 -> PaInt (o#_Loc_t _x0) (o#string _x1) + | PaInt32 _x0 _x1 -> PaInt32 (o#_Loc_t _x0) (o#string _x1) + | PaInt64 _x0 _x1 -> PaInt64 (o#_Loc_t _x0) (o#string _x1) + | PaNativeInt _x0 _x1 -> PaNativeInt (o#_Loc_t _x0) (o#string _x1) + | PaFlo _x0 _x1 -> PaFlo (o#_Loc_t _x0) (o#string _x1) + | PaLab _x0 _x1 _x2 -> + PaLab (o#_Loc_t _x0) (o#string _x1) (o#patt _x2) + | PaOlb _x0 _x1 _x2 -> + PaOlb (o#_Loc_t _x0) (o#string _x1) (o#patt _x2) + | PaOlbi _x0 _x1 _x2 _x3 -> + PaOlbi (o#_Loc_t _x0) (o#string _x1) (o#patt _x2) (o#expr _x3) + | PaOrp _x0 _x1 _x2 -> + PaOrp (o#_Loc_t _x0) (o#patt _x1) (o#patt _x2) + | PaRng _x0 _x1 _x2 -> + PaRng (o#_Loc_t _x0) (o#patt _x1) (o#patt _x2) + | PaRec _x0 _x1 -> PaRec (o#_Loc_t _x0) (o#patt _x1) + | PaEq _x0 _x1 _x2 -> PaEq (o#_Loc_t _x0) (o#patt _x1) (o#patt _x2) + | PaStr _x0 _x1 -> PaStr (o#_Loc_t _x0) (o#string _x1) + | PaTup _x0 _x1 -> PaTup (o#_Loc_t _x0) (o#patt _x1) + | PaTyc _x0 _x1 _x2 -> + PaTyc (o#_Loc_t _x0) (o#patt _x1) (o#ctyp _x2) + | PaTyp _x0 _x1 -> PaTyp (o#_Loc_t _x0) (o#ident _x1) + | PaVrn _x0 _x1 -> PaVrn (o#_Loc_t _x0) (o#string _x1) ]; + method module_type : module_type -> module_type = + fun + [ MtId _x0 _x1 -> MtId (o#_Loc_t _x0) (o#ident _x1) + | MtFun _x0 _x1 _x2 _x3 -> + MtFun (o#_Loc_t _x0) (o#string _x1) (o#module_type _x2) + (o#module_type _x3) + | MtQuo _x0 _x1 -> MtQuo (o#_Loc_t _x0) (o#string _x1) + | MtSig _x0 _x1 -> MtSig (o#_Loc_t _x0) (o#sig_item _x1) + | MtWit _x0 _x1 _x2 -> + MtWit (o#_Loc_t _x0) (o#module_type _x1) (o#with_constr _x2) + | MtAnt _x0 _x1 -> MtAnt (o#_Loc_t _x0) (o#string _x1) ]; + method module_expr : module_expr -> module_expr = + fun + [ MeId _x0 _x1 -> MeId (o#_Loc_t _x0) (o#ident _x1) + | MeApp _x0 _x1 _x2 -> + MeApp (o#_Loc_t _x0) (o#module_expr _x1) (o#module_expr _x2) + | MeFun _x0 _x1 _x2 _x3 -> + MeFun (o#_Loc_t _x0) (o#string _x1) (o#module_type _x2) + (o#module_expr _x3) + | MeStr _x0 _x1 -> MeStr (o#_Loc_t _x0) (o#str_item _x1) + | MeTyc _x0 _x1 _x2 -> + MeTyc (o#_Loc_t _x0) (o#module_expr _x1) (o#module_type _x2) + | MeAnt _x0 _x1 -> MeAnt (o#_Loc_t _x0) (o#string _x1) ]; + method module_binding : module_binding -> module_binding = + fun + [ MbNil _x0 -> MbNil (o#_Loc_t _x0) + | MbAnd _x0 _x1 _x2 -> + MbAnd (o#_Loc_t _x0) (o#module_binding _x1) + (o#module_binding _x2) + | MbColEq _x0 _x1 _x2 _x3 -> + MbColEq (o#_Loc_t _x0) (o#string _x1) (o#module_type _x2) + (o#module_expr _x3) + | MbCol _x0 _x1 _x2 -> + MbCol (o#_Loc_t _x0) (o#string _x1) (o#module_type _x2) + | MbAnt _x0 _x1 -> MbAnt (o#_Loc_t _x0) (o#string _x1) ]; + method meta_option : + ! 'a 'b. ('a -> 'b) -> meta_option 'a -> meta_option 'b = + fun _f_a -> + fun + [ ONone -> ONone + | OSome _x0 -> OSome (_f_a _x0) + | OAnt _x0 -> OAnt (o#string _x0) ]; + method meta_list : + ! 'a 'b. ('a -> 'b) -> meta_list 'a -> meta_list 'b = + fun _f_a -> + fun + [ LNil -> LNil + | LCons _x0 _x1 -> LCons (_f_a _x0) (o#meta_list _f_a _x1) + | LAnt _x0 -> LAnt (o#string _x0) ]; + method meta_bool : meta_bool -> meta_bool = + fun + [ BTrue -> BTrue + | BFalse -> BFalse + | BAnt _x0 -> BAnt (o#string _x0) ]; + method match_case : match_case -> match_case = + fun + [ McNil _x0 -> McNil (o#_Loc_t _x0) + | McOr _x0 _x1 _x2 -> + McOr (o#_Loc_t _x0) (o#match_case _x1) (o#match_case _x2) + | McArr _x0 _x1 _x2 _x3 -> + McArr (o#_Loc_t _x0) (o#patt _x1) (o#expr _x2) (o#expr _x3) + | McAnt _x0 _x1 -> McAnt (o#_Loc_t _x0) (o#string _x1) ]; + method ident : ident -> ident = + fun + [ IdAcc _x0 _x1 _x2 -> + IdAcc (o#_Loc_t _x0) (o#ident _x1) (o#ident _x2) + | IdApp _x0 _x1 _x2 -> + IdApp (o#_Loc_t _x0) (o#ident _x1) (o#ident _x2) + | IdLid _x0 _x1 -> IdLid (o#_Loc_t _x0) (o#string _x1) + | IdUid _x0 _x1 -> IdUid (o#_Loc_t _x0) (o#string _x1) + | IdAnt _x0 _x1 -> IdAnt (o#_Loc_t _x0) (o#string _x1) ]; + method expr : expr -> expr = + fun + [ ExNil _x0 -> ExNil (o#_Loc_t _x0) + | ExId _x0 _x1 -> ExId (o#_Loc_t _x0) (o#ident _x1) + | ExAcc _x0 _x1 _x2 -> + ExAcc (o#_Loc_t _x0) (o#expr _x1) (o#expr _x2) + | ExAnt _x0 _x1 -> ExAnt (o#_Loc_t _x0) (o#string _x1) + | ExApp _x0 _x1 _x2 -> + ExApp (o#_Loc_t _x0) (o#expr _x1) (o#expr _x2) + | ExAre _x0 _x1 _x2 -> + ExAre (o#_Loc_t _x0) (o#expr _x1) (o#expr _x2) + | ExArr _x0 _x1 -> ExArr (o#_Loc_t _x0) (o#expr _x1) + | ExSem _x0 _x1 _x2 -> + ExSem (o#_Loc_t _x0) (o#expr _x1) (o#expr _x2) + | ExAsf _x0 -> ExAsf (o#_Loc_t _x0) + | ExAsr _x0 _x1 -> ExAsr (o#_Loc_t _x0) (o#expr _x1) + | ExAss _x0 _x1 _x2 -> + ExAss (o#_Loc_t _x0) (o#expr _x1) (o#expr _x2) + | ExChr _x0 _x1 -> ExChr (o#_Loc_t _x0) (o#string _x1) + | ExCoe _x0 _x1 _x2 _x3 -> + ExCoe (o#_Loc_t _x0) (o#expr _x1) (o#ctyp _x2) (o#ctyp _x3) + | ExFlo _x0 _x1 -> ExFlo (o#_Loc_t _x0) (o#string _x1) + | ExFor _x0 _x1 _x2 _x3 _x4 _x5 -> + ExFor (o#_Loc_t _x0) (o#string _x1) (o#expr _x2) (o#expr _x3) + (o#meta_bool _x4) (o#expr _x5) + | ExFun _x0 _x1 -> ExFun (o#_Loc_t _x0) (o#match_case _x1) + | ExIfe _x0 _x1 _x2 _x3 -> + ExIfe (o#_Loc_t _x0) (o#expr _x1) (o#expr _x2) (o#expr _x3) + | ExInt _x0 _x1 -> ExInt (o#_Loc_t _x0) (o#string _x1) + | ExInt32 _x0 _x1 -> ExInt32 (o#_Loc_t _x0) (o#string _x1) + | ExInt64 _x0 _x1 -> ExInt64 (o#_Loc_t _x0) (o#string _x1) + | ExNativeInt _x0 _x1 -> ExNativeInt (o#_Loc_t _x0) (o#string _x1) + | ExLab _x0 _x1 _x2 -> + ExLab (o#_Loc_t _x0) (o#string _x1) (o#expr _x2) + | ExLaz _x0 _x1 -> ExLaz (o#_Loc_t _x0) (o#expr _x1) + | ExLet _x0 _x1 _x2 _x3 -> + ExLet (o#_Loc_t _x0) (o#meta_bool _x1) (o#binding _x2) + (o#expr _x3) + | ExLmd _x0 _x1 _x2 _x3 -> + ExLmd (o#_Loc_t _x0) (o#string _x1) (o#module_expr _x2) + (o#expr _x3) + | ExMat _x0 _x1 _x2 -> + ExMat (o#_Loc_t _x0) (o#expr _x1) (o#match_case _x2) + | ExNew _x0 _x1 -> ExNew (o#_Loc_t _x0) (o#ident _x1) + | ExObj _x0 _x1 _x2 -> + ExObj (o#_Loc_t _x0) (o#patt _x1) (o#class_str_item _x2) + | ExOlb _x0 _x1 _x2 -> + ExOlb (o#_Loc_t _x0) (o#string _x1) (o#expr _x2) + | ExOvr _x0 _x1 -> ExOvr (o#_Loc_t _x0) (o#binding _x1) + | ExRec _x0 _x1 _x2 -> + ExRec (o#_Loc_t _x0) (o#binding _x1) (o#expr _x2) + | ExSeq _x0 _x1 -> ExSeq (o#_Loc_t _x0) (o#expr _x1) + | ExSnd _x0 _x1 _x2 -> + ExSnd (o#_Loc_t _x0) (o#expr _x1) (o#string _x2) + | ExSte _x0 _x1 _x2 -> + ExSte (o#_Loc_t _x0) (o#expr _x1) (o#expr _x2) + | ExStr _x0 _x1 -> ExStr (o#_Loc_t _x0) (o#string _x1) + | ExTry _x0 _x1 _x2 -> + ExTry (o#_Loc_t _x0) (o#expr _x1) (o#match_case _x2) + | ExTup _x0 _x1 -> ExTup (o#_Loc_t _x0) (o#expr _x1) + | ExCom _x0 _x1 _x2 -> + ExCom (o#_Loc_t _x0) (o#expr _x1) (o#expr _x2) + | ExTyc _x0 _x1 _x2 -> + ExTyc (o#_Loc_t _x0) (o#expr _x1) (o#ctyp _x2) + | ExVrn _x0 _x1 -> ExVrn (o#_Loc_t _x0) (o#string _x1) + | ExWhi _x0 _x1 _x2 -> + ExWhi (o#_Loc_t _x0) (o#expr _x1) (o#expr _x2) ]; + method ctyp : ctyp -> ctyp = + fun + [ TyNil _x0 -> TyNil (o#_Loc_t _x0) + | TyAli _x0 _x1 _x2 -> + TyAli (o#_Loc_t _x0) (o#ctyp _x1) (o#ctyp _x2) + | TyAny _x0 -> TyAny (o#_Loc_t _x0) + | TyApp _x0 _x1 _x2 -> + TyApp (o#_Loc_t _x0) (o#ctyp _x1) (o#ctyp _x2) + | TyArr _x0 _x1 _x2 -> + TyArr (o#_Loc_t _x0) (o#ctyp _x1) (o#ctyp _x2) + | TyCls _x0 _x1 -> TyCls (o#_Loc_t _x0) (o#ident _x1) + | TyLab _x0 _x1 _x2 -> + TyLab (o#_Loc_t _x0) (o#string _x1) (o#ctyp _x2) + | TyId _x0 _x1 -> TyId (o#_Loc_t _x0) (o#ident _x1) + | TyMan _x0 _x1 _x2 -> + TyMan (o#_Loc_t _x0) (o#ctyp _x1) (o#ctyp _x2) + | TyDcl _x0 _x1 _x2 _x3 _x4 -> + TyDcl (o#_Loc_t _x0) (o#string _x1) (o#list o#ctyp _x2) + (o#ctyp _x3) + (o#list (fun (_x0, _x1) -> ((o#ctyp _x0), (o#ctyp _x1))) _x4) + | TyObj _x0 _x1 _x2 -> + TyObj (o#_Loc_t _x0) (o#ctyp _x1) (o#meta_bool _x2) + | TyOlb _x0 _x1 _x2 -> + TyOlb (o#_Loc_t _x0) (o#string _x1) (o#ctyp _x2) + | TyPol _x0 _x1 _x2 -> + TyPol (o#_Loc_t _x0) (o#ctyp _x1) (o#ctyp _x2) + | TyQuo _x0 _x1 -> TyQuo (o#_Loc_t _x0) (o#string _x1) + | TyQuP _x0 _x1 -> TyQuP (o#_Loc_t _x0) (o#string _x1) + | TyQuM _x0 _x1 -> TyQuM (o#_Loc_t _x0) (o#string _x1) + | TyVrn _x0 _x1 -> TyVrn (o#_Loc_t _x0) (o#string _x1) + | TyRec _x0 _x1 -> TyRec (o#_Loc_t _x0) (o#ctyp _x1) + | TyCol _x0 _x1 _x2 -> + TyCol (o#_Loc_t _x0) (o#ctyp _x1) (o#ctyp _x2) + | TySem _x0 _x1 _x2 -> + TySem (o#_Loc_t _x0) (o#ctyp _x1) (o#ctyp _x2) + | TyCom _x0 _x1 _x2 -> + TyCom (o#_Loc_t _x0) (o#ctyp _x1) (o#ctyp _x2) + | TySum _x0 _x1 -> TySum (o#_Loc_t _x0) (o#ctyp _x1) + | TyOf _x0 _x1 _x2 -> TyOf (o#_Loc_t _x0) (o#ctyp _x1) (o#ctyp _x2) + | TyAnd _x0 _x1 _x2 -> + TyAnd (o#_Loc_t _x0) (o#ctyp _x1) (o#ctyp _x2) + | TyOr _x0 _x1 _x2 -> TyOr (o#_Loc_t _x0) (o#ctyp _x1) (o#ctyp _x2) + | TyPrv _x0 _x1 -> TyPrv (o#_Loc_t _x0) (o#ctyp _x1) + | TyMut _x0 _x1 -> TyMut (o#_Loc_t _x0) (o#ctyp _x1) + | TyTup _x0 _x1 -> TyTup (o#_Loc_t _x0) (o#ctyp _x1) + | TySta _x0 _x1 _x2 -> + TySta (o#_Loc_t _x0) (o#ctyp _x1) (o#ctyp _x2) + | TyVrnEq _x0 _x1 -> TyVrnEq (o#_Loc_t _x0) (o#ctyp _x1) + | TyVrnSup _x0 _x1 -> TyVrnSup (o#_Loc_t _x0) (o#ctyp _x1) + | TyVrnInf _x0 _x1 -> TyVrnInf (o#_Loc_t _x0) (o#ctyp _x1) + | TyVrnInfSup _x0 _x1 _x2 -> + TyVrnInfSup (o#_Loc_t _x0) (o#ctyp _x1) (o#ctyp _x2) + | TyAmp _x0 _x1 _x2 -> + TyAmp (o#_Loc_t _x0) (o#ctyp _x1) (o#ctyp _x2) + | TyOfAmp _x0 _x1 _x2 -> + TyOfAmp (o#_Loc_t _x0) (o#ctyp _x1) (o#ctyp _x2) + | TyAnt _x0 _x1 -> TyAnt (o#_Loc_t _x0) (o#string _x1) ]; + method class_type : class_type -> class_type = + fun + [ CtNil _x0 -> CtNil (o#_Loc_t _x0) + | CtCon _x0 _x1 _x2 _x3 -> + CtCon (o#_Loc_t _x0) (o#meta_bool _x1) (o#ident _x2) + (o#ctyp _x3) + | CtFun _x0 _x1 _x2 -> + CtFun (o#_Loc_t _x0) (o#ctyp _x1) (o#class_type _x2) + | CtSig _x0 _x1 _x2 -> + CtSig (o#_Loc_t _x0) (o#ctyp _x1) (o#class_sig_item _x2) + | CtAnd _x0 _x1 _x2 -> + CtAnd (o#_Loc_t _x0) (o#class_type _x1) (o#class_type _x2) + | CtCol _x0 _x1 _x2 -> + CtCol (o#_Loc_t _x0) (o#class_type _x1) (o#class_type _x2) + | CtEq _x0 _x1 _x2 -> + CtEq (o#_Loc_t _x0) (o#class_type _x1) (o#class_type _x2) + | CtAnt _x0 _x1 -> CtAnt (o#_Loc_t _x0) (o#string _x1) ]; + method class_str_item : class_str_item -> class_str_item = + fun + [ CrNil _x0 -> CrNil (o#_Loc_t _x0) + | CrSem _x0 _x1 _x2 -> + CrSem (o#_Loc_t _x0) (o#class_str_item _x1) + (o#class_str_item _x2) + | CrCtr _x0 _x1 _x2 -> + CrCtr (o#_Loc_t _x0) (o#ctyp _x1) (o#ctyp _x2) + | CrInh _x0 _x1 _x2 -> + CrInh (o#_Loc_t _x0) (o#class_expr _x1) (o#string _x2) + | CrIni _x0 _x1 -> CrIni (o#_Loc_t _x0) (o#expr _x1) + | CrMth _x0 _x1 _x2 _x3 _x4 -> + CrMth (o#_Loc_t _x0) (o#string _x1) (o#meta_bool _x2) + (o#expr _x3) (o#ctyp _x4) + | CrVal _x0 _x1 _x2 _x3 -> + CrVal (o#_Loc_t _x0) (o#string _x1) (o#meta_bool _x2) + (o#expr _x3) + | CrVir _x0 _x1 _x2 _x3 -> + CrVir (o#_Loc_t _x0) (o#string _x1) (o#meta_bool _x2) + (o#ctyp _x3) + | CrVvr _x0 _x1 _x2 _x3 -> + CrVvr (o#_Loc_t _x0) (o#string _x1) (o#meta_bool _x2) + (o#ctyp _x3) + | CrAnt _x0 _x1 -> CrAnt (o#_Loc_t _x0) (o#string _x1) ]; + method class_sig_item : class_sig_item -> class_sig_item = + fun + [ CgNil _x0 -> CgNil (o#_Loc_t _x0) + | CgCtr _x0 _x1 _x2 -> + CgCtr (o#_Loc_t _x0) (o#ctyp _x1) (o#ctyp _x2) + | CgSem _x0 _x1 _x2 -> + CgSem (o#_Loc_t _x0) (o#class_sig_item _x1) + (o#class_sig_item _x2) + | CgInh _x0 _x1 -> CgInh (o#_Loc_t _x0) (o#class_type _x1) + | CgMth _x0 _x1 _x2 _x3 -> + CgMth (o#_Loc_t _x0) (o#string _x1) (o#meta_bool _x2) + (o#ctyp _x3) + | CgVal _x0 _x1 _x2 _x3 _x4 -> + CgVal (o#_Loc_t _x0) (o#string _x1) (o#meta_bool _x2) + (o#meta_bool _x3) (o#ctyp _x4) + | CgVir _x0 _x1 _x2 _x3 -> + CgVir (o#_Loc_t _x0) (o#string _x1) (o#meta_bool _x2) + (o#ctyp _x3) + | CgAnt _x0 _x1 -> CgAnt (o#_Loc_t _x0) (o#string _x1) ]; + method class_expr : class_expr -> class_expr = + fun + [ CeNil _x0 -> CeNil (o#_Loc_t _x0) + | CeApp _x0 _x1 _x2 -> + CeApp (o#_Loc_t _x0) (o#class_expr _x1) (o#expr _x2) + | CeCon _x0 _x1 _x2 _x3 -> + CeCon (o#_Loc_t _x0) (o#meta_bool _x1) (o#ident _x2) + (o#ctyp _x3) + | CeFun _x0 _x1 _x2 -> + CeFun (o#_Loc_t _x0) (o#patt _x1) (o#class_expr _x2) + | CeLet _x0 _x1 _x2 _x3 -> + CeLet (o#_Loc_t _x0) (o#meta_bool _x1) (o#binding _x2) + (o#class_expr _x3) + | CeStr _x0 _x1 _x2 -> + CeStr (o#_Loc_t _x0) (o#patt _x1) (o#class_str_item _x2) + | CeTyc _x0 _x1 _x2 -> + CeTyc (o#_Loc_t _x0) (o#class_expr _x1) (o#class_type _x2) + | CeAnd _x0 _x1 _x2 -> + CeAnd (o#_Loc_t _x0) (o#class_expr _x1) (o#class_expr _x2) + | CeEq _x0 _x1 _x2 -> + CeEq (o#_Loc_t _x0) (o#class_expr _x1) (o#class_expr _x2) + | CeAnt _x0 _x1 -> CeAnt (o#_Loc_t _x0) (o#string _x1) ]; + method binding : binding -> binding = + fun + [ BiNil _x0 -> BiNil (o#_Loc_t _x0) + | BiAnd _x0 _x1 _x2 -> + BiAnd (o#_Loc_t _x0) (o#binding _x1) (o#binding _x2) + | BiSem _x0 _x1 _x2 -> + BiSem (o#_Loc_t _x0) (o#binding _x1) (o#binding _x2) + | BiEq _x0 _x1 _x2 -> BiEq (o#_Loc_t _x0) (o#patt _x1) (o#expr _x2) + | BiAnt _x0 _x1 -> BiAnt (o#_Loc_t _x0) (o#string _x1) ]; + end; + class fold = + object ((o : 'self_type)) + method string = fun (_ : string) -> (o : 'self_type); + method int = fun (_ : int) -> (o : 'self_type); + method float = fun (_ : float) -> (o : 'self_type); + method bool = fun (_ : bool) -> (o : 'self_type); + method list : + ! 'a. ('self_type -> 'a -> 'self_type) -> list 'a -> 'self_type = + fun f -> List.fold_left f o; + method option : + ! 'a. ('self_type -> 'a -> 'self_type) -> option 'a -> 'self_type = + fun f -> fun [ None -> o | Some x -> f o x ]; + method array : + ! 'a. ('self_type -> 'a -> 'self_type) -> array 'a -> 'self_type = + fun f -> Array.fold_left f o; + method ref : + ! 'a. ('self_type -> 'a -> 'self_type) -> ref 'a -> 'self_type = + fun f { \val = x } -> f o x; + method _Loc_t : Loc.t -> 'self_type = fun _ -> o; + method with_constr : with_constr -> 'self_type = + fun + [ WcNil _x0 -> o#_Loc_t _x0 + | WcTyp _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | WcMod _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ident _x1)#ident _x2 + | WcAnd _x0 _x1 _x2 -> + ((o#_Loc_t _x0)#with_constr _x1)#with_constr _x2 + | WcAnt _x0 _x1 -> (o#_Loc_t _x0)#string _x1 ]; + method str_item : str_item -> 'self_type = + fun + [ StNil _x0 -> o#_Loc_t _x0 + | StCls _x0 _x1 -> (o#_Loc_t _x0)#class_expr _x1 + | StClt _x0 _x1 -> (o#_Loc_t _x0)#class_type _x1 + | StSem _x0 _x1 _x2 -> ((o#_Loc_t _x0)#str_item _x1)#str_item _x2 + | StDir _x0 _x1 _x2 -> ((o#_Loc_t _x0)#string _x1)#expr _x2 + | StExc _x0 _x1 _x2 -> + ((o#_Loc_t _x0)#ctyp _x1)#meta_option (fun o -> o#ident) _x2 + | StExp _x0 _x1 -> (o#_Loc_t _x0)#expr _x1 + | StExt _x0 _x1 _x2 _x3 -> + (((o#_Loc_t _x0)#string _x1)#ctyp _x2)#meta_list + (fun o -> o#string) _x3 + | StInc _x0 _x1 -> (o#_Loc_t _x0)#module_expr _x1 + | StMod _x0 _x1 _x2 -> ((o#_Loc_t _x0)#string _x1)#module_expr _x2 + | StRecMod _x0 _x1 -> (o#_Loc_t _x0)#module_binding _x1 + | StMty _x0 _x1 _x2 -> ((o#_Loc_t _x0)#string _x1)#module_type _x2 + | StOpn _x0 _x1 -> (o#_Loc_t _x0)#ident _x1 + | StTyp _x0 _x1 -> (o#_Loc_t _x0)#ctyp _x1 + | StVal _x0 _x1 _x2 -> ((o#_Loc_t _x0)#meta_bool _x1)#binding _x2 + | StAnt _x0 _x1 -> (o#_Loc_t _x0)#string _x1 ]; + method sig_item : sig_item -> 'self_type = + fun + [ SgNil _x0 -> o#_Loc_t _x0 + | SgCls _x0 _x1 -> (o#_Loc_t _x0)#class_type _x1 + | SgClt _x0 _x1 -> (o#_Loc_t _x0)#class_type _x1 + | SgSem _x0 _x1 _x2 -> ((o#_Loc_t _x0)#sig_item _x1)#sig_item _x2 + | SgDir _x0 _x1 _x2 -> ((o#_Loc_t _x0)#string _x1)#expr _x2 + | SgExc _x0 _x1 -> (o#_Loc_t _x0)#ctyp _x1 + | SgExt _x0 _x1 _x2 _x3 -> + (((o#_Loc_t _x0)#string _x1)#ctyp _x2)#meta_list + (fun o -> o#string) _x3 + | SgInc _x0 _x1 -> (o#_Loc_t _x0)#module_type _x1 + | SgMod _x0 _x1 _x2 -> ((o#_Loc_t _x0)#string _x1)#module_type _x2 + | SgRecMod _x0 _x1 -> (o#_Loc_t _x0)#module_binding _x1 + | SgMty _x0 _x1 _x2 -> ((o#_Loc_t _x0)#string _x1)#module_type _x2 + | SgOpn _x0 _x1 -> (o#_Loc_t _x0)#ident _x1 + | SgTyp _x0 _x1 -> (o#_Loc_t _x0)#ctyp _x1 + | SgVal _x0 _x1 _x2 -> ((o#_Loc_t _x0)#string _x1)#ctyp _x2 + | SgAnt _x0 _x1 -> (o#_Loc_t _x0)#string _x1 ]; + method patt : patt -> 'self_type = + fun + [ PaNil _x0 -> o#_Loc_t _x0 + | PaId _x0 _x1 -> (o#_Loc_t _x0)#ident _x1 + | PaAli _x0 _x1 _x2 -> ((o#_Loc_t _x0)#patt _x1)#patt _x2 + | PaAnt _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | PaAny _x0 -> o#_Loc_t _x0 + | PaApp _x0 _x1 _x2 -> ((o#_Loc_t _x0)#patt _x1)#patt _x2 + | PaArr _x0 _x1 -> (o#_Loc_t _x0)#patt _x1 + | PaCom _x0 _x1 _x2 -> ((o#_Loc_t _x0)#patt _x1)#patt _x2 + | PaSem _x0 _x1 _x2 -> ((o#_Loc_t _x0)#patt _x1)#patt _x2 + | PaChr _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | PaInt _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | PaInt32 _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | PaInt64 _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | PaNativeInt _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | PaFlo _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | PaLab _x0 _x1 _x2 -> ((o#_Loc_t _x0)#string _x1)#patt _x2 + | PaOlb _x0 _x1 _x2 -> ((o#_Loc_t _x0)#string _x1)#patt _x2 + | PaOlbi _x0 _x1 _x2 _x3 -> + (((o#_Loc_t _x0)#string _x1)#patt _x2)#expr _x3 + | PaOrp _x0 _x1 _x2 -> ((o#_Loc_t _x0)#patt _x1)#patt _x2 + | PaRng _x0 _x1 _x2 -> ((o#_Loc_t _x0)#patt _x1)#patt _x2 + | PaRec _x0 _x1 -> (o#_Loc_t _x0)#patt _x1 + | PaEq _x0 _x1 _x2 -> ((o#_Loc_t _x0)#patt _x1)#patt _x2 + | PaStr _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | PaTup _x0 _x1 -> (o#_Loc_t _x0)#patt _x1 + | PaTyc _x0 _x1 _x2 -> ((o#_Loc_t _x0)#patt _x1)#ctyp _x2 + | PaTyp _x0 _x1 -> (o#_Loc_t _x0)#ident _x1 + | PaVrn _x0 _x1 -> (o#_Loc_t _x0)#string _x1 ]; + method module_type : module_type -> 'self_type = + fun + [ MtId _x0 _x1 -> (o#_Loc_t _x0)#ident _x1 + | MtFun _x0 _x1 _x2 _x3 -> + (((o#_Loc_t _x0)#string _x1)#module_type _x2)#module_type _x3 + | MtQuo _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | MtSig _x0 _x1 -> (o#_Loc_t _x0)#sig_item _x1 + | MtWit _x0 _x1 _x2 -> + ((o#_Loc_t _x0)#module_type _x1)#with_constr _x2 + | MtAnt _x0 _x1 -> (o#_Loc_t _x0)#string _x1 ]; + method module_expr : module_expr -> 'self_type = + fun + [ MeId _x0 _x1 -> (o#_Loc_t _x0)#ident _x1 + | MeApp _x0 _x1 _x2 -> + ((o#_Loc_t _x0)#module_expr _x1)#module_expr _x2 + | MeFun _x0 _x1 _x2 _x3 -> + (((o#_Loc_t _x0)#string _x1)#module_type _x2)#module_expr _x3 + | MeStr _x0 _x1 -> (o#_Loc_t _x0)#str_item _x1 + | MeTyc _x0 _x1 _x2 -> + ((o#_Loc_t _x0)#module_expr _x1)#module_type _x2 + | MeAnt _x0 _x1 -> (o#_Loc_t _x0)#string _x1 ]; + method module_binding : module_binding -> 'self_type = + fun + [ MbNil _x0 -> o#_Loc_t _x0 + | MbAnd _x0 _x1 _x2 -> + ((o#_Loc_t _x0)#module_binding _x1)#module_binding _x2 + | MbColEq _x0 _x1 _x2 _x3 -> + (((o#_Loc_t _x0)#string _x1)#module_type _x2)#module_expr _x3 + | MbCol _x0 _x1 _x2 -> ((o#_Loc_t _x0)#string _x1)#module_type _x2 + | MbAnt _x0 _x1 -> (o#_Loc_t _x0)#string _x1 ]; + method meta_option : + ! 'a. + ('self_type -> 'a -> 'self_type) -> meta_option 'a -> 'self_type = + fun _f_a -> + fun + [ ONone -> o + | OSome _x0 -> _f_a o _x0 + | OAnt _x0 -> o#string _x0 ]; + method meta_list : + ! 'a. + ('self_type -> 'a -> 'self_type) -> meta_list 'a -> 'self_type = + fun _f_a -> + fun + [ LNil -> o + | LCons _x0 _x1 -> (_f_a o _x0)#meta_list (fun o -> _f_a o) _x1 + | LAnt _x0 -> o#string _x0 ]; + method meta_bool : meta_bool -> 'self_type = + fun [ BTrue -> o | BFalse -> o | BAnt _x0 -> o#string _x0 ]; + method match_case : match_case -> 'self_type = + fun + [ McNil _x0 -> o#_Loc_t _x0 + | McOr _x0 _x1 _x2 -> + ((o#_Loc_t _x0)#match_case _x1)#match_case _x2 + | McArr _x0 _x1 _x2 _x3 -> + (((o#_Loc_t _x0)#patt _x1)#expr _x2)#expr _x3 + | McAnt _x0 _x1 -> (o#_Loc_t _x0)#string _x1 ]; + method ident : ident -> 'self_type = + fun + [ IdAcc _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ident _x1)#ident _x2 + | IdApp _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ident _x1)#ident _x2 + | IdLid _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | IdUid _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | IdAnt _x0 _x1 -> (o#_Loc_t _x0)#string _x1 ]; + method expr : expr -> 'self_type = + fun + [ ExNil _x0 -> o#_Loc_t _x0 + | ExId _x0 _x1 -> (o#_Loc_t _x0)#ident _x1 + | ExAcc _x0 _x1 _x2 -> ((o#_Loc_t _x0)#expr _x1)#expr _x2 + | ExAnt _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | ExApp _x0 _x1 _x2 -> ((o#_Loc_t _x0)#expr _x1)#expr _x2 + | ExAre _x0 _x1 _x2 -> ((o#_Loc_t _x0)#expr _x1)#expr _x2 + | ExArr _x0 _x1 -> (o#_Loc_t _x0)#expr _x1 + | ExSem _x0 _x1 _x2 -> ((o#_Loc_t _x0)#expr _x1)#expr _x2 + | ExAsf _x0 -> o#_Loc_t _x0 + | ExAsr _x0 _x1 -> (o#_Loc_t _x0)#expr _x1 + | ExAss _x0 _x1 _x2 -> ((o#_Loc_t _x0)#expr _x1)#expr _x2 + | ExChr _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | ExCoe _x0 _x1 _x2 _x3 -> + (((o#_Loc_t _x0)#expr _x1)#ctyp _x2)#ctyp _x3 + | ExFlo _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | ExFor _x0 _x1 _x2 _x3 _x4 _x5 -> + (((((o#_Loc_t _x0)#string _x1)#expr _x2)#expr _x3)#meta_bool + _x4)# + expr _x5 + | ExFun _x0 _x1 -> (o#_Loc_t _x0)#match_case _x1 + | ExIfe _x0 _x1 _x2 _x3 -> + (((o#_Loc_t _x0)#expr _x1)#expr _x2)#expr _x3 + | ExInt _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | ExInt32 _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | ExInt64 _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | ExNativeInt _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | ExLab _x0 _x1 _x2 -> ((o#_Loc_t _x0)#string _x1)#expr _x2 + | ExLaz _x0 _x1 -> (o#_Loc_t _x0)#expr _x1 + | ExLet _x0 _x1 _x2 _x3 -> + (((o#_Loc_t _x0)#meta_bool _x1)#binding _x2)#expr _x3 + | ExLmd _x0 _x1 _x2 _x3 -> + (((o#_Loc_t _x0)#string _x1)#module_expr _x2)#expr _x3 + | ExMat _x0 _x1 _x2 -> ((o#_Loc_t _x0)#expr _x1)#match_case _x2 + | ExNew _x0 _x1 -> (o#_Loc_t _x0)#ident _x1 + | ExObj _x0 _x1 _x2 -> ((o#_Loc_t _x0)#patt _x1)#class_str_item _x2 + | ExOlb _x0 _x1 _x2 -> ((o#_Loc_t _x0)#string _x1)#expr _x2 + | ExOvr _x0 _x1 -> (o#_Loc_t _x0)#binding _x1 + | ExRec _x0 _x1 _x2 -> ((o#_Loc_t _x0)#binding _x1)#expr _x2 + | ExSeq _x0 _x1 -> (o#_Loc_t _x0)#expr _x1 + | ExSnd _x0 _x1 _x2 -> ((o#_Loc_t _x0)#expr _x1)#string _x2 + | ExSte _x0 _x1 _x2 -> ((o#_Loc_t _x0)#expr _x1)#expr _x2 + | ExStr _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | ExTry _x0 _x1 _x2 -> ((o#_Loc_t _x0)#expr _x1)#match_case _x2 + | ExTup _x0 _x1 -> (o#_Loc_t _x0)#expr _x1 + | ExCom _x0 _x1 _x2 -> ((o#_Loc_t _x0)#expr _x1)#expr _x2 + | ExTyc _x0 _x1 _x2 -> ((o#_Loc_t _x0)#expr _x1)#ctyp _x2 + | ExVrn _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | ExWhi _x0 _x1 _x2 -> ((o#_Loc_t _x0)#expr _x1)#expr _x2 ]; + method ctyp : ctyp -> 'self_type = + fun + [ TyNil _x0 -> o#_Loc_t _x0 + | TyAli _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyAny _x0 -> o#_Loc_t _x0 + | TyApp _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyArr _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyCls _x0 _x1 -> (o#_Loc_t _x0)#ident _x1 + | TyLab _x0 _x1 _x2 -> ((o#_Loc_t _x0)#string _x1)#ctyp _x2 + | TyId _x0 _x1 -> (o#_Loc_t _x0)#ident _x1 + | TyMan _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyDcl _x0 _x1 _x2 _x3 _x4 -> + ((((o#_Loc_t _x0)#string _x1)#list (fun o -> o#ctyp) _x2)#ctyp + _x3)# + list (fun o (_x0, _x1) -> (o#ctyp _x0)#ctyp _x1) _x4 + | TyObj _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ctyp _x1)#meta_bool _x2 + | TyOlb _x0 _x1 _x2 -> ((o#_Loc_t _x0)#string _x1)#ctyp _x2 + | TyPol _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyQuo _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | TyQuP _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | TyQuM _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | TyVrn _x0 _x1 -> (o#_Loc_t _x0)#string _x1 + | TyRec _x0 _x1 -> (o#_Loc_t _x0)#ctyp _x1 + | TyCol _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TySem _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyCom _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TySum _x0 _x1 -> (o#_Loc_t _x0)#ctyp _x1 + | TyOf _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyAnd _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyOr _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyPrv _x0 _x1 -> (o#_Loc_t _x0)#ctyp _x1 + | TyMut _x0 _x1 -> (o#_Loc_t _x0)#ctyp _x1 + | TyTup _x0 _x1 -> (o#_Loc_t _x0)#ctyp _x1 + | TySta _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyVrnEq _x0 _x1 -> (o#_Loc_t _x0)#ctyp _x1 + | TyVrnSup _x0 _x1 -> (o#_Loc_t _x0)#ctyp _x1 + | TyVrnInf _x0 _x1 -> (o#_Loc_t _x0)#ctyp _x1 + | TyVrnInfSup _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyAmp _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyOfAmp _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | TyAnt _x0 _x1 -> (o#_Loc_t _x0)#string _x1 ]; + method class_type : class_type -> 'self_type = + fun + [ CtNil _x0 -> o#_Loc_t _x0 + | CtCon _x0 _x1 _x2 _x3 -> + (((o#_Loc_t _x0)#meta_bool _x1)#ident _x2)#ctyp _x3 + | CtFun _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ctyp _x1)#class_type _x2 + | CtSig _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ctyp _x1)#class_sig_item _x2 + | CtAnd _x0 _x1 _x2 -> + ((o#_Loc_t _x0)#class_type _x1)#class_type _x2 + | CtCol _x0 _x1 _x2 -> + ((o#_Loc_t _x0)#class_type _x1)#class_type _x2 + | CtEq _x0 _x1 _x2 -> + ((o#_Loc_t _x0)#class_type _x1)#class_type _x2 + | CtAnt _x0 _x1 -> (o#_Loc_t _x0)#string _x1 ]; + method class_str_item : class_str_item -> 'self_type = + fun + [ CrNil _x0 -> o#_Loc_t _x0 + | CrSem _x0 _x1 _x2 -> + ((o#_Loc_t _x0)#class_str_item _x1)#class_str_item _x2 + | CrCtr _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | CrInh _x0 _x1 _x2 -> ((o#_Loc_t _x0)#class_expr _x1)#string _x2 + | CrIni _x0 _x1 -> (o#_Loc_t _x0)#expr _x1 + | CrMth _x0 _x1 _x2 _x3 _x4 -> + ((((o#_Loc_t _x0)#string _x1)#meta_bool _x2)#expr _x3)#ctyp _x4 + | CrVal _x0 _x1 _x2 _x3 -> + (((o#_Loc_t _x0)#string _x1)#meta_bool _x2)#expr _x3 + | CrVir _x0 _x1 _x2 _x3 -> + (((o#_Loc_t _x0)#string _x1)#meta_bool _x2)#ctyp _x3 + | CrVvr _x0 _x1 _x2 _x3 -> + (((o#_Loc_t _x0)#string _x1)#meta_bool _x2)#ctyp _x3 + | CrAnt _x0 _x1 -> (o#_Loc_t _x0)#string _x1 ]; + method class_sig_item : class_sig_item -> 'self_type = + fun + [ CgNil _x0 -> o#_Loc_t _x0 + | CgCtr _x0 _x1 _x2 -> ((o#_Loc_t _x0)#ctyp _x1)#ctyp _x2 + | CgSem _x0 _x1 _x2 -> + ((o#_Loc_t _x0)#class_sig_item _x1)#class_sig_item _x2 + | CgInh _x0 _x1 -> (o#_Loc_t _x0)#class_type _x1 + | CgMth _x0 _x1 _x2 _x3 -> + (((o#_Loc_t _x0)#string _x1)#meta_bool _x2)#ctyp _x3 + | CgVal _x0 _x1 _x2 _x3 _x4 -> + ((((o#_Loc_t _x0)#string _x1)#meta_bool _x2)#meta_bool _x3)# + ctyp _x4 + | CgVir _x0 _x1 _x2 _x3 -> + (((o#_Loc_t _x0)#string _x1)#meta_bool _x2)#ctyp _x3 + | CgAnt _x0 _x1 -> (o#_Loc_t _x0)#string _x1 ]; + method class_expr : class_expr -> 'self_type = + fun + [ CeNil _x0 -> o#_Loc_t _x0 + | CeApp _x0 _x1 _x2 -> ((o#_Loc_t _x0)#class_expr _x1)#expr _x2 + | CeCon _x0 _x1 _x2 _x3 -> + (((o#_Loc_t _x0)#meta_bool _x1)#ident _x2)#ctyp _x3 + | CeFun _x0 _x1 _x2 -> ((o#_Loc_t _x0)#patt _x1)#class_expr _x2 + | CeLet _x0 _x1 _x2 _x3 -> + (((o#_Loc_t _x0)#meta_bool _x1)#binding _x2)#class_expr _x3 + | CeStr _x0 _x1 _x2 -> ((o#_Loc_t _x0)#patt _x1)#class_str_item _x2 + | CeTyc _x0 _x1 _x2 -> + ((o#_Loc_t _x0)#class_expr _x1)#class_type _x2 + | CeAnd _x0 _x1 _x2 -> + ((o#_Loc_t _x0)#class_expr _x1)#class_expr _x2 + | CeEq _x0 _x1 _x2 -> + ((o#_Loc_t _x0)#class_expr _x1)#class_expr _x2 + | CeAnt _x0 _x1 -> (o#_Loc_t _x0)#string _x1 ]; + method binding : binding -> 'self_type = + fun + [ BiNil _x0 -> o#_Loc_t _x0 + | BiAnd _x0 _x1 _x2 -> ((o#_Loc_t _x0)#binding _x1)#binding _x2 + | BiSem _x0 _x1 _x2 -> ((o#_Loc_t _x0)#binding _x1)#binding _x2 + | BiEq _x0 _x1 _x2 -> ((o#_Loc_t _x0)#patt _x1)#expr _x2 + | BiAnt _x0 _x1 -> (o#_Loc_t _x0)#string _x1 ]; + end; + class c_expr f = + object inherit map as super; method expr = fun x -> f (super#expr x); + end; + class c_patt f = + object inherit map as super; method patt = fun x -> f (super#patt x); + end; + class c_ctyp f = + object inherit map as super; method ctyp = fun x -> f (super#ctyp x); + end; + class c_str_item f = + object inherit map as super; + method str_item = fun x -> f (super#str_item x); + end; + class c_sig_item f = + object inherit map as super; + method sig_item = fun x -> f (super#sig_item x); + end; + class c_loc f = + object inherit map as super; + method _Loc_t = fun x -> f (super#_Loc_t x); + end; + value map_patt f ast = (new c_patt f)#patt ast; + value map_loc f ast = (new c_loc f)#_Loc_t ast; + value map_sig_item f ast = (new c_sig_item f)#sig_item ast; + value map_str_item f ast = (new c_str_item f)#str_item ast; + value map_ctyp f ast = (new c_ctyp f)#ctyp ast; + value map_expr f ast = (new c_expr f)#expr ast; + value ghost = Loc.ghost; + value rec is_module_longident = + fun + [ Ast.IdAcc _ _ i -> is_module_longident i + | Ast.IdApp _ i1 i2 -> + (is_module_longident i1) && (is_module_longident i2) + | Ast.IdUid _ _ -> True + | _ -> False ]; + value rec is_irrefut_patt = + fun + [ Ast.PaId _ (Ast.IdLid _ _) -> True + | Ast.PaId _ (Ast.IdUid _ "()") -> True + | Ast.PaAny _ -> True + | Ast.PaAli _ x y -> (is_irrefut_patt x) && (is_irrefut_patt y) + | Ast.PaRec _ p -> is_irrefut_patt p + | Ast.PaEq _ (Ast.PaId _ (Ast.IdLid _ _)) p -> is_irrefut_patt p + | Ast.PaSem _ p1 p2 -> (is_irrefut_patt p1) && (is_irrefut_patt p2) + | Ast.PaCom _ p1 p2 -> (is_irrefut_patt p1) && (is_irrefut_patt p2) + | Ast.PaTyc _ p _ -> is_irrefut_patt p + | Ast.PaTup _ pl -> is_irrefut_patt pl + | Ast.PaOlb _ _ (Ast.PaNil _) -> True + | Ast.PaOlb _ _ p -> is_irrefut_patt p + | Ast.PaOlbi _ _ p _ -> is_irrefut_patt p + | Ast.PaLab _ _ (Ast.PaNil _) -> True + | Ast.PaLab _ _ p -> is_irrefut_patt p + | _ -> False ]; + value rec is_constructor = + fun + [ Ast.IdAcc _ _ i -> is_constructor i + | Ast.IdUid _ _ -> True + | Ast.IdLid _ _ | Ast.IdApp _ _ _ -> False + | Ast.IdAnt _ _ -> assert False ]; + value is_patt_constructor = + fun + [ Ast.PaId _ i -> is_constructor i + | Ast.PaVrn _ _ -> True + | _ -> False ]; + value rec is_expr_constructor = + fun + [ Ast.ExId _ i -> is_constructor i + | Ast.ExAcc _ e1 e2 -> + (is_expr_constructor e1) && (is_expr_constructor e2) + | Ast.ExVrn _ _ -> True + | _ -> False ]; + value ident_of_expr = + let error () = + invalid_arg "ident_of_expr: this expression is not an identifier" in + let rec self = + fun + [ Ast.ExApp _loc e1 e2 -> Ast.IdApp _loc (self e1) (self e2) + | Ast.ExAcc _loc e1 e2 -> Ast.IdAcc _loc (self e1) (self e2) + | Ast.ExId _ (Ast.IdLid _ _) -> error () + | Ast.ExId _ i -> if is_module_longident i then i else error () + | _ -> error () ] + in + fun [ Ast.ExId _ i -> i | Ast.ExApp _ _ _ -> 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 + [ Ast.TyApp _loc t1 t2 -> Ast.IdApp _loc (self t1) (self t2) + | Ast.TyId _ (Ast.IdLid _ _) -> error () + | Ast.TyId _ i -> if is_module_longident i then i else error () + | _ -> error () ] + in fun [ Ast.TyId _ i -> i | t -> self t ]; + value rec tyOr_of_list = + fun + [ [] -> Ast.TyNil ghost + | [ t ] -> t + | [ t :: ts ] -> + let _loc = loc_of_ctyp t in Ast.TyOr _loc t (tyOr_of_list ts) ]; + value rec tyAnd_of_list = + fun + [ [] -> Ast.TyNil ghost + | [ t ] -> t + | [ t :: ts ] -> + let _loc = loc_of_ctyp t in Ast.TyAnd _loc t (tyAnd_of_list ts) ]; + value rec tySem_of_list = + fun + [ [] -> Ast.TyNil ghost + | [ t ] -> t + | [ t :: ts ] -> + let _loc = loc_of_ctyp t in Ast.TySem _loc t (tySem_of_list ts) ]; + value rec stSem_of_list = + fun + [ [] -> Ast.StNil ghost + | [ t ] -> t + | [ t :: ts ] -> + let _loc = loc_of_str_item t in Ast.StSem _loc t (stSem_of_list ts) ]; + value rec sgSem_of_list = + fun + [ [] -> Ast.SgNil ghost + | [ t ] -> t + | [ t :: ts ] -> + let _loc = loc_of_sig_item t in Ast.SgSem _loc t (sgSem_of_list ts) ]; + value rec biAnd_of_list = + fun + [ [] -> Ast.BiNil ghost + | [ b ] -> b + | [ b :: bs ] -> + let _loc = loc_of_binding b in Ast.BiAnd _loc b (biAnd_of_list bs) ]; + value rec wcAnd_of_list = + fun + [ [] -> Ast.WcNil ghost + | [ w ] -> w + | [ w :: ws ] -> + let _loc = loc_of_with_constr w + in Ast.WcAnd _loc w (wcAnd_of_list ws) ]; + value rec idAcc_of_list = + fun + [ [] -> assert False + | [ i ] -> i + | [ i :: is ] -> + let _loc = loc_of_ident i in Ast.IdAcc _loc i (idAcc_of_list is) ]; + value rec idApp_of_list = + fun + [ [] -> assert False + | [ i ] -> i + | [ i :: is ] -> + let _loc = loc_of_ident i in Ast.IdApp _loc i (idApp_of_list is) ]; + value rec mcOr_of_list = + fun + [ [] -> Ast.McNil ghost + | [ x ] -> x + | [ x :: xs ] -> + let _loc = loc_of_match_case x in Ast.McOr _loc x (mcOr_of_list xs) ]; + value rec mbAnd_of_list = + fun + [ [] -> Ast.MbNil ghost + | [ x ] -> x + | [ x :: xs ] -> + let _loc = loc_of_module_binding x + in Ast.MbAnd _loc x (mbAnd_of_list xs) ]; + value rec meApp_of_list = + fun + [ [] -> assert False + | [ x ] -> x + | [ x :: xs ] -> + let _loc = loc_of_module_expr x + in Ast.MeApp _loc x (meApp_of_list xs) ]; + value rec ceAnd_of_list = + fun + [ [] -> Ast.CeNil ghost + | [ x ] -> x + | [ x :: xs ] -> + let _loc = loc_of_class_expr x + in Ast.CeAnd _loc x (ceAnd_of_list xs) ]; + value rec ctAnd_of_list = + fun + [ [] -> Ast.CtNil ghost + | [ x ] -> x + | [ x :: xs ] -> + let _loc = loc_of_class_type x + in Ast.CtAnd _loc x (ctAnd_of_list xs) ]; + value rec cgSem_of_list = + fun + [ [] -> Ast.CgNil ghost + | [ x ] -> x + | [ x :: xs ] -> + let _loc = loc_of_class_sig_item x + in Ast.CgSem _loc x (cgSem_of_list xs) ]; + value rec crSem_of_list = + fun + [ [] -> Ast.CrNil ghost + | [ x ] -> x + | [ x :: xs ] -> + let _loc = loc_of_class_str_item x + in Ast.CrSem _loc x (crSem_of_list xs) ]; + value rec paSem_of_list = + fun + [ [] -> Ast.PaNil ghost + | [ x ] -> x + | [ x :: xs ] -> + let _loc = loc_of_patt x in Ast.PaSem _loc x (paSem_of_list xs) ]; + value rec paCom_of_list = + fun + [ [] -> Ast.PaNil ghost + | [ x ] -> x + | [ x :: xs ] -> + let _loc = loc_of_patt x in Ast.PaCom _loc x (paCom_of_list xs) ]; + value rec biSem_of_list = + fun + [ [] -> Ast.BiNil ghost + | [ x ] -> x + | [ x :: xs ] -> + let _loc = loc_of_binding x in Ast.BiSem _loc x (biSem_of_list xs) ]; + value rec exSem_of_list = + fun + [ [] -> Ast.ExNil ghost + | [ x ] -> x + | [ x :: xs ] -> + let _loc = loc_of_expr x in Ast.ExSem _loc x (exSem_of_list xs) ]; + value rec exCom_of_list = + fun + [ [] -> Ast.ExNil ghost + | [ x ] -> x + | [ x :: xs ] -> + let _loc = loc_of_expr x in Ast.ExCom _loc x (exCom_of_list xs) ]; + value ty_of_stl = + fun + [ (_loc, s, []) -> Ast.TyId _loc (Ast.IdUid _loc s) + | (_loc, s, tl) -> + Ast.TyOf _loc (Ast.TyId _loc (Ast.IdUid _loc s)) (tyAnd_of_list tl) ]; + value ty_of_sbt = + fun + [ (_loc, s, True, t) -> + Ast.TyCol _loc (Ast.TyId _loc (Ast.IdLid _loc s)) + (Ast.TyMut _loc t) + | (_loc, s, False, t) -> + Ast.TyCol _loc (Ast.TyId _loc (Ast.IdLid _loc s)) t ]; + value bi_of_pe (p, e) = let _loc = loc_of_patt p in Ast.BiEq _loc 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 + [ Ast.BiAnd _ b1 b2 -> (pel_of_binding b1) @ (pel_of_binding b2) + | Ast.BiEq _ p e -> [ (p, e) ] + | Ast.BiSem _ b1 b2 -> (pel_of_binding b1) @ (pel_of_binding b2) + | _ -> assert False ]; + value rec list_of_binding x acc = + match x with + [ Ast.BiAnd _ b1 b2 | Ast.BiSem _ b1 b2 -> + list_of_binding b1 (list_of_binding b2 acc) + | t -> [ t :: acc ] ]; + value rec list_of_with_constr x acc = + match x with + [ Ast.WcAnd _ w1 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 + [ Ast.TyNil _ -> acc + | Ast.TyAmp _ x y | Ast.TyCom _ x y | Ast.TySta _ x y | Ast.TySem _ x y + | Ast.TyAnd _ x y | Ast.TyOr _ x y -> + list_of_ctyp x (list_of_ctyp y acc) + | x -> [ x :: acc ] ]; + value rec list_of_patt x acc = + match x with + [ Ast.PaNil _ -> acc + | Ast.PaCom _ x y | Ast.PaSem _ x y -> + list_of_patt x (list_of_patt y acc) + | x -> [ x :: acc ] ]; + value rec list_of_expr x acc = + match x with + [ Ast.ExNil _ -> acc + | Ast.ExCom _ x y | Ast.ExSem _ 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 + [ Ast.StNil _ -> acc + | Ast.StSem _ 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 + [ Ast.SgNil _ -> acc + | Ast.SgSem _ 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 + [ Ast.CgNil _ -> acc + | Ast.CgSem _ 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 + [ Ast.CrNil _ -> acc + | Ast.CrSem _ 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 + [ Ast.CtAnd _ x 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 + [ Ast.CeAnd _ x 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 + [ Ast.MeApp _ 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 + [ Ast.McNil _ -> acc + | Ast.McOr _ 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 + [ Ast.IdAcc _ x y | Ast.IdApp _ 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 + [ Ast.MbAnd _ x y -> + list_of_module_binding x (list_of_module_binding y acc) + | x -> [ x :: acc ] ]; + end; + diff --git a/camlp4/boot/Makefile b/camlp4/boot/Makefile new file mode 100644 index 00000000..2cc9f17e --- /dev/null +++ b/camlp4/boot/Makefile @@ -0,0 +1,24 @@ +# $Id: Makefile,v 1.2 2006/11/15 14:49:26 doligez Exp $ + +MAX_SAVE = 10 + +backup: + cp camlp4boot camlp4boot.save.0 + set -e; for i in camlp4boot.save.*; do \ + mv $$i camlp4boot.evas.$$((`echo $$i | sed -e 's/.*\.save\.\([0-9][0-9]*\)/\1/'` + 1)); \ + done + set -e; for i in camlp4boot.evas.*; do mv $$i $${i/.evas./.save.}; done + rm -f camlp4boot.save.$(MAX_SAVE) + +restore: + set -e; for i in camlp4boot.save.*; do \ + mv $$i camlp4boot.evas.$$((`echo $$i | sed -e 's/.*\.save\.\([0-9][0-9]*\)/\1/'` - 1)); \ + done + set -e; for i in camlp4boot.evas.*; do mv $$i $${i/.evas./.save.}; done + mv camlp4boot.save.0 camlp4boot + +boot-clean: + rm -f camlp4boot.save.* camlp4boot.evas.* + +maintainer-clean: + rm -f camlp4boot diff --git a/camlp4/boot/camlp4boot.ml b/camlp4/boot/camlp4boot.ml new file mode 100644 index 00000000..19505718 --- /dev/null +++ b/camlp4/boot/camlp4boot.ml @@ -0,0 +1,12207 @@ +module R = + struct + open Camlp4 + (* -*- camlp4r -*- *) + (****************************************************************************) + (* *) + (* Objective Caml *) + (* *) + (* INRIA Rocquencourt *) + (* *) + (* Copyright 2002-2006 Institut National de Recherche en Informatique et *) + (* en Automatique. All rights reserved. This file is distributed under *) + (* the terms of the GNU Library General Public License, with the special *) + (* exception on linking described in LICENSE at the top of the Objective *) + (* Caml source tree. *) + (* *) + (****************************************************************************) + (* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + module Id = + struct + let name = "Camlp4RevisedParserParser" + let version = + "$Id: camlp4boot.ml,v 1.2 2007/02/26 16:32:47 ertai Exp $" + end + module Make (Syntax : Sig.Camlp4Syntax) = + struct + open Sig + include Syntax + (* Camlp4_config.constructors_arity.val := True; *) + let _ = Camlp4_config.constructors_arity := false + let help_sequences () = + (Printf.eprintf + "\ +New syntax: + do {e1; e2; ... ; en} + while e do {e1; e2; ... ; en} + for v = v1 to/downto v2 do {e1; e2; ... ; en} +Old (no more supported) syntax: + do e1; e2; ... ; en-1; return en + while e do e1; e2; ... ; en; done + for v = v1 to/downto v2 do e1; e2; ... ; en; done + "; + flush stderr; + exit 1) + let _ = + Options.add "-help_seq" (Arg.Unit help_sequences) + "Print explanations about new sequences and exit." + let _ = Gram.Entry.clear a_CHAR + let _ = Gram.Entry.clear a_FLOAT + let _ = Gram.Entry.clear a_INT + let _ = Gram.Entry.clear a_INT32 + let _ = Gram.Entry.clear a_INT64 + let _ = Gram.Entry.clear a_LABEL + let _ = Gram.Entry.clear a_LIDENT + let _ = Gram.Entry.clear a_LIDENT_or_operator + let _ = Gram.Entry.clear a_NATIVEINT + let _ = Gram.Entry.clear a_OPTLABEL + let _ = Gram.Entry.clear a_STRING + let _ = Gram.Entry.clear a_UIDENT + let _ = Gram.Entry.clear a_ident + let _ = Gram.Entry.clear amp_ctyp + let _ = Gram.Entry.clear and_ctyp + let _ = Gram.Entry.clear match_case + let _ = Gram.Entry.clear match_case0 + let _ = Gram.Entry.clear match_case_quot + let _ = Gram.Entry.clear binding + let _ = Gram.Entry.clear binding_quot + let _ = Gram.Entry.clear class_declaration + let _ = Gram.Entry.clear class_description + let _ = Gram.Entry.clear class_expr + let _ = Gram.Entry.clear class_expr_quot + let _ = Gram.Entry.clear class_fun_binding + let _ = Gram.Entry.clear class_fun_def + let _ = Gram.Entry.clear class_info_for_class_expr + let _ = Gram.Entry.clear class_info_for_class_type + let _ = Gram.Entry.clear class_longident + let _ = Gram.Entry.clear class_longident_and_param + let _ = Gram.Entry.clear class_name_and_param + let _ = Gram.Entry.clear class_sig_item + let _ = Gram.Entry.clear class_sig_item_quot + let _ = Gram.Entry.clear class_signature + let _ = Gram.Entry.clear class_str_item + let _ = Gram.Entry.clear class_str_item_quot + let _ = Gram.Entry.clear class_structure + let _ = Gram.Entry.clear class_type + let _ = Gram.Entry.clear class_type_declaration + let _ = Gram.Entry.clear class_type_longident + let _ = Gram.Entry.clear class_type_longident_and_param + let _ = Gram.Entry.clear class_type_plus + let _ = Gram.Entry.clear class_type_quot + let _ = Gram.Entry.clear comma_ctyp + let _ = Gram.Entry.clear comma_expr + let _ = Gram.Entry.clear comma_ipatt + let _ = Gram.Entry.clear comma_patt + let _ = Gram.Entry.clear comma_type_parameter + let _ = Gram.Entry.clear constrain + let _ = Gram.Entry.clear constructor_arg_list + let _ = Gram.Entry.clear constructor_declaration + let _ = Gram.Entry.clear constructor_declarations + let _ = Gram.Entry.clear ctyp + let _ = Gram.Entry.clear ctyp_quot + let _ = Gram.Entry.clear cvalue_binding + let _ = Gram.Entry.clear direction_flag + let _ = Gram.Entry.clear dummy + let _ = Gram.Entry.clear eq_expr + let _ = Gram.Entry.clear expr + let _ = Gram.Entry.clear expr_eoi + let _ = Gram.Entry.clear expr_quot + let _ = Gram.Entry.clear field + let _ = Gram.Entry.clear field_expr + let _ = Gram.Entry.clear fun_binding + let _ = Gram.Entry.clear fun_def + let _ = Gram.Entry.clear ident + let _ = Gram.Entry.clear ident_quot + let _ = Gram.Entry.clear implem + let _ = Gram.Entry.clear interf + let _ = Gram.Entry.clear ipatt + let _ = Gram.Entry.clear ipatt_tcon + let _ = Gram.Entry.clear label + let _ = Gram.Entry.clear label_declaration + let _ = Gram.Entry.clear label_expr + let _ = Gram.Entry.clear label_ipatt + let _ = Gram.Entry.clear label_longident + let _ = Gram.Entry.clear label_patt + let _ = Gram.Entry.clear labeled_ipatt + let _ = Gram.Entry.clear let_binding + let _ = Gram.Entry.clear meth_list + let _ = Gram.Entry.clear module_binding + let _ = Gram.Entry.clear module_binding0 + let _ = Gram.Entry.clear module_binding_quot + let _ = Gram.Entry.clear module_declaration + let _ = Gram.Entry.clear module_expr + let _ = Gram.Entry.clear module_expr_quot + let _ = Gram.Entry.clear module_longident + let _ = Gram.Entry.clear module_longident_with_app + let _ = Gram.Entry.clear module_rec_declaration + let _ = Gram.Entry.clear module_type + let _ = Gram.Entry.clear module_type_quot + let _ = Gram.Entry.clear more_ctyp + let _ = Gram.Entry.clear name_tags + let _ = Gram.Entry.clear opt_as_lident + let _ = Gram.Entry.clear opt_class_self_patt + let _ = Gram.Entry.clear opt_class_self_type + let _ = Gram.Entry.clear opt_comma_ctyp + let _ = Gram.Entry.clear opt_dot_dot + let _ = Gram.Entry.clear opt_eq_ctyp + let _ = Gram.Entry.clear opt_expr + let _ = Gram.Entry.clear opt_meth_list + let _ = Gram.Entry.clear opt_mutable + let _ = Gram.Entry.clear opt_polyt + let _ = Gram.Entry.clear opt_private + let _ = Gram.Entry.clear opt_rec + let _ = Gram.Entry.clear opt_virtual + let _ = Gram.Entry.clear opt_when_expr + let _ = Gram.Entry.clear patt + let _ = Gram.Entry.clear patt_as_patt_opt + let _ = Gram.Entry.clear patt_eoi + let _ = Gram.Entry.clear patt_quot + let _ = Gram.Entry.clear patt_tcon + let _ = Gram.Entry.clear phrase + let _ = Gram.Entry.clear pipe_ctyp + let _ = Gram.Entry.clear poly_type + let _ = Gram.Entry.clear row_field + let _ = Gram.Entry.clear sem_ctyp + let _ = Gram.Entry.clear sem_expr + let _ = Gram.Entry.clear sem_expr_for_list + let _ = Gram.Entry.clear sem_patt + let _ = Gram.Entry.clear sem_patt_for_list + let _ = Gram.Entry.clear semi + let _ = Gram.Entry.clear sequence + let _ = Gram.Entry.clear sig_item + let _ = Gram.Entry.clear sig_item_quot + let _ = Gram.Entry.clear sig_items + let _ = Gram.Entry.clear star_ctyp + let _ = Gram.Entry.clear str_item + let _ = Gram.Entry.clear str_item_quot + let _ = Gram.Entry.clear str_items + let _ = Gram.Entry.clear top_phrase + let _ = Gram.Entry.clear type_constraint + let _ = Gram.Entry.clear type_declaration + let _ = Gram.Entry.clear type_ident_and_parameters + let _ = Gram.Entry.clear type_kind + let _ = Gram.Entry.clear type_longident + let _ = Gram.Entry.clear type_longident_and_parameters + let _ = Gram.Entry.clear type_parameter + let _ = Gram.Entry.clear type_parameters + let _ = Gram.Entry.clear typevars + let _ = Gram.Entry.clear use_file + let _ = Gram.Entry.clear val_longident + let _ = Gram.Entry.clear value_let + let _ = Gram.Entry.clear value_val + let _ = Gram.Entry.clear with_constr + let _ = Gram.Entry.clear with_constr_quot + let neg_string n = + let len = String.length n + in + if (len > 0) && (n.[0] = '-') + then String.sub n 1 (len - 1) + else "-" ^ n + let mkumin _loc f arg = + match arg with + | Ast.ExInt (_, n) -> Ast.ExInt (_loc, neg_string n) + | Ast.ExInt32 (_, n) -> Ast.ExInt32 (_loc, neg_string n) + | Ast.ExInt64 (_, n) -> Ast.ExInt64 (_loc, neg_string n) + | Ast.ExNativeInt (_, n) -> Ast.ExNativeInt (_loc, neg_string n) + | Ast.ExFlo (_, n) -> Ast.ExFlo (_loc, neg_string n) + | _ -> + Ast.ExApp (_loc, Ast.ExId (_loc, Ast.IdLid (_loc, "~" ^ f)), + arg) + let mklistexp _loc last = + let rec loop top = + function + | [] -> + (match last with + | Some e -> e + | None -> Ast.ExId (_loc, Ast.IdUid (_loc, "[]"))) + | e1 :: el -> + let _loc = + if top then _loc else Loc.merge (Ast.loc_of_expr e1) _loc + in + Ast.ExApp (_loc, + Ast.ExApp (_loc, Ast.ExId (_loc, Ast.IdUid (_loc, "::")), + e1), + loop false el) + in loop true + let mkassert _loc = + function + | Ast.ExId (_, (Ast.IdUid (_, "False"))) -> Ast.ExAsf _loc + | (* this case take care about + the special assert false node *) + e -> Ast.ExAsr (_loc, e) + let append_eLem el e = el @ [ e ] + let mk_anti ?(c = "") n s = "\\$" ^ (n ^ (c ^ (":" ^ s))) + let mksequence _loc = + function + | (Ast.ExSem (_, _, _) | Ast.ExAnt (_, _) as e) -> + Ast.ExSeq (_loc, e) + | e -> e + let bigarray_get _loc arr arg = + let coords = + match arg with + | Ast.ExTup (_, (Ast.ExCom (_, e1, e2))) | Ast.ExCom (_, e1, e2) + -> Ast.list_of_expr e1 (Ast.list_of_expr e2 []) + | _ -> [ arg ] + in + match coords with + | [ c1 ] -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Bigarray"), + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Array1"), + Ast.IdLid (_loc, "get")))), + arr), + c1) + | [ c1; c2 ] -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Bigarray"), + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Array2"), + Ast.IdLid (_loc, "get")))), + arr), + c1), + c2) + | [ c1; c2; c3 ] -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Bigarray"), + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Array3"), + Ast.IdLid (_loc, "get")))), + arr), + c1), + c2), + c3) + | (* | coords -> <:expr< Bigarray.Genarray.get $arr$ [| $`list:coords$ |] >> ] *) + coords -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Bigarray"), + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Genarray"), + Ast.IdLid (_loc, "get")))), + arr), + Ast.ExArr (_loc, Ast.exSem_of_list coords)) + let bigarray_set _loc var newval = + match var with + | Ast.ExApp (_, + (Ast.ExApp (_, + (Ast.ExId (_, + (Ast.IdAcc (_, (Ast.IdUid (_, "Bigarray")), + (Ast.IdAcc (_, (Ast.IdUid (_, "Array1")), + (Ast.IdLid (_, "get")))))))), + arr)), + c1) -> + Some + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Bigarray"), + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Array1"), + Ast.IdLid (_loc, "set")))), + arr), + c1), + newval)) + | Ast.ExApp (_, + (Ast.ExApp (_, + (Ast.ExApp (_, + (Ast.ExId (_, + (Ast.IdAcc (_, (Ast.IdUid (_, "Bigarray")), + (Ast.IdAcc (_, (Ast.IdUid (_, "Array2")), + (Ast.IdLid (_, "get")))))))), + arr)), + c1)), + c2) -> + Some + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Bigarray"), + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Array2"), + Ast.IdLid (_loc, "set")))), + arr), + c1), + c2), + newval)) + | Ast.ExApp (_, + (Ast.ExApp (_, + (Ast.ExApp (_, + (Ast.ExApp (_, + (Ast.ExId (_, + (Ast.IdAcc (_, (Ast.IdUid (_, "Bigarray")), + (Ast.IdAcc (_, (Ast.IdUid (_, "Array3")), + (Ast.IdLid (_, "get")))))))), + arr)), + c1)), + c2)), + c3) -> + Some + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Bigarray"), + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Array3"), + Ast.IdLid (_loc, "set")))), + arr), + c1), + c2), + c3), + newval)) + | Ast.ExApp (_, + (Ast.ExApp (_, + (Ast.ExId (_, + (Ast.IdAcc (_, (Ast.IdUid (_, "Bigarray")), + (Ast.IdAcc (_, (Ast.IdUid (_, "Genarray")), + (Ast.IdLid (_, "get")))))))), + arr)), + (Ast.ExArr (_, coords))) -> + Some + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Bigarray"), + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Genarray"), + Ast.IdLid (_loc, "set")))), + arr), + Ast.ExArr (_loc, coords)), + newval)) + | _ -> None + let choose_tvar tpl = + let abs = "abstract" in + let rec find_alpha n = + let ns = if n = 0 then "" else string_of_int n in + let s' = abs ^ ns in + let rec mem = + function + | (Ast.TyQuo (_, s) | Ast.TyQuP (_, s) | Ast.TyQuM (_, s)) :: + xs -> (s = s') || (mem xs) + | [] -> false + | _ -> assert false + in if mem tpl then find_alpha (succ n) else s' + in find_alpha 0 + let stopped_at _loc = Some (Loc.move_line 1 _loc) + (* FIXME be more precise *) + (* value list1sep symb sep one cons = + let rec kont al = + parser + [ [: v = sep; a = symb; s :] -> kont (cons al (one a)) s + | [: :] -> al ] + in + parser [: a = symb; s :] -> kont (one a) s; + + value sem_expr = + list1sep expr ";" (fun x -> x) (fun e1 e2 -> <:expr< $e1$; $e2$ >>) *) + (* transmit the context *) + let _ = + Gram.Entry.setup_parser sem_expr + (let symb = Gram.parse_tokens_after_filter expr in + let rec kont al (__strm : _ Stream.t) = + match Stream.peek __strm with + | Some ((KEYWORD ";", _loc)) -> + (Stream.junk __strm; + let a = + (try symb __strm + with | Stream.Failure -> raise (Stream.Error "")) in + let s = __strm in kont (Ast.ExSem (_loc, al, a)) s) + | _ -> al + in + fun (__strm : _ Stream.t) -> + let a = symb __strm in kont a __strm) + (* sem_expr_for_list: + [ [ e = expr; ";"; el = SELF -> fun acc -> <:expr< [ $e$ :: $el acc$ ] >> + | e = expr -> fun acc -> <:expr< [ $e$ :: $acc$ ] >> + ] ] + ; + comma_expr: + [ [ e1 = SELF; ","; e2 = SELF -> <:expr< $e1$, $e2$ >> + | e = expr -> e ] ] + ; *) + let _ = + let _ = (a_CHAR : 'a_CHAR Gram.Entry.t) + and _ = (with_constr_quot : 'with_constr_quot Gram.Entry.t) + and _ = (with_constr : 'with_constr Gram.Entry.t) + and _ = (value_val : 'value_val Gram.Entry.t) + and _ = (value_let : 'value_let Gram.Entry.t) + and _ = (val_longident : 'val_longident Gram.Entry.t) + and _ = (use_file : 'use_file Gram.Entry.t) + and _ = (typevars : 'typevars Gram.Entry.t) + and _ = (type_parameters : 'type_parameters Gram.Entry.t) + and _ = (type_parameter : 'type_parameter Gram.Entry.t) + and _ = + (type_longident_and_parameters : + 'type_longident_and_parameters Gram.Entry.t) + and _ = (type_longident : 'type_longident Gram.Entry.t) + and _ = (type_kind : 'type_kind Gram.Entry.t) + and _ = + (type_ident_and_parameters : + 'type_ident_and_parameters Gram.Entry.t) + and _ = (type_declaration : 'type_declaration Gram.Entry.t) + and _ = (type_constraint : 'type_constraint Gram.Entry.t) + and _ = (top_phrase : 'top_phrase Gram.Entry.t) + and _ = (str_items : 'str_items Gram.Entry.t) + and _ = (str_item_quot : 'str_item_quot Gram.Entry.t) + and _ = (str_item : 'str_item Gram.Entry.t) + and _ = (star_ctyp : 'star_ctyp Gram.Entry.t) + and _ = (sig_items : 'sig_items Gram.Entry.t) + and _ = (sig_item_quot : 'sig_item_quot Gram.Entry.t) + and _ = (sig_item : 'sig_item Gram.Entry.t) + and _ = (sequence : 'sequence Gram.Entry.t) + and _ = (semi : 'semi Gram.Entry.t) + and _ = (sem_patt_for_list : 'sem_patt_for_list Gram.Entry.t) + and _ = (sem_patt : 'sem_patt Gram.Entry.t) + and _ = (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t) + and _ = (sem_expr : 'sem_expr Gram.Entry.t) + and _ = (sem_ctyp : 'sem_ctyp Gram.Entry.t) + and _ = (row_field : 'row_field Gram.Entry.t) + and _ = (poly_type : 'poly_type Gram.Entry.t) + and _ = (pipe_ctyp : 'pipe_ctyp Gram.Entry.t) + and _ = (phrase : 'phrase Gram.Entry.t) + and _ = (patt_tcon : 'patt_tcon Gram.Entry.t) + and _ = (patt_quot : 'patt_quot Gram.Entry.t) + and _ = (patt_eoi : 'patt_eoi Gram.Entry.t) + and _ = (patt_as_patt_opt : 'patt_as_patt_opt Gram.Entry.t) + and _ = (patt : 'patt Gram.Entry.t) + and _ = (opt_when_expr : 'opt_when_expr Gram.Entry.t) + and _ = (opt_virtual : 'opt_virtual Gram.Entry.t) + and _ = (opt_rec : 'opt_rec Gram.Entry.t) + and _ = (opt_private : 'opt_private Gram.Entry.t) + and _ = (opt_polyt : 'opt_polyt Gram.Entry.t) + and _ = (opt_mutable : 'opt_mutable Gram.Entry.t) + and _ = (opt_meth_list : 'opt_meth_list Gram.Entry.t) + and _ = (opt_expr : 'opt_expr Gram.Entry.t) + and _ = (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t) + and _ = (opt_dot_dot : 'opt_dot_dot Gram.Entry.t) + and _ = (opt_comma_ctyp : 'opt_comma_ctyp Gram.Entry.t) + and _ = (opt_class_self_type : 'opt_class_self_type Gram.Entry.t) + and _ = (opt_class_self_patt : 'opt_class_self_patt Gram.Entry.t) + and _ = (opt_as_lident : 'opt_as_lident Gram.Entry.t) + and _ = (name_tags : 'name_tags Gram.Entry.t) + and _ = (more_ctyp : 'more_ctyp Gram.Entry.t) + and _ = (module_type_quot : 'module_type_quot Gram.Entry.t) + and _ = (module_type : 'module_type Gram.Entry.t) + and _ = + (module_rec_declaration : 'module_rec_declaration Gram.Entry.t) + and _ = + (module_longident_with_app : + 'module_longident_with_app Gram.Entry.t) + and _ = (module_longident : 'module_longident Gram.Entry.t) + and _ = (module_expr_quot : 'module_expr_quot Gram.Entry.t) + and _ = (module_expr : 'module_expr Gram.Entry.t) + and _ = (module_declaration : 'module_declaration Gram.Entry.t) + and _ = (module_binding_quot : 'module_binding_quot Gram.Entry.t) + and _ = (module_binding0 : 'module_binding0 Gram.Entry.t) + and _ = (module_binding : 'module_binding Gram.Entry.t) + and _ = (meth_list : 'meth_list Gram.Entry.t) + and _ = (let_binding : 'let_binding Gram.Entry.t) + and _ = (labeled_ipatt : 'labeled_ipatt Gram.Entry.t) + and _ = (label_patt : 'label_patt Gram.Entry.t) + and _ = (label_longident : 'label_longident Gram.Entry.t) + and _ = (label_ipatt : 'label_ipatt Gram.Entry.t) + and _ = (label_expr : 'label_expr Gram.Entry.t) + and _ = (label_declaration : 'label_declaration Gram.Entry.t) + and _ = (label : 'label Gram.Entry.t) + and _ = (ipatt_tcon : 'ipatt_tcon Gram.Entry.t) + and _ = (ipatt : 'ipatt Gram.Entry.t) + and _ = (interf : 'interf Gram.Entry.t) + and _ = (implem : 'implem Gram.Entry.t) + and _ = (ident_quot : 'ident_quot Gram.Entry.t) + and _ = (ident : 'ident Gram.Entry.t) + and _ = (fun_def : 'fun_def Gram.Entry.t) + and _ = (fun_binding : 'fun_binding Gram.Entry.t) + and _ = (field_expr : 'field_expr Gram.Entry.t) + and _ = (field : 'field Gram.Entry.t) + and _ = (expr_quot : 'expr_quot Gram.Entry.t) + and _ = (expr_eoi : 'expr_eoi Gram.Entry.t) + and _ = (expr : 'expr Gram.Entry.t) + and _ = (eq_expr : 'eq_expr Gram.Entry.t) + and _ = (dummy : 'dummy Gram.Entry.t) + and _ = (direction_flag : 'direction_flag Gram.Entry.t) + and _ = (cvalue_binding : 'cvalue_binding Gram.Entry.t) + and _ = (ctyp_quot : 'ctyp_quot Gram.Entry.t) + and _ = (ctyp : 'ctyp Gram.Entry.t) + and _ = + (constructor_declarations : + 'constructor_declarations Gram.Entry.t) + and _ = + (constructor_declaration : 'constructor_declaration Gram.Entry.t) + and _ = (constructor_arg_list : 'constructor_arg_list Gram.Entry.t) + and _ = (constrain : 'constrain Gram.Entry.t) + and _ = (comma_type_parameter : 'comma_type_parameter Gram.Entry.t) + and _ = (comma_patt : 'comma_patt Gram.Entry.t) + and _ = (comma_ipatt : 'comma_ipatt Gram.Entry.t) + and _ = (comma_expr : 'comma_expr Gram.Entry.t) + and _ = (comma_ctyp : 'comma_ctyp Gram.Entry.t) + and _ = (class_type_quot : 'class_type_quot Gram.Entry.t) + and _ = (class_type_plus : 'class_type_plus Gram.Entry.t) + and _ = + (class_type_longident_and_param : + 'class_type_longident_and_param Gram.Entry.t) + and _ = (class_type_longident : 'class_type_longident Gram.Entry.t) + and _ = + (class_type_declaration : 'class_type_declaration Gram.Entry.t) + and _ = (class_type : 'class_type Gram.Entry.t) + and _ = (class_structure : 'class_structure Gram.Entry.t) + and _ = (class_str_item_quot : 'class_str_item_quot Gram.Entry.t) + and _ = (class_str_item : 'class_str_item Gram.Entry.t) + and _ = (class_signature : 'class_signature Gram.Entry.t) + and _ = (class_sig_item_quot : 'class_sig_item_quot Gram.Entry.t) + and _ = (class_sig_item : 'class_sig_item Gram.Entry.t) + and _ = (class_name_and_param : 'class_name_and_param Gram.Entry.t) + and _ = + (class_longident_and_param : + 'class_longident_and_param Gram.Entry.t) + and _ = (class_longident : 'class_longident Gram.Entry.t) + and _ = + (class_info_for_class_type : + 'class_info_for_class_type Gram.Entry.t) + and _ = + (class_info_for_class_expr : + 'class_info_for_class_expr Gram.Entry.t) + and _ = (class_fun_def : 'class_fun_def Gram.Entry.t) + and _ = (class_fun_binding : 'class_fun_binding Gram.Entry.t) + and _ = (class_expr_quot : 'class_expr_quot Gram.Entry.t) + and _ = (class_expr : 'class_expr Gram.Entry.t) + and _ = (class_description : 'class_description Gram.Entry.t) + and _ = (class_declaration : 'class_declaration Gram.Entry.t) + and _ = (binding_quot : 'binding_quot Gram.Entry.t) + and _ = (binding : 'binding Gram.Entry.t) + and _ = (match_case_quot : 'match_case_quot Gram.Entry.t) + and _ = (match_case0 : 'match_case0 Gram.Entry.t) + and _ = (match_case : 'match_case Gram.Entry.t) + and _ = (and_ctyp : 'and_ctyp Gram.Entry.t) + and _ = (amp_ctyp : 'amp_ctyp Gram.Entry.t) + and _ = (a_ident : 'a_ident Gram.Entry.t) + and _ = (a_UIDENT : 'a_UIDENT Gram.Entry.t) + and _ = (a_STRING : 'a_STRING Gram.Entry.t) + and _ = (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t) + and _ = (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t) + and _ = (a_LIDENT_or_operator : 'a_LIDENT_or_operator Gram.Entry.t) + and _ = (a_LIDENT : 'a_LIDENT Gram.Entry.t) + and _ = (a_LABEL : 'a_LABEL Gram.Entry.t) + and _ = (a_INT64 : 'a_INT64 Gram.Entry.t) + and _ = (a_INT32 : 'a_INT32 Gram.Entry.t) + and _ = (a_INT : 'a_INT Gram.Entry.t) + and _ = (a_FLOAT : 'a_FLOAT Gram.Entry.t) in + let grammar_entry_create = Gram.Entry.mk in + let (* sem_expr: + [ [ e1 = SELF; ";"; e2 = SELF -> <:expr< $e1$; $e2$ >> + | e = expr -> e ] ] + ; *) + (* | i = opt_label; "("; p = patt_tcon; ")" -> *) + (* <:patt< ? $i$ : ($p$) >> *) + (* <:class_type< $virtual:mv$ $lid:i$ [ $t$ ] >> *) + (* | mv = opt_virtual; i = a_LIDENT -> *) + (* Ast.CeCon (_loc, mv, Ast.IdLid (_loc, i), Ast.ONone) *) + (* <:class_type< $lid:i$ >> *) + (* [ [ "virtual"; i = a_LIDENT; "["; t = comma_type_parameter; "]" -> + <:class_type< virtual $lid:i$ [ $t$ ] >> + | "virtual"; i = a_LIDENT -> + <:class_type< virtual $lid:i$ >> + | i = a_LIDENT; "["; t = comma_type_parameter; "]" -> + <:class_type< $lid:i$ [ $t$ ] >> + | i = a_LIDENT -> <:class_type< $lid:i$ >> + ] ] + ; *) + (* "virtual"; i = a_LIDENT; "["; t = comma_type_parameter; "]" -> *) + (* <:class_expr< virtual $lid:i$ [ $t$ ] >> *) + (* | "virtual"; i = a_LIDENT -> *) + (* <:class_expr< virtual $lid:i$ >> *) (* | *) + (* <:class_expr< $virtual:mv$ $lid:i$ [ $t$ ] >> *) + (* <:class_expr< $lid:i$ [ $t$ ] >> *) + (* | mv = opt_virtual; i = a_LIDENT -> *) + (* Ast.CeCon (_loc, mv, Ast.IdLid (_loc, i), Ast.ONone) *) + (* <:class_expr< $lid:i$ >> *) + (* | i = opt_label; "("; p = ipatt_tcon; ")" -> + <:patt< ? $i$ : ($p$) >> + | i = opt_label; "("; p = ipatt_tcon; "="; e = expr; ")" -> + <:patt< ? $i$ : ($p$ = $e$) >> *) + string_list : 'string_list Gram.Entry.t = + grammar_entry_create "string_list" + in + (Gram.extend (module_expr : 'module_expr Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "struct"; + Gram.Snterm + (Gram.Entry.obj + (str_items : 'str_items Gram.Entry.t)); + Gram.Skeyword "end" ], + (Gram.Action.mk + (fun _ (st : 'str_items) _ (_loc : Loc.t) -> + (Ast.MeStr (_loc, st) : 'module_expr)))); + ([ Gram.Skeyword "functor"; Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)); + Gram.Skeyword ")"; Gram.Skeyword "->"; Gram.Sself ], + (Gram.Action.mk + (fun (me : 'module_expr) _ _ (t : 'module_type) + _ (i : 'a_UIDENT) _ _ (_loc : Loc.t) -> + (Ast.MeFun (_loc, i, t, me) : 'module_expr)))) ]); + (None, None, + [ ([ Gram.Sself; Gram.Sself ], + (Gram.Action.mk + (fun (me2 : 'module_expr) (me1 : 'module_expr) + (_loc : Loc.t) -> + (Ast.MeApp (_loc, me1, me2) : 'module_expr)))) ]); + ((Some "simple"), None, + [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (me : 'module_expr) _ (_loc : Loc.t) -> + (me : 'module_expr)))); + ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (mt : 'module_type) _ (me : 'module_expr) + _ (_loc : Loc.t) -> + (Ast.MeTyc (_loc, me, mt) : 'module_expr)))); + ([ Gram.Snterm + (Gram.Entry.obj + (module_longident : + 'module_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'module_longident) (_loc : Loc.t) -> + (Ast.MeId (_loc, i) : 'module_expr)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "mexp" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"mexp\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "mexp" | "anti" | "list" as n)), + s) -> + (Ast.MeAnt (_loc, + mk_anti ~c: "module_expr" n s) : + 'module_expr) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (str_item : 'str_item Gram.Entry.t) + ((fun () -> + (None, + [ ((Some "top"), None, + [ ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) (_loc : Loc.t) -> + (Ast.StExp (_loc, e) : 'str_item)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "stri" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"stri\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "stri" | "anti" | "list" as n)), + s) -> + (Ast.StAnt (_loc, + mk_anti ~c: "str_item" n s) : + 'str_item) + | _ -> assert false))); + ([ Gram.Skeyword "class"; Gram.Skeyword "type"; + Gram.Snterm + (Gram.Entry.obj + (class_type_declaration : + 'class_type_declaration Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ctd : 'class_type_declaration) _ _ + (_loc : Loc.t) -> + (Ast.StClt (_loc, ctd) : 'str_item)))); + ([ Gram.Skeyword "class"; + Gram.Snterm + (Gram.Entry.obj + (class_declaration : + 'class_declaration Gram.Entry.t)) ], + (Gram.Action.mk + (fun (cd : 'class_declaration) _ (_loc : Loc.t) + -> (Ast.StCls (_loc, cd) : 'str_item)))); + ([ Gram.Snterm + (Gram.Entry.obj + (value_let : 'value_let Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_rec : 'opt_rec Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (binding : 'binding Gram.Entry.t)) ], + (Gram.Action.mk + (fun (bi : 'binding) (r : 'opt_rec) _ + (_loc : Loc.t) -> + (Ast.StVal (_loc, r, bi) : 'str_item)))); + ([ Gram.Skeyword "type"; + Gram.Snterm + (Gram.Entry.obj + (type_declaration : + 'type_declaration Gram.Entry.t)) ], + (Gram.Action.mk + (fun (td : 'type_declaration) _ (_loc : Loc.t) + -> (Ast.StTyp (_loc, td) : 'str_item)))); + ([ Gram.Skeyword "open"; + Gram.Snterm + (Gram.Entry.obj + (module_longident : + 'module_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'module_longident) _ (_loc : Loc.t) -> + (Ast.StOpn (_loc, i) : 'str_item)))); + ([ Gram.Skeyword "module"; Gram.Skeyword "type"; + Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (mt : 'module_type) _ (i : 'a_UIDENT) _ _ + (_loc : Loc.t) -> + (Ast.StMty (_loc, i, mt) : 'str_item)))); + ([ Gram.Skeyword "module"; Gram.Skeyword "rec"; + Gram.Snterm + (Gram.Entry.obj + (module_binding : + 'module_binding Gram.Entry.t)) ], + (Gram.Action.mk + (fun (mb : 'module_binding) _ _ (_loc : Loc.t) + -> (Ast.StRecMod (_loc, mb) : 'str_item)))); + ([ Gram.Skeyword "module"; + Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (module_binding0 : + 'module_binding0 Gram.Entry.t)) ], + (Gram.Action.mk + (fun (mb : 'module_binding0) (i : 'a_UIDENT) _ + (_loc : Loc.t) -> + (Ast.StMod (_loc, i, mb) : 'str_item)))); + ([ Gram.Skeyword "include"; + Gram.Snterm + (Gram.Entry.obj + (module_expr : 'module_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (me : 'module_expr) _ (_loc : Loc.t) -> + (Ast.StInc (_loc, me) : 'str_item)))); + ([ Gram.Skeyword "external"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (string_list : 'string_list Gram.Entry.t)) ], + (Gram.Action.mk + (fun (sl : 'string_list) _ (t : 'ctyp) _ + (i : 'a_LIDENT) _ (_loc : Loc.t) -> + (Ast.StExt (_loc, i, t, sl) : 'str_item)))); + ([ Gram.Skeyword "exception"; + Gram.Snterm + (Gram.Entry.obj + (constructor_declaration : + 'constructor_declaration Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (type_longident : + 'type_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'type_longident) _ + (t : 'constructor_declaration) _ + (_loc : Loc.t) -> + (Ast.StExc (_loc, t, Ast.OSome i) : + 'str_item)))); + ([ Gram.Skeyword "exception"; + Gram.Snterm + (Gram.Entry.obj + (constructor_declaration : + 'constructor_declaration Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'constructor_declaration) _ + (_loc : Loc.t) -> + (Ast.StExc (_loc, t, Ast.ONone) : 'str_item)))) ]) ])) + ()); + Gram.extend (module_binding0 : 'module_binding0 Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.RightA), + [ ([ Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (module_expr : 'module_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (me : 'module_expr) _ (_loc : Loc.t) -> + (me : 'module_binding0)))); + ([ Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (module_expr : 'module_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (me : 'module_expr) _ (mt : 'module_type) _ + (_loc : Loc.t) -> + (Ast.MeTyc (_loc, me, mt) : 'module_binding0)))); + ([ Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)); + Gram.Skeyword ")"; Gram.Sself ], + (Gram.Action.mk + (fun (mb : 'module_binding0) _ + (mt : 'module_type) _ (m : 'a_UIDENT) _ + (_loc : Loc.t) -> + (Ast.MeFun (_loc, m, mt, mb) : + 'module_binding0)))) ]) ])) + ()); + Gram.extend (module_binding : 'module_binding Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (module_expr : 'module_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (me : 'module_expr) _ (mt : 'module_type) _ + (m : 'a_UIDENT) (_loc : Loc.t) -> + (Ast.MbColEq (_loc, m, mt, me) : + 'module_binding)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("", _) -> true + | _ -> false), + "ANTIQUOT (\"\", _)")); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (module_expr : 'module_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (me : 'module_expr) _ (mt : 'module_type) _ + (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" as n)), m) -> + (Ast.MbColEq (_loc, mk_anti n m, mt, me) : + 'module_binding) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("", _) -> true + | _ -> false), + "ANTIQUOT (\"\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" as n)), s) -> + (Ast.MbAnt (_loc, + mk_anti ~c: "module_binding" n s) : + 'module_binding) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("module_binding" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"module_binding\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("module_binding" | "anti" | "list" as + n)), + s) -> + (Ast.MbAnt (_loc, + mk_anti ~c: "module_binding" n s) : + 'module_binding) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (b2 : 'module_binding) _ + (b1 : 'module_binding) (_loc : Loc.t) -> + (Ast.MbAnd (_loc, b1, b2) : 'module_binding)))) ]) ])) + ()); + Gram.extend (module_type : 'module_type Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "functor"; Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword ":"; Gram.Sself; Gram.Skeyword ")"; + Gram.Skeyword "->"; Gram.Sself ], + (Gram.Action.mk + (fun (mt : 'module_type) _ _ (t : 'module_type) + _ (i : 'a_UIDENT) _ _ (_loc : Loc.t) -> + (Ast.MtFun (_loc, i, t, mt) : 'module_type)))) ]); + (None, None, + [ ([ Gram.Sself; Gram.Skeyword "with"; + Gram.Snterm + (Gram.Entry.obj + (with_constr : 'with_constr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (wc : 'with_constr) _ (mt : 'module_type) + (_loc : Loc.t) -> + (Ast.MtWit (_loc, mt, wc) : 'module_type)))) ]); + (None, None, + [ ([ Gram.Skeyword "sig"; + Gram.Snterm + (Gram.Entry.obj + (sig_items : 'sig_items Gram.Entry.t)); + Gram.Skeyword "end" ], + (Gram.Action.mk + (fun _ (sg : 'sig_items) _ (_loc : Loc.t) -> + (Ast.MtSig (_loc, sg) : 'module_type)))) ]); + ((Some "simple"), None, + [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (mt : 'module_type) _ (_loc : Loc.t) -> + (mt : 'module_type)))); + ([ Gram.Skeyword "'"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_ident) _ (_loc : Loc.t) -> + (Ast.MtQuo (_loc, i) : 'module_type)))); + ([ Gram.Snterm + (Gram.Entry.obj + (module_longident_with_app : + 'module_longident_with_app Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'module_longident_with_app) + (_loc : Loc.t) -> + (Ast.MtId (_loc, i) : 'module_type)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "mtyp" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"mtyp\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "mtyp" | "anti" | "list" as n)), + s) -> + (Ast.MtAnt (_loc, + mk_anti ~c: "module_type" n s) : + 'module_type) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (sig_item : 'sig_item Gram.Entry.t) + ((fun () -> + (None, + [ ((Some "top"), None, + [ ([ Gram.Skeyword "class"; Gram.Skeyword "type"; + Gram.Snterm + (Gram.Entry.obj + (class_type_declaration : + 'class_type_declaration Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ctd : 'class_type_declaration) _ _ + (_loc : Loc.t) -> + (Ast.SgClt (_loc, ctd) : 'sig_item)))); + ([ Gram.Skeyword "class"; + Gram.Snterm + (Gram.Entry.obj + (class_description : + 'class_description Gram.Entry.t)) ], + (Gram.Action.mk + (fun (cd : 'class_description) _ (_loc : Loc.t) + -> (Ast.SgCls (_loc, cd) : 'sig_item)))); + ([ Gram.Snterm + (Gram.Entry.obj + (value_val : 'value_val Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT_or_operator : + 'a_LIDENT_or_operator Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) _ (i : 'a_LIDENT_or_operator) _ + (_loc : Loc.t) -> + (Ast.SgVal (_loc, i, t) : 'sig_item)))); + ([ Gram.Skeyword "type"; + Gram.Snterm + (Gram.Entry.obj + (type_declaration : + 'type_declaration Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'type_declaration) _ (_loc : Loc.t) -> + (Ast.SgTyp (_loc, t) : 'sig_item)))); + ([ Gram.Skeyword "open"; + Gram.Snterm + (Gram.Entry.obj + (module_longident : + 'module_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'module_longident) _ (_loc : Loc.t) -> + (Ast.SgOpn (_loc, i) : 'sig_item)))); + ([ Gram.Skeyword "module"; Gram.Skeyword "type"; + Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (mt : 'module_type) _ (i : 'a_UIDENT) _ _ + (_loc : Loc.t) -> + (Ast.SgMty (_loc, i, mt) : 'sig_item)))); + ([ Gram.Skeyword "module"; Gram.Skeyword "rec"; + Gram.Snterm + (Gram.Entry.obj + (module_rec_declaration : + 'module_rec_declaration Gram.Entry.t)) ], + (Gram.Action.mk + (fun (mb : 'module_rec_declaration) _ _ + (_loc : Loc.t) -> + (Ast.SgRecMod (_loc, mb) : 'sig_item)))); + ([ Gram.Skeyword "module"; + Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (module_declaration : + 'module_declaration Gram.Entry.t)) ], + (Gram.Action.mk + (fun (mt : 'module_declaration) (i : 'a_UIDENT) + _ (_loc : Loc.t) -> + (Ast.SgMod (_loc, i, mt) : 'sig_item)))); + ([ Gram.Skeyword "include"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (mt : 'module_type) _ (_loc : Loc.t) -> + (Ast.SgInc (_loc, mt) : 'sig_item)))); + ([ Gram.Skeyword "external"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (string_list : 'string_list Gram.Entry.t)) ], + (Gram.Action.mk + (fun (sl : 'string_list) _ (t : 'ctyp) _ + (i : 'a_LIDENT) _ (_loc : Loc.t) -> + (Ast.SgExt (_loc, i, t, sl) : 'sig_item)))); + ([ Gram.Skeyword "exception"; + Gram.Snterm + (Gram.Entry.obj + (constructor_declaration : + 'constructor_declaration Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'constructor_declaration) _ + (_loc : Loc.t) -> + (Ast.SgExc (_loc, t) : 'sig_item)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "sigi" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"sigi\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "sigi" | "anti" | "list" as n)), + s) -> + (Ast.SgAnt (_loc, + mk_anti ~c: "sig_item" n s) : + 'sig_item) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (module_declaration : 'module_declaration Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.RightA), + [ ([ Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)); + Gram.Skeyword ")"; Gram.Sself ], + (Gram.Action.mk + (fun (mt : 'module_declaration) _ + (t : 'module_type) _ (i : 'a_UIDENT) _ + (_loc : Loc.t) -> + (Ast.MtFun (_loc, i, t, mt) : + 'module_declaration)))); + ([ Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (mt : 'module_type) _ (_loc : Loc.t) -> + (mt : 'module_declaration)))) ]) ])) + ()); + Gram.extend + (module_rec_declaration : + 'module_rec_declaration Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (mt : 'module_type) _ (m : 'a_UIDENT) + (_loc : Loc.t) -> + (Ast.MbCol (_loc, m, mt) : + 'module_rec_declaration)))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("" | "module_binding" | "anti" | + "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"module_binding\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "module_binding" | "anti" | + "list" + as n)), + s) -> + (Ast.MbAnt (_loc, + mk_anti ~c: "module_binding" n s) : + 'module_rec_declaration) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (m2 : 'module_rec_declaration) _ + (m1 : 'module_rec_declaration) (_loc : Loc.t) + -> + (Ast.MbAnd (_loc, m1, m2) : + 'module_rec_declaration)))) ]) ])) + ()); + Gram.extend (with_constr : 'with_constr Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Skeyword "module"; + Gram.Snterm + (Gram.Entry.obj + (module_longident : + 'module_longident Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (module_longident_with_app : + 'module_longident_with_app Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i2 : 'module_longident_with_app) _ + (i1 : 'module_longident) _ (_loc : Loc.t) -> + (Ast.WcMod (_loc, i1, i2) : 'with_constr)))); + ([ Gram.Skeyword "type"; + Gram.Snterm + (Gram.Entry.obj + (type_longident_and_parameters : + 'type_longident_and_parameters Gram.Entry. + t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t2 : 'ctyp) _ + (t1 : 'type_longident_and_parameters) _ + (_loc : Loc.t) -> + (Ast.WcTyp (_loc, t1, t2) : 'with_constr)))); + ([ Gram.Skeyword "type"; + Gram.Stoken + (((function + | ANTIQUOT (("" | "typ" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) _ (__camlp4_0 : Gram.Token.t) _ + (_loc : Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" | "anti" as n)), s) + -> + (Ast.WcTyp (_loc, + Ast.TyAnt (_loc, + mk_anti ~c: "ctyp" n s), + t) : + 'with_constr) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("" | "with_constr" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"with_constr\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "with_constr" | "anti" | "list" + as n)), + s) -> + (Ast.WcAnt (_loc, + mk_anti ~c: "with_constr" n s) : + 'with_constr) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (wc2 : 'with_constr) _ (wc1 : 'with_constr) + (_loc : Loc.t) -> + (Ast.WcAnd (_loc, wc1, wc2) : 'with_constr)))) ]) ])) + ()); + Gram.extend (expr : 'expr Gram.Entry.t) + ((fun () -> + (None, + [ ((Some "top"), (Some Camlp4.Sig.Grammar.RightA), + [ ([ Gram.Skeyword "object"; + Gram.Snterm + (Gram.Entry.obj + (opt_class_self_patt : + 'opt_class_self_patt Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (class_structure : + 'class_structure Gram.Entry.t)); + Gram.Skeyword "end" ], + (Gram.Action.mk + (fun _ (cst : 'class_structure) + (csp : 'opt_class_self_patt) _ (_loc : Loc.t) + -> (Ast.ExObj (_loc, csp, cst) : 'expr)))); + ([ Gram.Skeyword "while"; Gram.Sself; + Gram.Skeyword "do"; Gram.Skeyword "{"; + Gram.Snterm + (Gram.Entry.obj + (sequence : 'sequence Gram.Entry.t)); + Gram.Skeyword "}" ], + (Gram.Action.mk + (fun _ (seq : 'sequence) _ _ (e : 'expr) _ + (_loc : Loc.t) -> + (Ast.ExWhi (_loc, e, seq) : 'expr)))); + ([ Gram.Skeyword "for"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword "="; Gram.Sself; + Gram.Snterm + (Gram.Entry.obj + (direction_flag : + 'direction_flag Gram.Entry.t)); + Gram.Sself; Gram.Skeyword "do"; + Gram.Skeyword "{"; + Gram.Snterm + (Gram.Entry.obj + (sequence : 'sequence Gram.Entry.t)); + Gram.Skeyword "}" ], + (Gram.Action.mk + (fun _ (seq : 'sequence) _ _ (e2 : 'expr) + (df : 'direction_flag) (e1 : 'expr) _ + (i : 'a_LIDENT) _ (_loc : Loc.t) -> + (Ast.ExFor (_loc, i, e1, e2, df, seq) : + 'expr)))); + ([ Gram.Skeyword "do"; Gram.Skeyword "{"; + Gram.Snterm + (Gram.Entry.obj + (sequence : 'sequence Gram.Entry.t)); + Gram.Skeyword "}" ], + (Gram.Action.mk + (fun _ (seq : 'sequence) _ _ (_loc : Loc.t) -> + (mksequence _loc seq : 'expr)))); + ([ Gram.Skeyword "if"; Gram.Sself; + Gram.Skeyword "then"; Gram.Sself; + Gram.Skeyword "else"; Gram.Sself ], + (Gram.Action.mk + (fun (e3 : 'expr) _ (e2 : 'expr) _ (e1 : 'expr) + _ (_loc : Loc.t) -> + (Ast.ExIfe (_loc, e1, e2, e3) : 'expr)))); + ([ Gram.Skeyword "try"; Gram.Sself; + Gram.Skeyword "with"; + Gram.Snterm + (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)); + Gram.Skeyword "->"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (p : 'ipatt) _ (e1 : 'expr) + _ (_loc : Loc.t) -> + (Ast.ExTry (_loc, e1, + Ast.McArr (_loc, p, Ast.ExNil _loc, e2)) : + 'expr)))); + ([ Gram.Skeyword "try"; Gram.Sself; + Gram.Skeyword "with"; Gram.Skeyword "["; + Gram.Snterm + (Gram.Entry.obj + (match_case : 'match_case Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (a : 'match_case) _ _ (e : 'expr) _ + (_loc : Loc.t) -> + (Ast.ExTry (_loc, e, a) : 'expr)))); + ([ Gram.Skeyword "match"; Gram.Sself; + Gram.Skeyword "with"; + Gram.Snterm + (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)); + Gram.Skeyword "->"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (p : 'ipatt) _ (e1 : 'expr) + _ (_loc : Loc.t) -> + (Ast.ExMat (_loc, e1, + Ast.McArr (_loc, p, Ast.ExNil _loc, e2)) : + 'expr)))); + ([ Gram.Skeyword "match"; Gram.Sself; + Gram.Skeyword "with"; Gram.Skeyword "["; + Gram.Snterm + (Gram.Entry.obj + (match_case : 'match_case Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (a : 'match_case) _ _ (e : 'expr) _ + (_loc : Loc.t) -> + (Ast.ExMat (_loc, e, a) : 'expr)))); + ([ Gram.Skeyword "fun"; + Gram.Snterm + (Gram.Entry.obj + (labeled_ipatt : + 'labeled_ipatt Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (fun_def : 'fun_def Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'fun_def) (p : 'labeled_ipatt) _ + (_loc : Loc.t) -> + (Ast.ExFun (_loc, + Ast.McArr (_loc, p, Ast.ExNil _loc, e)) : + 'expr)))); + ([ Gram.Skeyword "fun"; Gram.Skeyword "["; + Gram.Snterm + (Gram.Entry.obj + (match_case : 'match_case Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (a : 'match_case) _ _ (_loc : Loc.t) -> + (Ast.ExFun (_loc, a) : 'expr)))); + ([ Gram.Skeyword "let"; Gram.Skeyword "module"; + Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (module_binding0 : + 'module_binding0 Gram.Entry.t)); + Gram.Skeyword "in"; Gram.Sself ], + (Gram.Action.mk + (fun (e : 'expr) _ (mb : 'module_binding0) + (m : 'a_UIDENT) _ _ (_loc : Loc.t) -> + (Ast.ExLmd (_loc, m, mb, e) : 'expr)))); + ([ Gram.Skeyword "let"; + Gram.Snterm + (Gram.Entry.obj + (opt_rec : 'opt_rec Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (binding : 'binding Gram.Entry.t)); + Gram.Skeyword "in"; Gram.Sself ], + (Gram.Action.mk + (fun (x : 'expr) _ (bi : 'binding) + (r : 'opt_rec) _ (_loc : Loc.t) -> + (Ast.ExLet (_loc, r, bi, x) : 'expr)))) ]); + ((Some "where"), None, + [ ([ Gram.Sself; Gram.Skeyword "where"; + Gram.Snterm + (Gram.Entry.obj + (opt_rec : 'opt_rec Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (let_binding : 'let_binding Gram.Entry.t)) ], + (Gram.Action.mk + (fun (lb : 'let_binding) (rf : 'opt_rec) _ + (e : 'expr) (_loc : Loc.t) -> + (Ast.ExLet (_loc, rf, lb, e) : 'expr)))) ]); + ((Some ":="), (Some Camlp4.Sig.Grammar.NonA), + [ ([ Gram.Sself; Gram.Skeyword ":="; Gram.Sself; + Gram.Snterm + (Gram.Entry.obj (dummy : 'dummy Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (e2 : 'expr) _ (e1 : 'expr) + (_loc : Loc.t) -> + (match bigarray_set _loc e1 e2 with + | Some e -> e + | None -> Ast.ExAss (_loc, e1, e2) : 'expr)))) ]); + ((Some "||"), (Some Camlp4.Sig.Grammar.RightA), + [ ([ Gram.Sself; Gram.Skeyword "||"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "||")), + e1), + e2) : + 'expr)))) ]); + ((Some "&&"), (Some Camlp4.Sig.Grammar.RightA), + [ ([ Gram.Sself; Gram.Skeyword "&&"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "&&")), + e1), + e2) : + 'expr)))) ]); + ((Some "<"), (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Sself; Gram.Skeyword "!="; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "!=")), + e1), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "=="; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "==")), + e1), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "<>"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "<>")), + e1), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "="; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "=")), + e1), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword ">="; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, ">=")), + e1), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "<="; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "<=")), + e1), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword ">"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, ">")), + e1), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "<"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "<")), + e1), + e2) : + 'expr)))) ]); + ((Some "^"), (Some Camlp4.Sig.Grammar.RightA), + [ ([ Gram.Sself; Gram.Skeyword "@"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "@")), + e1), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "^^"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "^^")), + e1), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "^"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "^")), + e1), + e2) : + 'expr)))) ]); + ((Some "+"), (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Sself; Gram.Skeyword "-."; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "-.")), + e1), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "+."; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "+.")), + e1), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "-"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "-")), + e1), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "+"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "+")), + e1), + e2) : + 'expr)))) ]); + ((Some "*"), (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Sself; Gram.Skeyword "mod"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "mod")), + e1), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "lxor"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdLid (_loc, "lxor")), + e1), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "lor"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "lor")), + e1), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "land"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdLid (_loc, "land")), + e1), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "/."; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "/.")), + e1), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "*."; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "*.")), + e1), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "/"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "/")), + e1), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "*"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "*")), + e1), + e2) : + 'expr)))) ]); + ((Some "**"), (Some Camlp4.Sig.Grammar.RightA), + [ ([ Gram.Sself; Gram.Skeyword "lsr"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "lsr")), + e1), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "lsl"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "lsl")), + e1), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "asr"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "asr")), + e1), + e2) : + 'expr)))); + ([ Gram.Sself; Gram.Skeyword "**"; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "**")), + e1), + e2) : + 'expr)))) ]); + ((Some "unary minus"), (Some Camlp4.Sig.Grammar.NonA), + [ ([ Gram.Skeyword "-."; Gram.Sself ], + (Gram.Action.mk + (fun (e : 'expr) _ (_loc : Loc.t) -> + (mkumin _loc "-." e : 'expr)))); + ([ Gram.Skeyword "-"; Gram.Sself ], + (Gram.Action.mk + (fun (e : 'expr) _ (_loc : Loc.t) -> + (mkumin _loc "-" e : 'expr)))) ]); + ((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Skeyword "lazy"; Gram.Sself ], + (Gram.Action.mk + (fun (e : 'expr) _ (_loc : Loc.t) -> + (Ast.ExLaz (_loc, e) : 'expr)))); + ([ Gram.Skeyword "new"; + Gram.Snterm + (Gram.Entry.obj + (class_longident : + 'class_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'class_longident) _ (_loc : Loc.t) -> + (Ast.ExNew (_loc, i) : 'expr)))); + ([ Gram.Skeyword "assert"; Gram.Sself ], + (Gram.Action.mk + (fun (e : 'expr) _ (_loc : Loc.t) -> + (mkassert _loc e : 'expr)))); + ([ Gram.Sself; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) (e1 : 'expr) (_loc : Loc.t) -> + (Ast.ExApp (_loc, e1, e2) : 'expr)))) ]); + ((Some "label"), (Some Camlp4.Sig.Grammar.NonA), + [ ([ Gram.Skeyword "?"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) _ (_loc : Loc.t) -> + (Ast.ExOlb (_loc, i, Ast.ExNil _loc) : 'expr)))); + ([ Gram.Skeyword "?"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword ":"; Gram.Sself ], + (Gram.Action.mk + (fun (e : 'expr) _ (i : 'a_LIDENT) _ + (_loc : Loc.t) -> + (Ast.ExOlb (_loc, i, e) : 'expr)))); + ([ Gram.Stoken + (((function | OPTLABEL _ -> true | _ -> false), + "OPTLABEL _")); + Gram.Sself ], + (Gram.Action.mk + (fun (e : 'expr) (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | OPTLABEL i -> + (Ast.ExOlb (_loc, i, e) : 'expr) + | _ -> assert false))); + ([ Gram.Skeyword "~"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) _ (_loc : Loc.t) -> + (Ast.ExLab (_loc, i, Ast.ExNil _loc) : 'expr)))); + ([ Gram.Stoken + (((function | LABEL _ -> true | _ -> false), + "LABEL _")); + Gram.Sself ], + (Gram.Action.mk + (fun (e : 'expr) (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | LABEL i -> (Ast.ExLab (_loc, i, e) : 'expr) + | _ -> assert false))); + ([ Gram.Skeyword "~"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword ":"; Gram.Sself ], + (Gram.Action.mk + (fun (e : 'expr) _ (i : 'a_LIDENT) _ + (_loc : Loc.t) -> + (Ast.ExLab (_loc, i, e) : 'expr)))) ]); + ((Some "."), (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Sself; Gram.Skeyword "#"; + Gram.Snterm + (Gram.Entry.obj (label : 'label Gram.Entry.t)) ], + (Gram.Action.mk + (fun (lab : 'label) _ (e : 'expr) (_loc : Loc.t) + -> (Ast.ExSnd (_loc, e, lab) : 'expr)))); + ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'expr) _ (e1 : 'expr) (_loc : Loc.t) + -> (Ast.ExAcc (_loc, e1, e2) : 'expr)))); + ([ Gram.Sself; Gram.Skeyword "."; Gram.Skeyword "{"; + Gram.Snterm + (Gram.Entry.obj + (comma_expr : 'comma_expr Gram.Entry.t)); + Gram.Skeyword "}" ], + (Gram.Action.mk + (fun _ (e2 : 'comma_expr) _ _ (e1 : 'expr) + (_loc : Loc.t) -> + (bigarray_get _loc e1 e2 : 'expr)))); + ([ Gram.Sself; Gram.Skeyword "."; Gram.Skeyword "["; + Gram.Sself; Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (e2 : 'expr) _ _ (e1 : 'expr) + (_loc : Loc.t) -> + (Ast.ExSte (_loc, e1, e2) : 'expr)))); + ([ Gram.Sself; Gram.Skeyword "."; Gram.Skeyword "("; + Gram.Sself; Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (e2 : 'expr) _ _ (e1 : 'expr) + (_loc : Loc.t) -> + (Ast.ExAre (_loc, e1, e2) : 'expr)))) ]); + ((Some "~-"), (Some Camlp4.Sig.Grammar.NonA), + [ ([ Gram.Skeyword "~-."; Gram.Sself ], + (Gram.Action.mk + (fun (e : 'expr) _ (_loc : Loc.t) -> + (Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "~-.")), + e) : + 'expr)))); + ([ Gram.Skeyword "~-"; Gram.Sself ], + (Gram.Action.mk + (fun (e : 'expr) _ (_loc : Loc.t) -> + (Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "~-")), + e) : + 'expr)))) ]); + ((Some "simple"), None, + [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (e : 'expr) _ (_loc : Loc.t) -> + (e : 'expr)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ":>"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (t : 'ctyp) _ (e : 'expr) _ + (_loc : Loc.t) -> + (Ast.ExCoe (_loc, e, Ast.TyNil _loc, t) : + 'expr)))); + ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword ":>"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ (e : 'expr) + _ (_loc : Loc.t) -> + (Ast.ExCoe (_loc, e, t, t2) : 'expr)))); + ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ","; + Gram.Snterm + (Gram.Entry.obj + (comma_expr : 'comma_expr Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (el : 'comma_expr) _ (e : 'expr) _ + (_loc : Loc.t) -> + (Ast.ExTup (_loc, Ast.ExCom (_loc, e, el)) : + 'expr)))); + ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (t : 'ctyp) _ (e : 'expr) _ + (_loc : Loc.t) -> + (Ast.ExTyc (_loc, e, t) : 'expr)))); + ([ Gram.Skeyword "("; Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ _ (_loc : Loc.t) -> + (Ast.ExId (_loc, Ast.IdUid (_loc, "()")) : + 'expr)))); + ([ Gram.Skeyword "{<"; + Gram.Snterm + (Gram.Entry.obj + (field_expr : 'field_expr Gram.Entry.t)); + Gram.Skeyword ">}" ], + (Gram.Action.mk + (fun _ (fel : 'field_expr) _ (_loc : Loc.t) -> + (Ast.ExOvr (_loc, fel) : 'expr)))); + ([ Gram.Skeyword "{<"; Gram.Skeyword ">}" ], + (Gram.Action.mk + (fun _ _ (_loc : Loc.t) -> + (Ast.ExOvr (_loc, Ast.BiNil _loc) : 'expr)))); + ([ Gram.Skeyword "{"; Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword ")"; Gram.Skeyword "with"; + Gram.Snterm + (Gram.Entry.obj + (label_expr : 'label_expr Gram.Entry.t)); + Gram.Skeyword "}" ], + (Gram.Action.mk + (fun _ (el : 'label_expr) _ _ (e : 'expr) _ _ + (_loc : Loc.t) -> + (Ast.ExRec (_loc, el, e) : 'expr)))); + ([ Gram.Skeyword "{"; + Gram.Snterm + (Gram.Entry.obj + (label_expr : 'label_expr Gram.Entry.t)); + Gram.Skeyword "}" ], + (Gram.Action.mk + (fun _ (el : 'label_expr) _ (_loc : Loc.t) -> + (Ast.ExRec (_loc, el, Ast.ExNil _loc) : + 'expr)))); + ([ Gram.Skeyword "[|"; + Gram.Snterm + (Gram.Entry.obj + (sem_expr : 'sem_expr Gram.Entry.t)); + Gram.Skeyword "|]" ], + (Gram.Action.mk + (fun _ (el : 'sem_expr) _ (_loc : Loc.t) -> + (Ast.ExArr (_loc, el) : 'expr)))); + ([ Gram.Skeyword "[|"; Gram.Skeyword "|]" ], + (Gram.Action.mk + (fun _ _ (_loc : Loc.t) -> + (Ast.ExArr (_loc, Ast.ExNil _loc) : 'expr)))); + ([ Gram.Skeyword "["; + Gram.Snterm + (Gram.Entry.obj + (sem_expr_for_list : + 'sem_expr_for_list Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (mk_list : 'sem_expr_for_list) _ + (_loc : Loc.t) -> + (mk_list + (Ast.ExId (_loc, Ast.IdUid (_loc, "[]"))) : + 'expr)))); + ([ Gram.Skeyword "["; + Gram.Snterm + (Gram.Entry.obj + (sem_expr_for_list : + 'sem_expr_for_list Gram.Entry.t)); + Gram.Skeyword "::"; Gram.Sself; Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (last : 'expr) _ + (mk_list : 'sem_expr_for_list) _ + (_loc : Loc.t) -> (mk_list last : 'expr)))); + ([ Gram.Skeyword "["; Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ _ (_loc : Loc.t) -> + (Ast.ExId (_loc, Ast.IdUid (_loc, "[]")) : + 'expr)))); + ([ Gram.Skeyword "`"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_ident) _ (_loc : Loc.t) -> + (Ast.ExVrn (_loc, s) : 'expr)))); + ([ Gram.Snterm + (Gram.Entry.obj + (val_longident : + 'val_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'val_longident) (_loc : Loc.t) -> + (Ast.ExId (_loc, i) : 'expr)))); + ([ Gram.Snterm + (Gram.Entry.obj (a_CHAR : 'a_CHAR Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_CHAR) (_loc : Loc.t) -> + (Ast.ExChr (_loc, s) : 'expr)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_STRING : 'a_STRING Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_STRING) (_loc : Loc.t) -> + (Ast.ExStr (_loc, s) : 'expr)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_FLOAT) (_loc : Loc.t) -> + (Ast.ExFlo (_loc, s) : 'expr)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_NATIVEINT) (_loc : Loc.t) -> + (Ast.ExNativeInt (_loc, s) : 'expr)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_INT64 : 'a_INT64 Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_INT64) (_loc : Loc.t) -> + (Ast.ExInt64 (_loc, s) : 'expr)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_INT32 : 'a_INT32 Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_INT32) (_loc : Loc.t) -> + (Ast.ExInt32 (_loc, s) : 'expr)))); + ([ Gram.Snterm + (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_INT) (_loc : Loc.t) -> + (Ast.ExInt (_loc, s) : 'expr)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("tup", _) -> true + | _ -> false), + "ANTIQUOT (\"tup\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("tup" as n)), s) -> + (Ast.ExTup (_loc, + Ast.ExAnt (_loc, + mk_anti ~c: "expr" n s)) : + 'expr) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("exp" | "" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"exp\" | \"\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("exp" | "" | "anti" as n)), s) + -> + (Ast.ExAnt (_loc, mk_anti ~c: "expr" n s) : + 'expr) + | _ -> assert false))); + ([ Gram.Stoken + (((function | QUOTATION _ -> true | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand_expr + (Gram.parse_string expr) _loc x : + 'expr) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (sem_expr_for_list : 'sem_expr_for_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) (_loc : Loc.t) -> + (fun acc -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdUid (_loc, "::")), + e), + acc) : + 'sem_expr_for_list)))); + ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (el : 'sem_expr_for_list) _ (e : 'expr) + (_loc : Loc.t) -> + (fun acc -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdUid (_loc, "::")), + e), + el acc) : + 'sem_expr_for_list)))) ]) ])) + ()); + Gram.extend (comma_expr : 'comma_expr Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) (_loc : Loc.t) -> + (e : 'comma_expr)))); + ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], + (Gram.Action.mk + (fun (e2 : 'comma_expr) _ (e1 : 'comma_expr) + (_loc : Loc.t) -> + (Ast.ExCom (_loc, e1, e2) : 'comma_expr)))) ]) ])) + ()); + Gram.extend (dummy : 'dummy Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> (() : 'dummy)))) ]) ])) + ()); + Gram.extend (sequence : 'sequence Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) (_loc : Loc.t) -> + (e : 'sequence)))); + ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Skeyword ";" ], + (Gram.Action.mk + (fun _ (e : 'expr) (_loc : Loc.t) -> + (e : 'sequence)))); + ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (el : 'sequence) _ (e : 'expr) + (_loc : Loc.t) -> + (Ast.ExSem (_loc, e, el) : 'sequence)))); + ([ Gram.Skeyword "let"; + Gram.Snterm + (Gram.Entry.obj + (opt_rec : 'opt_rec Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (binding : 'binding Gram.Entry.t)); + Gram.srules sequence + [ ([ Gram.Skeyword ";" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) (_loc : Loc.t) -> + (Token.extract_string x : 'e__1)))); + ([ Gram.Skeyword "in" ], + (Gram.Action.mk + (fun (x : Gram.Token.t) (_loc : Loc.t) -> + (Token.extract_string x : 'e__1)))) ]; + Gram.Sself ], + (Gram.Action.mk + (fun (el : 'sequence) _ (bi : 'binding) + (rf : 'opt_rec) _ (_loc : Loc.t) -> + (Ast.ExLet (_loc, rf, bi, mksequence _loc el) : + 'sequence)))) ]) ])) + ()); + Gram.extend (binding : 'binding Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Snterm + (Gram.Entry.obj + (let_binding : 'let_binding Gram.Entry.t)) ], + (Gram.Action.mk + (fun (b : 'let_binding) (_loc : Loc.t) -> + (b : 'binding)))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (b2 : 'binding) _ (b1 : 'binding) + (_loc : Loc.t) -> + (Ast.BiAnd (_loc, b1, b2) : 'binding)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "anti"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "anti" as n)), s) -> + (Ast.BiAnt (_loc, + mk_anti ~c: "binding" n s) : + 'binding) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "anti"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"anti\"), _)")); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "anti" as n)), s) -> + (Ast.BiEq (_loc, + Ast.PaAnt (_loc, + mk_anti ~c: "patt" n s), + e) : + 'binding) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("binding" | "list"), _) -> true + | _ -> false), + "ANTIQUOT ((\"binding\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("binding" | "list" as n)), s) + -> + (Ast.BiAnt (_loc, + mk_anti ~c: "binding" n s) : + 'binding) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (let_binding : 'let_binding Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (fun_binding : 'fun_binding Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'fun_binding) (p : 'ipatt) + (_loc : Loc.t) -> + (Ast.BiEq (_loc, p, e) : 'let_binding)))) ]) ])) + ()); + Gram.extend (fun_binding : 'fun_binding Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.RightA), + [ ([ Gram.Skeyword ":>"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (t : 'ctyp) _ (_loc : Loc.t) + -> + (Ast.ExCoe (_loc, e, Ast.TyNil _loc, t) : + 'fun_binding)))); + ([ Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (t : 'ctyp) _ (_loc : Loc.t) + -> (Ast.ExTyc (_loc, e, t) : 'fun_binding)))); + ([ Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (_loc : Loc.t) -> + (e : 'fun_binding)))); + ([ Gram.Snterm + (Gram.Entry.obj + (labeled_ipatt : + 'labeled_ipatt Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (e : 'fun_binding) (p : 'labeled_ipatt) + (_loc : Loc.t) -> + (Ast.ExFun (_loc, + Ast.McArr (_loc, p, Ast.ExNil _loc, e)) : + 'fun_binding)))) ]) ])) + ()); + Gram.extend (match_case : 'match_case Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Slist0sep + (Gram.Snterm + (Gram.Entry.obj + (match_case0 : 'match_case0 Gram.Entry.t)), + Gram.Skeyword "|") ], + (Gram.Action.mk + (fun (l : 'match_case0 list) (_loc : Loc.t) -> + (Ast.mcOr_of_list l : 'match_case)))) ]) ])) + ()); + Gram.extend (match_case0 : 'match_case0 Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (patt_as_patt_opt : + 'patt_as_patt_opt Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_when_expr : + 'opt_when_expr Gram.Entry.t)); + Gram.Skeyword "->"; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (w : 'opt_when_expr) + (p : 'patt_as_patt_opt) (_loc : Loc.t) -> + (Ast.McArr (_loc, p, w, e) : 'match_case0)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "anti"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"anti\"), _)")); + Gram.Skeyword "when"; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Skeyword "->"; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (w : 'expr) _ + (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "anti" as n)), s) -> + (Ast.McArr (_loc, + Ast.PaAnt (_loc, + mk_anti ~c: "patt" n s), + w, e) : + 'match_case0) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "anti"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"anti\"), _)")); + Gram.Skeyword "->"; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "anti" as n)), s) -> + (Ast.McArr (_loc, + Ast.PaAnt (_loc, + mk_anti ~c: "patt" n s), + Ast.ExNil _loc, e) : + 'match_case0) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "anti"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "anti" as n)), s) -> + (Ast.McAnt (_loc, + mk_anti ~c: "match_case" n s) : + 'match_case0) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("match_case" | "list"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"match_case\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("match_case" | "list" as n)), + s) -> + (Ast.McAnt (_loc, + mk_anti ~c: "match_case" n s) : + 'match_case0) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (opt_when_expr : 'opt_when_expr Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.ExNil _loc : 'opt_when_expr)))); + ([ Gram.Skeyword "when"; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (w : 'expr) _ (_loc : Loc.t) -> + (w : 'opt_when_expr)))) ]) ])) + ()); + Gram.extend (patt_as_patt_opt : 'patt_as_patt_opt Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'patt) (_loc : Loc.t) -> + (p : 'patt_as_patt_opt)))); + ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Skeyword "as"; + Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p2 : 'patt) _ (p1 : 'patt) (_loc : Loc.t) + -> + (Ast.PaAli (_loc, p1, p2) : + 'patt_as_patt_opt)))) ]) ])) + ()); + Gram.extend (label_expr : 'label_expr Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Snterm + (Gram.Entry.obj + (label_longident : + 'label_longident Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (fun_binding : 'fun_binding Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'fun_binding) (p : 'label_longident) + (_loc : Loc.t) -> + (Ast.BiEq (_loc, Ast.PaId (_loc, p), e) : + 'label_expr)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.BiAnt (_loc, + mk_anti ~c: "binding;" n s) : + 'label_expr) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "binding" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"binding\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "binding" | "anti" as n)), + s) -> + (Ast.BiAnt (_loc, + mk_anti ~c: "binding" n s) : + 'label_expr) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (b2 : 'label_expr) _ (b1 : 'label_expr) + (_loc : Loc.t) -> + (Ast.BiSem (_loc, b1, b2) : 'label_expr)))) ]) ])) + ()); + Gram.extend (fun_def : 'fun_def Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.RightA), + [ ([ Gram.Skeyword "->"; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (_loc : Loc.t) -> + (e : 'fun_def)))); + ([ Gram.Snterm + (Gram.Entry.obj + (labeled_ipatt : + 'labeled_ipatt Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (e : 'fun_def) (p : 'labeled_ipatt) + (_loc : Loc.t) -> + (Ast.ExFun (_loc, + Ast.McArr (_loc, p, Ast.ExNil _loc, e)) : + 'fun_def)))) ]) ])) + ()); + Gram.extend (patt : 'patt Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ], + (Gram.Action.mk + (fun (p2 : 'patt) _ (p1 : 'patt) (_loc : Loc.t) + -> (Ast.PaOrp (_loc, p1, p2) : 'patt)))) ]); + (None, (Some Camlp4.Sig.Grammar.NonA), + [ ([ Gram.Sself; Gram.Skeyword ".."; Gram.Sself ], + (Gram.Action.mk + (fun (p2 : 'patt) _ (p1 : 'patt) (_loc : Loc.t) + -> (Ast.PaRng (_loc, p1, p2) : 'patt)))) ]); + (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Sself; Gram.Sself ], + (Gram.Action.mk + (fun (p2 : 'patt) (p1 : 'patt) (_loc : Loc.t) -> + (Ast.PaApp (_loc, p1, p2) : 'patt)))) ]); + ((Some "simple"), None, + [ ([ Gram.Skeyword "?"; Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (patt_tcon : 'patt_tcon Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (e : 'expr) _ (p : 'patt_tcon) _ _ + (_loc : Loc.t) -> + (Ast.PaOlbi (_loc, "", p, e) : 'patt)))); + ([ Gram.Skeyword "?"; Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (patt_tcon : 'patt_tcon Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (p : 'patt_tcon) _ _ (_loc : Loc.t) -> + (Ast.PaOlb (_loc, "", p) : 'patt)))); + ([ Gram.Skeyword "?"; + Gram.Stoken + (((function + | ANTIQUOT (("" | "lid"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"lid\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) _ + (_loc : Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "lid" as n)), i) -> + (Ast.PaOlb (_loc, mk_anti n i, + Ast.PaNil _loc) : + 'patt) + | _ -> assert false))); + ([ Gram.Skeyword "?"; + Gram.Stoken + (((function | LIDENT _ -> true | _ -> false), + "LIDENT _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) _ + (_loc : Loc.t) -> + match __camlp4_0 with + | LIDENT i -> + (Ast.PaOlb (_loc, i, Ast.PaNil _loc) : + 'patt) + | _ -> assert false))); + ([ Gram.Skeyword "?"; + Gram.Stoken + (((function + | ANTIQUOT (("" | "lid"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"lid\"), _)")); + Gram.Skeyword ":"; Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (patt_tcon : 'patt_tcon Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (eq_expr : 'eq_expr Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (f : 'eq_expr) (p : 'patt_tcon) _ _ + (__camlp4_0 : Gram.Token.t) _ (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "lid" as n)), i) -> + (f (mk_anti n i) p : 'patt) + | _ -> assert false))); + ([ Gram.Stoken + (((function | OPTLABEL _ -> true | _ -> false), + "OPTLABEL _")); + Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (patt_tcon : 'patt_tcon Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (eq_expr : 'eq_expr Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (f : 'eq_expr) (p : 'patt_tcon) _ + (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) -> + match __camlp4_0 with + | OPTLABEL i -> (f i p : 'patt) + | _ -> assert false))); + ([ Gram.Skeyword "~"; + Gram.Stoken + (((function | LIDENT _ -> true | _ -> false), + "LIDENT _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) _ + (_loc : Loc.t) -> + match __camlp4_0 with + | LIDENT i -> + (Ast.PaLab (_loc, i, Ast.PaNil _loc) : + 'patt) + | _ -> assert false))); + ([ Gram.Skeyword "~"; + Gram.Stoken + (((function + | ANTIQUOT (("" | "lid"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"lid\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) _ + (_loc : Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "lid" as n)), i) -> + (Ast.PaLab (_loc, mk_anti n i, + Ast.PaNil _loc) : + 'patt) + | _ -> assert false))); + ([ Gram.Skeyword "~"; + Gram.Stoken + (((function + | ANTIQUOT (("" | "lid"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"lid\"), _)")); + Gram.Skeyword ":"; Gram.Sself ], + (Gram.Action.mk + (fun (p : 'patt) _ (__camlp4_0 : Gram.Token.t) _ + (_loc : Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "lid" as n)), i) -> + (Ast.PaLab (_loc, mk_anti n i, p) : + 'patt) + | _ -> assert false))); + ([ Gram.Stoken + (((function | LABEL _ -> true | _ -> false), + "LABEL _")); + Gram.Sself ], + (Gram.Action.mk + (fun (p : 'patt) (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | LABEL i -> (Ast.PaLab (_loc, i, p) : 'patt) + | _ -> assert false))); + ([ Gram.Skeyword "#"; + Gram.Snterm + (Gram.Entry.obj + (type_longident : + 'type_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'type_longident) _ (_loc : Loc.t) -> + (Ast.PaTyp (_loc, i) : 'patt)))); + ([ Gram.Skeyword "`"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_ident) _ (_loc : Loc.t) -> + (Ast.PaVrn (_loc, s) : 'patt)))); + ([ Gram.Stoken + (((function | QUOTATION _ -> true | _ -> false), + "QUOTATION _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | QUOTATION x -> + (Quotation.expand_patt + (Gram.parse_string patt) _loc x : + 'patt) + | _ -> assert false))); + ([ Gram.Skeyword "_" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> + (Ast.PaAny _loc : 'patt)))); + ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ","; + Gram.Snterm + (Gram.Entry.obj + (comma_patt : 'comma_patt Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (pl : 'comma_patt) _ (p : 'patt) _ + (_loc : Loc.t) -> + (Ast.PaTup (_loc, Ast.PaCom (_loc, p, pl)) : + 'patt)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword "as"; Gram.Sself; Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (p2 : 'patt) _ (p : 'patt) _ + (_loc : Loc.t) -> + (Ast.PaAli (_loc, p, p2) : 'patt)))); + ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (t : 'ctyp) _ (p : 'patt) _ + (_loc : Loc.t) -> + (Ast.PaTyc (_loc, p, t) : 'patt)))); + ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (p : 'patt) _ (_loc : Loc.t) -> + (p : 'patt)))); + ([ Gram.Skeyword "("; Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ _ (_loc : Loc.t) -> + (Ast.PaId (_loc, Ast.IdUid (_loc, "()")) : + 'patt)))); + ([ Gram.Skeyword "{"; + Gram.Snterm + (Gram.Entry.obj + (label_patt : 'label_patt Gram.Entry.t)); + Gram.Skeyword "}" ], + (Gram.Action.mk + (fun _ (pl : 'label_patt) _ (_loc : Loc.t) -> + (Ast.PaRec (_loc, pl) : 'patt)))); + ([ Gram.Skeyword "[|"; + Gram.Snterm + (Gram.Entry.obj + (sem_patt : 'sem_patt Gram.Entry.t)); + Gram.Skeyword "|]" ], + (Gram.Action.mk + (fun _ (pl : 'sem_patt) _ (_loc : Loc.t) -> + (Ast.PaArr (_loc, pl) : 'patt)))); + ([ Gram.Skeyword "[|"; Gram.Skeyword "|]" ], + (Gram.Action.mk + (fun _ _ (_loc : Loc.t) -> + (Ast.PaArr (_loc, Ast.PaNil _loc) : 'patt)))); + ([ Gram.Skeyword "["; + Gram.Snterm + (Gram.Entry.obj + (sem_patt_for_list : + 'sem_patt_for_list Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (mk_list : 'sem_patt_for_list) _ + (_loc : Loc.t) -> + (mk_list + (Ast.PaId (_loc, Ast.IdUid (_loc, "[]"))) : + 'patt)))); + ([ Gram.Skeyword "["; + Gram.Snterm + (Gram.Entry.obj + (sem_patt_for_list : + 'sem_patt_for_list Gram.Entry.t)); + Gram.Skeyword "::"; Gram.Sself; Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (last : 'patt) _ + (mk_list : 'sem_patt_for_list) _ + (_loc : Loc.t) -> (mk_list last : 'patt)))); + ([ Gram.Skeyword "["; Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ _ (_loc : Loc.t) -> + (Ast.PaId (_loc, Ast.IdUid (_loc, "[]")) : + 'patt)))); + ([ Gram.Skeyword "-"; + Gram.Snterm + (Gram.Entry.obj + (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_FLOAT) _ (_loc : Loc.t) -> + (Ast.PaFlo (_loc, neg_string s) : 'patt)))); + ([ Gram.Skeyword "-"; + Gram.Snterm + (Gram.Entry.obj + (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_NATIVEINT) _ (_loc : Loc.t) -> + (Ast.PaNativeInt (_loc, neg_string s) : + 'patt)))); + ([ Gram.Skeyword "-"; + Gram.Snterm + (Gram.Entry.obj + (a_INT64 : 'a_INT64 Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_INT64) _ (_loc : Loc.t) -> + (Ast.PaInt64 (_loc, neg_string s) : 'patt)))); + ([ Gram.Skeyword "-"; + Gram.Snterm + (Gram.Entry.obj + (a_INT32 : 'a_INT32 Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_INT32) _ (_loc : Loc.t) -> + (Ast.PaInt32 (_loc, neg_string s) : 'patt)))); + ([ Gram.Skeyword "-"; + Gram.Snterm + (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_INT) _ (_loc : Loc.t) -> + (Ast.PaInt (_loc, neg_string s) : 'patt)))); + ([ Gram.Snterm + (Gram.Entry.obj (a_CHAR : 'a_CHAR Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_CHAR) (_loc : Loc.t) -> + (Ast.PaChr (_loc, s) : 'patt)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_STRING : 'a_STRING Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_STRING) (_loc : Loc.t) -> + (Ast.PaStr (_loc, s) : 'patt)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_FLOAT : 'a_FLOAT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_FLOAT) (_loc : Loc.t) -> + (Ast.PaFlo (_loc, s) : 'patt)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_NATIVEINT) (_loc : Loc.t) -> + (Ast.PaNativeInt (_loc, s) : 'patt)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_INT64 : 'a_INT64 Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_INT64) (_loc : Loc.t) -> + (Ast.PaInt64 (_loc, s) : 'patt)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_INT32 : 'a_INT32 Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_INT32) (_loc : Loc.t) -> + (Ast.PaInt32 (_loc, s) : 'patt)))); + ([ Gram.Snterm + (Gram.Entry.obj (a_INT : 'a_INT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_INT) (_loc : Loc.t) -> + (Ast.PaInt (_loc, s) : 'patt)))); + ([ Gram.Snterm + (Gram.Entry.obj (ident : 'ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'ident) (_loc : Loc.t) -> + (Ast.PaId (_loc, i) : 'patt)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("tup", _) -> true + | _ -> false), + "ANTIQUOT (\"tup\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("tup" as n)), s) -> + (Ast.PaTup (_loc, + Ast.PaAnt (_loc, + mk_anti ~c: "patt" n s)) : + 'patt) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "pat" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "pat" | "anti" as n)), s) + -> + (Ast.PaAnt (_loc, mk_anti ~c: "patt" n s) : + 'patt) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (comma_patt : 'comma_patt Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'patt) (_loc : Loc.t) -> + (p : 'comma_patt)))); + ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], + (Gram.Action.mk + (fun (p2 : 'comma_patt) _ (p1 : 'comma_patt) + (_loc : Loc.t) -> + (Ast.PaCom (_loc, p1, p2) : 'comma_patt)))) ]) ])) + ()); + Gram.extend (sem_patt : 'sem_patt Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'patt) (_loc : Loc.t) -> + (p : 'sem_patt)))); + ([ Gram.Sself; Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (p2 : 'sem_patt) _ (p1 : 'sem_patt) + (_loc : Loc.t) -> + (Ast.PaSem (_loc, p1, p2) : 'sem_patt)))) ]) ])) + ()); + Gram.extend + (sem_patt_for_list : 'sem_patt_for_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'patt) (_loc : Loc.t) -> + (fun acc -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdUid (_loc, "::")), + p), + acc) : + 'sem_patt_for_list)))); + ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (pl : 'sem_patt_for_list) _ (p : 'patt) + (_loc : Loc.t) -> + (fun acc -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdUid (_loc, "::")), + p), + pl acc) : + 'sem_patt_for_list)))) ]) ])) + ()); + Gram.extend (label_patt : 'label_patt Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Snterm + (Gram.Entry.obj + (label_longident : + 'label_longident Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'patt) _ (i : 'label_longident) + (_loc : Loc.t) -> + (Ast.PaEq (_loc, Ast.PaId (_loc, i), p) : + 'label_patt)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.PaAnt (_loc, + mk_anti ~c: "patt;" n s) : + 'label_patt) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "pat" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "pat" | "anti" as n)), s) + -> + (Ast.PaAnt (_loc, mk_anti ~c: "patt" n s) : + 'label_patt) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (p2 : 'label_patt) _ (p1 : 'label_patt) + (_loc : Loc.t) -> + (Ast.PaSem (_loc, p1, p2) : 'label_patt)))) ]) ])) + ()); + Gram.extend (ipatt : 'ipatt Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "_" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> + (Ast.PaAny _loc : 'ipatt)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_LIDENT) (_loc : Loc.t) -> + (Ast.PaId (_loc, Ast.IdLid (_loc, s)) : + 'ipatt)))); + ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ","; + Gram.Snterm + (Gram.Entry.obj + (comma_ipatt : 'comma_ipatt Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (pl : 'comma_ipatt) _ (p : 'ipatt) _ + (_loc : Loc.t) -> + (Ast.PaTup (_loc, Ast.PaCom (_loc, p, pl)) : + 'ipatt)))); + ([ Gram.Skeyword "("; Gram.Sself; + Gram.Skeyword "as"; Gram.Sself; Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (p2 : 'ipatt) _ (p : 'ipatt) _ + (_loc : Loc.t) -> + (Ast.PaAli (_loc, p, p2) : 'ipatt)))); + ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (t : 'ctyp) _ (p : 'ipatt) _ + (_loc : Loc.t) -> + (Ast.PaTyc (_loc, p, t) : 'ipatt)))); + ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (p : 'ipatt) _ (_loc : Loc.t) -> + (p : 'ipatt)))); + ([ Gram.Skeyword "("; Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ _ (_loc : Loc.t) -> + (Ast.PaId (_loc, Ast.IdUid (_loc, "()")) : + 'ipatt)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("tup", _) -> true + | _ -> false), + "ANTIQUOT (\"tup\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("tup" as n)), s) -> + (Ast.PaTup (_loc, + Ast.PaAnt (_loc, + mk_anti ~c: "patt" n s)) : + 'ipatt) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "pat" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "pat" | "anti" as n)), s) + -> + (Ast.PaAnt (_loc, mk_anti ~c: "patt" n s) : + 'ipatt) + | _ -> assert false))); + ([ Gram.Skeyword "{"; + Gram.Snterm + (Gram.Entry.obj + (label_ipatt : 'label_ipatt Gram.Entry.t)); + Gram.Skeyword "}" ], + (Gram.Action.mk + (fun _ (pl : 'label_ipatt) _ (_loc : Loc.t) -> + (Ast.PaRec (_loc, pl) : 'ipatt)))) ]) ])) + ()); + Gram.extend (labeled_ipatt : 'labeled_ipatt Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'ipatt) (_loc : Loc.t) -> + (p : 'labeled_ipatt)))) ]) ])) + ()); + Gram.extend (comma_ipatt : 'comma_ipatt Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Snterm + (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'ipatt) (_loc : Loc.t) -> + (p : 'comma_ipatt)))); + ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], + (Gram.Action.mk + (fun (p2 : 'comma_ipatt) _ (p1 : 'comma_ipatt) + (_loc : Loc.t) -> + (Ast.PaCom (_loc, p1, p2) : 'comma_ipatt)))) ]) ])) + ()); + Gram.extend (label_ipatt : 'label_ipatt Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Snterm + (Gram.Entry.obj + (label_longident : + 'label_longident Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'ipatt) _ (i : 'label_longident) + (_loc : Loc.t) -> + (Ast.PaEq (_loc, Ast.PaId (_loc, i), p) : + 'label_ipatt)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "pat" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"pat\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "pat" | "anti" as n)), s) + -> + (Ast.PaAnt (_loc, mk_anti ~c: "patt" n s) : + 'label_ipatt) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (p2 : 'label_ipatt) _ (p1 : 'label_ipatt) + (_loc : Loc.t) -> + (Ast.PaSem (_loc, p1, p2) : 'label_ipatt)))) ]) ])) + ()); + Gram.extend (type_declaration : 'type_declaration Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Snterm + (Gram.Entry.obj + (type_ident_and_parameters : + 'type_ident_and_parameters Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t)); + Gram.Slist0 + (Gram.Snterm + (Gram.Entry.obj + (constrain : 'constrain Gram.Entry.t))) ], + (Gram.Action.mk + (fun (cl : 'constrain list) (tk : 'opt_eq_ctyp) + ((n, tpl) : 'type_ident_and_parameters) + (_loc : Loc.t) -> + (Ast.TyDcl (_loc, n, tpl, tk tpl, cl) : + 'type_declaration)))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'type_declaration) _ + (t1 : 'type_declaration) (_loc : Loc.t) -> + (Ast.TyAnd (_loc, t1, t2) : + 'type_declaration)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.TyAnt (_loc, + mk_anti ~c: "ctypand" n s) : + 'type_declaration) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" | "anti" as n)), s) + -> + (Ast.TyAnt (_loc, mk_anti ~c: "ctyp" n s) : + 'type_declaration) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (constrain : 'constrain Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "constraint"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ + (_loc : Loc.t) -> ((t1, t2) : 'constrain)))) ]) ])) + ()); + Gram.extend (opt_eq_ctyp : 'opt_eq_ctyp Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (fun tpl -> Ast.TyQuo (_loc, choose_tvar tpl) : + 'opt_eq_ctyp)))); + ([ Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (type_kind : 'type_kind Gram.Entry.t)) ], + (Gram.Action.mk + (fun (tk : 'type_kind) _ (_loc : Loc.t) -> + (fun _ -> tk : 'opt_eq_ctyp)))) ]) ])) + ()); + Gram.extend (type_kind : 'type_kind Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) (_loc : Loc.t) -> + (t : 'type_kind)))) ]) ])) + ()); + Gram.extend + (type_ident_and_parameters : + 'type_ident_and_parameters Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Slist0 + (Gram.Snterm + (Gram.Entry.obj + (type_parameter : + 'type_parameter Gram.Entry.t))) ], + (Gram.Action.mk + (fun (tpl : 'type_parameter list) + (i : 'a_LIDENT) (_loc : Loc.t) -> + ((i, tpl) : 'type_ident_and_parameters)))) ]) ])) + ()); + Gram.extend + (type_longident_and_parameters : + 'type_longident_and_parameters Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (type_longident : + 'type_longident Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (type_parameters : + 'type_parameters Gram.Entry.t)) ], + (Gram.Action.mk + (fun (tpl : 'type_parameters) + (i : 'type_longident) (_loc : Loc.t) -> + (tpl (Ast.TyId (_loc, i)) : + 'type_longident_and_parameters)))) ]) ])) + ()); + Gram.extend (type_parameters : 'type_parameters Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (fun t -> t : 'type_parameters)))); + ([ Gram.Snterm + (Gram.Entry.obj + (type_parameter : + 'type_parameter Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'type_parameter) (_loc : Loc.t) -> + (fun acc -> Ast.TyApp (_loc, acc, t) : + 'type_parameters)))); + ([ Gram.Snterm + (Gram.Entry.obj + (type_parameter : + 'type_parameter Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'type_parameters) + (t1 : 'type_parameter) (_loc : Loc.t) -> + (fun acc -> t2 (Ast.TyApp (_loc, acc, t1)) : + 'type_parameters)))) ]) ])) + ()); + Gram.extend (type_parameter : 'type_parameter Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "-"; Gram.Skeyword "'"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_ident) _ _ (_loc : Loc.t) -> + (Ast.TyQuM (_loc, i) : 'type_parameter)))); + ([ Gram.Skeyword "+"; Gram.Skeyword "'"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_ident) _ _ (_loc : Loc.t) -> + (Ast.TyQuP (_loc, i) : 'type_parameter)))); + ([ Gram.Skeyword "'"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_ident) _ (_loc : Loc.t) -> + (Ast.TyQuo (_loc, i) : 'type_parameter)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" | "anti" as n)), s) + -> + (Ast.TyAnt (_loc, mk_anti n s) : + 'type_parameter) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (ctyp : 'ctyp Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Sself; Gram.Skeyword "=="; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (_loc : Loc.t) + -> (Ast.TyMan (_loc, t1, t2) : 'ctyp)))) ]); + (None, (Some Camlp4.Sig.Grammar.NonA), + [ ([ Gram.Skeyword "private"; + Gram.Snterml + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t), + "alias") ], + (Gram.Action.mk + (fun (t : 'ctyp) _ (_loc : Loc.t) -> + (Ast.TyPrv (_loc, t) : 'ctyp)))) ]); + ((Some "alias"), (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Sself; Gram.Skeyword "as"; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (_loc : Loc.t) + -> (Ast.TyAli (_loc, t1, t2) : 'ctyp)))) ]); + (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Skeyword "!"; + Gram.Snterm + (Gram.Entry.obj + (typevars : 'typevars Gram.Entry.t)); + Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'ctyp) _ (t1 : 'typevars) _ + (_loc : Loc.t) -> + (Ast.TyPol (_loc, t1, t2) : 'ctyp)))) ]); + ((Some "arrow"), (Some Camlp4.Sig.Grammar.RightA), + [ ([ Gram.Sself; Gram.Skeyword "->"; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (_loc : Loc.t) + -> (Ast.TyArr (_loc, t1, t2) : 'ctyp)))) ]); + ((Some "label"), (Some Camlp4.Sig.Grammar.NonA), + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (t : 'ctyp) (i : 'a_OPTLABEL) + (_loc : Loc.t) -> + (Ast.TyOlb (_loc, i, t) : 'ctyp)))); + ([ Gram.Skeyword "?"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword ":"; Gram.Sself ], + (Gram.Action.mk + (fun (t : 'ctyp) _ (i : 'a_LIDENT) _ + (_loc : Loc.t) -> + (Ast.TyOlb (_loc, i, t) : 'ctyp)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_LABEL : 'a_LABEL Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (t : 'ctyp) (i : 'a_LABEL) (_loc : Loc.t) + -> (Ast.TyLab (_loc, i, t) : 'ctyp)))); + ([ Gram.Skeyword "~"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword ":"; Gram.Sself ], + (Gram.Action.mk + (fun (t : 'ctyp) _ (i : 'a_LIDENT) _ + (_loc : Loc.t) -> + (Ast.TyLab (_loc, i, t) : 'ctyp)))) ]); + (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Sself; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'ctyp) (t1 : 'ctyp) (_loc : Loc.t) -> + (let t = Ast.TyApp (_loc, t1, t2) + in + try Ast.TyId (_loc, Ast.ident_of_ctyp t) + with | Invalid_argument _ -> t : + 'ctyp)))) ]); + (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) (_loc : Loc.t) + -> + (try + Ast.TyId (_loc, + Ast.IdAcc (_loc, Ast.ident_of_ctyp t1, + Ast.ident_of_ctyp t2)) + with + | Invalid_argument s -> + raise (Stream.Error s) : + 'ctyp)))) ]); + ((Some "simple"), None, + [ ([ Gram.Skeyword "<"; + Gram.Snterm + (Gram.Entry.obj + (opt_meth_list : + 'opt_meth_list Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)); + Gram.Skeyword ">" ], + (Gram.Action.mk + (fun _ (v : 'opt_dot_dot) (ml : 'opt_meth_list) + _ (_loc : Loc.t) -> + (Ast.TyObj (_loc, ml, v) : 'ctyp)))); + ([ Gram.Skeyword "#"; + Gram.Snterm + (Gram.Entry.obj + (class_longident : + 'class_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'class_longident) _ (_loc : Loc.t) -> + (Ast.TyCls (_loc, i) : 'ctyp)))); + ([ Gram.Skeyword "{"; + Gram.Snterm + (Gram.Entry.obj + (label_declaration : + 'label_declaration Gram.Entry.t)); + Gram.Sopt (Gram.Skeyword ";"); Gram.Skeyword "}" ], + (Gram.Action.mk + (fun _ _ (t : 'label_declaration) _ + (_loc : Loc.t) -> + (Ast.TyRec (_loc, t) : 'ctyp)))); + ([ Gram.Skeyword "[<"; + Gram.Snterm + (Gram.Entry.obj + (row_field : 'row_field Gram.Entry.t)); + Gram.Skeyword ">"; + Gram.Snterm + (Gram.Entry.obj + (name_tags : 'name_tags Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (ntl : 'name_tags) _ (rfl : 'row_field) _ + (_loc : Loc.t) -> + (Ast.TyVrnInfSup (_loc, rfl, ntl) : 'ctyp)))); + ([ Gram.Skeyword "[<"; + Gram.Snterm + (Gram.Entry.obj + (row_field : 'row_field Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (rfl : 'row_field) _ (_loc : Loc.t) -> + (Ast.TyVrnInf (_loc, rfl) : 'ctyp)))); + ([ Gram.Skeyword "["; Gram.Skeyword "<"; + Gram.Snterm + (Gram.Entry.obj + (row_field : 'row_field Gram.Entry.t)); + Gram.Skeyword ">"; + Gram.Snterm + (Gram.Entry.obj + (name_tags : 'name_tags Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (ntl : 'name_tags) _ (rfl : 'row_field) _ + _ (_loc : Loc.t) -> + (Ast.TyVrnInfSup (_loc, rfl, ntl) : 'ctyp)))); + ([ Gram.Skeyword "["; Gram.Skeyword "<"; + Gram.Snterm + (Gram.Entry.obj + (row_field : 'row_field Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (rfl : 'row_field) _ _ (_loc : Loc.t) -> + (Ast.TyVrnInf (_loc, rfl) : 'ctyp)))); + ([ Gram.Skeyword "["; Gram.Skeyword ">"; + Gram.Snterm + (Gram.Entry.obj + (row_field : 'row_field Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (rfl : 'row_field) _ _ (_loc : Loc.t) -> + (Ast.TyVrnSup (_loc, rfl) : 'ctyp)))); + ([ Gram.Skeyword "["; Gram.Skeyword ">"; + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ _ _ (_loc : Loc.t) -> + (Ast.TyVrnSup (_loc, Ast.TyNil _loc) : 'ctyp)))); + ([ Gram.Skeyword "["; Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (row_field : 'row_field Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (rfl : 'row_field) _ _ (_loc : Loc.t) -> + (Ast.TyVrnEq (_loc, rfl) : 'ctyp)))); + ([ Gram.Skeyword "["; + Gram.Snterm + (Gram.Entry.obj + (constructor_declarations : + 'constructor_declarations Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (t : 'constructor_declarations) _ + (_loc : Loc.t) -> + (Ast.TySum (_loc, t) : 'ctyp)))); + ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (t : 'ctyp) _ (_loc : Loc.t) -> + (t : 'ctyp)))); + ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword "*"; + Gram.Snterm + (Gram.Entry.obj + (star_ctyp : 'star_ctyp Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (tl : 'star_ctyp) _ (t : 'ctyp) _ + (_loc : Loc.t) -> + (Ast.TyTup (_loc, Ast.TySta (_loc, t, tl)) : + 'ctyp)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_UIDENT) (_loc : Loc.t) -> + (Ast.TyId (_loc, Ast.IdUid (_loc, i)) : + 'ctyp)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) (_loc : Loc.t) -> + (Ast.TyId (_loc, Ast.IdLid (_loc, i)) : + 'ctyp)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("id", _) -> true + | _ -> false), + "ANTIQUOT (\"id\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("id" as n)), s) -> + (Ast.TyId (_loc, + Ast.IdAnt (_loc, + mk_anti ~c: "ident" n s)) : + 'ctyp) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("tup", _) -> true + | _ -> false), + "ANTIQUOT (\"tup\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("tup" as n)), s) -> + (Ast.TyTup (_loc, + Ast.TyAnt (_loc, + mk_anti ~c: "ctyp" n s)) : + 'ctyp) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" | "anti" as n)), s) + -> + (Ast.TyAnt (_loc, mk_anti ~c: "ctyp" n s) : + 'ctyp) + | _ -> assert false))); + ([ Gram.Skeyword "_" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> + (Ast.TyAny _loc : 'ctyp)))); + ([ Gram.Skeyword "'"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_ident) _ (_loc : Loc.t) -> + (Ast.TyQuo (_loc, i) : 'ctyp)))) ]) ])) + ()); + Gram.extend (star_ctyp : 'star_ctyp Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) (_loc : Loc.t) -> + (t : 'star_ctyp)))); + ([ Gram.Sself; Gram.Skeyword "*"; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'star_ctyp) _ (t1 : 'star_ctyp) + (_loc : Loc.t) -> + (Ast.TySta (_loc, t1, t2) : 'star_ctyp)))) ]) ])) + ()); + Gram.extend + (constructor_declarations : + 'constructor_declarations Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Slist1sep + (Gram.Snterm + (Gram.Entry.obj + (constructor_declaration : + 'constructor_declaration Gram.Entry.t)), + Gram.Skeyword "|") ], + (Gram.Action.mk + (fun (l : 'constructor_declaration list) + (_loc : Loc.t) -> + (Ast.tyOr_of_list l : + 'constructor_declarations)))) ]) ])) + ()); + Gram.extend + (constructor_declaration : + 'constructor_declaration Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'a_UIDENT) (_loc : Loc.t) -> + (Ast.TyId (_loc, Ast.IdUid (_loc, s)) : + 'constructor_declaration)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword "of"; + Gram.Snterm + (Gram.Entry.obj + (constructor_arg_list : + 'constructor_arg_list Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'constructor_arg_list) _ + (s : 'a_UIDENT) (_loc : Loc.t) -> + (Ast.TyOf (_loc, + Ast.TyId (_loc, Ast.IdUid (_loc, s)), t) : + 'constructor_declaration)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" as n)), s) -> + (Ast.TyAnt (_loc, mk_anti ~c: "ctyp" n s) : + 'constructor_declaration) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (constructor_arg_list : 'constructor_arg_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) (_loc : Loc.t) -> + (t : 'constructor_arg_list)))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'constructor_arg_list) _ + (t1 : 'constructor_arg_list) (_loc : Loc.t) + -> + (Ast.TyAnd (_loc, t1, t2) : + 'constructor_arg_list)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.TyAnt (_loc, + mk_anti ~c: "ctypand" n s) : + 'constructor_arg_list) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (label_declaration : 'label_declaration Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword ":"; Gram.Skeyword "mutable"; + Gram.Snterm + (Gram.Entry.obj + (poly_type : 'poly_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'poly_type) _ _ (s : 'a_LIDENT) + (_loc : Loc.t) -> + (Ast.TyCol (_loc, + Ast.TyId (_loc, Ast.IdLid (_loc, s)), + Ast.TyMut (_loc, t)) : + 'label_declaration)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (poly_type : 'poly_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'poly_type) _ (s : 'a_LIDENT) + (_loc : Loc.t) -> + (Ast.TyCol (_loc, + Ast.TyId (_loc, Ast.IdLid (_loc, s)), t) : + 'label_declaration)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" as n)), s) -> + (Ast.TyAnt (_loc, mk_anti ~c: "ctyp" n s) : + 'label_declaration) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'label_declaration) _ + (t1 : 'label_declaration) (_loc : Loc.t) -> + (Ast.TySem (_loc, t1, t2) : + 'label_declaration)))) ]) ])) + ()); + Gram.extend (a_ident : 'a_ident Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_UIDENT) (_loc : Loc.t) -> + (i : 'a_ident)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) (_loc : Loc.t) -> + (i : 'a_ident)))) ]) ])) + ()); + Gram.extend (ident : 'ident Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (j : 'ident) _ (i : 'a_UIDENT) + (_loc : Loc.t) -> + (Ast.IdAcc (_loc, Ast.IdUid (_loc, i), j) : + 'ident)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "id" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")); + Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (i : 'ident) _ (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "id" | "anti" | "list" as n)), s) + -> + (Ast.IdAcc (_loc, + Ast.IdAnt (_loc, + mk_anti ~c: "ident" n s), + i) : + 'ident) + | _ -> assert false))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) (_loc : Loc.t) -> + (Ast.IdLid (_loc, i) : 'ident)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_UIDENT) (_loc : Loc.t) -> + (Ast.IdUid (_loc, i) : 'ident)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "id" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "id" | "anti" | "list" as n)), s) + -> + (Ast.IdAnt (_loc, + mk_anti ~c: "ident" n s) : + 'ident) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (module_longident : 'module_longident Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_UIDENT) (_loc : Loc.t) -> + (Ast.IdUid (_loc, i) : 'module_longident)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (l : 'module_longident) _ (m : 'a_UIDENT) + (_loc : Loc.t) -> + (Ast.IdAcc (_loc, Ast.IdUid (_loc, m), l) : + 'module_longident)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "id" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "id" | "anti" | "list" as n)), s) + -> + (Ast.IdAnt (_loc, + mk_anti ~c: "ident" n s) : + 'module_longident) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (module_longident_with_app : + 'module_longident_with_app Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Sself; Gram.Sself ], + (Gram.Action.mk + (fun (j : 'module_longident_with_app) + (i : 'module_longident_with_app) + (_loc : Loc.t) -> + (Ast.IdApp (_loc, i, j) : + 'module_longident_with_app)))) ]); + (None, None, + [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (j : 'module_longident_with_app) _ + (i : 'module_longident_with_app) + (_loc : Loc.t) -> + (Ast.IdAcc (_loc, i, j) : + 'module_longident_with_app)))) ]); + (None, None, + [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (i : 'module_longident_with_app) _ + (_loc : Loc.t) -> + (i : 'module_longident_with_app)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_UIDENT) (_loc : Loc.t) -> + (Ast.IdUid (_loc, i) : + 'module_longident_with_app)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "id" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "id" | "anti" | "list" as n)), s) + -> + (Ast.IdAnt (_loc, + mk_anti ~c: "ident" n s) : + 'module_longident_with_app) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (type_longident : 'type_longident Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Sself; Gram.Sself ], + (Gram.Action.mk + (fun (j : 'type_longident) (i : 'type_longident) + (_loc : Loc.t) -> + (Ast.IdApp (_loc, i, j) : 'type_longident)))) ]); + (None, None, + [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (j : 'type_longident) _ + (i : 'type_longident) (_loc : Loc.t) -> + (Ast.IdAcc (_loc, i, j) : 'type_longident)))) ]); + (None, None, + [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (i : 'type_longident) _ (_loc : Loc.t) -> + (i : 'type_longident)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_UIDENT) (_loc : Loc.t) -> + (Ast.IdUid (_loc, i) : 'type_longident)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) (_loc : Loc.t) -> + (Ast.IdLid (_loc, i) : 'type_longident)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "id" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "id" | "anti" | "list" as n)), s) + -> + (Ast.IdAnt (_loc, + mk_anti ~c: "ident" n s) : + 'type_longident) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (label_longident : 'label_longident Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) (_loc : Loc.t) -> + (Ast.IdLid (_loc, i) : 'label_longident)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (l : 'label_longident) _ (m : 'a_UIDENT) + (_loc : Loc.t) -> + (Ast.IdAcc (_loc, Ast.IdUid (_loc, m), l) : + 'label_longident)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "id" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "id" | "anti" | "list" as n)), s) + -> + (Ast.IdAnt (_loc, + mk_anti ~c: "ident" n s) : + 'label_longident) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (class_type_longident : 'class_type_longident Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (type_longident : + 'type_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'type_longident) (_loc : Loc.t) -> + (x : 'class_type_longident)))) ]) ])) + ()); + Gram.extend (val_longident : 'val_longident Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ident : 'ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'ident) (_loc : Loc.t) -> + (x : 'val_longident)))) ]) ])) + ()); + Gram.extend (class_longident : 'class_longident Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (label_longident : + 'label_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'label_longident) (_loc : Loc.t) -> + (x : 'class_longident)))) ]) ])) + ()); + Gram.extend + (class_declaration : 'class_declaration Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Snterm + (Gram.Entry.obj + (class_info_for_class_expr : + 'class_info_for_class_expr Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (class_fun_binding : + 'class_fun_binding Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ce : 'class_fun_binding) + (ci : 'class_info_for_class_expr) + (_loc : Loc.t) -> + (Ast.CeEq (_loc, ci, ce) : + 'class_declaration)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "cdcl" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"cdcl\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "cdcl" | "anti" | "list" as n)), + s) -> + (Ast.CeAnt (_loc, + mk_anti ~c: "class_expr" n s) : + 'class_declaration) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (c2 : 'class_declaration) _ + (c1 : 'class_declaration) (_loc : Loc.t) -> + (Ast.CeAnd (_loc, c1, c2) : + 'class_declaration)))) ]) ])) + ()); + Gram.extend + (class_fun_binding : 'class_fun_binding Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (labeled_ipatt : + 'labeled_ipatt Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (cfb : 'class_fun_binding) + (p : 'labeled_ipatt) (_loc : Loc.t) -> + (Ast.CeFun (_loc, p, cfb) : + 'class_fun_binding)))); + ([ Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (class_type_plus : + 'class_type_plus Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (class_expr : 'class_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ce : 'class_expr) _ + (ct : 'class_type_plus) _ (_loc : Loc.t) -> + (Ast.CeTyc (_loc, ce, ct) : + 'class_fun_binding)))); + ([ Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (class_expr : 'class_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ce : 'class_expr) _ (_loc : Loc.t) -> + (ce : 'class_fun_binding)))) ]) ])) + ()); + Gram.extend + (class_info_for_class_type : + 'class_info_for_class_type Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (opt_virtual : 'opt_virtual Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (class_name_and_param : + 'class_name_and_param Gram.Entry.t)) ], + (Gram.Action.mk + (fun ((i, ot) : 'class_name_and_param) + (mv : 'opt_virtual) (_loc : Loc.t) -> + (Ast.CtCon (_loc, mv, Ast.IdLid (_loc, i), + ot) : + 'class_info_for_class_type)))) ]) ])) + ()); + Gram.extend + (class_info_for_class_expr : + 'class_info_for_class_expr Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (opt_virtual : 'opt_virtual Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (class_name_and_param : + 'class_name_and_param Gram.Entry.t)) ], + (Gram.Action.mk + (fun ((i, ot) : 'class_name_and_param) + (mv : 'opt_virtual) (_loc : Loc.t) -> + (Ast.CeCon (_loc, mv, Ast.IdLid (_loc, i), + ot) : + 'class_info_for_class_expr)))) ]) ])) + ()); + Gram.extend + (class_name_and_param : 'class_name_and_param Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) (_loc : Loc.t) -> + ((i, (Ast.TyNil _loc)) : + 'class_name_and_param)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword "["; + Gram.Snterm + (Gram.Entry.obj + (comma_type_parameter : + 'comma_type_parameter Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (x : 'comma_type_parameter) _ + (i : 'a_LIDENT) (_loc : Loc.t) -> + ((i, x) : 'class_name_and_param)))) ]) ])) + ()); + Gram.extend + (comma_type_parameter : 'comma_type_parameter Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Snterm + (Gram.Entry.obj + (type_parameter : + 'type_parameter Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'type_parameter) (_loc : Loc.t) -> + (t : 'comma_type_parameter)))); + ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'comma_type_parameter) _ + (t1 : 'comma_type_parameter) (_loc : Loc.t) + -> + (Ast.TyCom (_loc, t1, t2) : + 'comma_type_parameter)))) ]) ])) + ()); + Gram.extend (opt_comma_ctyp : 'opt_comma_ctyp Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.TyNil _loc : 'opt_comma_ctyp)))); + ([ Gram.Skeyword "["; + Gram.Snterm + (Gram.Entry.obj + (comma_ctyp : 'comma_ctyp Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (x : 'comma_ctyp) _ (_loc : Loc.t) -> + (x : 'opt_comma_ctyp)))) ]) ])) + ()); + Gram.extend (comma_ctyp : 'comma_ctyp Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) (_loc : Loc.t) -> + (t : 'comma_ctyp)))); + ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'comma_ctyp) _ (t1 : 'comma_ctyp) + (_loc : Loc.t) -> + (Ast.TyCom (_loc, t1, t2) : 'comma_ctyp)))) ]) ])) + ()); + Gram.extend (class_fun_def : 'class_fun_def Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "->"; + Gram.Snterm + (Gram.Entry.obj + (class_expr : 'class_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ce : 'class_expr) _ (_loc : Loc.t) -> + (ce : 'class_fun_def)))); + ([ Gram.Snterm + (Gram.Entry.obj + (labeled_ipatt : + 'labeled_ipatt Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (ce : 'class_fun_def) (p : 'labeled_ipatt) + (_loc : Loc.t) -> + (Ast.CeFun (_loc, p, ce) : 'class_fun_def)))) ]) ])) + ()); + Gram.extend (class_expr : 'class_expr Gram.Entry.t) + ((fun () -> + (None, + [ ((Some "top"), None, + [ ([ Gram.Skeyword "let"; + Gram.Snterm + (Gram.Entry.obj + (opt_rec : 'opt_rec Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (binding : 'binding Gram.Entry.t)); + Gram.Skeyword "in"; Gram.Sself ], + (Gram.Action.mk + (fun (ce : 'class_expr) _ (bi : 'binding) + (rf : 'opt_rec) _ (_loc : Loc.t) -> + (Ast.CeLet (_loc, rf, bi, ce) : 'class_expr)))); + ([ Gram.Skeyword "fun"; + Gram.Snterm + (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (class_fun_def : + 'class_fun_def Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ce : 'class_fun_def) (p : 'ipatt) _ + (_loc : Loc.t) -> + (Ast.CeFun (_loc, p, ce) : 'class_expr)))) ]); + ((Some "apply"), (Some Camlp4.Sig.Grammar.NonA), + [ ([ Gram.Sself; + Gram.Snterml + (Gram.Entry.obj (expr : 'expr Gram.Entry.t), + "label") ], + (Gram.Action.mk + (fun (e : 'expr) (ce : 'class_expr) + (_loc : Loc.t) -> + (Ast.CeApp (_loc, ce, e) : 'class_expr)))) ]); + ((Some "simple"), None, + [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (ce : 'class_expr) _ (_loc : Loc.t) -> + (ce : 'class_expr)))); + ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (class_type : 'class_type Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (ct : 'class_type) _ (ce : 'class_expr) _ + (_loc : Loc.t) -> + (Ast.CeTyc (_loc, ce, ct) : 'class_expr)))); + ([ Gram.Skeyword "object"; + Gram.Snterm + (Gram.Entry.obj + (opt_class_self_patt : + 'opt_class_self_patt Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (class_structure : + 'class_structure Gram.Entry.t)); + Gram.Skeyword "end" ], + (Gram.Action.mk + (fun _ (cst : 'class_structure) + (csp : 'opt_class_self_patt) _ (_loc : Loc.t) + -> (Ast.CeStr (_loc, csp, cst) : 'class_expr)))); + ([ Gram.Snterm + (Gram.Entry.obj + (class_longident_and_param : + 'class_longident_and_param Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ce : 'class_longident_and_param) + (_loc : Loc.t) -> (ce : 'class_expr)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "cexp" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"cexp\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "cexp" | "anti" as n)), s) + -> + (Ast.CeAnt (_loc, + mk_anti ~c: "class_expr" n s) : + 'class_expr) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (class_longident_and_param : + 'class_longident_and_param Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (class_longident : + 'class_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ci : 'class_longident) (_loc : Loc.t) -> + (Ast.CeCon (_loc, Ast.BFalse, ci, + Ast.TyNil _loc) : + 'class_longident_and_param)))); + ([ Gram.Snterm + (Gram.Entry.obj + (class_longident : + 'class_longident Gram.Entry.t)); + Gram.Skeyword "["; + Gram.Snterm + (Gram.Entry.obj + (comma_ctyp : 'comma_ctyp Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (t : 'comma_ctyp) _ + (ci : 'class_longident) (_loc : Loc.t) -> + (Ast.CeCon (_loc, Ast.BFalse, ci, t) : + 'class_longident_and_param)))) ]) ])) + ()); + Gram.extend (class_structure : 'class_structure Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Slist0 + (Gram.srules class_structure + [ ([ Gram.Snterm + (Gram.Entry.obj + (class_str_item : + 'class_str_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (semi : 'semi Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (cst : 'class_str_item) + (_loc : Loc.t) -> (cst : 'e__2)))) ]) ], + (Gram.Action.mk + (fun (l : 'e__2 list) (_loc : Loc.t) -> + (Ast.crSem_of_list l : 'class_structure)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "cst" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"cst\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "cst" | "anti" | "list" as n)), + s) -> + (Ast.CrAnt (_loc, + mk_anti ~c: "class_str_item" n s) : + 'class_structure) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (opt_class_self_patt : 'opt_class_self_patt Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.PaNil _loc : 'opt_class_self_patt)))); + ([ Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (t : 'ctyp) _ (p : 'patt) _ + (_loc : Loc.t) -> + (Ast.PaTyc (_loc, p, t) : + 'opt_class_self_patt)))); + ([ Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (p : 'patt) _ (_loc : Loc.t) -> + (p : 'opt_class_self_patt)))) ]) ])) + ()); + Gram.extend (class_str_item : 'class_str_item Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Skeyword "initializer"; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (se : 'expr) _ (_loc : Loc.t) -> + (Ast.CrIni (_loc, se) : 'class_str_item)))); + ([ Gram.Skeyword "type"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ + (_loc : Loc.t) -> + (Ast.CrCtr (_loc, t1, t2) : 'class_str_item)))); + ([ Gram.Skeyword "method"; + Gram.Snterm + (Gram.Entry.obj + (opt_private : 'opt_private Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (label : 'label Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_polyt : 'opt_polyt Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (fun_binding : 'fun_binding Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'fun_binding) (topt : 'opt_polyt) + (l : 'label) (pf : 'opt_private) _ + (_loc : Loc.t) -> + (Ast.CrMth (_loc, l, pf, e, topt) : + 'class_str_item)))); + ([ Gram.Skeyword "method"; Gram.Skeyword "virtual"; + Gram.Snterm + (Gram.Entry.obj + (opt_private : 'opt_private Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (label : 'label Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (poly_type : 'poly_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'poly_type) _ (l : 'label) + (pf : 'opt_private) _ _ (_loc : Loc.t) -> + (Ast.CrVir (_loc, l, pf, t) : + 'class_str_item)))); + ([ Gram.Snterm + (Gram.Entry.obj + (value_val : 'value_val Gram.Entry.t)); + Gram.Skeyword "virtual"; + Gram.Snterm + (Gram.Entry.obj + (opt_mutable : 'opt_mutable Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (label : 'label Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (poly_type : 'poly_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'poly_type) _ (l : 'label) + (mf : 'opt_mutable) _ _ (_loc : Loc.t) -> + (Ast.CrVvr (_loc, l, mf, t) : + 'class_str_item)))); + ([ Gram.Snterm + (Gram.Entry.obj + (value_val : 'value_val Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_mutable : 'opt_mutable Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (label : 'label Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (cvalue_binding : + 'cvalue_binding Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'cvalue_binding) (lab : 'label) + (mf : 'opt_mutable) _ (_loc : Loc.t) -> + (Ast.CrVal (_loc, lab, mf, e) : + 'class_str_item)))); + ([ Gram.Skeyword "inherit"; + Gram.Snterm + (Gram.Entry.obj + (class_expr : 'class_expr Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_as_lident : + 'opt_as_lident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (pb : 'opt_as_lident) (ce : 'class_expr) _ + (_loc : Loc.t) -> + (Ast.CrInh (_loc, ce, pb) : 'class_str_item)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "cst" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"cst\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "cst" | "anti" | "list" as n)), + s) -> + (Ast.CrAnt (_loc, + mk_anti ~c: "class_str_item" n s) : + 'class_str_item) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (opt_as_lident : 'opt_as_lident Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> ("" : 'opt_as_lident)))); + ([ Gram.Skeyword "as"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) _ (_loc : Loc.t) -> + (i : 'opt_as_lident)))) ]) ])) + ()); + Gram.extend (opt_polyt : 'opt_polyt Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.TyNil _loc : 'opt_polyt)))); + ([ Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (poly_type : 'poly_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'poly_type) _ (_loc : Loc.t) -> + (t : 'opt_polyt)))) ]) ])) + ()); + Gram.extend (cvalue_binding : 'cvalue_binding Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword ":>"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (t : 'ctyp) _ (_loc : Loc.t) + -> + (Ast.ExCoe (_loc, e, Ast.TyNil _loc, t) : + 'cvalue_binding)))); + ([ Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword ":>"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (t2 : 'ctyp) _ (t : 'ctyp) _ + (_loc : Loc.t) -> + (Ast.ExCoe (_loc, e, t, t2) : + 'cvalue_binding)))); + ([ Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (t : 'ctyp) _ (_loc : Loc.t) + -> (Ast.ExTyc (_loc, e, t) : 'cvalue_binding)))); + ([ Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (_loc : Loc.t) -> + (e : 'cvalue_binding)))) ]) ])) + ()); + Gram.extend (label : 'label Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) (_loc : Loc.t) -> + (i : 'label)))) ]) ])) + ()); + Gram.extend (class_type : 'class_type Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "object"; + Gram.Snterm + (Gram.Entry.obj + (opt_class_self_type : + 'opt_class_self_type Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (class_signature : + 'class_signature Gram.Entry.t)); + Gram.Skeyword "end" ], + (Gram.Action.mk + (fun _ (csg : 'class_signature) + (cst : 'opt_class_self_type) _ (_loc : Loc.t) + -> (Ast.CtSig (_loc, cst, csg) : 'class_type)))); + ([ Gram.Snterm + (Gram.Entry.obj + (class_type_longident_and_param : + 'class_type_longident_and_param Gram. + Entry.t)) ], + (Gram.Action.mk + (fun (ct : 'class_type_longident_and_param) + (_loc : Loc.t) -> (ct : 'class_type)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "ctyp" | "anti"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"ctyp\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "ctyp" | "anti" as n)), s) + -> + (Ast.CtAnt (_loc, + mk_anti ~c: "class_type" n s) : + 'class_type) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (class_type_longident_and_param : + 'class_type_longident_and_param Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (class_type_longident : + 'class_type_longident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'class_type_longident) (_loc : Loc.t) + -> + (Ast.CtCon (_loc, Ast.BFalse, i, + Ast.TyNil _loc) : + 'class_type_longident_and_param)))); + ([ Gram.Snterm + (Gram.Entry.obj + (class_type_longident : + 'class_type_longident Gram.Entry.t)); + Gram.Skeyword "["; + Gram.Snterm + (Gram.Entry.obj + (comma_ctyp : 'comma_ctyp Gram.Entry.t)); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (t : 'comma_ctyp) _ + (i : 'class_type_longident) (_loc : Loc.t) -> + (Ast.CtCon (_loc, Ast.BFalse, i, t) : + 'class_type_longident_and_param)))) ]) ])) + ()); + Gram.extend (class_type_plus : 'class_type_plus Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (class_type : 'class_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ct : 'class_type) (_loc : Loc.t) -> + (ct : 'class_type_plus)))); + ([ Gram.Skeyword "["; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword "]"; Gram.Skeyword "->"; Gram.Sself ], + (Gram.Action.mk + (fun (ct : 'class_type_plus) _ _ (t : 'ctyp) _ + (_loc : Loc.t) -> + (Ast.CtFun (_loc, t, ct) : 'class_type_plus)))) ]) ])) + ()); + Gram.extend + (opt_class_self_type : 'opt_class_self_type Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.TyNil _loc : 'opt_class_self_type)))); + ([ Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (t : 'ctyp) _ (_loc : Loc.t) -> + (t : 'opt_class_self_type)))) ]) ])) + ()); + Gram.extend (class_signature : 'class_signature Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Slist0 + (Gram.srules class_signature + [ ([ Gram.Snterm + (Gram.Entry.obj + (class_sig_item : + 'class_sig_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (semi : 'semi Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (csg : 'class_sig_item) + (_loc : Loc.t) -> (csg : 'e__3)))) ]) ], + (Gram.Action.mk + (fun (l : 'e__3 list) (_loc : Loc.t) -> + (Ast.cgSem_of_list l : 'class_signature)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "csg" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"csg\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "csg" | "anti" | "list" as n)), + s) -> + (Ast.CgAnt (_loc, + mk_anti ~c: "class_sig_item" n s) : + 'class_signature) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (class_sig_item : 'class_sig_item Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (type_constraint : + 'type_constraint Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ + (_loc : Loc.t) -> + (Ast.CgCtr (_loc, t1, t2) : 'class_sig_item)))); + ([ Gram.Skeyword "method"; + Gram.Snterm + (Gram.Entry.obj + (opt_private : 'opt_private Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (label : 'label Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (poly_type : 'poly_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'poly_type) _ (l : 'label) + (pf : 'opt_private) _ (_loc : Loc.t) -> + (Ast.CgMth (_loc, l, pf, t) : + 'class_sig_item)))); + ([ Gram.Skeyword "method"; Gram.Skeyword "virtual"; + Gram.Snterm + (Gram.Entry.obj + (opt_private : 'opt_private Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (label : 'label Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (poly_type : 'poly_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'poly_type) _ (l : 'label) + (pf : 'opt_private) _ _ (_loc : Loc.t) -> + (Ast.CgVir (_loc, l, pf, t) : + 'class_sig_item)))); + ([ Gram.Snterm + (Gram.Entry.obj + (value_val : 'value_val Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_mutable : 'opt_mutable Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_virtual : 'opt_virtual Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (label : 'label Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) _ (l : 'label) + (mv : 'opt_virtual) (mf : 'opt_mutable) _ + (_loc : Loc.t) -> + (Ast.CgVal (_loc, l, mf, mv, t) : + 'class_sig_item)))); + ([ Gram.Skeyword "inherit"; + Gram.Snterm + (Gram.Entry.obj + (class_type : 'class_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (cs : 'class_type) _ (_loc : Loc.t) -> + (Ast.CgInh (_loc, cs) : 'class_sig_item)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "csg" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"csg\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "csg" | "anti" | "list" as n)), + s) -> + (Ast.CgAnt (_loc, + mk_anti ~c: "class_sig_item" n s) : + 'class_sig_item) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (type_constraint : 'type_constraint Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "type" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> (() : 'type_constraint)))) ]) ])) + ()); + Gram.extend + (class_description : 'class_description Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (class_info_for_class_type : + 'class_info_for_class_type Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (class_type_plus : + 'class_type_plus Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ct : 'class_type_plus) _ + (ci : 'class_info_for_class_type) + (_loc : Loc.t) -> + (Ast.CtCol (_loc, ci, ct) : + 'class_description)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "typ" | "anti" | "list" as n)), + s) -> + (Ast.CtAnt (_loc, + mk_anti ~c: "class_type" n s) : + 'class_description) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (cd2 : 'class_description) _ + (cd1 : 'class_description) (_loc : Loc.t) -> + (Ast.CtAnd (_loc, cd1, cd2) : + 'class_description)))) ]) ])) + ()); + Gram.extend + (class_type_declaration : + 'class_type_declaration Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Snterm + (Gram.Entry.obj + (class_info_for_class_type : + 'class_info_for_class_type Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (class_type : 'class_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ct : 'class_type) _ + (ci : 'class_info_for_class_type) + (_loc : Loc.t) -> + (Ast.CtEq (_loc, ci, ct) : + 'class_type_declaration)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "typ" | "anti" | "list" as n)), + s) -> + (Ast.CtAnt (_loc, + mk_anti ~c: "class_type" n s) : + 'class_type_declaration) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (cd2 : 'class_type_declaration) _ + (cd1 : 'class_type_declaration) + (_loc : Loc.t) -> + (Ast.CtAnd (_loc, cd1, cd2) : + 'class_type_declaration)))) ]) ])) + ()); + Gram.extend (field_expr : 'field_expr Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Snterm + (Gram.Entry.obj (label : 'label Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (l : 'label) (_loc : Loc.t) + -> + (Ast.BiEq (_loc, + Ast.PaId (_loc, Ast.IdLid (_loc, l)), e) : + 'field_expr)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("list", _) -> true + | _ -> false), + "ANTIQUOT (\"list\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("list" as n)), s) -> + (Ast.BiAnt (_loc, + mk_anti ~c: "binding;" n s) : + 'field_expr) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "bi" | "anti"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"bi\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "bi" | "anti" as n)), s) + -> + (Ast.BiAnt (_loc, + mk_anti ~c: "binding" n s) : + 'field_expr) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (b2 : 'field_expr) _ (b1 : 'field_expr) + (_loc : Loc.t) -> + (Ast.BiSem (_loc, b1, b2) : 'field_expr)))) ]) ])) + ()); + Gram.extend (meth_list : 'meth_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (field : 'field Gram.Entry.t)); + Gram.Sopt (Gram.Skeyword ";") ], + (Gram.Action.mk + (fun _ (f : 'field) (_loc : Loc.t) -> + (f : 'meth_list)))); + ([ Gram.Snterm + (Gram.Entry.obj (field : 'field Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (ml : 'meth_list) _ (f : 'field) + (_loc : Loc.t) -> + (Ast.TySem (_loc, f, ml) : 'meth_list)))) ]) ])) + ()); + Gram.extend (opt_meth_list : 'opt_meth_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.TyNil _loc : 'opt_meth_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (meth_list : 'meth_list Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ml : 'meth_list) (_loc : Loc.t) -> + (ml : 'opt_meth_list)))) ]) ])) + ()); + Gram.extend (field : 'field Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (poly_type : 'poly_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'poly_type) _ (lab : 'a_LIDENT) + (_loc : Loc.t) -> + (Ast.TyCol (_loc, + Ast.TyId (_loc, Ast.IdLid (_loc, lab)), t) : + 'field)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" as n)), s) -> + (Ast.TyAnt (_loc, mk_anti ~c: "ctyp" n s) : + 'field) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (poly_type : 'poly_type Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) (_loc : Loc.t) -> + (t : 'poly_type)))) ]) ])) + ()); + Gram.extend (typevars : 'typevars Gram.Entry.t) + ((fun () -> + (None, + [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ ([ Gram.Skeyword "'"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_ident) _ (_loc : Loc.t) -> + (Ast.TyQuo (_loc, i) : 'typevars)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" as n)), s) -> + (Ast.TyAnt (_loc, mk_anti ~c: "ctyp" n s) : + 'typevars) + | _ -> assert false))); + ([ Gram.Sself; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'typevars) (t1 : 'typevars) + (_loc : Loc.t) -> + (Ast.TyApp (_loc, t1, t2) : 'typevars)))) ]) ])) + ()); + Gram.extend (row_field : 'row_field Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) (_loc : Loc.t) -> + (t : 'row_field)))); + ([ Gram.Skeyword "`"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)); + Gram.Skeyword "of"; + Gram.Snterm + (Gram.Entry.obj + (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'amp_ctyp) _ (i : 'a_ident) _ + (_loc : Loc.t) -> + (Ast.TyOf (_loc, Ast.TyVrn (_loc, i), t) : + 'row_field)))); + ([ Gram.Skeyword "`"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)); + Gram.Skeyword "of"; Gram.Skeyword "&"; + Gram.Snterm + (Gram.Entry.obj + (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'amp_ctyp) _ _ (i : 'a_ident) _ + (_loc : Loc.t) -> + (Ast.TyOfAmp (_loc, Ast.TyVrn (_loc, i), t) : + 'row_field)))); + ([ Gram.Skeyword "`"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_ident) _ (_loc : Loc.t) -> + (Ast.TyVrn (_loc, i) : 'row_field)))); + ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'row_field) _ (t1 : 'row_field) + (_loc : Loc.t) -> + (Ast.TyOr (_loc, t1, t2) : 'row_field)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" as n)), s) -> + (Ast.TyAnt (_loc, mk_anti ~c: "ctyp" n s) : + 'row_field) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (sem_ctyp : 'sem_ctyp Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) (_loc : Loc.t) -> + (t : 'sem_ctyp)))); + ([ Gram.Sself; Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'sem_ctyp) _ (t1 : 'sem_ctyp) + (_loc : Loc.t) -> + (Ast.TySem (_loc, t1, t2) : 'sem_ctyp)))) ]) ])) + ()); + Gram.extend (pipe_ctyp : 'pipe_ctyp Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) (_loc : Loc.t) -> + (t : 'pipe_ctyp)))); + ([ Gram.Sself; Gram.Skeyword "|"; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'pipe_ctyp) _ (t1 : 'pipe_ctyp) + (_loc : Loc.t) -> + (Ast.TyOr (_loc, t1, t2) : 'pipe_ctyp)))) ]) ])) + ()); + Gram.extend (amp_ctyp : 'amp_ctyp Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) (_loc : Loc.t) -> + (t : 'amp_ctyp)))); + ([ Gram.Sself; Gram.Skeyword "&"; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'amp_ctyp) _ (t1 : 'amp_ctyp) + (_loc : Loc.t) -> + (Ast.TyAmp (_loc, t1, t2) : 'amp_ctyp)))) ]) ])) + ()); + Gram.extend (name_tags : 'name_tags Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "`"; + Gram.Snterm + (Gram.Entry.obj + (a_ident : 'a_ident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_ident) _ (_loc : Loc.t) -> + (Ast.TyVrn (_loc, i) : 'name_tags)))); + ([ Gram.Sself; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'name_tags) (t1 : 'name_tags) + (_loc : Loc.t) -> + (Ast.TyApp (_loc, t1, t2) : 'name_tags)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "typ"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"typ\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "typ" as n)), s) -> + (Ast.TyAnt (_loc, mk_anti ~c: "ctyp" n s) : + 'name_tags) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (eq_expr : 'eq_expr Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (fun i p -> Ast.PaOlb (_loc, i, p) : + 'eq_expr)))); + ([ Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (_loc : Loc.t) -> + (fun i p -> Ast.PaOlbi (_loc, i, p, e) : + 'eq_expr)))) ]) ])) + ()); + Gram.extend (patt_tcon : 'patt_tcon Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'patt) (_loc : Loc.t) -> + (p : 'patt_tcon)))); + ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) _ (p : 'patt) (_loc : Loc.t) -> + (Ast.PaTyc (_loc, p, t) : 'patt_tcon)))) ]) ])) + ()); + Gram.extend (ipatt : 'ipatt Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "?"; Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (e : 'expr) _ (p : 'ipatt_tcon) _ _ + (_loc : Loc.t) -> + (Ast.PaOlbi (_loc, "", p, e) : 'ipatt)))); + ([ Gram.Skeyword "?"; Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (p : 'ipatt_tcon) _ _ (_loc : Loc.t) -> + (Ast.PaOlb (_loc, "", p) : 'ipatt)))); + ([ Gram.Skeyword "?"; + Gram.Stoken + (((function + | ANTIQUOT (("" | "lid"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"lid\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) _ + (_loc : Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "lid" as n)), i) -> + (Ast.PaOlb (_loc, mk_anti n i, + Ast.PaNil _loc) : + 'ipatt) + | _ -> assert false))); + ([ Gram.Skeyword "?"; + Gram.Stoken + (((function | LIDENT _ -> true | _ -> false), + "LIDENT _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) _ + (_loc : Loc.t) -> + match __camlp4_0 with + | LIDENT i -> + (Ast.PaOlb (_loc, i, Ast.PaNil _loc) : + 'ipatt) + | _ -> assert false))); + ([ Gram.Skeyword "?"; + Gram.Stoken + (((function + | ANTIQUOT (("" | "lid"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"lid\"), _)")); + Gram.Skeyword ":"; Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (eq_expr : 'eq_expr Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (f : 'eq_expr) (p : 'ipatt_tcon) _ _ + (__camlp4_0 : Gram.Token.t) _ (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "lid" as n)), i) -> + (f (mk_anti n i) p : 'ipatt) + | _ -> assert false))); + ([ Gram.Stoken + (((function | OPTLABEL _ -> true | _ -> false), + "OPTLABEL _")); + Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj + (ipatt_tcon : 'ipatt_tcon Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (eq_expr : 'eq_expr Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (f : 'eq_expr) (p : 'ipatt_tcon) _ + (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) -> + match __camlp4_0 with + | OPTLABEL i -> (f i p : 'ipatt) + | _ -> assert false))); + ([ Gram.Skeyword "~"; + Gram.Stoken + (((function | LIDENT _ -> true | _ -> false), + "LIDENT _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) _ + (_loc : Loc.t) -> + match __camlp4_0 with + | LIDENT i -> + (Ast.PaLab (_loc, i, Ast.PaNil _loc) : + 'ipatt) + | _ -> assert false))); + ([ Gram.Skeyword "~"; + Gram.Stoken + (((function + | ANTIQUOT (("" | "lid"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"lid\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) _ + (_loc : Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "lid" as n)), i) -> + (Ast.PaLab (_loc, mk_anti n i, + Ast.PaNil _loc) : + 'ipatt) + | _ -> assert false))); + ([ Gram.Skeyword "~"; + Gram.Stoken + (((function + | ANTIQUOT (("" | "lid"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"lid\"), _)")); + Gram.Skeyword ":"; Gram.Sself ], + (Gram.Action.mk + (fun (p : 'ipatt) _ (__camlp4_0 : Gram.Token.t) + _ (_loc : Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" | "lid" as n)), i) -> + (Ast.PaLab (_loc, mk_anti n i, p) : + 'ipatt) + | _ -> assert false))); + ([ Gram.Stoken + (((function | LABEL _ -> true | _ -> false), + "LABEL _")); + Gram.Sself ], + (Gram.Action.mk + (fun (p : 'ipatt) (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | LABEL i -> + (Ast.PaLab (_loc, i, p) : 'ipatt) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (ipatt_tcon : 'ipatt_tcon Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'ipatt) (_loc : Loc.t) -> + (p : 'ipatt_tcon)))); + ([ Gram.Snterm + (Gram.Entry.obj (ipatt : 'ipatt Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'ctyp) _ (p : 'ipatt) (_loc : Loc.t) + -> (Ast.PaTyc (_loc, p, t) : 'ipatt_tcon)))) ]) ])) + ()); + Gram.extend (direction_flag : 'direction_flag Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function + | ANTIQUOT ("to", _) -> true + | _ -> false), + "ANTIQUOT (\"to\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("to" as n)), s) -> + (Ast.BAnt (mk_anti n s) : + 'direction_flag) + | _ -> assert false))); + ([ Gram.Skeyword "downto" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> + (Ast.BFalse : 'direction_flag)))); + ([ Gram.Skeyword "to" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> + (Ast.BTrue : 'direction_flag)))) ]) ])) + ()); + Gram.extend (opt_private : 'opt_private Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.BFalse : 'opt_private)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("private", _) -> true + | _ -> false), + "ANTIQUOT (\"private\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("private" as n)), s) -> + (Ast.BAnt (mk_anti n s) : 'opt_private) + | _ -> assert false))); + ([ Gram.Skeyword "private" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> + (Ast.BTrue : 'opt_private)))) ]) ])) + ()); + Gram.extend (opt_mutable : 'opt_mutable Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.BFalse : 'opt_mutable)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("mutable", _) -> true + | _ -> false), + "ANTIQUOT (\"mutable\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("mutable" as n)), s) -> + (Ast.BAnt (mk_anti n s) : 'opt_mutable) + | _ -> assert false))); + ([ Gram.Skeyword "mutable" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> + (Ast.BTrue : 'opt_mutable)))) ]) ])) + ()); + Gram.extend (opt_virtual : 'opt_virtual Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.BFalse : 'opt_virtual)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("virtual", _) -> true + | _ -> false), + "ANTIQUOT (\"virtual\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("virtual" as n)), s) -> + (Ast.BAnt (mk_anti n s) : 'opt_virtual) + | _ -> assert false))); + ([ Gram.Skeyword "virtual" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> + (Ast.BTrue : 'opt_virtual)))) ]) ])) + ()); + Gram.extend (opt_dot_dot : 'opt_dot_dot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.BFalse : 'opt_dot_dot)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("..", _) -> true + | _ -> false), + "ANTIQUOT (\"..\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT (((".." as n)), s) -> + (Ast.BAnt (mk_anti n s) : 'opt_dot_dot) + | _ -> assert false))); + ([ Gram.Skeyword ".." ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> + (Ast.BTrue : 'opt_dot_dot)))) ]) ])) + ()); + Gram.extend (opt_rec : 'opt_rec Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> (Ast.BFalse : 'opt_rec)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("rec", _) -> true + | _ -> false), + "ANTIQUOT (\"rec\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("rec" as n)), s) -> + (Ast.BAnt (mk_anti n s) : 'opt_rec) + | _ -> assert false))); + ([ Gram.Skeyword "rec" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> (Ast.BTrue : 'opt_rec)))) ]) ])) + ()); + Gram.extend (opt_expr : 'opt_expr Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.ExNil _loc : 'opt_expr)))); + ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) (_loc : Loc.t) -> + (e : 'opt_expr)))) ]) ])) + ()); + Gram.extend (interf : 'interf Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | EOI -> true | _ -> false), "EOI")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | EOI -> (([], None) : 'interf) + | _ -> assert false))); + ([ Gram.Snterm + (Gram.Entry.obj + (sig_item : 'sig_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun ((sil, stopped) : 'interf) _ + (si : 'sig_item) (_loc : Loc.t) -> + (((si :: sil), stopped) : 'interf)))); + ([ Gram.Skeyword "#"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_expr : 'opt_expr Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ + (_loc : Loc.t) -> + (([ Ast.SgDir (_loc, n, dp) ], + (stopped_at _loc)) : 'interf)))) ]) ])) + ()); + Gram.extend (sig_items : 'sig_items Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Slist0 + (Gram.srules sig_items + [ ([ Gram.Snterm + (Gram.Entry.obj + (sig_item : + 'sig_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (semi : 'semi Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (sg : 'sig_item) (_loc : Loc.t) + -> (sg : 'e__4)))) ]) ], + (Gram.Action.mk + (fun (l : 'e__4 list) (_loc : Loc.t) -> + (Ast.sgSem_of_list l : 'sig_items)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "sigi" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"sigi\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "sigi" | "anti" | "list" as n)), + s) -> + (Ast.SgAnt (_loc, + mk_anti n ~c: "sig_item" s) : + 'sig_items) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (implem : 'implem Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | EOI -> true | _ -> false), "EOI")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | EOI -> (([], None) : 'implem) + | _ -> assert false))); + ([ Gram.Snterm + (Gram.Entry.obj + (str_item : 'str_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun ((sil, stopped) : 'implem) _ + (si : 'str_item) (_loc : Loc.t) -> + (((si :: sil), stopped) : 'implem)))); + ([ Gram.Skeyword "#"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_expr : 'opt_expr Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ + (_loc : Loc.t) -> + (([ Ast.StDir (_loc, n, dp) ], + (stopped_at _loc)) : 'implem)))) ]) ])) + ()); + Gram.extend (str_items : 'str_items Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Slist0 + (Gram.srules str_items + [ ([ Gram.Snterm + (Gram.Entry.obj + (str_item : + 'str_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (semi : 'semi Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (st : 'str_item) (_loc : Loc.t) + -> (st : 'e__5)))) ]) ], + (Gram.Action.mk + (fun (l : 'e__5 list) (_loc : Loc.t) -> + (Ast.stSem_of_list l : 'str_items)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "stri" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"stri\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "stri" | "anti" | "list" as n)), + s) -> + (Ast.StAnt (_loc, + mk_anti n ~c: "str_item" s) : + 'str_items) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (top_phrase : 'top_phrase Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | EOI -> true | _ -> false), "EOI")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | EOI -> (None : 'top_phrase) + | _ -> assert false))); + ([ Gram.Snterm + (Gram.Entry.obj (phrase : 'phrase Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ph : 'phrase) (_loc : Loc.t) -> + (Some ph : 'top_phrase)))) ]) ])) + ()); + Gram.extend (use_file : 'use_file Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | EOI -> true | _ -> false), "EOI")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | EOI -> (([], None) : 'use_file) + | _ -> assert false))); + ([ Gram.Snterm + (Gram.Entry.obj + (str_item : 'str_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun ((sil, stopped) : 'use_file) _ + (si : 'str_item) (_loc : Loc.t) -> + (((si :: sil), stopped) : 'use_file)))); + ([ Gram.Skeyword "#"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_expr : 'opt_expr Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ + (_loc : Loc.t) -> + (([ Ast.StDir (_loc, n, dp) ], + (stopped_at _loc)) : 'use_file)))) ]) ])) + ()); + Gram.extend (phrase : 'phrase Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (str_item : 'str_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (st : 'str_item) (_loc : Loc.t) -> + (st : 'phrase)))); + ([ Gram.Skeyword "#"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_expr : 'opt_expr Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (dp : 'opt_expr) (n : 'a_LIDENT) _ + (_loc : Loc.t) -> + (Ast.StDir (_loc, n, dp) : 'phrase)))) ]) ])) + ()); + Gram.extend (a_INT : 'a_INT Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | INT (_, _) -> true | _ -> false), + "INT (_, _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | INT (_, s) -> (s : 'a_INT) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "int" | "`int"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"int\" | \"`int\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "int" | "`int" as n)), s) + -> (mk_anti n s : 'a_INT) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (a_INT32 : 'a_INT32 Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | INT32 (_, _) -> true | _ -> false), + "INT32 (_, _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | INT32 (_, s) -> (s : 'a_INT32) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "int32" | "`int32"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"int32\" | \"`int32\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "int32" | "`int32" as n)), + s) -> (mk_anti n s : 'a_INT32) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (a_INT64 : 'a_INT64 Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | INT64 (_, _) -> true | _ -> false), + "INT64 (_, _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | INT64 (_, s) -> (s : 'a_INT64) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "int64" | "`int64"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"int64\" | \"`int64\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "int64" | "`int64" as n)), + s) -> (mk_anti n s : 'a_INT64) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (a_NATIVEINT : 'a_NATIVEINT Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function + | NATIVEINT (_, _) -> true + | _ -> false), + "NATIVEINT (_, _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | NATIVEINT (_, s) -> (s : 'a_NATIVEINT) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT + (("" | "nativeint" | "`nativeint"), _) + -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"nativeint\" | \"`nativeint\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "nativeint" | "`nativeint" as n)), + s) -> (mk_anti n s : 'a_NATIVEINT) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (a_FLOAT : 'a_FLOAT Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | FLOAT (_, _) -> true | _ -> false), + "FLOAT (_, _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | FLOAT (_, s) -> (s : 'a_FLOAT) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "flo" | "`flo"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"flo\" | \"`flo\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "flo" | "`flo" as n)), s) + -> (mk_anti n s : 'a_FLOAT) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (a_CHAR : 'a_CHAR Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | CHAR (_, _) -> true | _ -> false), + "CHAR (_, _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | CHAR (_, s) -> (s : 'a_CHAR) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "chr" | "`chr"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"chr\" | \"`chr\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "chr" | "`chr" as n)), s) + -> (mk_anti n s : 'a_CHAR) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (a_UIDENT : 'a_UIDENT Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | UIDENT _ -> true | _ -> false), + "UIDENT _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | UIDENT s -> (s : 'a_UIDENT) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "uid"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"uid\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "uid" as n)), s) -> + (mk_anti n s : 'a_UIDENT) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (a_LIDENT : 'a_LIDENT Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | LIDENT _ -> true | _ -> false), + "LIDENT _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | LIDENT s -> (s : 'a_LIDENT) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "lid"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"lid\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "lid" as n)), s) -> + (mk_anti n s : 'a_LIDENT) + | _ -> assert false))) ]) ])) + ()); + Gram.extend + (a_LIDENT_or_operator : 'a_LIDENT_or_operator Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'a_LIDENT) (_loc : Loc.t) -> + (x : 'a_LIDENT_or_operator)))) ]) ])) + ()); + Gram.extend (a_LABEL : 'a_LABEL Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | LABEL _ -> true | _ -> false), + "LABEL _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | LABEL s -> (s : 'a_LABEL) + | _ -> assert false))); + ([ Gram.Skeyword "~"; + Gram.Stoken + (((function + | ANTIQUOT ("", _) -> true + | _ -> false), + "ANTIQUOT (\"\", _)")); + Gram.Skeyword ":" ], + (Gram.Action.mk + (fun _ (__camlp4_0 : Gram.Token.t) _ + (_loc : Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" as n)), s) -> + (mk_anti n s : 'a_LABEL) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (a_OPTLABEL : 'a_OPTLABEL Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | OPTLABEL _ -> true | _ -> false), + "OPTLABEL _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | OPTLABEL s -> (s : 'a_OPTLABEL) + | _ -> assert false))); + ([ Gram.Skeyword "?"; + Gram.Stoken + (((function + | ANTIQUOT ("", _) -> true + | _ -> false), + "ANTIQUOT (\"\", _)")); + Gram.Skeyword ":" ], + (Gram.Action.mk + (fun _ (__camlp4_0 : Gram.Token.t) _ + (_loc : Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" as n)), s) -> + (mk_anti n s : 'a_OPTLABEL) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (a_STRING : 'a_STRING Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function + | STRING (_, _) -> true + | _ -> false), + "STRING (_, _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | STRING (_, s) -> (s : 'a_STRING) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "str" | "`str"), _) -> + true + | _ -> false), + "ANTIQUOT ((\"\" | \"str\" | \"`str\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" | "str" | "`str" as n)), s) + -> (mk_anti n s : 'a_STRING) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (string_list : 'string_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function + | STRING (_, _) -> true + | _ -> false), + "STRING (_, _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | STRING (_, x) -> + (Ast.LCons (x, Ast.LNil) : 'string_list) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | STRING (_, _) -> true + | _ -> false), + "STRING (_, _)")); + Gram.Sself ], + (Gram.Action.mk + (fun (xs : 'string_list) + (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) -> + match __camlp4_0 with + | STRING (_, x) -> + (Ast.LCons (x, xs) : 'string_list) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "str_list"), _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"str_list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT (("" | "str_list"), s) -> + (Ast.LAnt (mk_anti "str_list" s) : + 'string_list) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (value_let : 'value_let Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "value" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> (() : 'value_let)))) ]) ])) + ()); + Gram.extend (value_val : 'value_val Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "value" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> (() : 'value_val)))) ]) ])) + ()); + Gram.extend (semi : 'semi Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword ";" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> (() : 'semi)))) ]) ])) + ()); + Gram.extend (expr_quot : 'expr_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.ExNil _loc : 'expr_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) (_loc : Loc.t) -> + (e : 'expr_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Skeyword ";"; + Gram.Snterm + (Gram.Entry.obj + (sem_expr : 'sem_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e2 : 'sem_expr) _ (e1 : 'expr) + (_loc : Loc.t) -> + (Ast.ExSem (_loc, e1, e2) : 'expr_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Skeyword ","; + Gram.Snterm + (Gram.Entry.obj + (comma_expr : 'comma_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e2 : 'comma_expr) _ (e1 : 'expr) + (_loc : Loc.t) -> + (Ast.ExCom (_loc, e1, e2) : 'expr_quot)))) ]) ])) + ()); + Gram.extend (patt_quot : 'patt_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.PaNil _loc : 'patt_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'patt) (_loc : Loc.t) -> + (x : 'patt_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'patt) _ (x : 'patt) (_loc : Loc.t) -> + (Ast.PaEq (_loc, x, y) : 'patt_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Skeyword ";"; + Gram.Snterm + (Gram.Entry.obj + (sem_patt : 'sem_patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'sem_patt) _ (x : 'patt) + (_loc : Loc.t) -> + (Ast.PaSem (_loc, x, y) : 'patt_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Skeyword ","; + Gram.Snterm + (Gram.Entry.obj + (comma_patt : 'comma_patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'comma_patt) _ (x : 'patt) + (_loc : Loc.t) -> + (Ast.PaCom (_loc, x, y) : 'patt_quot)))) ]) ])) + ()); + Gram.extend (ctyp_quot : 'ctyp_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.TyNil _loc : 'ctyp_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'more_ctyp) (_loc : Loc.t) -> + (x : 'ctyp_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)); + Gram.Skeyword "and"; + Gram.Snterm + (Gram.Entry.obj + (constructor_arg_list : + 'constructor_arg_list Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'constructor_arg_list) _ + (x : 'more_ctyp) (_loc : Loc.t) -> + (Ast.TyAnd (_loc, x, y) : 'ctyp_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)); + Gram.Skeyword "&"; + Gram.Snterm + (Gram.Entry.obj + (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'amp_ctyp) _ (x : 'more_ctyp) + (_loc : Loc.t) -> + (Ast.TyAmp (_loc, x, y) : 'ctyp_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)); + Gram.Skeyword "*"; + Gram.Snterm + (Gram.Entry.obj + (star_ctyp : 'star_ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'star_ctyp) _ (x : 'more_ctyp) + (_loc : Loc.t) -> + (Ast.TySta (_loc, x, y) : 'ctyp_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'more_ctyp) _ (x : 'more_ctyp) + (_loc : Loc.t) -> + (Ast.TyCol (_loc, x, y) : 'ctyp_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)); + Gram.Skeyword "of"; Gram.Skeyword "&"; + Gram.Snterm + (Gram.Entry.obj + (amp_ctyp : 'amp_ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'amp_ctyp) _ _ (x : 'more_ctyp) + (_loc : Loc.t) -> + (Ast.TyOfAmp (_loc, x, y) : 'ctyp_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)); + Gram.Skeyword "of"; + Gram.Snterm + (Gram.Entry.obj + (constructor_arg_list : + 'constructor_arg_list Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'constructor_arg_list) _ + (x : 'more_ctyp) (_loc : Loc.t) -> + (Ast.TyOf (_loc, x, y) : 'ctyp_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)); + Gram.Skeyword "|"; + Gram.Snterm + (Gram.Entry.obj + (pipe_ctyp : 'pipe_ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'pipe_ctyp) _ (x : 'more_ctyp) + (_loc : Loc.t) -> + (Ast.TyOr (_loc, x, y) : 'ctyp_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)); + Gram.Skeyword ";"; + Gram.Snterm + (Gram.Entry.obj + (sem_ctyp : 'sem_ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'sem_ctyp) _ (x : 'more_ctyp) + (_loc : Loc.t) -> + (Ast.TySem (_loc, x, y) : 'ctyp_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (more_ctyp : 'more_ctyp Gram.Entry.t)); + Gram.Skeyword ","; + Gram.Snterm + (Gram.Entry.obj + (comma_ctyp : 'comma_ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (y : 'comma_ctyp) _ (x : 'more_ctyp) + (_loc : Loc.t) -> + (Ast.TyCom (_loc, x, y) : 'ctyp_quot)))) ]) ])) + ()); + Gram.extend (more_ctyp : 'more_ctyp Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (type_parameter : + 'type_parameter Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'type_parameter) (_loc : Loc.t) -> + (x : 'more_ctyp)))); + ([ Gram.Snterm + (Gram.Entry.obj (ctyp : 'ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'ctyp) (_loc : Loc.t) -> + (x : 'more_ctyp)))); + ([ Gram.Skeyword "`"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'a_LIDENT) _ (_loc : Loc.t) -> + (Ast.TyVrn (_loc, x) : 'more_ctyp)))); + ([ Gram.Skeyword "mutable"; Gram.Sself ], + (Gram.Action.mk + (fun (x : 'more_ctyp) _ (_loc : Loc.t) -> + (Ast.TyMut (_loc, x) : 'more_ctyp)))) ]) ])) + ()); + Gram.extend (str_item_quot : 'str_item_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.StNil _loc : 'str_item_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (str_item : 'str_item Gram.Entry.t)) ], + (Gram.Action.mk + (fun (st : 'str_item) (_loc : Loc.t) -> + (st : 'str_item_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (str_item : 'str_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (st2 : 'str_item_quot) _ (st1 : 'str_item) + (_loc : Loc.t) -> + (Ast.StSem (_loc, st1, st2) : 'str_item_quot)))); + ([ Gram.Skeyword "#"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_expr : 'opt_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (dp : 'opt_expr) (n : 'a_LIDENT) _ + (_loc : Loc.t) -> + (Ast.StDir (_loc, n, dp) : 'str_item_quot)))) ]) ])) + ()); + Gram.extend (sig_item_quot : 'sig_item_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.SgNil _loc : 'sig_item_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (sig_item : 'sig_item Gram.Entry.t)) ], + (Gram.Action.mk + (fun (sg : 'sig_item) (_loc : Loc.t) -> + (sg : 'sig_item_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (sig_item : 'sig_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (sg2 : 'sig_item_quot) _ (sg1 : 'sig_item) + (_loc : Loc.t) -> + (Ast.SgSem (_loc, sg1, sg2) : 'sig_item_quot)))); + ([ Gram.Skeyword "#"; + Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_expr : 'opt_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (dp : 'opt_expr) (n : 'a_LIDENT) _ + (_loc : Loc.t) -> + (Ast.SgDir (_loc, n, dp) : 'sig_item_quot)))) ]) ])) + ()); + Gram.extend (module_type_quot : 'module_type_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'module_type) (_loc : Loc.t) -> + (x : 'module_type_quot)))) ]) ])) + ()); + Gram.extend (module_expr_quot : 'module_expr_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (module_expr : 'module_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'module_expr) (_loc : Loc.t) -> + (x : 'module_expr_quot)))) ]) ])) + ()); + Gram.extend (match_case_quot : 'match_case_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.McNil _loc : 'match_case_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (match_case : 'match_case Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'match_case) (_loc : Loc.t) -> + (x : 'match_case_quot)))) ]) ])) + ()); + Gram.extend (binding_quot : 'binding_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.BiNil _loc : 'binding_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_expr : 'label_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'label_expr) (_loc : Loc.t) -> + (x : 'binding_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (binding : 'binding Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'binding) (_loc : Loc.t) -> + (x : 'binding_quot)))); + ([ Gram.Sself; Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (b2 : 'binding_quot) _ (b1 : 'binding_quot) + (_loc : Loc.t) -> + (Ast.BiSem (_loc, b1, b2) : 'binding_quot)))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (b2 : 'binding_quot) _ (b1 : 'binding_quot) + (_loc : Loc.t) -> + (Ast.BiAnd (_loc, b1, b2) : 'binding_quot)))) ]) ])) + ()); + Gram.extend + (module_binding_quot : 'module_binding_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.MbNil _loc : 'module_binding_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (module_expr : 'module_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (me : 'module_expr) _ (mt : 'module_type) _ + (m : 'a_UIDENT) (_loc : Loc.t) -> + (Ast.MbColEq (_loc, m, mt, me) : + 'module_binding_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (mt : 'module_type) _ (m : 'a_UIDENT) + (_loc : Loc.t) -> + (Ast.MbCol (_loc, m, mt) : + 'module_binding_quot)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("", _) -> true + | _ -> false), + "ANTIQUOT (\"\", _)")); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (module_expr : 'module_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (me : 'module_expr) _ (mt : 'module_type) _ + (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" as n)), m) -> + (Ast.MbColEq (_loc, mk_anti n m, mt, me) : + 'module_binding_quot) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("", _) -> true + | _ -> false), + "ANTIQUOT (\"\", _)")); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (module_type : 'module_type Gram.Entry.t)) ], + (Gram.Action.mk + (fun (mt : 'module_type) _ + (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("" as n)), m) -> + (Ast.MbCol (_loc, mk_anti n m, mt) : + 'module_binding_quot) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("", _) -> true + | _ -> false), + "ANTIQUOT (\"\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ((("" as n)), s) -> + (Ast.MbAnt (_loc, + mk_anti ~c: "module_binding" n s) : + 'module_binding_quot) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("module_binding" | "anti"), _) + -> true + | _ -> false), + "ANTIQUOT ((\"module_binding\" | \"anti\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("module_binding" | "anti" as n)), s) + -> + (Ast.MbAnt (_loc, + mk_anti ~c: "module_binding" n s) : + 'module_binding_quot) + | _ -> assert false))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (b2 : 'module_binding_quot) _ + (b1 : 'module_binding_quot) (_loc : Loc.t) -> + (Ast.MbAnd (_loc, b1, b2) : + 'module_binding_quot)))) ]) ])) + ()); + Gram.extend (ident_quot : 'ident_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Sself; Gram.Sself ], + (Gram.Action.mk + (fun (j : 'ident_quot) (i : 'ident_quot) + (_loc : Loc.t) -> + (Ast.IdApp (_loc, i, j) : 'ident_quot)))) ]); + (None, None, + [ ([ Gram.Sself; Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (j : 'ident_quot) _ (i : 'ident_quot) + (_loc : Loc.t) -> + (Ast.IdAcc (_loc, i, j) : 'ident_quot)))) ]); + (None, None, + [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (i : 'ident_quot) _ (_loc : Loc.t) -> + (i : 'ident_quot)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "id" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")); + Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (i : 'ident_quot) _ + (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "id" | "anti" | "list" as n)), s) + -> + (Ast.IdAcc (_loc, + Ast.IdAnt (_loc, + mk_anti ~c: "ident" n s), + i) : + 'ident_quot) + | _ -> assert false))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) (_loc : Loc.t) -> + (Ast.IdLid (_loc, i) : 'ident_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_UIDENT : 'a_UIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_UIDENT) (_loc : Loc.t) -> + (Ast.IdUid (_loc, i) : 'ident_quot)))); + ([ Gram.Stoken + (((function + | ANTIQUOT (("" | "id" | "anti" | "list"), + _) -> true + | _ -> false), + "ANTIQUOT ((\"\" | \"id\" | \"anti\" | \"list\"), _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT + ((("" | "id" | "anti" | "list" as n)), s) + -> + (Ast.IdAnt (_loc, + mk_anti ~c: "ident" n s) : + 'ident_quot) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (class_expr_quot : 'class_expr_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.CeNil _loc : 'class_expr_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (class_expr : 'class_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'class_expr) (_loc : Loc.t) -> + (x : 'class_expr_quot)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("virtual", _) -> true + | _ -> false), + "ANTIQUOT (\"virtual\", _)")); + Gram.Snterm + (Gram.Entry.obj (ident : 'ident Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_comma_ctyp : + 'opt_comma_ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ot : 'opt_comma_ctyp) (i : 'ident) + (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("virtual" as n)), s) -> + (Ast.CeCon (_loc, + Ast.BAnt + (mk_anti ~c: "class_expr" n s), + i, ot) : + 'class_expr_quot) + | _ -> assert false))); + ([ Gram.Skeyword "virtual"; + Gram.Snterm + (Gram.Entry.obj + (class_name_and_param : + 'class_name_and_param Gram.Entry.t)) ], + (Gram.Action.mk + (fun ((i, ot) : 'class_name_and_param) _ + (_loc : Loc.t) -> + (Ast.CeCon (_loc, Ast.BTrue, + Ast.IdLid (_loc, i), ot) : + 'class_expr_quot)))); + ([ Gram.Sself; Gram.Skeyword "="; Gram.Sself ], + (Gram.Action.mk + (fun (ce2 : 'class_expr_quot) _ + (ce1 : 'class_expr_quot) (_loc : Loc.t) -> + (Ast.CeEq (_loc, ce1, ce2) : + 'class_expr_quot)))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (ce2 : 'class_expr_quot) _ + (ce1 : 'class_expr_quot) (_loc : Loc.t) -> + (Ast.CeAnd (_loc, ce1, ce2) : + 'class_expr_quot)))) ]) ])) + ()); + Gram.extend (class_type_quot : 'class_type_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.CtNil _loc : 'class_type_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (class_type_plus : + 'class_type_plus Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'class_type_plus) (_loc : Loc.t) -> + (x : 'class_type_quot)))); + ([ Gram.Stoken + (((function + | ANTIQUOT ("virtual", _) -> true + | _ -> false), + "ANTIQUOT (\"virtual\", _)")); + Gram.Snterm + (Gram.Entry.obj (ident : 'ident Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_comma_ctyp : + 'opt_comma_ctyp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ot : 'opt_comma_ctyp) (i : 'ident) + (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ((("virtual" as n)), s) -> + (Ast.CtCon (_loc, + Ast.BAnt + (mk_anti ~c: "class_type" n s), + i, ot) : + 'class_type_quot) + | _ -> assert false))); + ([ Gram.Skeyword "virtual"; + Gram.Snterm + (Gram.Entry.obj + (class_name_and_param : + 'class_name_and_param Gram.Entry.t)) ], + (Gram.Action.mk + (fun ((i, ot) : 'class_name_and_param) _ + (_loc : Loc.t) -> + (Ast.CtCon (_loc, Ast.BTrue, + Ast.IdLid (_loc, i), ot) : + 'class_type_quot)))); + ([ Gram.Sself; Gram.Skeyword ":"; Gram.Sself ], + (Gram.Action.mk + (fun (ct2 : 'class_type_quot) _ + (ct1 : 'class_type_quot) (_loc : Loc.t) -> + (Ast.CtCol (_loc, ct1, ct2) : + 'class_type_quot)))); + ([ Gram.Sself; Gram.Skeyword "="; Gram.Sself ], + (Gram.Action.mk + (fun (ct2 : 'class_type_quot) _ + (ct1 : 'class_type_quot) (_loc : Loc.t) -> + (Ast.CtEq (_loc, ct1, ct2) : + 'class_type_quot)))); + ([ Gram.Sself; Gram.Skeyword "and"; Gram.Sself ], + (Gram.Action.mk + (fun (ct2 : 'class_type_quot) _ + (ct1 : 'class_type_quot) (_loc : Loc.t) -> + (Ast.CtAnd (_loc, ct1, ct2) : + 'class_type_quot)))) ]) ])) + ()); + Gram.extend + (class_str_item_quot : 'class_str_item_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.CrNil _loc : 'class_str_item_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (class_str_item : + 'class_str_item Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'class_str_item) (_loc : Loc.t) -> + (x : 'class_str_item_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (class_str_item : + 'class_str_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (x2 : 'class_str_item_quot) _ + (x1 : 'class_str_item) (_loc : Loc.t) -> + (Ast.CrSem (_loc, x1, x2) : + 'class_str_item_quot)))) ]) ])) + ()); + Gram.extend + (class_sig_item_quot : 'class_sig_item_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.CgNil _loc : 'class_sig_item_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (class_sig_item : + 'class_sig_item Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'class_sig_item) (_loc : Loc.t) -> + (x : 'class_sig_item_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (class_sig_item : + 'class_sig_item Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (semi : 'semi Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (x2 : 'class_sig_item_quot) _ + (x1 : 'class_sig_item) (_loc : Loc.t) -> + (Ast.CgSem (_loc, x1, x2) : + 'class_sig_item_quot)))) ]) ])) + ()); + Gram.extend (with_constr_quot : 'with_constr_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> + (Ast.WcNil _loc : 'with_constr_quot)))); + ([ Gram.Snterm + (Gram.Entry.obj + (with_constr : 'with_constr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'with_constr) (_loc : Loc.t) -> + (x : 'with_constr_quot)))) ]) ])) + ()); + Gram.extend (patt_eoi : 'patt_eoi Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Stoken + (((function | EOI -> true | _ -> false), "EOI")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (x : 'patt) + (_loc : Loc.t) -> + match __camlp4_0 with + | EOI -> (x : 'patt_eoi) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (expr_eoi : 'expr_eoi Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Stoken + (((function | EOI -> true | _ -> false), "EOI")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (x : 'expr) + (_loc : Loc.t) -> + match __camlp4_0 with + | EOI -> (x : 'expr_eoi) + | _ -> assert false))) ]) ])) + ())) + end + let _ = let module M = Register.OCamlSyntaxExtension(Id)(Make) in () + end +module Camlp4QuotationCommon = + struct + open Camlp4 + (* -*- camlp4r -*- *) + (****************************************************************************) + (* *) + (* Objective Caml *) + (* *) + (* INRIA Rocquencourt *) + (* *) + (* Copyright 2002-2006 Institut National de Recherche en Informatique et *) + (* en Automatique. All rights reserved. This file is distributed under *) + (* the terms of the GNU Library General Public License, with the special *) + (* exception on linking described in LICENSE at the top of the Objective *) + (* Caml source tree. *) + (* *) + (****************************************************************************) + (* Authors: + * - Nicolas Pouillard: initial version + *) + module Id = + struct + let name = "Camlp4QuotationCommon" + let version = + "$Id: camlp4boot.ml,v 1.2 2007/02/26 16:32:47 ertai Exp $" + end + module Make + (Syntax : Sig.Camlp4Syntax) + (TheAntiquotSyntax : + Sig.AntiquotSyntax with module Ast = Sig.Camlp4AstToAst(Syntax.Ast)) = + struct + open Sig + include Syntax + (* Be careful an AntiquotSyntax module appears here *) + module MetaLocHere = Ast.Meta.MetaLoc + module MetaLoc = + struct + module Ast = Ast + let loc_name = ref None + let meta_loc_expr _loc loc = + match !loc_name with + | None -> Ast.ExId (_loc, Ast.IdLid (_loc, !Loc.name)) + | Some "here" -> MetaLocHere.meta_loc_expr _loc loc + | Some x -> Ast.ExId (_loc, Ast.IdLid (_loc, x)) + let meta_loc_patt _loc _ = Ast.PaAny _loc + end + module MetaAst = Ast.Meta.Make(MetaLoc) + module ME = MetaAst.Expr + module MP = MetaAst.Patt + let is_antiquot s = + let len = String.length s + in (len > 2) && ((s.[0] = '\\') && (s.[1] = '$')) + let handle_antiquot_in_string s term parse loc decorate = + if is_antiquot s + then + (let pos = String.index s ':' in + let name = String.sub s 2 (pos - 2) + and code = + String.sub s (pos + 1) (((String.length s) - pos) - 1) + in decorate name (parse loc code)) + else term + let antiquot_expander = + object + inherit Ast.map as super + method patt = + function + | (Ast.PaAnt (_loc, s) | Ast.PaStr (_loc, s) as p) -> + let mloc _loc = MetaLoc.meta_loc_patt _loc _loc + in + handle_antiquot_in_string s p TheAntiquotSyntax. + parse_patt _loc + (fun n p -> + match n with + | "antisig_item" -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgAnt"))), + mloc _loc), + p) + | "antistr_item" -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StAnt"))), + mloc _loc), + p) + | "antictyp" -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyAnt"))), + mloc _loc), + p) + | "antipatt" -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaAnt"))), + mloc _loc), + p) + | "antiexpr" -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExAnt"))), + mloc _loc), + p) + | "antimodule_type" -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MtAnt"))), + mloc _loc), + p) + | "antimodule_expr" -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MeAnt"))), + mloc _loc), + p) + | "anticlass_type" -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CtAnt"))), + mloc _loc), + p) + | "anticlass_expr" -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CeAnt"))), + mloc _loc), + p) + | "anticlass_sig_item" -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CgAnt"))), + mloc _loc), + p) + | "anticlass_str_item" -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CrAnt"))), + mloc _loc), + p) + | "antiwith_constr" -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "WcAnt"))), + mloc _loc), + p) + | "antibinding" -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "BiAnt"))), + mloc _loc), + p) + | "antimatch_case" -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "McAnt"))), + mloc _loc), + p) + | "antimodule_binding" -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MbAnt"))), + mloc _loc), + p) + | "antiident" -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "IdAnt"))), + mloc _loc), + p) + | _ -> p) + | p -> super#patt p + method expr = + function + | (Ast.ExAnt (_loc, s) | Ast.ExStr (_loc, s) as e) -> + let mloc _loc = MetaLoc.meta_loc_expr _loc _loc + in + handle_antiquot_in_string s e TheAntiquotSyntax. + parse_expr _loc + (fun n e -> + match n with + | "`int" -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdLid (_loc, "string_of_int")), + e) + | "`int32" -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Int32"), + Ast.IdLid (_loc, "to_string"))), + e) + | "`int64" -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Int64"), + Ast.IdLid (_loc, "to_string"))), + e) + | "`nativeint" -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Nativeint"), + Ast.IdLid (_loc, "to_string"))), + e) + | "`flo" -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdLid (_loc, "string_of_float")), + e) + | "`str" -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdLid (_loc, "safe_string_escaped"))), + e) + | "`chr" -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Char"), + Ast.IdLid (_loc, "escaped"))), + e) + | "liststr_item" -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdLid (_loc, "stSem_of_list"))), + e) + | "listsig_item" -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdLid (_loc, "sgSem_of_list"))), + e) + | "listclass_sig_item" -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdLid (_loc, "cgSem_of_list"))), + e) + | "listclass_str_item" -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdLid (_loc, "crSem_of_list"))), + e) + | "listmodule_expr" -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdLid (_loc, "meApp_of_list"))), + e) + | "listmodule_type" -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdLid (_loc, "mtApp_of_list"))), + e) + | "listmodule_binding" -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdLid (_loc, "mbAnd_of_list"))), + e) + | "listbinding" -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdLid (_loc, "biAnd_of_list"))), + e) + | "listbinding;" -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdLid (_loc, "biSem_of_list"))), + e) + | "listclass_type" -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdLid (_loc, "ctAnd_of_list"))), + e) + | "listclass_expr" -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdLid (_loc, "ceAnd_of_list"))), + e) + | "listident" -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdLid (_loc, "idAcc_of_list"))), + e) + | "listctypand" -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdLid (_loc, "tyAnd_of_list"))), + e) + | "listwith_constr" -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdLid (_loc, "wcAnd_of_list"))), + e) + | "listmatch_case" -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdLid (_loc, "mcOr_of_list"))), + e) + | "listpatt;" -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdLid (_loc, "paSem_of_list"))), + e) + | "antisig_item" -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "SgAnt"))), + mloc _loc), + e) + | "antistr_item" -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "StAnt"))), + mloc _loc), + e) + | "antictyp" -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "TyAnt"))), + mloc _loc), + e) + | "antipatt" -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaAnt"))), + mloc _loc), + e) + | "antiexpr" -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "ExAnt"))), + mloc _loc), + e) + | "antimodule_type" -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MtAnt"))), + mloc _loc), + e) + | "antimodule_expr" -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MeAnt"))), + mloc _loc), + e) + | "anticlass_type" -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CtAnt"))), + mloc _loc), + e) + | "anticlass_expr" -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CeAnt"))), + mloc _loc), + e) + | "anticlass_sig_item" -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CgAnt"))), + mloc _loc), + e) + | "anticlass_str_item" -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "CrAnt"))), + mloc _loc), + e) + | "antiwith_constr" -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "WcAnt"))), + mloc _loc), + e) + | "antibinding" -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "BiAnt"))), + mloc _loc), + e) + | "antimatch_case" -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "McAnt"))), + mloc _loc), + e) + | "antimodule_binding" -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "MbAnt"))), + mloc _loc), + e) + | "antiident" -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "IdAnt"))), + mloc _loc), + e) + | _ -> e) + | e -> super#expr e + end + let add_quotation name entry mexpr mpatt = + let entry_eoi = Gram.Entry.mk (Gram.Entry.name entry) in + let expand_expr loc loc_name_opt s = + let ast = Gram.parse_string entry_eoi loc s in + let () = MetaLoc.loc_name := loc_name_opt in + let meta_ast = mexpr loc ast in + let exp_ast = antiquot_expander#expr meta_ast in exp_ast in + let expand_patt _loc loc_name_opt s = + let ast = Gram.parse_string entry_eoi _loc s in + let meta_ast = mpatt _loc ast in + let exp_ast = antiquot_expander#patt meta_ast + in + match loc_name_opt with + | None -> exp_ast + | Some name -> + let rec subst_first_loc = + (function + | Ast.PaApp (_loc, + (Ast.PaId (_, + (Ast.IdAcc (_, (Ast.IdUid (_, "Ast")), + (Ast.IdUid (_, u)))))), + _) -> + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, u))), + Ast.PaId (_loc, Ast.IdLid (_loc, name))) + | Ast.PaApp (_loc, a, b) -> + Ast.PaApp (_loc, subst_first_loc a, b) + | p -> p) + in subst_first_loc exp_ast + in + (Gram.extend (entry_eoi : 'entry_eoi Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (entry : 'entry Gram.Entry.t)); + Gram.Stoken + (((function | EOI -> true | _ -> false), "EOI")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (x : 'entry) + (_loc : Loc.t) -> + match __camlp4_0 with + | EOI -> (x : 'entry_eoi) + | _ -> assert false))) ]) ])) + ()); + Quotation.add name + (Quotation.ExAst ((expand_expr, expand_patt)))) + let _ = + add_quotation "sig_item" sig_item_quot ME.meta_sig_item MP. + meta_sig_item + let _ = + add_quotation "str_item" str_item_quot ME.meta_str_item MP. + meta_str_item + let _ = add_quotation "ctyp" ctyp_quot ME.meta_ctyp MP.meta_ctyp + let _ = add_quotation "patt" patt_quot ME.meta_patt MP.meta_patt + let _ = add_quotation "expr" expr_quot ME.meta_expr MP.meta_expr + let _ = + add_quotation "module_type" module_type_quot ME.meta_module_type + MP.meta_module_type + let _ = + add_quotation "module_expr" module_expr_quot ME.meta_module_expr + MP.meta_module_expr + let _ = + add_quotation "class_type" class_type_quot ME.meta_class_type MP. + meta_class_type + let _ = + add_quotation "class_expr" class_expr_quot ME.meta_class_expr MP. + meta_class_expr + let _ = + add_quotation "class_sig_item" class_sig_item_quot ME. + meta_class_sig_item MP.meta_class_sig_item + let _ = + add_quotation "class_str_item" class_str_item_quot ME. + meta_class_str_item MP.meta_class_str_item + let _ = + add_quotation "with_constr" with_constr_quot ME.meta_with_constr + MP.meta_with_constr + let _ = + add_quotation "binding" binding_quot ME.meta_binding MP. + meta_binding + let _ = + add_quotation "match_case" match_case_quot ME.meta_match_case MP. + meta_match_case + let _ = + add_quotation "module_binding" module_binding_quot ME. + meta_module_binding MP.meta_module_binding + let _ = add_quotation "ident" ident_quot ME.meta_ident MP.meta_ident + end + end +module Q = + struct + open Camlp4 + (* -*- camlp4r -*- *) + (****************************************************************************) + (* *) + (* Objective Caml *) + (* *) + (* INRIA Rocquencourt *) + (* *) + (* Copyright 2002-2006 Institut National de Recherche en Informatique et *) + (* en Automatique. All rights reserved. This file is distributed under *) + (* the terms of the GNU Library General Public License, with the special *) + (* exception on linking described in LICENSE at the top of the Objective *) + (* Caml source tree. *) + (* *) + (****************************************************************************) + (* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + module Id = + struct + let name = "Camlp4QuotationExpander" + let version = + "$Id: camlp4boot.ml,v 1.2 2007/02/26 16:32:47 ertai Exp $" + end + module Make (Syntax : Sig.Camlp4Syntax) = + struct + module M = Camlp4QuotationCommon.Make(Syntax)(Syntax.AntiquotSyntax) + include M + end + let _ = let module M = Register.OCamlSyntaxExtension(Id)(Make) in () + end +module Rp = + struct + open Camlp4 + (* -*- camlp4r -*- *) + (****************************************************************************) + (* *) + (* Objective Caml *) + (* *) + (* INRIA Rocquencourt *) + (* *) + (* Copyright 1998-2006 Institut National de Recherche en Informatique et *) + (* en Automatique. All rights reserved. This file is distributed under *) + (* the terms of the GNU Library General Public License, with the special *) + (* exception on linking described in LICENSE at the top of the Objective *) + (* Caml source tree. *) + (* *) + (****************************************************************************) + (* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + module Id : Sig.Id = + struct + let name = "Camlp4OCamlRevisedParserParser" + let version = + "$Id: camlp4boot.ml,v 1.2 2007/02/26 16:32:47 ertai Exp $" + end + module Make (Syntax : Sig.Camlp4Syntax) = + struct + open Sig + include Syntax + type spat_comp = + | SpTrm of Loc.t * Ast.patt * Ast.expr option + | SpNtr of Loc.t * Ast.patt * Ast.expr | SpStr of Loc.t * Ast.patt + type sexp_comp = + | SeTrm of Loc.t * Ast.expr | SeNtr of Loc.t * Ast.expr + let stream_expr = Gram.Entry.mk "stream_expr" + let stream_begin = Gram.Entry.mk "stream_begin" + let stream_end = Gram.Entry.mk "stream_end" + let stream_quot = Gram.Entry.mk "stream_quot" + let parser_case = Gram.Entry.mk "parser_case" + let parser_case_list = Gram.Entry.mk "parser_case_list" + let strm_n = "__strm" + let peek_fun _loc = + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Stream"), + Ast.IdLid (_loc, "peek"))) + let junk_fun _loc = + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Stream"), + Ast.IdLid (_loc, "junk"))) + (* Parsers. *) + (* In syntax generated, many cases are optimisations. *) + let rec pattern_eq_expression p e = + match (p, e) with + | (Ast.PaId (_, (Ast.IdLid (_, a))), + Ast.ExId (_, (Ast.IdLid (_, b)))) -> a = b + | (Ast.PaId (_, (Ast.IdUid (_, a))), + Ast.ExId (_, (Ast.IdUid (_, b)))) -> a = b + | (Ast.PaApp (_, p1, p2), Ast.ExApp (_, e1, e2)) -> + (pattern_eq_expression p1 e1) && (pattern_eq_expression p2 e2) + | _ -> false + let is_raise e = + match e with + | Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, "raise")))), _) -> + true + | _ -> false + let is_raise_failure e = + match e with + | Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, "raise")))), + (Ast.ExId (_, + (Ast.IdAcc (_, (Ast.IdUid (_, "Stream")), + (Ast.IdUid (_, "Failure"))))))) + -> true + | _ -> false + let rec handle_failure e = + match e with + | Ast.ExTry (_, _, + (Ast.McArr (_, + (Ast.PaId (_, + (Ast.IdAcc (_, (Ast.IdUid (_, "Stream")), + (Ast.IdUid (_, "Failure")))))), + (Ast.ExNil _), e))) + -> handle_failure e + | Ast.ExMat (_, me, a) -> + let rec match_case_handle_failure = + (function + | Ast.McOr (_, a1, a2) -> + (match_case_handle_failure a1) && + (match_case_handle_failure a2) + | Ast.McArr (_, _, (Ast.ExNil _), e) -> handle_failure e + | _ -> false) + in (handle_failure me) && (match_case_handle_failure a) + | Ast.ExLet (_, Ast.BFalse, bi, e) -> + let rec binding_handle_failure = + (function + | Ast.BiAnd (_, b1, b2) -> + (binding_handle_failure b1) && + (binding_handle_failure b2) + | Ast.BiEq (_, _, e) -> handle_failure e + | _ -> false) + in (binding_handle_failure bi) && (handle_failure e) + | Ast.ExId (_, (Ast.IdLid (_, _))) | Ast.ExInt (_, _) | + Ast.ExStr (_, _) | Ast.ExChr (_, _) | Ast.ExFun (_, _) | + Ast.ExId (_, (Ast.IdUid (_, _))) -> true + | Ast.ExApp (_, (Ast.ExId (_, (Ast.IdLid (_, "raise")))), e) -> + (match e with + | Ast.ExId (_, + (Ast.IdAcc (_, (Ast.IdUid (_, "Stream")), + (Ast.IdUid (_, "Failure"))))) + -> false + | _ -> true) + | Ast.ExApp (_, f, x) -> + (is_constr_apply f) && + ((handle_failure f) && (handle_failure x)) + | _ -> false + and is_constr_apply = + function + | Ast.ExId (_, (Ast.IdUid (_, _))) -> true + | Ast.ExId (_, (Ast.IdLid (_, _))) -> false + | Ast.ExApp (_, x, _) -> is_constr_apply x + | _ -> false + let rec subst v e = + let _loc = Ast.loc_of_expr e + in + match e with + | Ast.ExId (_, (Ast.IdLid (_, x))) -> + let x = if x = v then strm_n else x + in Ast.ExId (_loc, Ast.IdLid (_loc, x)) + | Ast.ExId (_, (Ast.IdUid (_, _))) -> e + | Ast.ExInt (_, _) -> e + | Ast.ExChr (_, _) -> e + | Ast.ExStr (_, _) -> e + | Ast.ExAcc (_, _, _) -> e + | Ast.ExLet (_, rf, bi, e) -> + Ast.ExLet (_loc, rf, subst_binding v bi, subst v e) + | Ast.ExApp (_, e1, e2) -> + Ast.ExApp (_loc, subst v e1, subst v e2) + | Ast.ExTup (_, e) -> Ast.ExTup (_loc, subst v e) + | Ast.ExCom (_, e1, e2) -> + Ast.ExCom (_loc, subst v e1, subst v e2) + | _ -> raise Not_found + and subst_binding v = + function + | Ast.BiAnd (_loc, b1, b2) -> + Ast.BiAnd (_loc, subst_binding v b1, subst_binding v b2) + | Ast.BiEq (_loc, (Ast.PaId (_, (Ast.IdLid (_, v')))), e) -> + Ast.BiEq (_loc, Ast.PaId (_loc, Ast.IdLid (_loc, v')), + if v = v' then e else subst v e) + | _ -> raise Not_found + let stream_pattern_component skont ckont = + function + | SpTrm (_loc, p, None) -> + Ast.ExMat (_loc, + Ast.ExApp (_loc, peek_fun _loc, + Ast.ExId (_loc, Ast.IdLid (_loc, strm_n))), + Ast.McOr (_loc, + Ast.McArr (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, Ast.IdUid (_loc, "Some")), p), + Ast.ExNil _loc, + Ast.ExSeq (_loc, + Ast.ExSem (_loc, + Ast.ExApp (_loc, junk_fun _loc, + Ast.ExId (_loc, Ast.IdLid (_loc, strm_n))), + skont))), + Ast.McArr (_loc, Ast.PaAny _loc, Ast.ExNil _loc, ckont))) + | SpTrm (_loc, p, (Some w)) -> + Ast.ExMat (_loc, + Ast.ExApp (_loc, peek_fun _loc, + Ast.ExId (_loc, Ast.IdLid (_loc, strm_n))), + Ast.McOr (_loc, + Ast.McArr (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, Ast.IdUid (_loc, "Some")), p), + w, + Ast.ExSeq (_loc, + Ast.ExSem (_loc, + Ast.ExApp (_loc, junk_fun _loc, + Ast.ExId (_loc, Ast.IdLid (_loc, strm_n))), + skont))), + Ast.McArr (_loc, Ast.PaAny _loc, Ast.ExNil _loc, ckont))) + | SpNtr (_loc, p, e) -> + let e = + (match e with + | Ast.ExFun (_, + (Ast.McArr (_, + (Ast.PaTyc (_, (Ast.PaId (_, (Ast.IdLid (_, v)))), + (Ast.TyApp (_, + (Ast.TyId (_, + (Ast.IdAcc (_, (Ast.IdUid (_, "Stream")), + (Ast.IdLid (_, "t")))))), + (Ast.TyAny _))))), + (Ast.ExNil _), e))) + when v = strm_n -> e + | _ -> + Ast.ExApp (_loc, e, + Ast.ExId (_loc, Ast.IdLid (_loc, strm_n)))) + in + if pattern_eq_expression p skont + then + if is_raise_failure ckont + then e + else + if handle_failure e + then e + else + Ast.ExTry (_loc, e, + Ast.McArr (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Stream"), + Ast.IdUid (_loc, "Failure"))), + Ast.ExNil _loc, ckont)) + else + if is_raise_failure ckont + then + Ast.ExLet (_loc, Ast.BFalse, Ast.BiEq (_loc, p, e), + skont) + else + if + pattern_eq_expression + (Ast.PaApp (_loc, + Ast.PaId (_loc, Ast.IdUid (_loc, "Some")), p)) + skont + then + Ast.ExTry (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdUid (_loc, "Some")), e), + Ast.McArr (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Stream"), + Ast.IdUid (_loc, "Failure"))), + Ast.ExNil _loc, ckont)) + else + if is_raise ckont + then + (let tst = + if handle_failure e + then e + else + Ast.ExTry (_loc, e, + Ast.McArr (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Stream"), + Ast.IdUid (_loc, "Failure"))), + Ast.ExNil _loc, ckont)) + in + Ast.ExLet (_loc, Ast.BFalse, + Ast.BiEq (_loc, p, tst), skont)) + else + Ast.ExMat (_loc, + Ast.ExTry (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdUid (_loc, "Some")), e), + Ast.McArr (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Stream"), + Ast.IdUid (_loc, "Failure"))), + Ast.ExNil _loc, + Ast.ExId (_loc, Ast.IdUid (_loc, "None")))), + Ast.McOr (_loc, + Ast.McArr (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, Ast.IdUid (_loc, "Some")), p), + Ast.ExNil _loc, skont), + Ast.McArr (_loc, Ast.PaAny _loc, Ast.ExNil _loc, + ckont))) + | SpStr (_loc, p) -> + (try + match p with + | Ast.PaId (_, (Ast.IdLid (_, v))) -> subst v skont + | _ -> raise Not_found + with + | Not_found -> + Ast.ExLet (_loc, Ast.BFalse, + Ast.BiEq (_loc, p, + Ast.ExId (_loc, Ast.IdLid (_loc, strm_n))), + skont)) + let rec stream_pattern _loc epo e ekont = + function + | [] -> + (match epo with + | Some ep -> + Ast.ExLet (_loc, Ast.BFalse, + Ast.BiEq (_loc, ep, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Stream"), + Ast.IdLid (_loc, "count"))), + Ast.ExId (_loc, Ast.IdLid (_loc, strm_n)))), + e) + | _ -> e) + | (spc, err) :: spcl -> + let skont = + let ekont err = + let str = + (match err with + | Some estr -> estr + | _ -> Ast.ExStr (_loc, "")) + in + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "raise")), + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Stream"), + Ast.IdUid (_loc, "Error"))), + str)) + in stream_pattern _loc epo e ekont spcl in + let ckont = ekont err + in stream_pattern_component skont ckont spc + let stream_patterns_term _loc ekont tspel = + let pel = + List.fold_right + (fun (p, w, _loc, spcl, epo, e) acc -> + let p = + Ast.PaApp (_loc, + Ast.PaId (_loc, Ast.IdUid (_loc, "Some")), p) in + let e = + let ekont err = + let str = + match err with + | Some estr -> estr + | _ -> Ast.ExStr (_loc, "") + in + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "raise")), + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Stream"), + Ast.IdUid (_loc, "Error"))), + str)) in + let skont = stream_pattern _loc epo e ekont spcl + in + Ast.ExSeq (_loc, + Ast.ExSem (_loc, + Ast.ExApp (_loc, junk_fun _loc, + Ast.ExId (_loc, Ast.IdLid (_loc, strm_n))), + skont)) + in + match w with + | Some w -> + Ast.McOr (_loc, Ast.McArr (_loc, p, w, e), acc) + | None -> + Ast.McOr (_loc, + Ast.McArr (_loc, p, Ast.ExNil _loc, e), acc)) + tspel (Ast.McNil _loc) + in + Ast.ExMat (_loc, + Ast.ExApp (_loc, peek_fun _loc, + Ast.ExId (_loc, Ast.IdLid (_loc, strm_n))), + Ast.McOr (_loc, pel, + Ast.McArr (_loc, Ast.PaAny _loc, Ast.ExNil _loc, ekont ()))) + let rec group_terms = + function + | ((SpTrm (_loc, p, w), None) :: spcl, epo, e) :: spel -> + let (tspel, spel) = group_terms spel + in (((p, w, _loc, spcl, epo, e) :: tspel), spel) + | spel -> ([], spel) + let rec parser_cases _loc = + function + | [] -> + Ast.ExApp (_loc, Ast.ExId (_loc, Ast.IdLid (_loc, "raise")), + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Stream"), + Ast.IdUid (_loc, "Failure")))) + | spel -> + (match group_terms spel with + | ([], (spcl, epo, e) :: spel) -> + stream_pattern _loc epo e + (fun _ -> parser_cases _loc spel) spcl + | (tspel, spel) -> + stream_patterns_term _loc + (fun _ -> parser_cases _loc spel) tspel) + let cparser _loc bpo pc = + let e = parser_cases _loc pc in + let e = + match bpo with + | Some bp -> + Ast.ExLet (_loc, Ast.BFalse, + Ast.BiEq (_loc, bp, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Stream"), + Ast.IdLid (_loc, "count"))), + Ast.ExId (_loc, Ast.IdLid (_loc, strm_n)))), + e) + | None -> e in + let p = + Ast.PaTyc (_loc, Ast.PaId (_loc, Ast.IdLid (_loc, strm_n)), + Ast.TyApp (_loc, + Ast.TyId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Stream"), + Ast.IdLid (_loc, "t"))), + Ast.TyAny _loc)) + in Ast.ExFun (_loc, Ast.McArr (_loc, p, Ast.ExNil _loc, e)) + let cparser_match _loc me bpo pc = + let pc = parser_cases _loc pc in + let e = + match bpo with + | Some bp -> + Ast.ExLet (_loc, Ast.BFalse, + Ast.BiEq (_loc, bp, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Stream"), + Ast.IdLid (_loc, "count"))), + Ast.ExId (_loc, Ast.IdLid (_loc, strm_n)))), + pc) + | None -> pc + in + match me with + | Ast.ExId (_, (Ast.IdLid (_, x))) when x = strm_n -> e + | _ -> + Ast.ExLet (_loc, Ast.BFalse, + Ast.BiEq (_loc, + Ast.PaTyc (_loc, + Ast.PaId (_loc, Ast.IdLid (_loc, strm_n)), + Ast.TyApp (_loc, + Ast.TyId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Stream"), + Ast.IdLid (_loc, "t"))), + Ast.TyAny _loc)), + me), + e) + (* streams *) + let rec not_computing = + function + | Ast.ExId (_, (Ast.IdLid (_, _))) | + Ast.ExId (_, (Ast.IdUid (_, _))) | Ast.ExInt (_, _) | + Ast.ExFlo (_, _) | Ast.ExChr (_, _) | Ast.ExStr (_, _) -> true + | Ast.ExApp (_, x, y) -> + (is_cons_apply_not_computing x) && (not_computing y) + | _ -> false + and is_cons_apply_not_computing = + function + | Ast.ExId (_, (Ast.IdUid (_, _))) -> true + | Ast.ExId (_, (Ast.IdLid (_, _))) -> false + | Ast.ExApp (_, x, y) -> + (is_cons_apply_not_computing x) && (not_computing y) + | _ -> false + let slazy _loc e = + match e with + | Ast.ExApp (_, f, (Ast.ExId (_, (Ast.IdUid (_, "()"))))) -> + (match f with + | Ast.ExId (_, (Ast.IdLid (_, _))) -> f + | _ -> + Ast.ExFun (_loc, + Ast.McArr (_loc, Ast.PaAny _loc, Ast.ExNil _loc, e))) + | _ -> + Ast.ExFun (_loc, + Ast.McArr (_loc, Ast.PaAny _loc, Ast.ExNil _loc, e)) + let rec cstream gloc = + function + | [] -> + let _loc = gloc + in + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Stream"), + Ast.IdLid (_loc, "sempty"))) + | [ SeTrm (_loc, e) ] -> + if not_computing e + then + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Stream"), + Ast.IdLid (_loc, "ising"))), + e) + else + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Stream"), + Ast.IdLid (_loc, "lsing"))), + slazy _loc e) + | SeTrm (_loc, e) :: secl -> + if not_computing e + then + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Stream"), + Ast.IdLid (_loc, "icons"))), + e), + cstream gloc secl) + else + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Stream"), + Ast.IdLid (_loc, "lcons"))), + slazy _loc e), + cstream gloc secl) + | [ SeNtr (_loc, e) ] -> + if not_computing e + then e + else + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Stream"), + Ast.IdLid (_loc, "slazy"))), + slazy _loc e) + | SeNtr (_loc, e) :: secl -> + if not_computing e + then + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Stream"), + Ast.IdLid (_loc, "iapp"))), + e), + cstream gloc secl) + else + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Stream"), + Ast.IdLid (_loc, "lapp"))), + slazy _loc e), + cstream gloc secl) + (* Syntax extensions in Revised Syntax grammar *) + let _ = + let _ = (expr : 'expr Gram.Entry.t) + and _ = (parser_case_list : 'parser_case_list Gram.Entry.t) + and _ = (parser_case : 'parser_case Gram.Entry.t) + and _ = (stream_quot : 'stream_quot Gram.Entry.t) + and _ = (stream_end : 'stream_end Gram.Entry.t) + and _ = (stream_begin : 'stream_begin Gram.Entry.t) + and _ = (stream_expr : 'stream_expr Gram.Entry.t) in + let grammar_entry_create = Gram.Entry.mk in + let stream_patt : 'stream_patt Gram.Entry.t = + grammar_entry_create "stream_patt" + and stream_expr_comp : 'stream_expr_comp Gram.Entry.t = + grammar_entry_create "stream_expr_comp" + and stream_expr_comp_list : 'stream_expr_comp_list Gram.Entry.t = + grammar_entry_create "stream_expr_comp_list" + and parser_ipatt : 'parser_ipatt Gram.Entry.t = + grammar_entry_create "parser_ipatt" + and stream_patt_comp : 'stream_patt_comp Gram.Entry.t = + grammar_entry_create "stream_patt_comp" + and stream_patt_comp_err_list : + 'stream_patt_comp_err_list Gram.Entry.t = + grammar_entry_create "stream_patt_comp_err_list" + and stream_patt_comp_err : 'stream_patt_comp_err Gram.Entry.t = + grammar_entry_create "stream_patt_comp_err" + in + (Gram.extend (expr : 'expr Gram.Entry.t) + ((fun () -> + ((Some (Camlp4.Sig.Grammar.Level "top")), + [ (None, None, + [ ([ Gram.Skeyword "match"; Gram.Sself; + Gram.Skeyword "with"; Gram.Skeyword "parser"; + Gram.Sopt + (Gram.Snterm + (Gram.Entry.obj + (parser_ipatt : + 'parser_ipatt Gram.Entry.t))); + Gram.Snterm + (Gram.Entry.obj + (parser_case_list : + 'parser_case_list Gram.Entry.t)) ], + (Gram.Action.mk + (fun (pcl : 'parser_case_list) + (po : 'parser_ipatt option) _ _ (e : 'expr) _ + (_loc : Loc.t) -> + (cparser_match _loc e po pcl : 'expr)))); + ([ Gram.Skeyword "parser"; + Gram.Sopt + (Gram.Snterm + (Gram.Entry.obj + (parser_ipatt : + 'parser_ipatt Gram.Entry.t))); + Gram.Snterm + (Gram.Entry.obj + (parser_case_list : + 'parser_case_list Gram.Entry.t)) ], + (Gram.Action.mk + (fun (pcl : 'parser_case_list) + (po : 'parser_ipatt option) _ (_loc : Loc.t) + -> (cparser _loc po pcl : 'expr)))) ]) ])) + ()); + Gram.extend (parser_case_list : 'parser_case_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (parser_case : 'parser_case Gram.Entry.t)) ], + (Gram.Action.mk + (fun (pc : 'parser_case) (_loc : Loc.t) -> + ([ pc ] : 'parser_case_list)))); + ([ Gram.Skeyword "["; + Gram.Slist0sep + (Gram.Snterm + (Gram.Entry.obj + (parser_case : 'parser_case Gram.Entry.t)), + Gram.Skeyword "|"); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (pcl : 'parser_case list) _ + (_loc : Loc.t) -> (pcl : 'parser_case_list)))) ]) ])) + ()); + Gram.extend (parser_case : 'parser_case Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (stream_begin : 'stream_begin Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (stream_patt : 'stream_patt Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (stream_end : 'stream_end Gram.Entry.t)); + Gram.Sopt + (Gram.Snterm + (Gram.Entry.obj + (parser_ipatt : + 'parser_ipatt Gram.Entry.t))); + Gram.Skeyword "->"; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (po : 'parser_ipatt option) _ + (sp : 'stream_patt) _ (_loc : Loc.t) -> + ((sp, po, e) : 'parser_case)))) ]) ])) + ()); + Gram.extend (stream_begin : 'stream_begin Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "[:" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> (() : 'stream_begin)))) ]) ])) + ()); + Gram.extend (stream_end : 'stream_end Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword ":]" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> (() : 'stream_end)))) ]) ])) + ()); + Gram.extend (stream_quot : 'stream_quot Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "`" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> (() : 'stream_quot)))) ]) ])) + ()); + Gram.extend (stream_expr : 'stream_expr Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) (_loc : Loc.t) -> + (e : 'stream_expr)))) ]) ])) + ()); + Gram.extend (stream_patt : 'stream_patt Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> ([] : 'stream_patt)))); + ([ Gram.Snterm + (Gram.Entry.obj + (stream_patt_comp : + 'stream_patt_comp Gram.Entry.t)); + Gram.Skeyword ";"; + Gram.Snterm + (Gram.Entry.obj + (stream_patt_comp_err_list : + 'stream_patt_comp_err_list Gram.Entry.t)) ], + (Gram.Action.mk + (fun (sp : 'stream_patt_comp_err_list) _ + (spc : 'stream_patt_comp) (_loc : Loc.t) -> + ((spc, None) :: sp : 'stream_patt)))); + ([ Gram.Snterm + (Gram.Entry.obj + (stream_patt_comp : + 'stream_patt_comp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (spc : 'stream_patt_comp) (_loc : Loc.t) -> + ([ (spc, None) ] : 'stream_patt)))) ]) ])) + ()); + Gram.extend + (stream_patt_comp_err : 'stream_patt_comp_err Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (stream_patt_comp : + 'stream_patt_comp Gram.Entry.t)); + Gram.Sopt + (Gram.srules stream_patt_comp_err + [ ([ Gram.Skeyword "??"; + Gram.Snterm + (Gram.Entry.obj + (stream_expr : + 'stream_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'stream_expr) _ + (_loc : Loc.t) -> (e : 'e__6)))) ]) ], + (Gram.Action.mk + (fun (eo : 'e__6 option) + (spc : 'stream_patt_comp) (_loc : Loc.t) -> + ((spc, eo) : 'stream_patt_comp_err)))) ]) ])) + ()); + Gram.extend + (stream_patt_comp_err_list : + 'stream_patt_comp_err_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (stream_patt_comp_err : + 'stream_patt_comp_err Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (sp : 'stream_patt_comp_err_list) _ + (spc : 'stream_patt_comp_err) (_loc : Loc.t) + -> (spc :: sp : 'stream_patt_comp_err_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (stream_patt_comp_err : + 'stream_patt_comp_err Gram.Entry.t)); + Gram.Skeyword ";" ], + (Gram.Action.mk + (fun _ (spc : 'stream_patt_comp_err) + (_loc : Loc.t) -> + ([ spc ] : 'stream_patt_comp_err_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (stream_patt_comp_err : + 'stream_patt_comp_err Gram.Entry.t)) ], + (Gram.Action.mk + (fun (spc : 'stream_patt_comp_err) + (_loc : Loc.t) -> + ([ spc ] : 'stream_patt_comp_err_list)))) ]) ])) + ()); + Gram.extend (stream_patt_comp : 'stream_patt_comp Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'patt) (_loc : Loc.t) -> + (SpStr (_loc, p) : 'stream_patt_comp)))); + ([ Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj + (stream_expr : 'stream_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'stream_expr) _ (p : 'patt) + (_loc : Loc.t) -> + (SpNtr (_loc, p, e) : 'stream_patt_comp)))); + ([ Gram.Snterm + (Gram.Entry.obj + (stream_quot : 'stream_quot Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)); + Gram.Sopt + (Gram.srules stream_patt_comp + [ ([ Gram.Skeyword "when"; + Gram.Snterm + (Gram.Entry.obj + (stream_expr : + 'stream_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'stream_expr) _ + (_loc : Loc.t) -> (e : 'e__7)))) ]) ], + (Gram.Action.mk + (fun (eo : 'e__7 option) (p : 'patt) _ + (_loc : Loc.t) -> + (SpTrm (_loc, p, eo) : 'stream_patt_comp)))) ]) ])) + ()); + Gram.extend (parser_ipatt : 'parser_ipatt Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "_" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> + (Ast.PaAny _loc : 'parser_ipatt)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) (_loc : Loc.t) -> + (Ast.PaId (_loc, Ast.IdLid (_loc, i)) : + 'parser_ipatt)))) ]) ])) + ()); + Gram.extend (expr : 'expr Gram.Entry.t) + ((fun () -> + ((Some (Camlp4.Sig.Grammar.Level "simple")), + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (stream_begin : 'stream_begin Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (stream_expr_comp_list : + 'stream_expr_comp_list Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (stream_end : 'stream_end Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (sel : 'stream_expr_comp_list) _ + (_loc : Loc.t) -> (cstream _loc sel : 'expr)))); + ([ Gram.Snterm + (Gram.Entry.obj + (stream_begin : 'stream_begin Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (stream_end : 'stream_end Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ _ (_loc : Loc.t) -> + (cstream _loc [] : 'expr)))) ]) ])) + ()); + Gram.extend + (stream_expr_comp_list : 'stream_expr_comp_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (stream_expr_comp : + 'stream_expr_comp Gram.Entry.t)) ], + (Gram.Action.mk + (fun (se : 'stream_expr_comp) (_loc : Loc.t) -> + ([ se ] : 'stream_expr_comp_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (stream_expr_comp : + 'stream_expr_comp Gram.Entry.t)); + Gram.Skeyword ";" ], + (Gram.Action.mk + (fun _ (se : 'stream_expr_comp) (_loc : Loc.t) + -> ([ se ] : 'stream_expr_comp_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (stream_expr_comp : + 'stream_expr_comp Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (sel : 'stream_expr_comp_list) _ + (se : 'stream_expr_comp) (_loc : Loc.t) -> + (se :: sel : 'stream_expr_comp_list)))) ]) ])) + ()); + Gram.extend (stream_expr_comp : 'stream_expr_comp Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (stream_expr : 'stream_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'stream_expr) (_loc : Loc.t) -> + (SeNtr (_loc, e) : 'stream_expr_comp)))); + ([ Gram.Snterm + (Gram.Entry.obj + (stream_quot : 'stream_quot Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (stream_expr : 'stream_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'stream_expr) _ (_loc : Loc.t) -> + (SeTrm (_loc, e) : 'stream_expr_comp)))) ]) ])) + ())) + end + (* + Gram.Entry.clear stream_expr; + Gram.Entry.clear stream_expr; + stream_expr: + [ [ e = expr LEVEL "stream_expr" -> e ] ] + ; + stream_begin: + [ [ "[<" -> () ] ] + ; + stream_end: + [ [ ">]" -> () ] ] + ; + stream_quot: + [ [ "'" -> () ] ] + ; + *) + module M = Register.OCamlSyntaxExtension(Id)(Make) + end +module G = + struct + open Camlp4 + (* -*- camlp4r -*- *) + (****************************************************************************) + (* *) + (* Objective Caml *) + (* *) + (* INRIA Rocquencourt *) + (* *) + (* Copyright 2002-2006 Institut National de Recherche en Informatique et *) + (* en Automatique. All rights reserved. This file is distributed under *) + (* the terms of the GNU Library General Public License, with the special *) + (* exception on linking described in LICENSE at the top of the Objective *) + (* Caml source tree. *) + (* *) + (****************************************************************************) + (* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + module Id = + struct + let name = "Camlp4GrammarParser" + let version = + "$Id: camlp4boot.ml,v 1.2 2007/02/26 16:32:47 ertai Exp $" + end + module Make (Syntax : Sig.Camlp4Syntax) = + struct + open Sig + include Syntax + module MetaLoc = Ast.Meta.MetaGhostLoc + module MetaAst = Ast.Meta.Make(MetaLoc) + module PP = Camlp4.Printers.OCaml.Make(Syntax) + let pp = new PP.printer ~comments: false () + let string_of_patt patt = + let buf = Buffer.create 42 in + let () = Format.bprintf buf "%a@?" pp#patt patt in + let str = Buffer.contents buf + in if str = "" then assert false else str + let split_ext = ref false + type loc = Loc.t + type 'e name = { expr : 'e; tvar : string; loc : loc } + type styp = + | STlid of loc * string | STapp of loc * styp * styp + | STquo of loc * string | STself of loc * string | STtok of loc + | STstring_tok of loc | STany of loc | STtyp of Ast.ctyp + type (** The first is the match function expr, + the second is the string description. + The description string will be used for + grammar insertion and left factoring. + Keep this string normalized and well comparable. *) + ('e, 'p) text = + | TXmeta of loc * string * (('e, 'p) text) list * 'e * styp + | TXlist of loc * bool * ('e, 'p) symbol * (('e, 'p) symbol) option + | TXnext of loc | TXnterm of loc * 'e name * string option + | TXopt of loc * ('e, 'p) text + | TXrules of loc * (((('e, 'p) text) list) * 'e) list + | TXself of loc | TXkwd of loc * string + | TXtok of loc * 'e * string + and ('e, 'p) entry = + { name : 'e name; pos : 'e option; levels : (('e, 'p) level) list + } + and ('e, 'p) level = + { label : string option; assoc : 'e option; + rules : (('e, 'p) rule) list + } + and ('e, 'p) rule = + { prod : (('e, 'p) symbol) list; action : 'e option + } + and ('e, 'p) symbol = + { used : string list; text : ('e, 'p) text; styp : styp; + pattern : 'p option + } + type used = | Unused | UsedScanned | UsedNotScanned + let _loc = Loc.ghost + let gm = "Camlp4Grammar__" + let mark_used modif ht n = + try + let rll = Hashtbl.find_all ht n + in + List.iter + (fun (r, _) -> + if !r == Unused + then (r := UsedNotScanned; modif := true) + else ()) + rll + with | Not_found -> () + let rec mark_symbol modif ht symb = + List.iter (fun e -> mark_used modif ht e) symb.used + let check_use nl el = + let ht = Hashtbl.create 301 in + let modif = ref false + in + (List.iter + (fun e -> + let u = + match e.name.expr with + | Ast.ExId (_, (Ast.IdLid (_, _))) -> Unused + | _ -> UsedNotScanned + in Hashtbl.add ht e.name.tvar ((ref u), e)) + el; + List.iter + (fun n -> + try + let rll = Hashtbl.find_all ht n.tvar + in List.iter (fun (r, _) -> r := UsedNotScanned) rll + with | _ -> ()) + nl; + modif := true; + while !modif do modif := false; + Hashtbl.iter + (fun _ (r, e) -> + if !r = UsedNotScanned + then + (r := UsedScanned; + List.iter + (fun level -> + let rules = level.rules + in + List.iter + (fun rule -> + List.iter + (fun s -> mark_symbol modif ht s) + rule.prod) + rules) + e.levels) + else ()) + ht + done; + Hashtbl.iter + (fun s (r, e) -> + if !r = Unused + then + Warning.print e.name.loc + ("Unused local entry \"" ^ (s ^ "\"")) + else ()) + ht) + let new_type_var = + let i = ref 0 in fun () -> (incr i; "e__" ^ (string_of_int !i)) + let used_of_rule_list rl = + List.fold_left + (fun nl r -> List.fold_left (fun nl s -> s.used @ nl) nl r.prod) + [] rl + let retype_rule_list_without_patterns _loc rl = + try + (* ...; [ "foo" ]; ... ==> ...; (x = [ "foo" ] -> Token.extract_string x); ... *) + (* ...; [ symb ]; ... ==> ...; (x = [ symb ] -> x); ... *) + (* ...; ([] -> a); ... *) + List.map + (function + | { + prod = [ ({ pattern = None; styp = STtok _ } as s) ]; + action = None } -> + { + + prod = + [ { + (s) + with + + pattern = + Some (Ast.PaId (_loc, Ast.IdLid (_loc, "x"))); + } ]; + action = + Some + (Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Token"), + Ast.IdLid (_loc, "extract_string"))), + Ast.ExId (_loc, Ast.IdLid (_loc, "x")))); + } + | { prod = [ ({ pattern = None } as s) ]; action = None } -> + { + + prod = + [ { + (s) + with + + pattern = + Some (Ast.PaId (_loc, Ast.IdLid (_loc, "x"))); + } ]; + action = Some (Ast.ExId (_loc, Ast.IdLid (_loc, "x"))); + } + | ({ prod = []; action = Some _ } as r) -> r + | _ -> raise Exit) + rl + with | Exit -> rl + let meta_action = ref false + let mklistexp _loc = + let rec loop top = + function + | [] -> Ast.ExId (_loc, Ast.IdUid (_loc, "[]")) + | e1 :: el -> + let _loc = + if top then _loc else Loc.merge (Ast.loc_of_expr e1) _loc + in + Ast.ExApp (_loc, + Ast.ExApp (_loc, Ast.ExId (_loc, Ast.IdUid (_loc, "::")), + e1), + loop false el) + in loop true + let mklistpat _loc = + let rec loop top = + function + | [] -> Ast.PaId (_loc, Ast.IdUid (_loc, "[]")) + | p1 :: pl -> + let _loc = + if top then _loc else Loc.merge (Ast.loc_of_patt p1) _loc + in + Ast.PaApp (_loc, + Ast.PaApp (_loc, Ast.PaId (_loc, Ast.IdUid (_loc, "::")), + p1), + loop false pl) + in loop true + let rec expr_fa al = + function + | Ast.ExApp (_, f, a) -> expr_fa (a :: al) f + | f -> (f, al) + let rec make_ctyp styp tvar = + match styp with + | STlid (_loc, s) -> Ast.TyId (_loc, Ast.IdLid (_loc, s)) + | STapp (_loc, t1, t2) -> + Ast.TyApp (_loc, make_ctyp t1 tvar, make_ctyp t2 tvar) + | STquo (_loc, s) -> Ast.TyQuo (_loc, s) + | STself (_loc, x) -> + if tvar = "" + then + Loc.raise _loc + (Stream.Error + ("'" ^ (x ^ "' illegal in anonymous entry level"))) + else Ast.TyQuo (_loc, tvar) + | STany _loc -> Ast.TyAny _loc + | STtok _loc -> + Ast.TyId (_loc, + Ast.IdAcc (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdUid (_loc, "Token")), + Ast.IdLid (_loc, "t"))) + | STstring_tok _loc -> Ast.TyId (_loc, Ast.IdLid (_loc, "string")) + | STtyp t -> t + let make_ctyp_patt styp tvar patt = + let styp = + match styp with | STstring_tok _loc -> STtok _loc | t -> t + in + match make_ctyp styp tvar with + | Ast.TyAny _ -> patt + | t -> + let _loc = Ast.loc_of_patt patt in Ast.PaTyc (_loc, patt, t) + let make_ctyp_expr styp tvar expr = + match make_ctyp styp tvar with + | Ast.TyAny _ -> expr + | t -> let _loc = Ast.loc_of_expr expr in Ast.ExTyc (_loc, expr, t) + let text_of_action _loc psl rtvar act tvar = + let locid = Ast.PaId (_loc, Ast.IdLid (_loc, !Loc.name)) in + let act = + match act with + | Some act -> act + | None -> Ast.ExId (_loc, Ast.IdUid (_loc, "()")) in + let (tok_match_pl, act, _) = + List.fold_left + (fun ((tok_match_pl, act, i) as accu) -> + function + | { pattern = None } -> accu + | { pattern = Some p } when Ast.is_irrefut_patt p -> accu + | { + pattern = + Some + (Ast.PaAli (_, + (Ast.PaApp (_, _, (Ast.PaTup (_, (Ast.PaAny _))))), + (Ast.PaId (_, (Ast.IdLid (_, s)))))) + } -> + (tok_match_pl, + (Ast.ExLet (_loc, Ast.BFalse, + Ast.BiEq (_loc, + Ast.PaId (_loc, Ast.IdLid (_loc, s)), + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Token"), + Ast.IdLid (_loc, "extract_string")))), + Ast.ExId (_loc, Ast.IdLid (_loc, s)))), + act)), + i) + | { pattern = Some p; text = TXtok (_, _, _) } -> + let id = "__camlp4_" ^ (string_of_int i) + in + ((Some + (match tok_match_pl with + | None -> + ((Ast.ExId (_loc, Ast.IdLid (_loc, id))), p) + | Some ((tok_pl, match_pl)) -> + ((Ast.ExCom (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, id)), + tok_pl)), + (Ast.PaCom (_loc, p, match_pl))))), + act, (succ i)) + | _ -> accu) + (None, act, 0) psl in + let e = + let e1 = Ast.ExTyc (_loc, act, Ast.TyQuo (_loc, rtvar)) in + let e2 = + match tok_match_pl with + | None -> e1 + | Some ((Ast.ExCom (_, t1, t2), Ast.PaCom (_, p1, p2))) -> + Ast.ExMat (_loc, + Ast.ExTup (_loc, Ast.ExCom (_loc, t1, t2)), + Ast.McOr (_loc, + Ast.McArr (_loc, + Ast.PaTup (_loc, Ast.PaCom (_loc, p1, p2)), + Ast.ExNil _loc, e1), + Ast.McArr (_loc, Ast.PaAny _loc, Ast.ExNil _loc, + Ast.ExAsf _loc))) + | Some ((tok, match_)) -> + Ast.ExMat (_loc, tok, + Ast.McOr (_loc, + Ast.McArr (_loc, match_, Ast.ExNil _loc, e1), + Ast.McArr (_loc, Ast.PaAny _loc, Ast.ExNil _loc, + Ast.ExAsf _loc))) + in + Ast.ExFun (_loc, + Ast.McArr (_loc, + Ast.PaTyc (_loc, locid, + Ast.TyId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Loc"), + Ast.IdLid (_loc, "t")))), + Ast.ExNil _loc, e2)) in + let (txt, _) = + List.fold_left + (fun (txt, i) s -> + match s.pattern with + | None | Some (Ast.PaAny _) -> + ((Ast.ExFun (_loc, + Ast.McArr (_loc, Ast.PaAny _loc, Ast.ExNil _loc, + txt))), + i) + | Some + (Ast.PaAli (_, + (Ast.PaApp (_, _, (Ast.PaTup (_, (Ast.PaAny _))))), + p)) + -> + let p = make_ctyp_patt s.styp tvar p + in + ((Ast.ExFun (_loc, + Ast.McArr (_loc, p, Ast.ExNil _loc, txt))), + i) + | Some p when Ast.is_irrefut_patt p -> + let p = make_ctyp_patt s.styp tvar p + in + ((Ast.ExFun (_loc, + Ast.McArr (_loc, p, Ast.ExNil _loc, txt))), + i) + | Some _ -> + let p = + make_ctyp_patt s.styp tvar + (Ast.PaId (_loc, + Ast.IdLid (_loc, "__camlp4_" ^ (string_of_int i)))) + in + ((Ast.ExFun (_loc, + Ast.McArr (_loc, p, Ast.ExNil _loc, txt))), + (succ i))) + (e, 0) psl in + let txt = + if !meta_action + then + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Obj"), + Ast.IdLid (_loc, "magic"))), + MetaAst.Expr.meta_expr _loc txt) + else txt + in + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Action"), + Ast.IdLid (_loc, "mk")))), + txt) + let srules loc t rl tvar = + List.map + (fun r -> + let sl = List.map (fun s -> s.text) r.prod in + let ac = text_of_action loc r.prod t r.action tvar in (sl, ac)) + rl + let rec make_expr entry tvar = + function + | TXmeta (_loc, n, tl, e, t) -> + let el = + List.fold_right + (fun t el -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdUid (_loc, "::")), + make_expr entry "" t), + el)) + tl (Ast.ExId (_loc, Ast.IdUid (_loc, "[]"))) + in + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdUid (_loc, "Smeta"))), + Ast.ExStr (_loc, n)), + el), + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Action"), + Ast.IdLid (_loc, "mk")))), + make_ctyp_expr t tvar e)) + | TXlist (_loc, min, t, ts) -> + let txt = make_expr entry "" t.text + in + (match (min, ts) with + | (false, None) -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdUid (_loc, "Slist0"))), + txt) + | (true, None) -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdUid (_loc, "Slist1"))), + txt) + | (false, Some s) -> + let x = make_expr entry tvar s.text + in + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdUid (_loc, "Slist0sep"))), + txt), + x) + | (true, Some s) -> + let x = make_expr entry tvar s.text + in + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdUid (_loc, "Slist1sep"))), + txt), + x)) + | TXnext _loc -> + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdUid (_loc, "Snext"))) + | TXnterm (_loc, n, lev) -> + (match lev with + | Some lab -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdUid (_loc, "Snterml"))), + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Entry"), + Ast.IdLid (_loc, "obj")))), + Ast.ExTyc (_loc, n.expr, + Ast.TyApp (_loc, + Ast.TyId (_loc, + Ast.IdAcc (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdUid (_loc, "Entry")), + Ast.IdLid (_loc, "t"))), + Ast.TyQuo (_loc, n.tvar))))), + Ast.ExStr (_loc, lab)) + | None -> + if n.tvar = tvar + then + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdUid (_loc, "Sself"))) + else + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdUid (_loc, "Snterm"))), + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Entry"), + Ast.IdLid (_loc, "obj")))), + Ast.ExTyc (_loc, n.expr, + Ast.TyApp (_loc, + Ast.TyId (_loc, + Ast.IdAcc (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdUid (_loc, "Entry")), + Ast.IdLid (_loc, "t"))), + Ast.TyQuo (_loc, n.tvar)))))) + | TXopt (_loc, t) -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdUid (_loc, "Sopt"))), + make_expr entry "" t) + | TXrules (_loc, rl) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdLid (_loc, "srules"))), + entry.expr), + make_expr_rules _loc entry rl "") + | TXself _loc -> + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdUid (_loc, "Sself"))) + | TXkwd (_loc, kwd) -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdUid (_loc, "Skeyword"))), + Ast.ExStr (_loc, kwd)) + | TXtok (_loc, match_fun, descr) -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdUid (_loc, "Stoken"))), + Ast.ExTup (_loc, + Ast.ExCom (_loc, match_fun, + Ast.ExStr (_loc, Ast.safe_string_escaped descr)))) + and make_expr_rules _loc n rl tvar = + List.fold_left + (fun txt (sl, ac) -> + let sl = + List.fold_right + (fun t txt -> + let x = make_expr n tvar t + in + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdUid (_loc, "::")), x), + txt)) + sl (Ast.ExId (_loc, Ast.IdUid (_loc, "[]"))) + in + Ast.ExApp (_loc, + Ast.ExApp (_loc, Ast.ExId (_loc, Ast.IdUid (_loc, "::")), + Ast.ExTup (_loc, Ast.ExCom (_loc, sl, ac))), + txt)) + (Ast.ExId (_loc, Ast.IdUid (_loc, "[]"))) rl + let expr_of_delete_rule _loc n sl = + let sl = + List.fold_right + (fun s e -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, Ast.ExId (_loc, Ast.IdUid (_loc, "::")), + make_expr n "" s.text), + e)) + sl (Ast.ExId (_loc, Ast.IdUid (_loc, "[]"))) + in ((n.expr), sl) + let rec tvar_of_ident = + function + | Ast.IdLid (_, x) | Ast.IdUid (_, x) -> x + | Ast.IdAcc (_, (Ast.IdUid (_, x)), xs) -> + x ^ ("__" ^ (tvar_of_ident xs)) + | _ -> failwith "internal error in the Grammar extension" + let mk_name _loc i = + { expr = Ast.ExId (_loc, i); tvar = tvar_of_ident i; loc = _loc; } + let slist loc min sep symb = TXlist (loc, min, symb, sep) + let sstoken _loc s = + let n = mk_name _loc (Ast.IdLid (_loc, "a_" ^ s)) + in TXnterm (_loc, n, None) + let mk_symbol p s t = + { used = []; text = s; styp = t; pattern = Some p; } + let sslist _loc min sep s = + let rl = + let r1 = + let prod = + let n = mk_name _loc (Ast.IdLid (_loc, "a_list")) + in + [ mk_symbol (Ast.PaId (_loc, Ast.IdLid (_loc, "a"))) + (TXnterm (_loc, n, None)) (STquo (_loc, "a_list")) ] in + let act = Ast.ExId (_loc, Ast.IdLid (_loc, "a")) + in { prod = prod; action = Some act; } in + let r2 = + let prod = + [ mk_symbol (Ast.PaId (_loc, Ast.IdLid (_loc, "a"))) + (slist _loc min sep s) + (STapp (_loc, STlid (_loc, "list"), s.styp)) ] in + let act = + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Qast"), + Ast.IdUid (_loc, "List"))), + Ast.ExId (_loc, Ast.IdLid (_loc, "a"))) + in { prod = prod; action = Some act; } + in [ r1; r2 ] in + let used = + match sep with | Some symb -> symb.used @ s.used | None -> s.used in + let used = "a_list" :: used in + let text = TXrules (_loc, srules _loc "a_list" rl "") in + let styp = STquo (_loc, "a_list") + in { used = used; text = text; styp = styp; pattern = None; } + let ssopt _loc s = + let rl = + let r1 = + let prod = + let n = mk_name _loc (Ast.IdLid (_loc, "a_opt")) + in + [ mk_symbol (Ast.PaId (_loc, Ast.IdLid (_loc, "a"))) + (TXnterm (_loc, n, None)) (STquo (_loc, "a_opt")) ] in + let act = Ast.ExId (_loc, Ast.IdLid (_loc, "a")) + in { prod = prod; action = Some act; } in + let r2 = + let s = + match s.text with + | TXkwd (_loc, _) | TXtok (_loc, _, _) -> + let rl = + [ { + + prod = + [ { + (s) + with + + pattern = + Some + (Ast.PaId (_loc, Ast.IdLid (_loc, "x"))); + } ]; + action = + Some + (Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Qast"), + Ast.IdUid (_loc, "Str"))), + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Token"), + Ast.IdLid (_loc, "extract_string"))), + Ast.ExId (_loc, Ast.IdLid (_loc, "x"))))); + } ] in + let t = new_type_var () + in + { + + used = []; + text = TXrules (_loc, srules _loc t rl ""); + styp = STquo (_loc, t); + pattern = None; + } + | _ -> s in + let prod = + [ mk_symbol (Ast.PaId (_loc, Ast.IdLid (_loc, "a"))) + (TXopt (_loc, s.text)) + (STapp (_loc, STlid (_loc, "option"), s.styp)) ] in + let act = + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Qast"), + Ast.IdUid (_loc, "Option"))), + Ast.ExId (_loc, Ast.IdLid (_loc, "a"))) + in { prod = prod; action = Some act; } + in [ r1; r2 ] in + let used = "a_opt" :: s.used in + let text = TXrules (_loc, srules _loc "a_opt" rl "") in + let styp = STquo (_loc, "a_opt") + in { used = used; text = text; styp = styp; pattern = None; } + let text_of_entry _loc e = + let ent = + let x = e.name in + let _loc = e.name.loc + in + Ast.ExTyc (_loc, x.expr, + Ast.TyApp (_loc, + Ast.TyId (_loc, + Ast.IdAcc (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdUid (_loc, "Entry")), + Ast.IdLid (_loc, "t"))), + Ast.TyQuo (_loc, x.tvar))) in + let pos = + match e.pos with + | Some pos -> + Ast.ExApp (_loc, Ast.ExId (_loc, Ast.IdUid (_loc, "Some")), + pos) + | None -> Ast.ExId (_loc, Ast.IdUid (_loc, "None")) in + let txt = + List.fold_right + (fun level txt -> + let lab = + match level.label with + | Some lab -> + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdUid (_loc, "Some")), + Ast.ExStr (_loc, lab)) + | None -> Ast.ExId (_loc, Ast.IdUid (_loc, "None")) in + let ass = + match level.assoc with + | Some ass -> + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdUid (_loc, "Some")), ass) + | None -> Ast.ExId (_loc, Ast.IdUid (_loc, "None")) in + let txt = + let rl = + srules _loc e.name.tvar level.rules e.name.tvar in + let e = make_expr_rules _loc e.name rl e.name.tvar + in + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdUid (_loc, "::")), + Ast.ExTup (_loc, + Ast.ExCom (_loc, lab, Ast.ExCom (_loc, ass, e)))), + txt) + in txt) + e.levels (Ast.ExId (_loc, Ast.IdUid (_loc, "[]"))) + in (ent, pos, txt) + let let_in_of_extend _loc gram gl el args = + match gl with + | None -> args + | Some nl -> + (check_use nl el; + let ll = + let same_tvar e n = e.name.tvar = n.tvar + in + List.fold_right + (fun e ll -> + match e.name.expr with + | Ast.ExId (_, (Ast.IdLid (_, _))) -> + if List.exists (same_tvar e) nl + then ll + else + if List.exists (same_tvar e) ll + then ll + else e.name :: ll + | _ -> ll) + el [] in + let local_binding_of_name { expr = e; tvar = x; loc = _loc } = + let i = + (match e with + | Ast.ExId (_, (Ast.IdLid (_, i))) -> i + | _ -> failwith "internal error in the Grammar extension") + in + Ast.BiEq (_loc, Ast.PaId (_loc, Ast.IdLid (_loc, i)), + Ast.ExTyc (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdLid (_loc, "grammar_entry_create")), + Ast.ExStr (_loc, i)), + Ast.TyApp (_loc, + Ast.TyId (_loc, + Ast.IdAcc (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdUid (_loc, "Entry")), + Ast.IdLid (_loc, "t"))), + Ast.TyQuo (_loc, x)))) in + let expr_of_name { expr = e; tvar = x; loc = _loc } = + Ast.ExTyc (_loc, e, + Ast.TyApp (_loc, + Ast.TyId (_loc, + Ast.IdAcc (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdUid (_loc, "Entry")), + Ast.IdLid (_loc, "t"))), + Ast.TyQuo (_loc, x))) in + let e = + (match ll with + | [] -> args + | x :: xs -> + let locals = + List.fold_right + (fun name acc -> + Ast.BiAnd (_loc, acc, + local_binding_of_name name)) + xs (local_binding_of_name x) in + let entry_mk = + (match gram with + | Some g -> + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Entry"), + Ast.IdLid (_loc, "mk")))), + Ast.ExId (_loc, g)) + | None -> + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Entry"), + Ast.IdLid (_loc, "mk"))))) + in + Ast.ExLet (_loc, Ast.BFalse, + Ast.BiEq (_loc, + Ast.PaId (_loc, + Ast.IdLid (_loc, "grammar_entry_create")), + entry_mk), + Ast.ExLet (_loc, Ast.BFalse, locals, args))) + in + (match nl with + | [] -> e + | x :: xs -> + let globals = + List.fold_right + (fun name acc -> + Ast.BiAnd (_loc, acc, + Ast.BiEq (_loc, Ast.PaAny _loc, + expr_of_name name))) + xs + (Ast.BiEq (_loc, Ast.PaAny _loc, expr_of_name x)) + in Ast.ExLet (_loc, Ast.BFalse, globals, e))) + class subst gmod = + object inherit Ast.map as super + method ident = + function + | Ast.IdUid (_, x) when x = gm -> gmod + | x -> super#ident x + end + let subst_gmod ast gmod = (new subst gmod)#expr ast + let text_of_functorial_extend _loc gmod gram gl el = + let args = + let el = + List.map + (fun e -> + let (ent, pos, txt) = text_of_entry e.name.loc e in + let e = + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdLid (_loc, "extend"))), + ent), + Ast.ExApp (_loc, + Ast.ExFun (_loc, + Ast.McArr (_loc, + Ast.PaId (_loc, Ast.IdUid (_loc, "()")), + Ast.ExNil _loc, + Ast.ExTup (_loc, Ast.ExCom (_loc, pos, txt)))), + Ast.ExId (_loc, Ast.IdUid (_loc, "()")))) + in + if !split_ext + then + Ast.ExLet (_loc, Ast.BFalse, + Ast.BiEq (_loc, + Ast.PaId (_loc, Ast.IdLid (_loc, "aux")), + Ast.ExFun (_loc, + Ast.McArr (_loc, + Ast.PaId (_loc, Ast.IdUid (_loc, "()")), + Ast.ExNil _loc, e))), + Ast.ExApp (_loc, + Ast.ExId (_loc, Ast.IdLid (_loc, "aux")), + Ast.ExId (_loc, Ast.IdUid (_loc, "()")))) + else e) + el + in + match el with + | [] -> Ast.ExId (_loc, Ast.IdUid (_loc, "()")) + | [ e ] -> e + | e :: el -> + Ast.ExSeq (_loc, + List.fold_left (fun acc x -> Ast.ExSem (_loc, acc, x)) e + el) + in subst_gmod (let_in_of_extend _loc gram gl el args) gmod + let wildcarder = + object (self) + inherit Ast.map as super + method patt = + function + | Ast.PaId (_loc, (Ast.IdLid (_, _))) -> Ast.PaAny _loc + | Ast.PaAli (_, p, _) -> self#patt p + | Ast.PaEq (_loc, p1, p2) -> Ast.PaEq (_loc, p1, self#patt p2) + | p -> super#patt p + end + let mk_tok _loc p t = + let p' = wildcarder#patt p in + let match_fun = + if Ast.is_irrefut_patt p' + then + Ast.ExFun (_loc, + Ast.McArr (_loc, p', Ast.ExNil _loc, + Ast.ExId (_loc, Ast.IdUid (_loc, "True")))) + else + Ast.ExFun (_loc, + Ast.McOr (_loc, + Ast.McArr (_loc, p', Ast.ExNil _loc, + Ast.ExId (_loc, Ast.IdUid (_loc, "True"))), + Ast.McArr (_loc, Ast.PaAny _loc, Ast.ExNil _loc, + Ast.ExId (_loc, Ast.IdUid (_loc, "False"))))) in + let descr = string_of_patt p' in + let text = TXtok (_loc, match_fun, descr) + in { used = []; text = text; styp = t; pattern = Some p; } + let symbol = Gram.Entry.mk "symbol" + let check_not_tok s = + match s with + | { text = TXtok (_loc, _, _) } -> + Loc.raise _loc + (Stream.Error + ("Deprecated syntax, use a sub rule. " ^ + "LIST0 STRING becomes LIST0 [ x = STRING -> x ]")) + | _ -> () + let _ = + let _ = (expr : 'expr Gram.Entry.t) + and _ = (symbol : 'symbol Gram.Entry.t) in + let grammar_entry_create = Gram.Entry.mk in + let extend_header : 'extend_header Gram.Entry.t = + grammar_entry_create "extend_header" + and semi_sep : 'semi_sep Gram.Entry.t = + grammar_entry_create "semi_sep" + and string : 'string Gram.Entry.t = grammar_entry_create "string" + and name : 'name Gram.Entry.t = grammar_entry_create "name" + and comma_patt : 'comma_patt Gram.Entry.t = + grammar_entry_create "comma_patt" + and pattern : 'pattern Gram.Entry.t = + grammar_entry_create "pattern" + and psymbol : 'psymbol Gram.Entry.t = + grammar_entry_create "psymbol" + and rule : 'rule Gram.Entry.t = grammar_entry_create "rule" + and rule_list : 'rule_list Gram.Entry.t = + grammar_entry_create "rule_list" + and assoc : 'assoc Gram.Entry.t = grammar_entry_create "assoc" + and level : 'level Gram.Entry.t = grammar_entry_create "level" + and level_list : 'level_list Gram.Entry.t = + grammar_entry_create "level_list" + and position : 'position Gram.Entry.t = + grammar_entry_create "position" + and entry : 'entry Gram.Entry.t = grammar_entry_create "entry" + and global : 'global Gram.Entry.t = grammar_entry_create "global" + and t_qualid : 't_qualid Gram.Entry.t = + grammar_entry_create "t_qualid" + and qualid : 'qualid Gram.Entry.t = grammar_entry_create "qualid" + and qualuid : 'qualuid Gram.Entry.t = + grammar_entry_create "qualuid" + and delete_rule_body : 'delete_rule_body Gram.Entry.t = + grammar_entry_create "delete_rule_body" + and extend_body : 'extend_body Gram.Entry.t = + grammar_entry_create "extend_body" + in + (Gram.extend (expr : 'expr Gram.Entry.t) + ((fun () -> + ((Some (Camlp4.Sig.Grammar.After "top")), + [ (None, None, + [ ([ Gram.Skeyword "GEXTEND" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> + (Loc.raise _loc + (Stream.Error + "Deprecated syntax, use EXTEND MyGramModule ... END instead") : + 'expr)))); + ([ Gram.Skeyword "GDELETE_RULE" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> + (Loc.raise _loc + (Stream.Error + "Deprecated syntax, use DELETE_RULE MyGramModule ... END instead") : + 'expr)))); + ([ Gram.Skeyword "DELETE_RULE"; + Gram.Snterm + (Gram.Entry.obj + (delete_rule_body : + 'delete_rule_body Gram.Entry.t)); + Gram.Skeyword "END" ], + (Gram.Action.mk + (fun _ (e : 'delete_rule_body) _ (_loc : Loc.t) + -> (e : 'expr)))); + ([ Gram.Skeyword "EXTEND"; + Gram.Snterm + (Gram.Entry.obj + (extend_body : 'extend_body Gram.Entry.t)); + Gram.Skeyword "END" ], + (Gram.Action.mk + (fun _ (e : 'extend_body) _ (_loc : Loc.t) -> + (e : 'expr)))) ]) ])) + ()); + Gram.extend (extend_header : 'extend_header Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (qualuid : 'qualuid Gram.Entry.t)) ], + (Gram.Action.mk + (fun (g : 'qualuid) (_loc : Loc.t) -> + ((None, g) : 'extend_header)))); + ([ Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj (qualid : 'qualid Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Snterm + (Gram.Entry.obj + (t_qualid : 't_qualid Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (t : 't_qualid) _ (i : 'qualid) _ + (_loc : Loc.t) -> + (((Some i), t) : 'extend_header)))) ]) ])) + ()); + Gram.extend (extend_body : 'extend_body Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (extend_header : + 'extend_header Gram.Entry.t)); + Gram.Sopt + (Gram.Snterm + (Gram.Entry.obj + (global : 'global Gram.Entry.t))); + Gram.Slist1 + (Gram.srules extend_body + [ ([ Gram.Snterm + (Gram.Entry.obj + (entry : 'entry Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (semi_sep : + 'semi_sep Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (e : 'entry) (_loc : Loc.t) -> + (e : 'e__8)))) ]) ], + (Gram.Action.mk + (fun (el : 'e__8 list) + (global_list : 'global option) + ((gram, g) : 'extend_header) (_loc : Loc.t) + -> + (text_of_functorial_extend _loc g gram + global_list el : + 'extend_body)))) ]) ])) + ()); + Gram.extend (delete_rule_body : 'delete_rule_body Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (qualuid : 'qualuid Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (name : 'name Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Slist0sep + (Gram.Snterm + (Gram.Entry.obj + (symbol : 'symbol Gram.Entry.t)), + Gram.Snterm + (Gram.Entry.obj + (semi_sep : 'semi_sep Gram.Entry.t))) ], + (Gram.Action.mk + (fun (sl : 'symbol list) _ (n : 'name) + (g : 'qualuid) (_loc : Loc.t) -> + (let (e, b) = expr_of_delete_rule _loc n sl + in + subst_gmod + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, gm), + Ast.IdLid (_loc, "delete_rule"))), + e), + b)) + g : + 'delete_rule_body)))) ]) ])) + ()); + Gram.extend (qualuid : 'qualuid Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.srules qualuid + [ ([ Gram.Stoken + (((function + | UIDENT "GLOBAL" -> true + | _ -> false), + "UIDENT \"GLOBAL\"")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT "GLOBAL" -> (() : 'e__9) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | LIDENT ((_)) -> true + | _ -> false), + "LIDENT ((_))")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | LIDENT ((_)) -> (() : 'e__9) + | _ -> assert false))) ] ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> + (Loc.raise _loc + (Stream.Error + "Deprecated syntax, the grammar module is expected") : + 'qualuid)))) ]); + (None, None, + [ ([ Gram.Stoken + (((function | UIDENT ((_)) -> true | _ -> false), + "UIDENT _")) ], + (Gram.Action.mk + (fun (i : Gram.Token.t) (_loc : Loc.t) -> + (let i = Gram.Token.extract_string i + in Ast.IdUid (_loc, i) : 'qualuid)))); + ([ Gram.Stoken + (((function | UIDENT ((_)) -> true | _ -> false), + "UIDENT _")); + Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (xs : 'qualuid) _ (x : Gram.Token.t) + (_loc : Loc.t) -> + (let x = Gram.Token.extract_string x + in Ast.IdAcc (_loc, Ast.IdUid (_loc, x), xs) : + 'qualuid)))) ]) ])) + ()); + Gram.extend (qualuid : 'qualuid Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.srules qualuid + [ ([ Gram.Stoken + (((function + | UIDENT "GLOBAL" -> true + | _ -> false), + "UIDENT \"GLOBAL\"")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT "GLOBAL" -> (() : 'e__10) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | LIDENT ((_)) -> true + | _ -> false), + "LIDENT ((_))")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | LIDENT ((_)) -> (() : 'e__10) + | _ -> assert false))) ] ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> + (Loc.raise _loc + (Stream.Error + "Deprecated syntax, the grammar module is expected") : + 'qualuid)))) ]); + (None, None, + [ ([ Gram.Stoken + (((function | UIDENT ((_)) -> true | _ -> false), + "UIDENT _")) ], + (Gram.Action.mk + (fun (i : Gram.Token.t) (_loc : Loc.t) -> + (let i = Gram.Token.extract_string i + in Ast.IdUid (_loc, i) : 'qualuid)))); + ([ Gram.Stoken + (((function | UIDENT ((_)) -> true | _ -> false), + "UIDENT _")); + Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (xs : 'qualuid) _ (x : Gram.Token.t) + (_loc : Loc.t) -> + (let x = Gram.Token.extract_string x + in Ast.IdAcc (_loc, Ast.IdUid (_loc, x), xs) : + 'qualuid)))) ]) ])) + ()); + Gram.extend (qualid : 'qualid Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | LIDENT ((_)) -> true | _ -> false), + "LIDENT _")) ], + (Gram.Action.mk + (fun (i : Gram.Token.t) (_loc : Loc.t) -> + (let i = Gram.Token.extract_string i + in Ast.IdLid (_loc, i) : 'qualid)))); + ([ Gram.Stoken + (((function | UIDENT ((_)) -> true | _ -> false), + "UIDENT _")) ], + (Gram.Action.mk + (fun (i : Gram.Token.t) (_loc : Loc.t) -> + (let i = Gram.Token.extract_string i + in Ast.IdUid (_loc, i) : 'qualid)))); + ([ Gram.Stoken + (((function | UIDENT ((_)) -> true | _ -> false), + "UIDENT _")); + Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (xs : 'qualid) _ (x : Gram.Token.t) + (_loc : Loc.t) -> + (let x = Gram.Token.extract_string x + in Ast.IdAcc (_loc, Ast.IdUid (_loc, x), xs) : + 'qualid)))) ]) ])) + ()); + Gram.extend (t_qualid : 't_qualid Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function + | LIDENT _ | UIDENT _ -> true + | _ -> false), + "LIDENT _ | UIDENT _")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | LIDENT _ | UIDENT _ -> + (Loc.raise _loc + (Stream.Error + ("Wrong EXTEND header, the grammar type must finish by 't', " + ^ + "like in EXTEND (g : Gram.t) ... END")) : + 't_qualid) + | _ -> assert false))); + ([ Gram.Stoken + (((function | UIDENT ((_)) -> true | _ -> false), + "UIDENT _")); + Gram.Skeyword "."; + Gram.Stoken + (((function | LIDENT "t" -> true | _ -> false), + "LIDENT \"t\"")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) _ + (x : Gram.Token.t) (_loc : Loc.t) -> + match __camlp4_0 with + | LIDENT "t" -> + (let x = Gram.Token.extract_string x + in Ast.IdUid (_loc, x) : 't_qualid) + | _ -> assert false))); + ([ Gram.Stoken + (((function | UIDENT ((_)) -> true | _ -> false), + "UIDENT _")); + Gram.Skeyword "."; Gram.Sself ], + (Gram.Action.mk + (fun (xs : 't_qualid) _ (x : Gram.Token.t) + (_loc : Loc.t) -> + (let x = Gram.Token.extract_string x + in Ast.IdAcc (_loc, Ast.IdUid (_loc, x), xs) : + 't_qualid)))) ]) ])) + ()); + Gram.extend (global : 'global Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function + | UIDENT "GLOBAL" -> true + | _ -> false), + "UIDENT \"GLOBAL\"")); + Gram.Skeyword ":"; + Gram.Slist1 + (Gram.Snterm + (Gram.Entry.obj (name : 'name Gram.Entry.t))); + Gram.Snterm + (Gram.Entry.obj + (semi_sep : 'semi_sep Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (sl : 'name list) _ + (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT "GLOBAL" -> (sl : 'global) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (entry : 'entry Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (name : 'name Gram.Entry.t)); + Gram.Skeyword ":"; + Gram.Sopt + (Gram.Snterm + (Gram.Entry.obj + (position : 'position Gram.Entry.t))); + Gram.Snterm + (Gram.Entry.obj + (level_list : 'level_list Gram.Entry.t)) ], + (Gram.Action.mk + (fun (ll : 'level_list) (pos : 'position option) + _ (n : 'name) (_loc : Loc.t) -> + ({ name = n; pos = pos; levels = ll; } : + 'entry)))) ]) ])) + ()); + Gram.extend (position : 'position Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function + | UIDENT "LEVEL" -> true + | _ -> false), + "UIDENT \"LEVEL\"")); + Gram.Snterm + (Gram.Entry.obj (string : 'string Gram.Entry.t)) ], + (Gram.Action.mk + (fun (n : 'string) (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT "LEVEL" -> + (Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Camlp4"), + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Sig"), + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Grammar"), + Ast.IdUid (_loc, "Level"))))), + n) : + 'position) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | UIDENT "AFTER" -> true + | _ -> false), + "UIDENT \"AFTER\"")); + Gram.Snterm + (Gram.Entry.obj (string : 'string Gram.Entry.t)) ], + (Gram.Action.mk + (fun (n : 'string) (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT "AFTER" -> + (Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Camlp4"), + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Sig"), + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Grammar"), + Ast.IdUid (_loc, "After"))))), + n) : + 'position) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | UIDENT "BEFORE" -> true + | _ -> false), + "UIDENT \"BEFORE\"")); + Gram.Snterm + (Gram.Entry.obj (string : 'string Gram.Entry.t)) ], + (Gram.Action.mk + (fun (n : 'string) (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT "BEFORE" -> + (Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Camlp4"), + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Sig"), + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Grammar"), + Ast.IdUid (_loc, "Before"))))), + n) : + 'position) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | UIDENT "LAST" -> true + | _ -> false), + "UIDENT \"LAST\"")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | UIDENT "LAST" -> + (Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Camlp4"), + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Sig"), + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Grammar"), + Ast.IdUid (_loc, "Last"))))) : + 'position) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | UIDENT "FIRST" -> true + | _ -> false), + "UIDENT \"FIRST\"")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | UIDENT "FIRST" -> + (Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Camlp4"), + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Sig"), + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Grammar"), + Ast.IdUid (_loc, "First"))))) : + 'position) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (level_list : 'level_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "["; + Gram.Slist0sep + (Gram.Snterm + (Gram.Entry.obj + (level : 'level Gram.Entry.t)), + Gram.Skeyword "|"); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (ll : 'level list) _ (_loc : Loc.t) -> + (ll : 'level_list)))) ]) ])) + ()); + Gram.extend (level : 'level Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Sopt + (Gram.srules level + [ ([ Gram.Stoken + (((function + | STRING ((_)) -> true + | _ -> false), + "STRING _")) ], + (Gram.Action.mk + (fun (x : Gram.Token.t) (_loc : Loc.t) + -> + (let x = + Gram.Token.extract_string x + in x : 'e__11)))) ]); + Gram.Sopt + (Gram.Snterm + (Gram.Entry.obj + (assoc : 'assoc Gram.Entry.t))); + Gram.Snterm + (Gram.Entry.obj + (rule_list : 'rule_list Gram.Entry.t)) ], + (Gram.Action.mk + (fun (rules : 'rule_list) (ass : 'assoc option) + (lab : 'e__11 option) (_loc : Loc.t) -> + ({ label = lab; assoc = ass; rules = rules; + } : 'level)))) ]) ])) + ()); + Gram.extend (assoc : 'assoc Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function + | UIDENT "NONA" -> true + | _ -> false), + "UIDENT \"NONA\"")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | UIDENT "NONA" -> + (Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Camlp4"), + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Sig"), + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Grammar"), + Ast.IdUid (_loc, "NonA"))))) : + 'assoc) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | UIDENT "RIGHTA" -> true + | _ -> false), + "UIDENT \"RIGHTA\"")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | UIDENT "RIGHTA" -> + (Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Camlp4"), + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Sig"), + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Grammar"), + Ast.IdUid (_loc, "RightA"))))) : + 'assoc) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | UIDENT "LEFTA" -> true + | _ -> false), + "UIDENT \"LEFTA\"")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | UIDENT "LEFTA" -> + (Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Camlp4"), + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Sig"), + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Grammar"), + Ast.IdUid (_loc, "LeftA"))))) : + 'assoc) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (rule_list : 'rule_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "["; + Gram.Slist1sep + (Gram.Snterm + (Gram.Entry.obj (rule : 'rule Gram.Entry.t)), + Gram.Skeyword "|"); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (rules : 'rule list) _ (_loc : Loc.t) -> + (retype_rule_list_without_patterns _loc rules : + 'rule_list)))); + ([ Gram.Skeyword "["; Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ _ (_loc : Loc.t) -> ([] : 'rule_list)))) ]) ])) + ()); + Gram.extend (rule : 'rule Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Slist0sep + (Gram.Snterm + (Gram.Entry.obj + (psymbol : 'psymbol Gram.Entry.t)), + Gram.Snterm + (Gram.Entry.obj + (semi_sep : 'semi_sep Gram.Entry.t))) ], + (Gram.Action.mk + (fun (psl : 'psymbol list) (_loc : Loc.t) -> + ({ prod = psl; action = None; } : 'rule)))); + ([ Gram.Slist0sep + (Gram.Snterm + (Gram.Entry.obj + (psymbol : 'psymbol Gram.Entry.t)), + Gram.Snterm + (Gram.Entry.obj + (semi_sep : 'semi_sep Gram.Entry.t))); + Gram.Skeyword "->"; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (act : 'expr) _ (psl : 'psymbol list) + (_loc : Loc.t) -> + ({ prod = psl; action = Some act; } : 'rule)))) ]) ])) + ()); + Gram.extend (psymbol : 'psymbol Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (symbol : 'symbol Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'symbol) (_loc : Loc.t) -> + (s : 'psymbol)))); + ([ Gram.Snterm + (Gram.Entry.obj + (pattern : 'pattern Gram.Entry.t)); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (symbol : 'symbol Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'symbol) _ (p : 'pattern) + (_loc : Loc.t) -> + (match s.pattern with + | Some + (Ast.PaApp (_, + (Ast.PaId (_, (Ast.IdUid (_, u)))), + (Ast.PaTup (_, (Ast.PaAny _))))) + -> + mk_tok _loc + (Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdUid (_loc, u)), + p)) + s.styp + | _ -> { (s) with pattern = Some p; } : + 'psymbol)))); + ([ Gram.Stoken + (((function | LIDENT ((_)) -> true | _ -> false), + "LIDENT _")); + Gram.Sopt + (Gram.srules psymbol + [ ([ Gram.Stoken + (((function + | UIDENT "LEVEL" -> true + | _ -> false), + "UIDENT \"LEVEL\"")); + Gram.Stoken + (((function + | STRING ((_)) -> true + | _ -> false), + "STRING _")) ], + (Gram.Action.mk + (fun (s : Gram.Token.t) + (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT "LEVEL" -> + (let s = + Gram.Token.extract_string s + in s : 'e__12) + | _ -> assert false))) ]) ], + (Gram.Action.mk + (fun (lev : 'e__12 option) (i : Gram.Token.t) + (_loc : Loc.t) -> + (let i = Gram.Token.extract_string i in + let name = + mk_name _loc (Ast.IdLid (_loc, i)) in + let text = TXnterm (_loc, name, lev) in + let styp = STquo (_loc, i) + in + { + + used = [ i ]; + text = text; + styp = styp; + pattern = None; + } : + 'psymbol)))); + ([ Gram.Stoken + (((function | LIDENT ((_)) -> true | _ -> false), + "LIDENT _")); + Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (symbol : 'symbol Gram.Entry.t)) ], + (Gram.Action.mk + (fun (s : 'symbol) _ (p : Gram.Token.t) + (_loc : Loc.t) -> + (let p = Gram.Token.extract_string p + in + match s.pattern with + | Some + ((Ast.PaApp (_, + (Ast.PaId (_, (Ast.IdUid (_, u)))), + (Ast.PaTup (_, (Ast.PaAny _)))) + as p')) + -> + let match_fun = + Ast.ExFun (_loc, + Ast.McOr (_loc, + Ast.McArr (_loc, p', + Ast.ExNil _loc, + Ast.ExId (_loc, + Ast.IdUid (_loc, "True"))), + Ast.McArr (_loc, Ast.PaAny _loc, + Ast.ExNil _loc, + Ast.ExId (_loc, + Ast.IdUid (_loc, "False"))))) in + let p' = + Ast.PaAli (_loc, p', + Ast.PaId (_loc, + Ast.IdLid (_loc, p))) in + let descr = u ^ " _" in + let text = + TXtok (_loc, match_fun, descr) + in + { + (s) + with + + text = text; + pattern = Some p'; + } + | _ -> + { + (s) + with + + pattern = + Some + (Ast.PaId (_loc, + Ast.IdLid (_loc, p))); + } : + 'psymbol)))) ]) ])) + ()); + Gram.extend (symbol : 'symbol Gram.Entry.t) + ((fun () -> + (None, + [ ((Some "top"), (Some Camlp4.Sig.Grammar.NonA), + [ ([ Gram.Stoken + (((function | UIDENT "OPT" -> true | _ -> false), + "UIDENT \"OPT\"")); + Gram.Sself ], + (Gram.Action.mk + (fun (s : 'symbol) (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT "OPT" -> + (let () = check_not_tok s in + let styp = + STapp (_loc, STlid (_loc, "option"), + s.styp) in + let text = TXopt (_loc, s.text) + in + { + + used = s.used; + text = text; + styp = styp; + pattern = None; + } : + 'symbol) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | UIDENT "LIST1" -> true + | _ -> false), + "UIDENT \"LIST1\"")); + Gram.Sself; + Gram.Sopt + (Gram.srules symbol + [ ([ Gram.Stoken + (((function + | UIDENT "SEP" -> true + | _ -> false), + "UIDENT \"SEP\"")); + Gram.Snterm + (Gram.Entry.obj + (symbol : 'symbol Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'symbol) + (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT "SEP" -> (t : 'e__14) + | _ -> assert false))) ]) ], + (Gram.Action.mk + (fun (sep : 'e__14 option) (s : 'symbol) + (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT "LIST1" -> + (let () = check_not_tok s in + let used = + (match sep with + | Some symb -> symb.used @ s.used + | None -> s.used) in + let styp = + STapp (_loc, STlid (_loc, "list"), + s.styp) in + let text = slist _loc true sep s + in + { + + used = used; + text = text; + styp = styp; + pattern = None; + } : + 'symbol) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | UIDENT "LIST0" -> true + | _ -> false), + "UIDENT \"LIST0\"")); + Gram.Sself; + Gram.Sopt + (Gram.srules symbol + [ ([ Gram.Stoken + (((function + | UIDENT "SEP" -> true + | _ -> false), + "UIDENT \"SEP\"")); + Gram.Snterm + (Gram.Entry.obj + (symbol : 'symbol Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'symbol) + (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT "SEP" -> (t : 'e__13) + | _ -> assert false))) ]) ], + (Gram.Action.mk + (fun (sep : 'e__13 option) (s : 'symbol) + (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT "LIST0" -> + (let () = check_not_tok s in + let used = + (match sep with + | Some symb -> symb.used @ s.used + | None -> s.used) in + let styp = + STapp (_loc, STlid (_loc, "list"), + s.styp) in + let text = slist _loc false sep s + in + { + + used = used; + text = text; + styp = styp; + pattern = None; + } : + 'symbol) + | _ -> assert false))) ]); + (None, None, + [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (s_t : 'symbol) _ (_loc : Loc.t) -> + (s_t : 'symbol)))); + ([ Gram.Snterm + (Gram.Entry.obj (name : 'name Gram.Entry.t)); + Gram.Sopt + (Gram.srules symbol + [ ([ Gram.Stoken + (((function + | UIDENT "LEVEL" -> true + | _ -> false), + "UIDENT \"LEVEL\"")); + Gram.Stoken + (((function + | STRING ((_)) -> true + | _ -> false), + "STRING _")) ], + (Gram.Action.mk + (fun (s : Gram.Token.t) + (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT "LEVEL" -> + (let s = + Gram.Token.extract_string s + in s : 'e__16) + | _ -> assert false))) ]) ], + (Gram.Action.mk + (fun (lev : 'e__16 option) (n : 'name) + (_loc : Loc.t) -> + ({ + + used = [ n.tvar ]; + text = TXnterm (_loc, n, lev); + styp = STquo (_loc, n.tvar); + pattern = None; + } : 'symbol)))); + ([ Gram.Stoken + (((function | UIDENT ((_)) -> true | _ -> false), + "UIDENT _")); + Gram.Skeyword "."; + Gram.Snterm + (Gram.Entry.obj (qualid : 'qualid Gram.Entry.t)); + Gram.Sopt + (Gram.srules symbol + [ ([ Gram.Stoken + (((function + | UIDENT "LEVEL" -> true + | _ -> false), + "UIDENT \"LEVEL\"")); + Gram.Stoken + (((function + | STRING ((_)) -> true + | _ -> false), + "STRING _")) ], + (Gram.Action.mk + (fun (s : Gram.Token.t) + (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT "LEVEL" -> + (let s = + Gram.Token.extract_string s + in s : 'e__15) + | _ -> assert false))) ]) ], + (Gram.Action.mk + (fun (lev : 'e__15 option) (il : 'qualid) _ + (i : Gram.Token.t) (_loc : Loc.t) -> + (let i = Gram.Token.extract_string i in + let n = + mk_name _loc + (Ast.IdAcc (_loc, Ast.IdUid (_loc, i), + il)) + in + { + + used = [ n.tvar ]; + text = TXnterm (_loc, n, lev); + styp = STquo (_loc, n.tvar); + pattern = None; + } : + 'symbol)))); + ([ Gram.Stoken + (((function | STRING ((_)) -> true | _ -> false), + "STRING _")) ], + (Gram.Action.mk + (fun (s : Gram.Token.t) (_loc : Loc.t) -> + (let s = Gram.Token.extract_string s + in + { + + used = []; + text = TXkwd (_loc, s); + styp = STtok _loc; + pattern = None; + } : + 'symbol)))); + ([ Gram.Stoken + (((function | UIDENT ((_)) -> true | _ -> false), + "UIDENT _")); + Gram.Stoken + (((function + | ANTIQUOT ("", _) -> true + | _ -> false), + "ANTIQUOT (\"\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (x : Gram.Token.t) (_loc : Loc.t) -> + match __camlp4_0 with + | ANTIQUOT ("", s) -> + (let x = Gram.Token.extract_string x in + let e = + AntiquotSyntax.parse_expr _loc s in + let match_fun = + Ast.ExFun (_loc, + Ast.McOr (_loc, + Ast.McArr (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdUid (_loc, x)), + Ast.PaId (_loc, + Ast.IdLid (_loc, "camlp4_x"))), + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdLid (_loc, "=")), + Ast.ExId (_loc, + Ast.IdLid (_loc, + "camlp4_x"))), + e), + Ast.ExId (_loc, + Ast.IdUid (_loc, "True"))), + Ast.McArr (_loc, Ast.PaAny _loc, + Ast.ExNil _loc, + Ast.ExId (_loc, + Ast.IdUid (_loc, "False"))))) in + let descr = "$" ^ (x ^ (" " ^ s)) in + let text = + TXtok (_loc, match_fun, descr) in + let p = + Ast.PaApp (_loc, + Ast.PaId (_loc, Ast.IdUid (_loc, x)), + Ast.PaTup (_loc, Ast.PaAny _loc)) + in + { + + used = []; + text = text; + styp = STtok _loc; + pattern = Some p; + } : + 'symbol) + | _ -> assert false))); + ([ Gram.Stoken + (((function | UIDENT ((_)) -> true | _ -> false), + "UIDENT _")); + Gram.Stoken + (((function | STRING ((_)) -> true | _ -> false), + "STRING _")) ], + (Gram.Action.mk + (fun (s : Gram.Token.t) (x : Gram.Token.t) + (_loc : Loc.t) -> + (let s = Gram.Token.extract_string s in + let x = Gram.Token.extract_string x + in + mk_tok _loc + (Ast.PaApp (_loc, + Ast.PaId (_loc, Ast.IdUid (_loc, x)), + Ast.PaStr (_loc, s))) + (STtok _loc) : + 'symbol)))); + ([ Gram.Stoken + (((function | UIDENT ((_)) -> true | _ -> false), + "UIDENT _")) ], + (Gram.Action.mk + (fun (x : Gram.Token.t) (_loc : Loc.t) -> + (let x = Gram.Token.extract_string x + in + mk_tok _loc + (Ast.PaApp (_loc, + Ast.PaId (_loc, Ast.IdUid (_loc, x)), + Ast.PaTup (_loc, Ast.PaAny _loc))) + (STstring_tok _loc) : + 'symbol)))); + ([ Gram.Skeyword "`"; + Gram.Snterm + (Gram.Entry.obj (patt : 'patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'patt) _ (_loc : Loc.t) -> + (mk_tok _loc p (STtok _loc) : 'symbol)))); + ([ Gram.Skeyword "["; + Gram.Slist0sep + (Gram.Snterm + (Gram.Entry.obj (rule : 'rule Gram.Entry.t)), + Gram.Skeyword "|"); + Gram.Skeyword "]" ], + (Gram.Action.mk + (fun _ (rl : 'rule list) _ (_loc : Loc.t) -> + (let rl = + retype_rule_list_without_patterns _loc rl in + let t = new_type_var () + in + { + + used = used_of_rule_list rl; + text = + TXrules (_loc, srules _loc t rl ""); + styp = STquo (_loc, t); + pattern = None; + } : + 'symbol)))); + ([ Gram.Stoken + (((function + | UIDENT "NEXT" -> true + | _ -> false), + "UIDENT \"NEXT\"")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | UIDENT "NEXT" -> + ({ + + used = []; + text = TXnext _loc; + styp = STself (_loc, "NEXT"); + pattern = None; + } : 'symbol) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | UIDENT "SELF" -> true + | _ -> false), + "UIDENT \"SELF\"")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | UIDENT "SELF" -> + ({ + + used = []; + text = TXself _loc; + styp = STself (_loc, "SELF"); + pattern = None; + } : 'symbol) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (pattern : 'pattern Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ","; + Gram.Snterm + (Gram.Entry.obj + (comma_patt : 'comma_patt Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (p2 : 'comma_patt) _ (p1 : 'pattern) _ + (_loc : Loc.t) -> + (Ast.PaTup (_loc, Ast.PaCom (_loc, p1, p2)) : + 'pattern)))); + ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (p : 'pattern) _ (_loc : Loc.t) -> + (p : 'pattern)))); + ([ Gram.Skeyword "_" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> + (Ast.PaAny _loc : 'pattern)))); + ([ Gram.Stoken + (((function | LIDENT ((_)) -> true | _ -> false), + "LIDENT _")) ], + (Gram.Action.mk + (fun (i : Gram.Token.t) (_loc : Loc.t) -> + (let i = Gram.Token.extract_string i + in Ast.PaId (_loc, Ast.IdLid (_loc, i)) : + 'pattern)))) ]) ])) + ()); + Gram.extend (comma_patt : 'comma_patt Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (pattern : 'pattern Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p : 'pattern) (_loc : Loc.t) -> + (p : 'comma_patt)))); + ([ Gram.Sself; Gram.Skeyword ","; Gram.Sself ], + (Gram.Action.mk + (fun (p2 : 'comma_patt) _ (p1 : 'comma_patt) + (_loc : Loc.t) -> + (Ast.PaCom (_loc, p1, p2) : 'comma_patt)))) ]) ])) + ()); + Gram.extend (name : 'name Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (qualid : 'qualid Gram.Entry.t)) ], + (Gram.Action.mk + (fun (il : 'qualid) (_loc : Loc.t) -> + (mk_name _loc il : 'name)))) ]) ])) + ()); + Gram.extend (string : 'string Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function + | ANTIQUOT ("", _) -> true + | _ -> false), + "ANTIQUOT (\"\", _)")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | ANTIQUOT ("", s) -> + (AntiquotSyntax.parse_expr _loc s : + 'string) + | _ -> assert false))); + ([ Gram.Stoken + (((function | STRING ((_)) -> true | _ -> false), + "STRING _")) ], + (Gram.Action.mk + (fun (s : Gram.Token.t) (_loc : Loc.t) -> + (let s = Gram.Token.extract_string s + in Ast.ExStr (_loc, s) : 'string)))) ]) ])) + ()); + Gram.extend (semi_sep : 'semi_sep Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword ";" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> (() : 'semi_sep)))) ]) ])) + ())) + let _ = + Gram.extend (symbol : 'symbol Gram.Entry.t) + ((fun () -> + ((Some (Camlp4.Sig.Grammar.Level "top")), + [ (None, (Some Camlp4.Sig.Grammar.NonA), + [ ([ Gram.Stoken + (((function | UIDENT "SOPT" -> true | _ -> false), + "UIDENT \"SOPT\"")); + Gram.Sself ], + (Gram.Action.mk + (fun (s : 'symbol) (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT "SOPT" -> (ssopt _loc s : 'symbol) + | _ -> assert false))); + ([ Gram.srules symbol + [ ([ Gram.Stoken + (((function + | UIDENT "SLIST1" -> true + | _ -> false), + "UIDENT \"SLIST1\"")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT "SLIST1" -> (true : 'e__17) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | UIDENT "SLIST0" -> true + | _ -> false), + "UIDENT \"SLIST0\"")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT "SLIST0" -> (false : 'e__17) + | _ -> assert false))) ]; + Gram.Sself; + Gram.Sopt + (Gram.srules symbol + [ ([ Gram.Stoken + (((function + | UIDENT "SEP" -> true + | _ -> false), + "UIDENT \"SEP\"")); + Gram.Snterm + (Gram.Entry.obj + (symbol : 'symbol Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t : 'symbol) + (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT "SEP" -> (t : 'e__18) + | _ -> assert false))) ]) ], + (Gram.Action.mk + (fun (sep : 'e__18 option) (s : 'symbol) + (min : 'e__17) (_loc : Loc.t) -> + (sslist _loc min sep s : 'symbol)))) ]) ])) + ()) + let sfold _loc n foldfun f e s = + let styp = STquo (_loc, new_type_var ()) in + let e = + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdLid (_loc, foldfun))), + f), + e) in + let t = + STapp (_loc, + STapp (_loc, + STtyp + (Ast.TyApp (_loc, + Ast.TyId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdLid (_loc, "fold"))), + Ast.TyAny _loc)), + s.styp), + styp) + in + { + + used = s.used; + text = TXmeta (_loc, n, [ s.text ], e, t); + styp = styp; + pattern = None; + } + let sfoldsep _loc n foldfun f e s sep = + let styp = STquo (_loc, new_type_var ()) in + let e = + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdLid (_loc, foldfun))), + f), + e) in + let t = + STapp (_loc, + STapp (_loc, + STtyp + (Ast.TyApp (_loc, + Ast.TyId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, gm), + Ast.IdLid (_loc, "foldsep"))), + Ast.TyAny _loc)), + s.styp), + styp) + in + { + + used = s.used @ sep.used; + text = TXmeta (_loc, n, [ s.text; sep.text ], e, t); + styp = styp; + pattern = None; + } + let _ = + let _ = (symbol : 'symbol Gram.Entry.t) in + let grammar_entry_create = Gram.Entry.mk in + let simple_expr : 'simple_expr Gram.Entry.t = + grammar_entry_create "simple_expr" + in + (Gram.extend (symbol : 'symbol Gram.Entry.t) + ((fun () -> + ((Some (Camlp4.Sig.Grammar.Level "top")), + [ (None, None, + [ ([ Gram.Stoken + (((function + | UIDENT "FOLD1" -> true + | _ -> false), + "UIDENT \"FOLD1\"")); + Gram.Snterm + (Gram.Entry.obj + (simple_expr : 'simple_expr Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (simple_expr : 'simple_expr Gram.Entry.t)); + Gram.Sself; + Gram.Stoken + (((function | UIDENT "SEP" -> true | _ -> false), + "UIDENT \"SEP\"")); + Gram.Sself ], + (Gram.Action.mk + (fun (sep : 'symbol) (__camlp4_1 : Gram.Token.t) + (s : 'symbol) (e : 'simple_expr) + (f : 'simple_expr) + (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) -> + match (__camlp4_1, __camlp4_0) with + | (UIDENT "SEP", UIDENT "FOLD1") -> + (sfoldsep _loc "FOLD1 SEP" "sfold1sep" f + e s sep : + 'symbol) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | UIDENT "FOLD0" -> true + | _ -> false), + "UIDENT \"FOLD0\"")); + Gram.Snterm + (Gram.Entry.obj + (simple_expr : 'simple_expr Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (simple_expr : 'simple_expr Gram.Entry.t)); + Gram.Sself; + Gram.Stoken + (((function | UIDENT "SEP" -> true | _ -> false), + "UIDENT \"SEP\"")); + Gram.Sself ], + (Gram.Action.mk + (fun (sep : 'symbol) (__camlp4_1 : Gram.Token.t) + (s : 'symbol) (e : 'simple_expr) + (f : 'simple_expr) + (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) -> + match (__camlp4_1, __camlp4_0) with + | (UIDENT "SEP", UIDENT "FOLD0") -> + (sfoldsep _loc "FOLD0 SEP" "sfold0sep" f + e s sep : + 'symbol) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | UIDENT "FOLD1" -> true + | _ -> false), + "UIDENT \"FOLD1\"")); + Gram.Snterm + (Gram.Entry.obj + (simple_expr : 'simple_expr Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (simple_expr : 'simple_expr Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (s : 'symbol) (e : 'simple_expr) + (f : 'simple_expr) + (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT "FOLD1" -> + (sfold _loc "FOLD1" "sfold1" f e s : + 'symbol) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | UIDENT "FOLD0" -> true + | _ -> false), + "UIDENT \"FOLD0\"")); + Gram.Snterm + (Gram.Entry.obj + (simple_expr : 'simple_expr Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (simple_expr : 'simple_expr Gram.Entry.t)); + Gram.Sself ], + (Gram.Action.mk + (fun (s : 'symbol) (e : 'simple_expr) + (f : 'simple_expr) + (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT "FOLD0" -> + (sfold _loc "FOLD0" "sfold0" f e s : + 'symbol) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (simple_expr : 'simple_expr Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "("; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)); + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ (e : 'expr) _ (_loc : Loc.t) -> + (e : 'simple_expr)))); + ([ Gram.Snterm + (Gram.Entry.obj + (a_LIDENT : 'a_LIDENT Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'a_LIDENT) (_loc : Loc.t) -> + (Ast.ExId (_loc, Ast.IdLid (_loc, i)) : + 'simple_expr)))) ]) ])) + ())) + let _ = + Options.add "-split_ext" (Arg.Set split_ext) + "Split EXTEND by functions to turn around a PowerPC problem." + let _ = + Options.add "-split_gext" (Arg.Set split_ext) + "Old name for the option -split_ext." + let _ = + Options.add "-meta_action" (Arg.Set meta_action) "Undocumented" + end + (* FIXME *) + module M = Register.OCamlSyntaxExtension(Id)(Make) + end +module M = + struct + open Camlp4 + (* -*- camlp4r -*- *) + (****************************************************************************) + (* *) + (* Objective Caml *) + (* *) + (* INRIA Rocquencourt *) + (* *) + (* Copyright 2006 Institut National de Recherche en Informatique et *) + (* en Automatique. All rights reserved. This file is distributed under *) + (* the terms of the GNU Library General Public License, with the special *) + (* exception on linking described in LICENSE at the top of the Objective *) + (* Caml source tree. *) + (* *) + (****************************************************************************) + (* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + module Id = + struct + let name = "Camlp4MacroParser" + let version = + "$Id: camlp4boot.ml,v 1.2 2007/02/26 16:32:47 ertai Exp $" + end + (* +Added statements: + + At toplevel (structure item): + + DEFINE + DEFINE = + DEFINE () = + IFDEF THEN (END | ENDIF) + IFDEF THEN ELSE (END | ENDIF) + IFNDEF THEN (END | ENDIF) + IFNDEF THEN ELSE (END | ENDIF) + INCLUDE + + In expressions: + + IFDEF THEN ELSE (END | ENDIF) + IFNDEF THEN ELSE (END | ENDIF) + __FILE__ + __LOCATION__ + + In patterns: + + IFDEF THEN ELSE (END | ENDIF) + IFNDEF THEN ELSE (END | ENDIF) + + As Camlp4 options: + + -D define + -U undefine it + -I add to the search path for INCLUDE'd files + + After having used a DEFINE followed by "= ", you + can use it in expressions *and* in patterns. If the expression defining + the macro cannot be used as a pattern, there is an error message if + it is used in a pattern. + + + + The toplevel statement INCLUDE can be used to include a + file containing macro definitions and also any other toplevel items. + The included files are looked up in directories passed in via the -I + option, falling back to the current directory. + + The expression __FILE__ returns the current compiled file name. + The expression __LOCATION__ returns the current location of itself. + +*) + open Camlp4 + module Make (Syntax : Sig.Camlp4Syntax) = + struct + open Sig + include Syntax + type 'a item_or_def = + | SdStr of 'a | SdDef of string * ((string list) * Ast.expr) option + | SdUnd of string | SdITE of string * 'a * 'a | SdInc of string + let rec list_remove x = + function + | (y, _) :: l when y = x -> l + | d :: l -> d :: (list_remove x l) + | [] -> [] + let defined = ref [] + let is_defined i = List.mem_assoc i !defined + class reloc _loc = + object inherit Ast.map as super method _Loc_t = fun _ -> _loc end + class subst _loc env = + object inherit reloc _loc as super + method expr = + function + | (Ast.ExId (_, (Ast.IdLid (_, x))) | + Ast.ExId (_, (Ast.IdUid (_, x))) + as e) -> (try List.assoc x env with | Not_found -> e) + | e -> super#expr e + end + let bad_patt _loc = + Loc.raise _loc + (Failure + "this macro cannot be used in a pattern (see its definition)") + let substp _loc env = + let rec loop = + function + | Ast.ExApp (_, e1, e2) -> Ast.PaApp (_loc, loop e1, loop e2) + | Ast.ExId (_, (Ast.IdLid (_, x))) -> + (try List.assoc x env + with | Not_found -> Ast.PaId (_loc, Ast.IdLid (_loc, x))) + | Ast.ExId (_, (Ast.IdUid (_, x))) -> + (try List.assoc x env + with | Not_found -> Ast.PaId (_loc, Ast.IdUid (_loc, x))) + | Ast.ExInt (_, x) -> Ast.PaInt (_loc, x) + | Ast.ExStr (_, s) -> Ast.PaStr (_loc, s) + | Ast.ExTup (_, x) -> Ast.PaTup (_loc, loop x) + | Ast.ExCom (_, x1, x2) -> Ast.PaCom (_loc, loop x1, loop x2) + | Ast.ExRec (_, bi, (Ast.ExNil _)) -> + let rec substbi = + (function + | Ast.BiSem (_, b1, b2) -> + Ast.PaSem (_loc, substbi b1, substbi b2) + | Ast.BiEq (_, p, e) -> Ast.PaEq (_loc, p, loop e) + | _ -> bad_patt _loc) + in Ast.PaRec (_loc, substbi bi) + | _ -> bad_patt _loc + in loop + let incorrect_number loc l1 l2 = + Loc.raise loc + (Failure + (Printf.sprintf "expected %d parameters; found %d" + (List.length l2) (List.length l1))) + let define eo x = + ((match eo with + | Some (([], e)) -> + (Gram.extend (expr : 'expr Gram.Entry.t) + ((fun () -> + ((Some (Camlp4.Sig.Grammar.Level "simple")), + [ (None, None, + [ ([ Gram.Stoken + (((function + | UIDENT camlp4_x when camlp4_x = x -> + true + | _ -> false), + "$UIDENT x")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT ((_)) -> + ((new reloc _loc)#expr e : 'expr) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (patt : 'patt Gram.Entry.t) + ((fun () -> + ((Some (Camlp4.Sig.Grammar.Level "simple")), + [ (None, None, + [ ([ Gram.Stoken + (((function + | UIDENT camlp4_x when camlp4_x = x -> + true + | _ -> false), + "$UIDENT x")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT ((_)) -> + (let p = substp _loc [] e + in (new reloc _loc)#patt p : 'patt) + | _ -> assert false))) ]) ])) + ())) + | Some ((sl, e)) -> + (Gram.extend (expr : 'expr Gram.Entry.t) + ((fun () -> + ((Some (Camlp4.Sig.Grammar.Level "apply")), + [ (None, None, + [ ([ Gram.Stoken + (((function + | UIDENT camlp4_x when camlp4_x = x -> + true + | _ -> false), + "$UIDENT x")); + Gram.Sself ], + (Gram.Action.mk + (fun (param : 'expr) + (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT ((_)) -> + (let el = + (match param with + | Ast.ExTup (_, e) -> + Ast.list_of_expr e [] + | e -> [ e ]) + in + if + (List.length el) = + (List.length sl) + then + (let env = List.combine sl el + in (new subst _loc env)#expr e) + else incorrect_number _loc el sl : + 'expr) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (patt : 'patt Gram.Entry.t) + ((fun () -> + ((Some (Camlp4.Sig.Grammar.Level "simple")), + [ (None, None, + [ ([ Gram.Stoken + (((function + | UIDENT camlp4_x when camlp4_x = x -> + true + | _ -> false), + "$UIDENT x")); + Gram.Sself ], + (Gram.Action.mk + (fun (param : 'patt) + (__camlp4_0 : Gram.Token.t) + (_loc : Loc.t) -> + match __camlp4_0 with + | UIDENT ((_)) -> + (let pl = + (match param with + | Ast.PaTup (_, p) -> + Ast.list_of_patt p [] + | p -> [ p ]) + in + if + (List.length pl) = + (List.length sl) + then + (let env = List.combine sl pl in + let p = substp _loc env e + in (new reloc _loc)#patt p) + else incorrect_number _loc pl sl : + 'patt) + | _ -> assert false))) ]) ])) + ())) + | None -> ()); + defined := (x, eo) :: !defined) + let undef x = + try + let eo = List.assoc x !defined + in + ((match eo with + | Some (([], _)) -> + (Gram.delete_rule expr + [ Gram.Stoken + (((function + | UIDENT camlp4_x when camlp4_x = x -> true + | _ -> false), + "$UIDENT x")) ]; + Gram.delete_rule patt + [ Gram.Stoken + (((function + | UIDENT camlp4_x when camlp4_x = x -> true + | _ -> false), + "$UIDENT x")) ]) + | Some ((_, _)) -> + (Gram.delete_rule expr + [ Gram.Stoken + (((function + | UIDENT camlp4_x when camlp4_x = x -> true + | _ -> false), + "$UIDENT x")); + Gram.Sself ]; + Gram.delete_rule patt + [ Gram.Stoken + (((function + | UIDENT camlp4_x when camlp4_x = x -> true + | _ -> false), + "$UIDENT x")); + Gram.Sself ]) + | None -> ()); + defined := list_remove x !defined) + with | Not_found -> () + (* This is a list of directories to search for INCLUDE statements. *) + let include_dirs = ref [] + (* Add something to the above, make sure it ends with a slash. *) + let add_include_dir str = + if str <> "" + then + (let str = + if (String.get str ((String.length str) - 1)) = '/' + then str + else str ^ "/" + in include_dirs := !include_dirs @ [ str ]) + else () + let parse_include_file rule = + let dir_ok file dir = Sys.file_exists (dir ^ file) + in + fun file -> + let file = + try + (List.find (dir_ok file) (!include_dirs @ [ "./" ])) ^ file + with | Not_found -> file in + let ch = open_in file in + let st = Stream.of_channel ch + in Gram.parse rule (Loc.mk file) st + let _ = + let _ = (expr : 'expr Gram.Entry.t) + and _ = (sig_item : 'sig_item Gram.Entry.t) + and _ = (str_item : 'str_item Gram.Entry.t) + and _ = (patt : 'patt Gram.Entry.t) in + let grammar_entry_create = Gram.Entry.mk in + let endif : 'endif Gram.Entry.t = grammar_entry_create "endif" + and uident : 'uident Gram.Entry.t = grammar_entry_create "uident" + and opt_macro_value : 'opt_macro_value Gram.Entry.t = + grammar_entry_create "opt_macro_value" + in + (Gram.extend (str_item : 'str_item Gram.Entry.t) + ((fun () -> + ((Some Camlp4.Sig.Grammar.First), + [ (None, None, + [ ([ Gram.Skeyword "INCLUDE"; + Gram.Stoken + (((function | STRING ((_)) -> true | _ -> false), + "STRING _")) ], + (Gram.Action.mk + (fun (fname : Gram.Token.t) _ (_loc : Loc.t) -> + (let fname = Gram.Token.extract_string fname + in parse_include_file str_items fname : + 'str_item)))); + ([ Gram.Skeyword "IFNDEF"; + Gram.Snterm + (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); + Gram.Skeyword "THEN"; + Gram.Snterm + (Gram.Entry.obj + (str_items : 'str_items Gram.Entry.t)); + Gram.Skeyword "ELSE"; + Gram.Snterm + (Gram.Entry.obj + (str_items : 'str_items Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (st2 : 'str_items) _ (st1 : 'str_items) _ + (i : 'uident) _ (_loc : Loc.t) -> + (if is_defined i then st2 else st1 : + 'str_item)))); + ([ Gram.Skeyword "IFNDEF"; + Gram.Snterm + (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); + Gram.Skeyword "THEN"; + Gram.Snterm + (Gram.Entry.obj + (str_items : 'str_items Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (st : 'str_items) _ (i : 'uident) _ + (_loc : Loc.t) -> + (if is_defined i then Ast.StNil _loc else st : + 'str_item)))); + ([ Gram.Skeyword "IFDEF"; + Gram.Snterm + (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); + Gram.Skeyword "THEN"; + Gram.Snterm + (Gram.Entry.obj + (str_items : 'str_items Gram.Entry.t)); + Gram.Skeyword "ELSE"; + Gram.Snterm + (Gram.Entry.obj + (str_items : 'str_items Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (st2 : 'str_items) _ (st1 : 'str_items) _ + (i : 'uident) _ (_loc : Loc.t) -> + (if is_defined i then st1 else st2 : + 'str_item)))); + ([ Gram.Skeyword "IFDEF"; + Gram.Snterm + (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); + Gram.Skeyword "THEN"; + Gram.Snterm + (Gram.Entry.obj + (str_items : 'str_items Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (st : 'str_items) _ (i : 'uident) _ + (_loc : Loc.t) -> + (if is_defined i then st else Ast.StNil _loc : + 'str_item)))); + ([ Gram.Skeyword "UNDEF"; + Gram.Snterm + (Gram.Entry.obj (uident : 'uident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'uident) _ (_loc : Loc.t) -> + ((undef i; Ast.StNil _loc) : 'str_item)))); + ([ Gram.Skeyword "DEFINE"; + Gram.Snterm + (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_macro_value : + 'opt_macro_value Gram.Entry.t)) ], + (Gram.Action.mk + (fun (def : 'opt_macro_value) (i : 'uident) _ + (_loc : Loc.t) -> + ((define def i; Ast.StNil _loc) : 'str_item)))) ]) ])) + ()); + Gram.extend (sig_item : 'sig_item Gram.Entry.t) + ((fun () -> + ((Some Camlp4.Sig.Grammar.First), + [ (None, None, + [ ([ Gram.Skeyword "INCLUDE"; + Gram.Stoken + (((function | STRING ((_)) -> true | _ -> false), + "STRING _")) ], + (Gram.Action.mk + (fun (fname : Gram.Token.t) _ (_loc : Loc.t) -> + (let fname = Gram.Token.extract_string fname + in parse_include_file sig_items fname : + 'sig_item)))) ]) ])) + ()); + Gram.extend (endif : 'endif Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "ENDIF" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> (() : 'endif)))); + ([ Gram.Skeyword "END" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> (() : 'endif)))) ]) ])) + ()); + Gram.extend (opt_macro_value : 'opt_macro_value Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([], + (Gram.Action.mk + (fun (_loc : Loc.t) -> (None : 'opt_macro_value)))); + ([ Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (_loc : Loc.t) -> + (Some (([], e)) : 'opt_macro_value)))); + ([ Gram.Skeyword "("; + Gram.Slist1sep + (Gram.srules opt_macro_value + [ ([ Gram.Stoken + (((function + | LIDENT ((_)) -> true + | _ -> false), + "LIDENT _")) ], + (Gram.Action.mk + (fun (x : Gram.Token.t) (_loc : Loc.t) + -> + (let x = + Gram.Token.extract_string x + in x : 'e__19)))) ], + Gram.Skeyword ","); + Gram.Skeyword ")"; Gram.Skeyword "="; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ _ (pl : 'e__19 list) _ + (_loc : Loc.t) -> + (Some ((pl, e)) : 'opt_macro_value)))) ]) ])) + ()); + Gram.extend (expr : 'expr Gram.Entry.t) + ((fun () -> + ((Some (Camlp4.Sig.Grammar.Level "top")), + [ (None, None, + [ ([ Gram.Skeyword "IFNDEF"; + Gram.Snterm + (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); + Gram.Skeyword "THEN"; Gram.Sself; + Gram.Skeyword "ELSE"; Gram.Sself; + Gram.Snterm + (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (e2 : 'expr) _ (e1 : 'expr) _ + (i : 'uident) _ (_loc : Loc.t) -> + (if is_defined i then e2 else e1 : 'expr)))); + ([ Gram.Skeyword "IFDEF"; + Gram.Snterm + (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); + Gram.Skeyword "THEN"; Gram.Sself; + Gram.Skeyword "ELSE"; Gram.Sself; + Gram.Snterm + (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (e2 : 'expr) _ (e1 : 'expr) _ + (i : 'uident) _ (_loc : Loc.t) -> + (if is_defined i then e1 else e2 : 'expr)))) ]) ])) + ()); + Gram.extend (expr : 'expr Gram.Entry.t) + ((fun () -> + ((Some (Camlp4.Sig.Grammar.Level "simple")), + [ (None, None, + [ ([ Gram.Stoken + (((function + | LIDENT "__LOCATION__" -> true + | _ -> false), + "LIDENT \"__LOCATION__\"")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | LIDENT "__LOCATION__" -> + (let (a, b, c, d, e, f, g, h) = + Loc.to_tuple _loc + in + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, + Ast.IdUid (_loc, "Loc"), + Ast.IdLid (_loc, "of_tuple"))), + Ast.ExTup (_loc, + Ast.ExCom (_loc, + Ast.ExStr (_loc, + Ast.safe_string_escaped a), + Ast.ExCom (_loc, + Ast.ExCom (_loc, + Ast.ExCom (_loc, + Ast.ExCom (_loc, + Ast.ExCom (_loc, + Ast.ExCom (_loc, + Ast.ExInt (_loc, + string_of_int b), + Ast.ExInt (_loc, + string_of_int c)), + Ast.ExInt (_loc, + string_of_int d)), + Ast.ExInt (_loc, + string_of_int e)), + Ast.ExInt (_loc, + string_of_int f)), + Ast.ExInt (_loc, + string_of_int g)), + if h + then + Ast.ExId (_loc, + Ast.IdUid (_loc, "True")) + else + Ast.ExId (_loc, + Ast.IdUid (_loc, "False")))))) : + 'expr) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | LIDENT "__FILE__" -> true + | _ -> false), + "LIDENT \"__FILE__\"")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | LIDENT "__FILE__" -> + (Ast.ExStr (_loc, + Ast.safe_string_escaped + (Loc.file_name _loc)) : + 'expr) + | _ -> assert false))) ]) ])) + ()); + Gram.extend (patt : 'patt Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "IFNDEF"; + Gram.Snterm + (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); + Gram.Skeyword "THEN"; Gram.Sself; + Gram.Skeyword "ELSE"; Gram.Sself; + Gram.Snterm + (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (p2 : 'patt) _ (p1 : 'patt) _ + (i : 'uident) _ (_loc : Loc.t) -> + (if is_defined i then p2 else p1 : 'patt)))); + ([ Gram.Skeyword "IFDEF"; + Gram.Snterm + (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); + Gram.Skeyword "THEN"; Gram.Sself; + Gram.Skeyword "ELSE"; Gram.Sself; + Gram.Snterm + (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (p2 : 'patt) _ (p1 : 'patt) _ + (i : 'uident) _ (_loc : Loc.t) -> + (if is_defined i then p1 else p2 : 'patt)))) ]) ])) + ()); + Gram.extend (uident : 'uident Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function | UIDENT ((_)) -> true | _ -> false), + "UIDENT _")) ], + (Gram.Action.mk + (fun (i : Gram.Token.t) (_loc : Loc.t) -> + (let i = Gram.Token.extract_string i in i : + 'uident)))) ]) ])) + ())) + let _ = + Options.add "-D" (Arg.String (define None)) + " Define for IFDEF instruction." + let _ = + Options.add "-U" (Arg.String undef) + " Undefine for IFDEF instruction." + let _ = + Options.add "-I" (Arg.String add_include_dir) + " Add a directory to INCLUDE search path." + end + let _ = let module M = Register.OCamlSyntaxExtension(Id)(Make) in () + end +module D = + struct + open Camlp4 + (* -*- camlp4r -*- *) + (****************************************************************************) + (* *) + (* Objective Caml *) + (* *) + (* INRIA Rocquencourt *) + (* *) + (* Copyright 2006 Institut National de Recherche en Informatique et *) + (* en Automatique. All rights reserved. This file is distributed under *) + (* the terms of the GNU Library General Public License, with the special *) + (* exception on linking described in LICENSE at the top of the Objective *) + (* Caml source tree. *) + (* *) + (****************************************************************************) + (* Authors: + * - Nicolas Pouillard: initial version + *) + module Id = + struct + let name = "Camlp4DebugParser" + let version = + "$Id: camlp4boot.ml,v 1.2 2007/02/26 16:32:47 ertai Exp $" + end + module Make (Syntax : Sig.Camlp4Syntax) = + struct + open Sig + include Syntax + module StringSet = Set.Make(String) + let debug_mode = + try + let str = Sys.getenv "STATIC_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) + let rec apply accu = + function + | [] -> accu + | x :: xs -> + let _loc = Ast.loc_of_expr x + in apply (Ast.ExApp (_loc, accu, x)) xs + let mk_debug_mode _loc = + function + | None -> + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Debug"), + Ast.IdLid (_loc, "mode"))) + | Some m -> + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, m), + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Debug"), + Ast.IdLid (_loc, "mode")))) + let mk_debug _loc m fmt section args = + let call = + apply + (Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Debug"), + Ast.IdLid (_loc, "printf"))), + Ast.ExStr (_loc, section)), + Ast.ExStr (_loc, fmt))) + args + in + Ast.ExIfe (_loc, + Ast.ExApp (_loc, mk_debug_mode _loc m, + Ast.ExStr (_loc, section)), + call, Ast.ExId (_loc, Ast.IdUid (_loc, "()"))) + let _ = + let _ = (expr : 'expr Gram.Entry.t) in + let grammar_entry_create = Gram.Entry.mk in + let end_or_in : 'end_or_in Gram.Entry.t = + grammar_entry_create "end_or_in" + and start_debug : 'start_debug Gram.Entry.t = + grammar_entry_create "start_debug" + in + (Gram.extend (expr : 'expr Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (start_debug : 'start_debug Gram.Entry.t)); + Gram.Stoken + (((function | LIDENT ((_)) -> true | _ -> false), + "LIDENT _")); + Gram.Stoken + (((function | STRING ((_)) -> true | _ -> false), + "STRING _")); + Gram.Slist0 + (Gram.Snterml + (Gram.Entry.obj (expr : 'expr Gram.Entry.t), + ".")); + Gram.Snterm + (Gram.Entry.obj + (end_or_in : 'end_or_in Gram.Entry.t)) ], + (Gram.Action.mk + (fun (x : 'end_or_in) (args : 'expr list) + (fmt : Gram.Token.t) (section : Gram.Token.t) + (m : 'start_debug) (_loc : Loc.t) -> + (let fmt = Gram.Token.extract_string fmt in + let section = + Gram.Token.extract_string section + in + match (x, (debug_mode section)) with + | (None, false) -> + Ast.ExId (_loc, + Ast.IdUid (_loc, "()")) + | (Some e, false) -> e + | (None, _) -> + mk_debug _loc m fmt section args + | (Some e, _) -> + Ast.ExLet (_loc, Ast.BFalse, + Ast.BiEq (_loc, + Ast.PaId (_loc, + Ast.IdUid (_loc, "()")), + mk_debug _loc m fmt section args), + e) : + 'expr)))) ]) ])) + ()); + Gram.extend (end_or_in : 'end_or_in Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Skeyword "in"; + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (e : 'expr) _ (_loc : Loc.t) -> + (Some e : 'end_or_in)))); + ([ Gram.Skeyword "end" ], + (Gram.Action.mk + (fun _ (_loc : Loc.t) -> (None : 'end_or_in)))) ]) ])) + ()); + Gram.extend (start_debug : 'start_debug Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Stoken + (((function + | LIDENT "camlp4_debug" -> true + | _ -> false), + "LIDENT \"camlp4_debug\"")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | LIDENT "camlp4_debug" -> + (Some "Camlp4" : 'start_debug) + | _ -> assert false))); + ([ Gram.Stoken + (((function + | LIDENT "debug" -> true + | _ -> false), + "LIDENT \"debug\"")) ], + (Gram.Action.mk + (fun (__camlp4_0 : Gram.Token.t) (_loc : Loc.t) + -> + match __camlp4_0 with + | LIDENT "debug" -> (None : 'start_debug) + | _ -> assert false))) ]) ])) + ())) + end + let _ = let module M = Register.OCamlSyntaxExtension(Id)(Make) in () + end +module P = + struct + (****************************************************************************) + (* *) + (* Objective Caml *) + (* *) + (* INRIA Rocquencourt *) + (* *) + (* Copyright 2006 Institut National de Recherche en Informatique et *) + (* en Automatique. All rights reserved. This file is distributed under *) + (* the terms of the GNU Library General Public License, with the special *) + (* exception on linking described in LICENSE at the top of the Objective *) + (* Caml source tree. *) + (* *) + (****************************************************************************) + (* Authors: + * - Nicolas Pouillard: initial version + *) + let _ = Camlp4.Register.enable_dump_ocaml_ast_printer () + end +module B = + struct + (* camlp4r *) + (****************************************************************************) + (* *) + (* Objective Caml *) + (* *) + (* INRIA Rocquencourt *) + (* *) + (* Copyright 2006 Institut National de Recherche en Informatique et *) + (* en Automatique. All rights reserved. This file is distributed under *) + (* the terms of the GNU Library General Public License, with the special *) + (* exception on linking described in LICENSE at the top of the Objective *) + (* Caml source tree. *) + (* *) + (****************************************************************************) + (* Authors: + * - Daniel de Rauglaudre: initial version + * - Nicolas Pouillard: refactoring + *) + (* $Id: camlp4boot.ml,v 1.2 2007/02/26 16:32:47 ertai Exp $ *) + open Camlp4 + open PreCast.Syntax + open PreCast + open Format + module CleanAst = Camlp4.Struct.CleanAst.Make(Ast) + module SSet = Set.Make(String) + let pa_r = "Camlp4OCamlRevisedParser" + (* value pa_rr = "Camlp4OCamlrrParser"; *) + let pa_o = "Camlp4OCamlParser" + let pa_rp = "Camlp4OCamlRevisedParserParser" + let pa_op = "Camlp4OCamlParserParser" + let pa_g = "Camlp4GrammarParser" + let pa_m = "Camlp4MacroParser" + let pa_qb = "Camlp4QuotationCommon" + let pa_q = "Camlp4QuotationExpander" + let pa_rq = "Camlp4OCamlRevisedQuotationExpander" + let pa_oq = "Camlp4OCamlOriginalQuotationExpander" + let dyn_loader = + ref (fun _ -> raise (Match_failure ("./camlp4/Camlp4Bin.ml", 42, 24))) + let rcall_callback = ref (fun () -> ()) + let loaded_modules = ref SSet.empty + let add_to_loaded_modules name = + loaded_modules := SSet.add name !loaded_modules + let rewrite_and_load n x = + let dyn_loader = !dyn_loader () in + let find_in_path = DynLoader.find_in_path dyn_loader in + let real_load name = + (add_to_loaded_modules name; DynLoader.load dyn_loader name) in + let load = + List.iter + (fun n -> + if SSet.mem n !loaded_modules + then () + else + (add_to_loaded_modules n; + DynLoader.load dyn_loader (n ^ ".cmo"))) + in + ((match (n, (String.lowercase x)) with + | (("Parsers" | ""), + ("pa_r.cmo" | "r" | "ocamlr" | "ocamlrevised" | + "camlp4ocamlrevisedparser.cmo")) + -> load [ pa_r ] + | (* | ("Parsers"|"", "rr" | "OCamlrr") -> load [pa_r; 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_o; 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_r; pa_g ] + | (("Parsers" | ""), + ("pa_macro.cmo" | "m" | "macro" | "camlp4macroparser.cmo")) -> + load [ pa_r; pa_m ] + | (("Parsers" | ""), ("q" | "camlp4quotationexpander.cmo")) -> + load [ pa_r; pa_qb; pa_q ] + | (("Parsers" | ""), + ("q_MLast.cmo" | "rq" | + "camlp4ocamlrevisedquotationexpander.cmo")) + -> load [ pa_r; 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_m ] + | (("Parsers" | ""), "of") -> + load [ pa_r; pa_o; pa_rp; pa_op; pa_qb; pa_rq; pa_g; pa_m ] + | (("Filters" | ""), ("lift" | "camlp4astlifter.cmo")) -> + load [ "Camlp4AstLifter" ] + | (("Filters" | ""), ("exn" | "camlp4exceptiontracer.cmo")) -> + load [ "Camlp4ExceptionTracer" ] + | (("Filters" | ""), ("prof" | "camlp4profiler.cmo")) -> + load [ "Camlp4Profiler" ] + | (("Filters" | ""), ("map" | "camlp4mapgenerator.cmo")) -> + load [ "Camlp4MapGenerator" ] + | (("Filters" | ""), ("fold" | "camlp4foldgenerator.cmo")) -> + load [ "Camlp4FoldGenerator" ] + | (("Filters" | ""), ("meta" | "camlp4metagenerator.cmo")) -> + load [ "Camlp4MetaGenerator" ] + | (("Filters" | ""), ("trash" | "camlp4trashremover.cmo")) -> + load [ "Camlp4TrashRemover" ] + | (("Filters" | ""), ("striploc" | "camlp4locationstripper.cmo")) + -> load [ "Camlp4LocationStripper" ] + | (("Filters" | ""), ("tracer" | "camlp4tracer.cmo")) -> + load [ "Camlp4Tracer" ] + | (("Printers" | ""), + ("pr_r.cmo" | "r" | "ocamlr" | "camlp4ocamlrevisedprinter.cmo")) + -> Register.enable_ocamlr_printer () + | (* | ("Printers"|"", "rr" | "OCamlrr" | "Camlp4Printers/OCamlrr.cmo") -> *) + (* Register.enable_ocamlrr_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 ^ ".cmo"))) + in real_load (try find_in_path y with | Not_found -> x)); + !rcall_callback ()) + let print_warning = eprintf "%a:\n%s@." Loc.print + let 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) -> (rewrite_and_load "" s; None) + | (_, "directory", s) -> + (DynLoader.include_dir dyn_loader s; None) + | (_, "use", s) -> Some (parse_file dyn_loader s pa getdir) + | (_, "default_quotation", s) -> + (Quotation.default := s; None) + | (loc, _, _) -> + Loc.raise loc (Stream.Error "bad directive")) + | None -> None) in + let loc = Loc.mk name + in + (Warning.current := print_warning; + let ic = if name = "-" then stdin else open_in_bin name in + let cs = Stream.of_channel ic in + let clear () = if name = "-" then () else close_in ic in + let phr = + try pa ?directive_handler loc cs with | x -> (clear (); raise x) + in (clear (); phr)) + let output_file = ref None + let 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 ast + let gind = + function + | Ast.SgDir (loc, n, (Ast.ExStr (_, s))) -> Some ((loc, n, s)) + | _ -> None + let gimd = + function + | Ast.StDir (loc, n, (Ast.ExStr (_, s))) -> Some ((loc, n, s)) + | _ -> None + open Register + let 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 + let 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 + let just_print_the_version () = + (printf "%s@." Camlp4_config.version; exit 0) + let print_version () = + (eprintf "Camlp4 version %s@." Camlp4_config.version; exit 0) + let print_stdlib () = + (printf "%s@." Camlp4_config.camlp4_standard_library; exit 0) + let usage ini_sl ext_sl = + (eprintf + "\ +Usage: camlp4 [load-options] [--] [other-options] +Options: +.ml Parse this implementation file +.mli Parse this interface file +.(cmo|cma) Load this module inside the Camlp4 core@."; + 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 + (eprintf "Options added by loaded object files:@."; + Options.print_usage_list ext_sl) + else ()) + let warn_noassert () = + eprintf + "\ +camlp4 warning: option -noassert is obsolete +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 + let search_stdlib = ref true + let print_loaded_modules = ref false + let (task, do_task) = + let t = ref None in + let task f x = + let () = Camlp4_config.current_input_file := x + in + t := + Some + (if !t = None then (fun _ -> f x) else (fun usage -> usage ())) in + let do_task usage = match !t with | Some f -> f usage | None -> () + in (task, do_task) + let input_file x = + let dyn_loader = !dyn_loader () + in + (!rcall_callback (); + (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 -> + let (f, o) = Filename.open_temp_file "from_string" ".ml" + in + (output_string o s; + close_out o; + task (process_impl dyn_loader) f) + | ModuleImpl file_name -> rewrite_and_load "" file_name + | IncludeDir dir -> DynLoader.include_dir dyn_loader dir); + !rcall_callback ()) + let initial_spec_list = + [ ("-I", (Arg.String (fun x -> input_file (IncludeDir 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 ^ ")."))); + ("-QD", (Arg.String (fun x -> Quotation.dump_file := Some x)), + " Dump quotation expander result in case of syntax error."); + ("-o", (Arg.String (fun x -> output_file := 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."); + ("-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/.cmo"); + ("-printer", (Arg.String (rewrite_and_load "Printers")), + " Load the printer Camlp4Printers/.cmo"); + ("-filter", (Arg.String (rewrite_and_load "Filters")), + " Load the filter Camlp4Filters/.cmo"); + ("-ignore", (Arg.String ignore), "ignore the next argument"); + ("--", (Arg.Unit ignore), "Deprecated, does nothing") ] + let _ = Options.init initial_spec_list + let 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 ".cmo" + then ModuleImpl name + else + if Filename.check_suffix name ".cma" + then ModuleImpl name + else raise (Arg.Bad ("don't know what to do with " ^ name))) + let main argv = + let usage () = + (usage initial_spec_list (Options.ext_spec_list ()); exit 0) + in + try + let dynloader = + DynLoader.mk ~ocaml_stdlib: !search_stdlib + ~camlp4_stdlib: !search_stdlib () + in + (dyn_loader := (fun () -> dynloader); + let call_callback () = + Register.iter_and_take_callbacks + (fun (name, module_callback) -> + let () = add_to_loaded_modules name in module_callback ()) + in + (call_callback (); + rcall_callback := call_callback; + (match Options.parse anon_fun argv with + | [] -> () + | ("-help" | "--help" | "-h" | "-?") :: _ -> usage () + | s :: _ -> + (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 + then SSet.iter (eprintf "%s@.") !loaded_modules + else ())) + with + | Arg.Bad s -> + (eprintf "Error: %s\n" s; + eprintf "Use option -help for usage@."; + exit 2) + | Arg.Help _ -> usage () + | exc -> (eprintf "@[%a@]@." ErrorHandler.print exc; exit 2) + let _ = main Sys.argv + end + diff --git a/camlp4/boot/camlp4boot.ml4 b/camlp4/boot/camlp4boot.ml4 new file mode 100644 index 00000000..582ce9c2 --- /dev/null +++ b/camlp4/boot/camlp4boot.ml4 @@ -0,0 +1,9 @@ +module R = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml"; end; +module Camlp4QuotationCommon = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml"; end; +module Q = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4QuotationExpander.ml"; end; +module Rp = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml"; end; +module G = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4GrammarParser.ml"; end; +module M = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4MacroParser.ml"; end; +module D = struct INCLUDE "camlp4/Camlp4Parsers/Camlp4DebugParser.ml"; end; +module P = struct INCLUDE "camlp4/Camlp4Printers/Camlp4OCamlAstDumper.ml"; end; +module B = struct INCLUDE "camlp4/Camlp4Bin.ml"; end; diff --git a/camlp4/build/.cvsignore b/camlp4/build/.cvsignore new file mode 100644 index 00000000..81edfb4d --- /dev/null +++ b/camlp4/build/.cvsignore @@ -0,0 +1,7 @@ +camlp4_config.ml +linenum.mli +linenum.mll +location.ml +location.mli +terminfo.ml +terminfo.mli diff --git a/camlp4/camlp4/.cvsignore b/camlp4/camlp4/.cvsignore deleted file mode 100644 index 38b5e090..00000000 --- a/camlp4/camlp4/.cvsignore +++ /dev/null @@ -1,6 +0,0 @@ -*.cm[oia] -camlp4 -*.lib -crc.ml -extract_crc -phony diff --git a/camlp4/camlp4/.depend b/camlp4/camlp4/.depend deleted file mode 100644 index 2f078d8d..00000000 --- a/camlp4/camlp4/.depend +++ /dev/null @@ -1,21 +0,0 @@ -ast2pt.cmi: $(OTOP)/parsing/parsetree.cmi mLast.cmi $(OTOP)/parsing/longident.cmi \ - $(OTOP)/parsing/location.cmi -pcaml.cmi: spretty.cmi mLast.cmi -quotation.cmi: mLast.cmi -reloc.cmi: mLast.cmi -argl.cmo: pcaml.cmi ../odyl/odyl_main.cmi mLast.cmi ast2pt.cmi -argl.cmx: pcaml.cmx ../odyl/odyl_main.cmx mLast.cmi ast2pt.cmx -ast2pt.cmo: pcaml.cmi $(OTOP)/parsing/parsetree.cmi mLast.cmi \ - $(OTOP)/parsing/longident.cmi $(OTOP)/parsing/location.cmi \ - $(OTOP)/parsing/asttypes.cmi ast2pt.cmi -ast2pt.cmx: pcaml.cmx $(OTOP)/parsing/parsetree.cmi mLast.cmi \ - $(OTOP)/parsing/longident.cmx $(OTOP)/parsing/location.cmx \ - $(OTOP)/parsing/asttypes.cmi ast2pt.cmi -pcaml.cmo: spretty.cmi reloc.cmi quotation.cmi mLast.cmi pcaml.cmi -pcaml.cmx: spretty.cmx reloc.cmx quotation.cmx mLast.cmi pcaml.cmi -quotation.cmo: mLast.cmi quotation.cmi -quotation.cmx: mLast.cmi quotation.cmi -reloc.cmo: mLast.cmi reloc.cmi -reloc.cmx: mLast.cmi reloc.cmi -spretty.cmo: spretty.cmi -spretty.cmx: spretty.cmi diff --git a/camlp4/camlp4/Makefile b/camlp4/camlp4/Makefile deleted file mode 100644 index e3c056e7..00000000 --- a/camlp4/camlp4/Makefile +++ /dev/null @@ -1,97 +0,0 @@ -# $Id: Makefile,v 1.27.4.1 2006/09/12 08:58:10 doligez Exp $ - -include ../config/Makefile - -SHELL=/bin/sh - -INCLUDES=-I ../odyl -I ../boot -I $(OTOP)/utils -I $(OTOP)/parsing -I $(OTOP)/otherlibs/dynlink -OCAMLCFLAGS= $(INCLUDES) -warn-error A $(INCLUDES) -LINKFLAGS=$(INCLUDES) -INTERFACES=-I $(OLIBDIR) Arg Array ArrayLabels Buffer Callback CamlinternalOO Char Complex Digest Filename Format Gc Genlex Hashtbl Int32 Int64 Lazy Lexing List ListLabels Map Marshal MoreLabels Nativeint Obj Oo Parsing Pervasives Printexc Printf Queue Random Scanf Set Sort Stack StdLabels Stream String StringLabels Sys Weak -I ../boot Extfold Extfun Fstream Gramext Grammar Plexer Stdpp Token -I $(OTOP)/utils Config Warnings -I $(OTOP)/parsing Asttypes Location Longident Parsetree -I . Ast2pt MLast Pcaml Quotation Spretty -CAMLP4_INTF=$(OTOP)/utils/config.cmi $(OTOP)/utils/warnings.cmi $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmi $(OTOP)/parsing/longident.cmi $(OTOP)/parsing/parsetree.cmi ast2pt.cmi mLast.cmi pcaml.cmi spretty.cmi quotation.cmi -CAMLP4_OBJS=../boot/stdpp.cmo ../boot/token.cmo ../boot/plexer.cmo ../boot/gramext.cmo ../boot/grammar.cmo ../boot/extfold.cmo ../boot/extfun.cmo ../boot/fstream.cmo $(OTOP)/utils/config.cmo quotation.cmo spretty.cmo reloc.cmo pcaml.cmo ast2pt.cmo argl.cmo -CAMLP4_XOBJS=../lib/stdpp.cmx ../lib/token.cmx ../lib/plexer.cmx ../lib/gramext.cmx ../lib/grammar.cmx ../lib/extfold.cmx ../lib/extfun.cmx ../lib/fstream.cmx $(OTOP)/utils/config.cmx quotation.cmx spretty.cmx reloc.cmx pcaml.cmx ast2pt.cmx argl.cmx -OBJS=../odyl/odyl.cma camlp4.cma -CAMLP4M= - -CAMLP4=camlp4$(EXE) -CAMLP4OPT=phony - -all: $(CAMLP4) - -opt: opt$(PROFILING) - -optnoprof: $(OBJS:.cma=.cmxa) - -optprof: optnoprof $(OBJS:.cma=.p.cmxa) - -optp4: $(CAMLP4OPT) - -$(CAMLP4): $(OBJS) ../odyl/odyl.cmo - $(OCAMLC) -linkall -o $@ $(OBJS) $(CAMLP4M) ../odyl/odyl.cmo - -$(CAMLP4OPT): $(OBJS:.cma=.cmxa) ../odyl/odyl.cmx - $(OCAMLOPT) -linkall -o $@ $(OBJS:.cma=.cmxa) $(CAMLP4M) ../odyl/odyl.cmx - -$(OTOP)/utils/config.cmx: $(OTOP)/utils/config.ml - $(OCAMLOPT) -I $(OTOP)/utils -c $(OTOP)/utils/config.ml - -$(OTOP)/utils/config.p.cmx: $(OTOP)/utils/config.ml - $(OCAMLOPT) -I $(OTOP)/utils -p -c -o $@ $(OTOP)/utils/config.ml - -camlp4.cma: $(CAMLP4_OBJS) - $(OCAMLC) $(LINKFLAGS) -a -o $@ $(CAMLP4_OBJS) - -camlp4.cmxa: $(CAMLP4_XOBJS) - $(OCAMLOPT) $(LINKFLAGS) -a -o $@ $(CAMLP4_XOBJS) - -camlp4.p.cmxa: $(CAMLP4_XOBJS:.cmx=.p.cmx) - $(OCAMLOPT) $(LINKFLAGS) -a -o $@ $(CAMLP4_XOBJS:.cmx=.p.cmx) - -clean:: - rm -f *.cm* *.pp[io] *.$(O) *.$(A) *.bak .*.bak *.out *.opt - rm -f $(CAMLP4) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -promote: - cp $(CAMLP4) ../boot/. - -compare: - @for j in $(CAMLP4); do \ - if cmp $$j ../boot/$$j; then :; else exit 1; fi; \ - done - -EXPORTED = mLast quotation ast2pt pcaml spretty reloc - -install: - -$(MKDIR) "$(BINDIR)" - -$(MKDIR) "$(LIBDIR)/camlp4" - cp $(CAMLP4) "$(BINDIR)/." - for ext in mli cmi cmo cmx o; do for mod in $(EXPORTED); do \ - cp $${mod}.$${ext} "$(LIBDIR)/camlp4/."; done; done - cp argl.cmi argl.cmo "$(LIBDIR)/camlp4/." - for f in argl.o argl.cmx; do \ - if test -r $$f ; then \ - cp $$f "$(LIBDIR)/camlp4/." ; \ - fi ; \ - done - cp camlp4.cma $(LIBDIR)/camlp4/. - for f in camlp4.$(A) camlp4.p.$(A) ; do \ - if test -f $$f ; then \ - cp $$f "$(LIBDIR)/camlp4/." && ( cd "$(LIBDIR)/camlp4/." && $(RANLIB) $$f ) ; \ - fi ; \ - done - for f in camlp4.cmxa camlp4.p.cmxa ; do \ - if test -f $$f ; then \ - cp $$f "$(LIBDIR)/camlp4/." ; \ - fi ; \ - done - -include .depend diff --git a/camlp4/camlp4/argl.ml b/camlp4/camlp4/argl.ml deleted file mode 100644 index 9bcb6d59..00000000 --- a/camlp4/camlp4/argl.ml +++ /dev/null @@ -1,443 +0,0 @@ -(* camlp4r q_MLast.cmo *) -(* $Id: argl.ml,v 1.18.2.1 2006/01/11 17:44:58 mauny Exp $ *) - -open Printf; - -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 "bool_of_string" -> None ] - | [] -> None ] - else - try do { f (bool_of_string s); Some sl } with - [ Invalid_argument "bool_of_string" -> 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 "int_of_string" -> None ] - | [] -> None ] - else - try do { f (int_of_string s); Some sl } with - [ Failure "int_of_string" -> 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 "int_of_string" -> None ] - | [] -> None ] - else - try do { r.val := (int_of_string s); Some sl } with - [ Failure "int_of_string" -> 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 rec parse_arg s sl = - fun - [ [(name, action, _) :: spec_list] -> - 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 _ -> parse_arg s sl spec_list ] - else parse_arg s sl spec_list - | [] -> None ] -; - -value rec parse_aux spec_list anon_fun = - fun - [ [] -> [] - | [s :: sl] -> - if String.length s > 1 && s.[0] = '-' then - match parse_arg s sl spec_list with - [ Some sl -> parse_aux spec_list anon_fun sl - | None -> [s :: parse_aux spec_list anon_fun sl] ] - else do { (anon_fun s : unit); parse_aux spec_list anon_fun sl } ] -; - -value loc_fmt = - match Sys.os_type with - [ "MacOS" -> - format_of_string "File \"%s\"; line %d; characters %d to %d\n### " - | _ -> - format_of_string "File \"%s\", line %d, characters %d-%d:\n" ] -; - -value print_location loc = - if Pcaml.input_file.val <> "-" then - let (fname, line, bp, ep) = Stdpp.line_of_loc Pcaml.input_file.val loc in - eprintf loc_fmt fname line bp ep - else eprintf "At location %d-%d\n" (fst loc).Lexing.pos_cnum (snd loc).Lexing.pos_cnum -; - -value print_warning loc s = - do { print_location loc; eprintf "%s\n" s } -; - -value rec parse_file pa getdir useast = - let name = Pcaml.input_file.val in - let (_,_,fname) = Pcaml.position.val in - let () = fname.val := name in - do { - Pcaml.warning.val := print_warning; - let ic = if name = "-" then stdin else open_in_bin name in - let cs = Stream.of_channel ic in - let clear () = if name = "-" then () else close_in ic in - let phr = - try - loop () where rec loop () = - let (pl, stopped_at_directive) = pa cs in - if stopped_at_directive then - let pl = - let rpl = List.rev pl in - match getdir rpl with - [ Some x -> - match x with - [ (loc, "load", Some <:expr< $str:s$ >>) -> - do { Odyl_main.loadfile s; pl } - | (loc, "directory", Some <:expr< $str:s$ >>) -> - do { Odyl_main.directory s; pl } - | (loc, "use", Some <:expr< $str:s$ >>) -> - List.rev_append rpl - [(useast loc s (use_file pa getdir useast s), loc)] - | (loc, _, _) -> - Stdpp.raise_with_loc loc (Stream.Error "bad directive") ] - | None -> pl ] - in - pl @ loop () - else pl - with x -> - do { clear (); raise x } - in - clear (); - phr - } -and use_file pa getdir useast s = - let (bolpos,lnum,fname) = Pcaml.position.val in - let clear = - let v_input_file = Pcaml.input_file.val in - let (bolp,ln,fn) = (bolpos.val, lnum.val, fname.val) in - fun () -> do { - Pcaml.input_file.val := v_input_file; - bolpos.val := bolp; lnum.val := ln; fname.val := fn - } - in - do { - Pcaml.input_file.val := s; - bolpos.val := 0; lnum.val := 1; fname.val := s; - try - let r = parse_file pa getdir useast in - do { clear (); r } - with e -> - do { clear (); raise e } - } -; - -value process pa pr getdir useast = - pr (parse_file pa getdir useast); - - -value gind = - fun - [ [(MLast.SgDir loc n dp, _) :: _] -> Some (loc, n, dp) - | _ -> None ] -; - -value gimd = - fun - [ [(MLast.StDir loc n dp, _) :: _] -> Some (loc, n, dp) - | _ -> None ] -; - -value usesig loc fname ast = MLast.SgUse loc fname ast; -value usestr loc fname ast = MLast.StUse loc fname ast; - -value process_intf () = - process Pcaml.parse_interf.val Pcaml.print_interf.val gind usesig; -value process_impl () = - process Pcaml.parse_implem.val Pcaml.print_implem.val gimd usestr; - -type file_kind = - [ Intf - | Impl ] -; -value file_kind = ref Intf; -value file_kind_of_name name = - if Filename.check_suffix name ".mli" then Intf - else if Filename.check_suffix name ".ml" then Impl - else raise (Arg.Bad ("don't know what to do with " ^ name)) -; - -value print_version_string () = - do { - print_string Pcaml.version; print_newline(); exit 0 - } -; - -value print_version () = - do { - eprintf "Camlp4 version %s\n" Pcaml.version; flush stderr; exit 0 - } -; - -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 (13 - 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 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 usage ini_sl ext_sl = - do { - eprintf "\ -Usage: camlp4 [load-options] [--] [other-options] -Load options: - -I directory Add directory in search patch for object files. - -where Print camlp4 library directory and exit. - -nolib No automatic search for object files in library directory. - Load this file in Camlp4 core. -Other options: - Parse this file.\n"; - 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.\n" ]; - if ext_sl <> [] then do { - eprintf "Options added by loaded object files:\n"; - print_usage_list ext_sl; - } - else (); - } -; - -value warn_noassert () = - do { - eprintf "\ -camlp4 warning: option -noassert is obsolete -You should give the -noassert option to the ocaml compiler instead. -"; - } -; - -value initial_spec_list = - [("-intf", - Arg.String - (fun x -> do { file_kind.val := Intf; Pcaml.input_file.val := x }), - " Parse as an interface, whatever its extension."); - ("-impl", - Arg.String - (fun x -> do { file_kind.val := Impl; Pcaml.input_file.val := x }), - " Parse as an implementation, whatever its extension."); - ("-unsafe", Arg.Set Ast2pt.fast, - "Generate unsafe accesses to array and strings."); - ("-noassert", Arg.Unit warn_noassert, - "Obsolete, do not use this option."); - ("-verbose", Arg.Set Grammar.error_verbose, - "More verbose in parsing errors."); - ("-loc", Arg.String (fun x -> Stdpp.loc_name.val := x), - " Name of the location variable (default: " ^ Stdpp.loc_name.val ^ - ")"); - ("-QD", Arg.String (fun x -> Pcaml.quotation_dump_file.val := Some x), - " Dump quotation expander result in case of syntax error."); - ("-o", Arg.String (fun x -> Pcaml.output_file.val := Some x), - " Output on instead of standard output."); - ("-v", Arg.Unit print_version, - "Print Camlp4 version and exit."); - ("-version", Arg.Unit print_version_string, - "Print Camlp4 version number and exit."); - ("-no_quot", Arg.Set Plexer.no_quotations, - " Don't parse quotations, allowing to use, e.g. \"<:>\" as token") - ] -; - -value anon_fun x = - do { Pcaml.input_file.val := x; file_kind.val := file_kind_of_name x } -; - -value parse spec_list anon_fun remaining_args = - let spec_list = - Sort.list (fun (k1, _, _) (k2, _, _) -> k1 >= k2) spec_list - in - try parse_aux spec_list anon_fun remaining_args with - [ Arg.Bad s -> - do { - eprintf "Error: %s\n" s; - eprintf "Use option -help for usage\n"; - flush stderr; - exit 2 - } ] -; - -value remaining_args = - let rec loop l i = - if i == Array.length Sys.argv then l else loop [Sys.argv.(i) :: l] (i + 1) - in - List.rev (loop [] (Arg.current.val + 1)) -; - -value report_error = - fun - [ Odyl_main.Error fname msg -> - do { - Format.print_string "Error while loading \""; - Format.print_string fname; - Format.print_string "\": "; - Format.print_string msg - } - | exc -> Pcaml.report_error exc ] -; - -value go () = - let ext_spec_list = Pcaml.arg_spec_list () in - let arg_spec_list = initial_spec_list @ ext_spec_list in - do { - match parse arg_spec_list anon_fun remaining_args with - [ [] -> () - | ["-help" :: sl] -> do { usage initial_spec_list ext_spec_list; exit 0 } - | [s :: sl] -> - do { - eprintf "%s: unknown or misused option\n" s; - eprintf "Use option -help for usage\n"; - exit 2 - } ]; - try - if Pcaml.input_file.val <> "" then - match file_kind.val with - [ Intf -> process_intf () - | Impl -> process_impl () ] - else () - with exc -> - do { - Format.set_formatter_out_channel stderr; - Format.open_vbox 0; - let exc = - match exc with - [ Stdpp.Exc_located (bp, ep) exc -> - do { print_location (bp, ep); exc } - | _ -> exc ] - in - report_error exc; - Format.close_box (); - Format.print_newline (); - raise exc - } - } -; - -Odyl_main.name.val := "camlp4"; -Odyl_main.go.val := go; diff --git a/camlp4/camlp4/ast2pt.ml b/camlp4/camlp4/ast2pt.ml deleted file mode 100644 index fba1a67c..00000000 --- a/camlp4/camlp4/ast2pt.ml +++ /dev/null @@ -1,938 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: ast2pt.ml,v 1.36 2005/06/29 04:11:26 garrigue Exp $ *) - -open Stdpp; -open MLast; -open Parsetree; -open Longident; -open Asttypes; - -value fast = ref False; -value no_constructors_arity = Pcaml.no_constructors_arity; - -value get_tag x = - if Obj.is_block (Obj.repr x) then Obj.tag (Obj.repr x) else Obj.magic x -; - -value error loc str = raise_with_loc loc (Failure str); - -value char_of_char_token loc s = - try Token.eval_char s with [ Failure _ as exn -> raise_with_loc loc exn ] -; - -value string_of_string_token loc s = - try Token.eval_string loc s - with [ Failure _ as exn -> raise_with_loc loc exn ] -; - -value glob_fname = ref ""; - -value mkloc (bp, ep) = - let loc_at n = - { (n) with - Lexing.pos_fname = - if n.Lexing.pos_fname = "" then - if glob_fname.val = "" then - Pcaml.input_file.val - else - glob_fname.val - else - n.Lexing.pos_fname - } - in - {Location.loc_start = loc_at bp; - Location.loc_end = loc_at ep; - Location.loc_ghost = - bp.Lexing.pos_cnum = 0 && ep.Lexing.pos_cnum = 0} -; - -value mkghloc (bp, ep) = - let loc_at n = - { (n) with - Lexing.pos_fname = - if n.Lexing.pos_fname = "" then - if glob_fname.val = "" then - Pcaml.input_file.val - else - glob_fname.val - else - n.Lexing.pos_fname - } - in - {Location.loc_start = loc_at bp; - Location.loc_end = loc_at ep; - Location.loc_ghost = True} -; - -value mktyp loc d = {ptyp_desc = d; ptyp_loc = mkloc loc}; -value mkpat loc d = {ppat_desc = d; ppat_loc = mkloc loc}; -value mkghpat loc d = {ppat_desc = d; ppat_loc = mkghloc loc}; -value mkexp loc d = {pexp_desc = d; pexp_loc = mkloc loc}; -value mkmty loc d = {pmty_desc = d; pmty_loc = mkloc loc}; -value mksig loc d = {psig_desc = d; psig_loc = mkloc loc}; -value mkmod loc d = {pmod_desc = d; pmod_loc = mkloc loc}; -value mkstr loc d = {pstr_desc = d; pstr_loc = mkloc loc}; -value mkfield loc d = {pfield_desc = d; pfield_loc = mkloc loc}; -value mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc}; -value mkpcl loc d = {pcl_desc = d; pcl_loc = mkloc loc}; -value mkpolytype t = - match t with - [ TyPol _ _ _ -> t - | _ -> TyPol (MLast.loc_of_ctyp t) [] t ] -; - -value lident s = Lident s; -value ldot l s = Ldot 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 str name = - ldot (lident str) (if fast.val then "unsafe_" ^ name else name) -; - -value mkrf = - fun - [ True -> Recursive - | False -> Nonrecursive ] -; - -value mkli s = - loop (fun s -> lident s) where rec loop f = - fun - [ [i :: il] -> loop (fun s -> ldot (f i) s) il - | [] -> f s ] -; - -value long_id_of_string_list loc sl = - match List.rev sl with - [ [] -> error loc "bad ast in long ident" - | [s :: sl] -> mkli s (List.rev sl) ] -; - -value rec ctyp_fa al = - fun - [ TyApp _ f a -> ctyp_fa [a :: al] f - | f -> (f, al) ] -; - -value rec ctyp_long_id_prefix t = - match t with - [ TyAcc _ m (TyLid _ s) -> - error (loc_of_ctyp t) "invalid module expression" - | TyAcc _ m (TyUid _ s) -> - let (is_cls, li) = ctyp_long_id_prefix m in - (is_cls, ldot li s) - | TyApp _ m1 m2 -> - let (is_cls, li1) = ctyp_long_id_prefix m1 in - let (_, li2) = ctyp_long_id_prefix m2 in - (is_cls, Lapply li1 li2) - | TyUid _ s -> (False, lident s) - | TyLid _ s -> - error (loc_of_ctyp t) "invalid module expression" - | t -> error (loc_of_ctyp t) "invalid module expression" ] -; - -value ctyp_long_id t = - match t with - [ TyAcc _ m (TyLid _ s) -> - let (is_cls, li) = ctyp_long_id_prefix m in - (is_cls, ldot li s) - | TyAcc _ m (TyUid _ s as t) -> - error (loc_of_ctyp t) "invalid type name" - | TyApp _ m1 m2 -> - error (loc_of_ctyp t) "invalid type name" - | TyUid _ s -> - error (loc_of_ctyp t) "invalid type name" - | TyLid _ s -> (False, lident s) - | TyCls loc sl -> (True, long_id_of_string_list loc sl) - | t -> error (loc_of_ctyp t) "invalid type" ] -; - -value rec ctyp = - fun - [ TyAcc loc _ _ as f -> - let (is_cls, li) = ctyp_long_id f in - if is_cls then mktyp loc (Ptyp_class li [] []) - else 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 loc1 lab t1) t2 -> - mktyp loc (Ptyp_arrow lab (ctyp t1) (ctyp t2)) - | TyArr loc (TyOlb loc1 lab t1) t2 -> - let t1 = TyApp loc1 (TyLid loc1 "option") t1 in - mktyp loc (Ptyp_arrow ("?" ^ lab) (ctyp t1) (ctyp t2)) - | TyArr loc t1 t2 -> mktyp loc (Ptyp_arrow "" (ctyp t1) (ctyp t2)) - | TyObj loc fl v -> mktyp loc (Ptyp_object (meth_list loc fl v)) - | TyCls loc id -> - mktyp loc (Ptyp_class (long_id_of_string_list loc id) [] []) - | TyLab loc _ _ -> error loc "labelled type not allowed here" - | TyLid loc s -> mktyp loc (Ptyp_constr (lident s) []) - | TyMan loc _ _ -> error loc "manifest type not allowed here" - | TyOlb loc lab _ -> error loc "labelled type not allowed here" - | TyPol loc pl t -> mktyp loc (Ptyp_poly pl (ctyp t)) - | 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" - | TyTup loc tl -> mktyp loc (Ptyp_tuple (List.map ctyp tl)) - | TyUid loc s as t -> error (loc_of_ctyp t) "invalid type" - | TyVrn loc catl ool -> - let catl = - List.map - (fun - [ RfTag c a t -> Rtag c a (List.map ctyp t) - | RfInh t -> Rinherit (ctyp t) ]) - catl - in - let (clos, sl) = - match ool with - [ None -> (True, None) - | Some None -> (False, None) - | Some (Some sl) -> (True, Some sl) ] - in - mktyp loc (Ptyp_variant catl clos sl) ] -and meth_list loc fl v = - match fl with - [ [] -> if v then [mkfield loc Pfield_var] else [] - | [(lab, t) :: fl] -> - [mkfield loc (Pfield lab (ctyp (mkpolytype t))) :: meth_list loc fl v] ] -; - -value mktype loc tl cl tk tm = - let (params, variance) = List.split tl in - {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk; - ptype_manifest = tm; ptype_loc = mkloc loc; ptype_variance = variance} -; -value mkmutable m = if m then Mutable else Immutable; -value mkprivate m = if m then Private else Public; -value mktrecord (loc, n, m, t) = - (n, mkmutable m, ctyp (mkpolytype t), mkloc loc); -value mkvariant (loc, c, tl) = (c, List.map ctyp tl, mkloc loc); -value rec type_decl tl cl loc m pflag = - fun - [ TyMan _ t1 t2 -> - type_decl tl cl loc (Some (ctyp t1)) pflag t2 - | TyPrv _ t -> - type_decl tl cl loc m True t - | TyRec _ ltl -> - mktype loc tl cl - (Ptype_record (List.map mktrecord ltl) (mkprivate pflag)) - m - | TySum _ ctl -> - mktype loc tl cl - (Ptype_variant (List.map mkvariant ctl) (mkprivate pflag)) - m - | t -> - if m <> None then - error loc "only one manifest type allowed by definition" else - let m = - match t with - [ TyQuo _ s -> if List.mem_assoc s tl then Some (ctyp t) else None - | _ -> Some (ctyp t) ] - in - let k = if pflag then Ptype_private else Ptype_abstract in - mktype loc tl cl k m ] -; - -value type_decl tl cl t = type_decl tl cl (loc_of_ctyp t) None False t; - -value mkvalue_desc t p = {pval_type = ctyp t; pval_prim = p}; - -value option f = - fun - [ Some x -> Some (f x) - | None -> None ] -; - -value expr_of_lab loc lab = - fun - [ Some e -> e - | None -> ExLid loc lab ] -; - -value patt_of_lab loc lab = - fun - [ Some p -> p - | None -> PaLid loc lab ] -; - -value paolab loc lab peoo = - let lab = - match (lab, peoo) with - [ ("", Some (PaLid _ i | PaTyc _ (PaLid _ i) _, _)) -> i - | ("", _) -> error loc "bad ast in label" - | _ -> lab ] - in - let (p, eo) = - match peoo with - [ Some peo -> peo - | None -> (PaLid loc lab, None) ] - in - (lab, p, eo) -; - -value rec same_type_expr ct ce = - match (ct, ce) with - [ (TyLid _ s1, ExLid _ s2) -> s1 = s2 - | (TyUid _ s1, ExUid _ s2) -> s1 = s2 - | (TyAcc _ t1 t2, ExAcc _ e1 e2) -> - same_type_expr t1 e1 && same_type_expr t2 e2 - | _ -> False ] -; - -value rec common_id loc t e = - match (t, e) with - [ (TyLid _ s1, ExLid _ s2) when s1 = s2 -> lident s1 - | (TyUid _ s1, ExUid _ s2) when s1 = s2 -> lident s1 - | (TyAcc _ t1 (TyLid _ s1), ExAcc _ e1 (ExLid _ s2)) when s1 = s2 -> - ldot (common_id loc t1 e1) s1 - | (TyAcc _ t1 (TyUid _ s1), ExAcc _ e1 (ExUid _ s2)) when s1 = s2 -> - ldot (common_id loc t1 e1) s1 - | _ -> error loc "this expression should repeat the class id inherited" ] -; - -value rec type_id loc t = - match t with - [ TyLid _ s1 -> lident s1 - | TyUid _ s1 -> lident s1 - | TyAcc _ t1 (TyLid _ s1) -> ldot (type_id loc t1) s1 - | TyAcc _ t1 (TyUid _ s1) -> ldot (type_id loc t1) s1 - | _ -> error loc "type identifier expected" ] -; - -value rec module_type_long_id = - fun - [ MtAcc _ m (MtUid _ s) -> ldot (module_type_long_id m) s - | MtAcc _ m (MtLid _ s) -> ldot (module_type_long_id m) s - | MtApp _ m1 m2 -> Lapply (module_type_long_id m1) (module_type_long_id m2) - | MtLid _ s -> lident s - | MtUid _ s -> lident s - | t -> error (loc_of_module_type t) "bad module type long ident" ] -; - -value rec module_expr_long_id = - fun - [ MeAcc _ m (MeUid _ s) -> ldot (module_expr_long_id m) s - | MeUid _ s -> lident s - | t -> error (loc_of_module_expr t) "bad module expr long ident" ] -; - -value mkwithc = - fun - [ WcTyp loc id tpl ct -> - let (params, variance) = List.split tpl in - (long_id_of_string_list loc id, - Pwith_type - {ptype_params = params; ptype_cstrs = []; - ptype_kind = Ptype_abstract; ptype_manifest = Some (ctyp ct); - ptype_loc = mkloc loc; ptype_variance = variance}) - | WcMod loc id m -> - (long_id_of_string_list loc id, Pwith_module (module_expr_long_id m)) ] -; - -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 (Const_char c1)) - else - mkghpat loc - (Ppat_or (mkghpat loc (Ppat_constant (Const_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 (Const_char c1)) - else - mkpat loc - (Ppat_or (mkghpat loc (Ppat_constant (Const_char c1))) - (deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2)) -; - -value rec patt_long_id il = - fun - [ PaAcc _ p (PaUid _ i) -> patt_long_id [i :: il] p - | p -> (p, il) ] -; - -value rec patt_label_long_id = - fun - [ PaAcc _ m (PaLid _ s) -> ldot (patt_label_long_id m) (conv_lab s) - | PaAcc _ m (PaUid _ s) -> ldot (patt_label_long_id m) s - | PaUid _ s -> lident s - | PaLid _ s -> lident (conv_lab s) - | p -> error (loc_of_patt p) "bad label" ] -; - -value rec patt = - fun - [ PaAcc loc p1 p2 -> - let p = - match patt_long_id [] p1 with - [ (PaUid _ i, il) -> - match p2 with - [ PaUid _ s -> - Ppat_construct (mkli (conv_con s) [i :: il]) None - (not no_constructors_arity.val) - | _ -> error (loc_of_patt p2) "uppercase identifier expected" ] - | _ -> error (loc_of_patt p2) "bad pattern" ] - in - mkpat loc p - | PaAli loc p1 p2 -> - let (p, i) = - match (p1, p2) with - [ (p, PaLid _ s) -> (p, s) - | (PaLid _ s, p) -> (p, s) - | _ -> error loc "invalid alias pattern" ] - in - mkpat loc (Ppat_alias (patt p) i) - | PaAnt _ p -> patt p - | PaAny loc -> mkpat loc 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 _ -> - if no_constructors_arity.val then - let a = - match al with - [ [a] -> a - | _ -> mkpat loc (Ppat_tuple al) ] - in - mkpat loc (Ppat_construct li (Some a) False) - else - let a = mkpat loc (Ppat_tuple al) in - mkpat loc (Ppat_construct li (Some a) True) - | 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 pl -> mkpat loc (Ppat_array (List.map patt pl)) - | PaChr loc s -> - mkpat loc (Ppat_constant (Const_char (char_of_char_token loc s))) - | PaInt loc s -> - let i = try int_of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int" - ] in mkpat loc (Ppat_constant (Const_int i)) - | PaInt32 loc s -> - let i32 = try Int32.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int32" - ] in mkpat loc (Ppat_constant (Const_int32 i32)) - | PaInt64 loc s -> - let i64 = try Int64.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int64" - ] in mkpat loc (Ppat_constant (Const_int64 i64)) - | PaNativeInt loc s -> - let nati = try Nativeint.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type nativeint" - ] in mkpat loc (Ppat_constant (Const_nativeint nati)) - | PaFlo loc s -> mkpat loc (Ppat_constant (Const_float s)) - | PaLab loc _ _ -> error loc "labeled pattern not allowed here" - | PaLid loc s -> mkpat loc (Ppat_var s) - | PaOlb 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 lpl -> mkpat loc (Ppat_record (List.map mklabpat lpl)) - | PaStr loc s -> - mkpat loc (Ppat_constant (Const_string (string_of_string_token loc s))) - | PaTup loc [] -> error loc "empty tuple pattern" - | PaTup loc [_] -> error loc "singleton tuple pattern" - | PaTup loc pl -> mkpat loc (Ppat_tuple (List.map patt pl)) - | PaTyc loc p t -> mkpat loc (Ppat_constraint (patt p) (ctyp t)) - | PaTyp loc sl -> mkpat loc (Ppat_type (long_id_of_string_list loc sl)) - | PaUid loc s -> - let ca = not no_constructors_arity.val in - mkpat loc (Ppat_construct (lident (conv_con s)) None ca) - | PaVrn loc s -> mkpat loc (Ppat_variant s None) ] -and mklabpat (lab, p) = (patt_label_long_id lab, patt p); - -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 - | ExUid ((bp, _) as loc) s as e -> - match l with - [ [] -> [(loc, [], e)] - | [((_, ep), sl, e) :: l] -> [((bp, ep), [s :: sl], e) :: l] ] - | e -> [(loc_of_expr e, [], e) :: l] ] -; - -(* -value expr_label_long_id e = - match sep_expr_acc [] e with - [ [(_, ml, ExLid _ s)] -> mkli (conv_lab s) ml - | _ -> error (loc_of_expr e) "invalid label" ] -; -*) - -value class_info class_expr ci = - let (params, variance) = List.split (snd ci.ciPrm) in - {pci_virt = if ci.ciVir then Virtual else Concrete; - pci_params = (params, mkloc (fst ci.ciPrm)); pci_name = ci.ciNam; - pci_expr = class_expr ci.ciExp; pci_loc = mkloc ci.ciLoc; - pci_variance = variance} -; - -value apply_with_var v x f = - let vx = v.val in - try - do { - v.val := x; - let r = f (); - v.val := vx; - r - } - with e -> do { v.val := vx; raise e } -; - -value rec expr = - fun - [ ExAcc loc x (ExLid _ "val") -> - mkexp loc - (Pexp_apply (mkexp loc (Pexp_ident (Lident "!"))) [("", expr x)]) - | ExAcc loc _ _ as e -> - let (e, l) = - match sep_expr_acc [] e with - [ [(loc, ml, ExUid _ s) :: l] -> - let ca = not no_constructors_arity.val in - (mkexp loc (Pexp_construct (mkli s ml) None ca), l) - | [(loc, ml, ExLid _ s) :: l] -> - (mkexp loc (Pexp_ident (mkli s ml)), l) - | [(_, [], e) :: l] -> (expr e, l) - | _ -> error loc "bad ast in expression" ] - in - let (_, e) = - List.fold_left - (fun ((bp, _), e1) ((_, ep), ml, e2) -> - match e2 with - [ ExLid _ s -> - let loc = (bp, ep) in - (loc, mkexp loc (Pexp_field e1 (mkli (conv_lab s) ml))) - | _ -> error (loc_of_expr e2) "lowercase identifier expected" ]) - (loc, e) l - in - e - | ExAnt _ e -> expr e - | 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 - if no_constructors_arity.val then - let a = - match al with - [ [a] -> a - | _ -> mkexp loc (Pexp_tuple al) ] - in - mkexp loc (Pexp_construct li (Some a) False) - else - let a = mkexp loc (Pexp_tuple al) in - mkexp loc (Pexp_construct li (Some a) True) - | 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 "Array" "get"))) - [("", expr e1); ("", expr e2)]) - | ExArr loc el -> mkexp loc (Pexp_array (List.map expr el)) - | ExAsf loc -> mkexp loc Pexp_assertfalse - | ExAss loc e v -> - let e = - match e with - [ ExAcc loc x (ExLid _ "val") -> - Pexp_apply (mkexp loc (Pexp_ident (Lident ":="))) - [("", expr x); ("", expr v)] - | ExAcc loc _ _ -> - match (expr e).pexp_desc with - [ Pexp_field e lab -> Pexp_setfield e lab (expr v) - | _ -> error loc "bad record access" ] - | ExAre _ e1 e2 -> - Pexp_apply (mkexp loc (Pexp_ident (array_function "Array" "set"))) - [("", expr e1); ("", expr e2); ("", expr v)] - | ExLid _ lab -> Pexp_setinstvar lab (expr v) - | ExSte _ e1 e2 -> - Pexp_apply - (mkexp loc (Pexp_ident (array_function "String" "set"))) - [("", expr e1); ("", expr e2); ("", 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 (Const_char (char_of_char_token loc s))) - | ExCoe loc e t1 t2 -> - mkexp loc (Pexp_constraint (expr e) (option ctyp t1) (Some (ctyp t2))) - | ExFlo loc s -> mkexp loc (Pexp_constant (Const_float s)) - | ExFor loc i e1 e2 df el -> - let e3 = ExSeq loc el in - let df = if df then Upto else Downto in - mkexp loc (Pexp_for i (expr e1) (expr e2) df (expr e3)) - | ExFun loc [(PaLab _ lab po, w, e)] -> - mkexp loc - (Pexp_function lab None - [(patt (patt_of_lab loc lab po), when_expr e w)]) - | ExFun loc [(PaOlb _ lab peoo, w, e)] -> - let (lab, p, eo) = paolab loc lab peoo in - mkexp loc - (Pexp_function ("?" ^ lab) (option expr eo) [(patt p, when_expr e w)]) - | ExFun loc pel -> mkexp loc (Pexp_function "" None (List.map mkpwe pel)) - | ExIfe loc e1 e2 e3 -> - mkexp loc (Pexp_ifthenelse (expr e1) (expr e2) (Some (expr e3))) - | ExInt loc s -> - let i = try int_of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int" - ] in mkexp loc (Pexp_constant (Const_int i)) - | ExInt32 loc s -> - let i32 = try Int32.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int32" - ] in mkexp loc (Pexp_constant (Const_int32 i32)) - | ExInt64 loc s -> - let i64 = try Int64.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type int64" - ] in mkexp loc (Pexp_constant (Const_int64 i64)) - | ExNativeInt loc s -> - let nati = try Nativeint.of_string s with [ - Failure _ -> error loc "Integer literal exceeds the range of representable integers of type nativeint" - ] in mkexp loc (Pexp_constant (Const_nativeint nati)) - | ExLab loc _ _ -> error loc "labeled expression not allowed here" - | ExLaz loc e -> mkexp loc (Pexp_lazy (expr e)) - | ExLet loc rf pel e -> - mkexp loc (Pexp_let (mkrf rf) (List.map mkpe pel) (expr e)) - | ExLid loc s -> mkexp loc (Pexp_ident (lident s)) - | ExLmd loc i me e -> mkexp loc (Pexp_letmodule i (module_expr me) (expr e)) - | ExMat loc e pel -> mkexp loc (Pexp_match (expr e) (List.map mkpwe pel)) - | ExNew loc id -> mkexp loc (Pexp_new (long_id_of_string_list loc id)) - | ExObj loc po cfl -> - let p = - match po with - [ Some p -> p - | None -> PaAny loc ] - in - let cil = List.fold_right class_str_item cfl [] in - mkexp loc (Pexp_object (patt p, cil)) - | ExOlb loc _ _ -> error loc "labeled expression not allowed here" - | ExOvr loc iel -> mkexp loc (Pexp_override (List.map mkideexp iel)) - | ExRec loc lel eo -> - if lel = [] then error loc "empty record" - else - let eo = - match eo with - [ Some e -> Some (expr e) - | None -> None ] - in - mkexp loc (Pexp_record (List.map mklabexp lel) eo) - | ExSeq loc el -> - let rec loop = - fun - [ [] -> expr (ExUid loc "()") - | [e] -> expr e - | [e :: el] -> - let loc = (fst (loc_of_expr e), snd loc) in - mkexp loc (Pexp_sequence (expr e) (loop el)) ] - in - loop el - | ExSnd loc e s -> mkexp loc (Pexp_send (expr e) s) - | ExSte loc e1 e2 -> - mkexp loc - (Pexp_apply (mkexp loc (Pexp_ident (array_function "String" "get"))) - [("", expr e1); ("", expr e2)]) - | ExStr loc s -> - mkexp loc (Pexp_constant (Const_string (string_of_string_token loc s))) - | ExTry loc e pel -> mkexp loc (Pexp_try (expr e) (List.map mkpwe pel)) - | ExTup loc [] -> error loc "empty tuple" - | ExTup loc [e] -> error loc "singleton tuple" - | ExTup loc el -> mkexp loc (Pexp_tuple (List.map expr el)) - | ExTyc loc e t -> mkexp loc (Pexp_constraint (expr e) (Some (ctyp t)) None) - | ExUid loc s -> - let ca = not no_constructors_arity.val in - mkexp loc (Pexp_construct (lident (conv_con s)) None ca) - | ExVrn loc s -> mkexp loc (Pexp_variant s None) - | ExWhi loc e1 el -> - let e2 = ExSeq loc el in - mkexp loc (Pexp_while (expr e1) (expr e2)) ] -and label_expr = - fun - [ ExLab loc lab eo -> (lab, expr (expr_of_lab loc lab eo)) - | ExOlb loc lab eo -> ("?" ^ lab, expr (expr_of_lab loc lab eo)) - | e -> ("", expr e) ] -and mkpe (p, e) = (patt p, expr e) -and mkpwe (p, w, e) = (patt p, when_expr e w) -and when_expr e = - fun - [ Some w -> mkexp (loc_of_expr e) (Pexp_when (expr w) (expr e)) - | None -> expr e ] -and mklabexp (lab, e) = (patt_label_long_id lab, expr e) -and mkideexp (ide, e) = (ide, expr e) -and mktype_decl ((loc, c), tl, td, cl) = - let cl = - List.map - (fun (t1, t2) -> - let loc = (fst (loc_of_ctyp t1), snd (loc_of_ctyp t2)) in - (ctyp t1, ctyp t2, mkloc loc)) - cl - in - (c, type_decl tl cl td) -and module_type = - fun - [ MtAcc loc _ _ as f -> mkmty loc (Pmty_ident (module_type_long_id f)) - | MtApp loc _ _ as f -> mkmty loc (Pmty_ident (module_type_long_id f)) - | MtFun loc n nt mt -> - mkmty loc (Pmty_functor n (module_type nt) (module_type mt)) - | MtLid loc s -> mkmty loc (Pmty_ident (lident s)) - | MtQuo loc _ -> error loc "abstract module type not allowed here" - | MtSig loc sl -> - mkmty loc (Pmty_signature (List.fold_right sig_item sl [])) - | MtUid loc s -> mkmty loc (Pmty_ident (lident s)) - | MtWit loc mt wcl -> - mkmty loc (Pmty_with (module_type mt) (List.map mkwithc wcl)) ] -and sig_item s l = - match s with - [ SgCls loc cd -> - [mksig loc (Psig_class (List.map (class_info class_type) cd)) :: l] - | SgClt loc ctd -> - [mksig loc (Psig_class_type (List.map (class_info class_type) ctd)) :: - l] - | SgDcl loc sl -> List.fold_right sig_item sl l - | SgDir loc _ _ -> l - | SgExc loc n tl -> [mksig loc (Psig_exception n (List.map ctyp tl)) :: l] - | SgExt loc n t p -> [mksig loc (Psig_value n (mkvalue_desc t p)) :: l] - | SgInc loc mt -> [mksig loc (Psig_include (module_type mt)) :: l] - | SgMod loc n mt -> [mksig loc (Psig_module n (module_type mt)) :: l] - | SgRecMod loc nmts -> - [mksig loc (Psig_recmodule (List.map (fun (n,mt) -> (n, module_type mt)) nmts)) :: l] - | SgMty loc n mt -> - let si = - match mt with - [ MtQuo _ _ -> Pmodtype_abstract - | _ -> Pmodtype_manifest (module_type mt) ] - in - [mksig loc (Psig_modtype n si) :: l] - | SgOpn loc id -> - [mksig loc (Psig_open (long_id_of_string_list loc id)) :: l] - | SgTyp loc tdl -> [mksig loc (Psig_type (List.map mktype_decl tdl)) :: l] - | SgUse loc fn sl -> - apply_with_var glob_fname fn - (fun () -> List.fold_right (fun (si, _) -> sig_item si) sl l) - | SgVal loc n t -> [mksig loc (Psig_value n (mkvalue_desc t [])) :: l] ] -and module_expr = - fun - [ MeAcc loc _ _ as f -> mkmod loc (Pmod_ident (module_expr_long_id f)) - | MeApp loc me1 me2 -> - mkmod loc (Pmod_apply (module_expr me1) (module_expr me2)) - | MeFun loc n mt me -> - mkmod loc (Pmod_functor n (module_type mt) (module_expr me)) - | MeStr loc sl -> - mkmod loc (Pmod_structure (List.fold_right str_item sl [])) - | MeTyc loc me mt -> - mkmod loc (Pmod_constraint (module_expr me) (module_type mt)) - | MeUid loc s -> mkmod loc (Pmod_ident (lident s)) ] -and str_item s l = - match s with - [ StCls loc cd -> - [mkstr loc (Pstr_class (List.map (class_info class_expr) cd)) :: l] - | StClt loc ctd -> - [mkstr loc (Pstr_class_type (List.map (class_info class_type) ctd)) :: - l] - | StDcl loc sl -> List.fold_right str_item sl l - | StDir loc _ _ -> l - | StExc loc n tl sl -> - let si = - match (tl, sl) with - [ (tl, []) -> Pstr_exception n (List.map ctyp tl) - | ([], sl) -> Pstr_exn_rebind n (long_id_of_string_list loc sl) - | _ -> error loc "bad exception declaration" ] - in - [mkstr loc si :: l] - | StExp loc e -> [mkstr loc (Pstr_eval (expr e)) :: l] - | StExt loc n t p -> [mkstr loc (Pstr_primitive n (mkvalue_desc t p)) :: l] - | StInc loc me -> [mkstr loc (Pstr_include (module_expr me)) :: l] - | StMod loc n me -> [mkstr loc (Pstr_module n (module_expr me)) :: l] - | StRecMod loc nmes -> - [mkstr loc - (Pstr_recmodule - (List.map - (fun (n,mt,me) -> (n, module_type mt, module_expr me)) - nmes)) :: l] - | StMty loc n mt -> [mkstr loc (Pstr_modtype n (module_type mt)) :: l] - | StOpn loc id -> - [mkstr loc (Pstr_open (long_id_of_string_list loc id)) :: l] - | StTyp loc tdl -> [mkstr loc (Pstr_type (List.map mktype_decl tdl)) :: l] - | StUse loc fn sl -> - apply_with_var glob_fname fn - (fun () -> List.fold_right (fun (si, _) -> str_item si) sl l) - | StVal loc rf pel -> - [mkstr loc (Pstr_value (mkrf rf) (List.map mkpe pel)) :: l] ] -and class_type = - fun - [ CtCon loc id tl -> - mkcty loc - (Pcty_constr (long_id_of_string_list loc id) (List.map ctyp tl)) - | CtFun loc (TyLab _ lab t) ct -> - mkcty loc (Pcty_fun lab (ctyp t) (class_type ct)) - | CtFun loc (TyOlb loc1 lab t) ct -> - let t = TyApp loc1 (TyLid loc1 "option") t in - mkcty loc (Pcty_fun ("?" ^ lab) (ctyp t) (class_type ct)) - | CtFun loc t ct -> mkcty loc (Pcty_fun "" (ctyp t) (class_type ct)) - | CtSig loc t_o ctfl -> - let t = - match t_o with - [ Some t -> t - | None -> TyAny loc ] - in - let cil = List.fold_right class_sig_item ctfl [] in - mkcty loc (Pcty_signature (ctyp t, cil)) ] -and class_sig_item c l = - match c with - [ CgCtr loc t1 t2 -> [Pctf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l] - | CgDcl loc cl -> List.fold_right class_sig_item cl l - | CgInh loc ct -> [Pctf_inher (class_type ct) :: l] - | CgMth loc s pf t -> - [Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l] - | CgVal loc s b t -> - [Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l] - | CgVir loc s b t -> - [Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ] -and class_expr = - fun - [ CeApp loc _ _ as c -> - let (ce, el) = class_expr_fa [] c in - let el = List.map label_expr el in - mkpcl loc (Pcl_apply (class_expr ce) el) - | CeCon loc id tl -> - mkpcl loc - (Pcl_constr (long_id_of_string_list loc id) (List.map ctyp tl)) - | CeFun loc (PaLab _ lab po) ce -> - mkpcl loc - (Pcl_fun lab None (patt (patt_of_lab loc lab po)) (class_expr ce)) - | CeFun loc (PaOlb _ lab peoo) ce -> - let (lab, p, eo) = paolab loc lab peoo in - mkpcl loc - (Pcl_fun ("?" ^ lab) (option expr eo) (patt p) (class_expr ce)) - | CeFun loc p ce -> mkpcl loc (Pcl_fun "" None (patt p) (class_expr ce)) - | CeLet loc rf pel ce -> - mkpcl loc (Pcl_let (mkrf rf) (List.map mkpe pel) (class_expr ce)) - | CeStr loc po cfl -> - let p = - match po with - [ Some p -> p - | None -> PaAny loc ] - in - let cil = List.fold_right class_str_item cfl [] in - mkpcl loc (Pcl_structure (patt p, cil)) - | CeTyc loc ce ct -> - mkpcl loc (Pcl_constraint (class_expr ce) (class_type ct)) ] -and class_str_item c l = - match c with - [ CrCtr loc t1 t2 -> [Pcf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l] - | CrDcl loc cl -> List.fold_right class_str_item cl l - | CrInh loc ce pb -> [Pcf_inher (class_expr ce) pb :: l] - | CrIni loc e -> [Pcf_init (expr e) :: l] - | CrMth loc s b e t -> - let t = option (fun t -> ctyp (mkpolytype t)) t in - let e = mkexp loc (Pexp_poly (expr e) t) in - [Pcf_meth (s, mkprivate b, e, mkloc loc) :: l] - | CrVal loc s b e -> [Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l] - | CrVir loc s b t -> - [Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l] ] -; - -value interf ast = List.fold_right sig_item ast []; -value implem ast = List.fold_right str_item ast []; - -value directive loc = - fun - [ None -> Pdir_none - | Some (ExStr _ s) -> Pdir_string s - | Some (ExInt _ i) -> Pdir_int (int_of_string i) - | Some (ExUid _ "True") -> Pdir_bool True - | Some (ExUid _ "False") -> Pdir_bool False - | Some e -> - let sl = - loop e where rec loop = - fun - [ ExLid _ i | ExUid _ i -> [i] - | ExAcc _ e (ExLid _ i) | ExAcc _ e (ExUid _ i) -> loop e @ [i] - | e -> raise_with_loc (loc_of_expr e) (Failure "bad ast in directive") ] - in - Pdir_ident (long_id_of_string_list loc sl) ] -; - -value phrase = - fun - [ StDir loc d dp -> Ptop_dir d (directive loc dp) - | si -> Ptop_def (str_item si []) ] -; diff --git a/camlp4/camlp4/ast2pt.mli b/camlp4/camlp4/ast2pt.mli deleted file mode 100644 index 74e559b7..00000000 --- a/camlp4/camlp4/ast2pt.mli +++ /dev/null @@ -1,23 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: ast2pt.mli,v 1.4 2004/05/12 15:22:38 mauny Exp $ *) - -value fast : ref bool; -value no_constructors_arity : ref bool; -value mkloc : MLast.loc -> Location.t; -value long_id_of_string_list : MLast.loc -> list string -> Longident.t; - -value str_item : MLast.str_item -> Parsetree.structure -> Parsetree.structure; -value interf : list MLast.sig_item -> Parsetree.signature; -value implem : list MLast.str_item -> Parsetree.structure; -value phrase : MLast.str_item -> Parsetree.toplevel_phrase; diff --git a/camlp4/camlp4/mLast.mli b/camlp4/camlp4/mLast.mli deleted file mode 100644 index 92fe09d8..00000000 --- a/camlp4/camlp4/mLast.mli +++ /dev/null @@ -1,213 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: mLast.mli,v 1.18 2005/06/29 04:11:26 garrigue Exp $ *) - -(* Module [MLast]: abstract syntax tree - - This is undocumented because the AST is not supposed to be used - directly; the good usage is to use the quotations representing - these values in concrete syntax (see the Camlp4 documentation). - See also the file q_MLast.ml in Camlp4 sources. *) - -type loc = (Lexing.position * Lexing.position); - -type ctyp = - [ TyAcc of loc and ctyp and ctyp - | TyAli of loc and ctyp and ctyp - | TyAny of loc - | TyApp of loc and ctyp and ctyp - | TyArr of loc and ctyp and ctyp - | TyCls of loc and list string - | TyLab of loc and string and ctyp - | TyLid of loc and string - | TyMan of loc and ctyp and ctyp - | TyObj of loc and list (string * ctyp) and bool - | TyOlb of loc and string and ctyp - | TyPol of loc and list string and ctyp - | TyQuo of loc and string - | TyRec of loc and list (loc * string * bool * ctyp) - | TySum of loc and list (loc * string * list ctyp) - | TyPrv of loc and ctyp - | TyTup of loc and list ctyp - | TyUid of loc and string - | TyVrn of loc and list row_field and option (option (list string)) ] -and row_field = - [ RfTag of string and bool and list ctyp - | RfInh of ctyp ] -; - -type class_infos 'a = - { ciLoc : loc; - ciVir : bool; - ciPrm : (loc * list (string * (bool * bool))); - ciNam : string; - ciExp : 'a } -; - -type patt = - [ PaAcc of loc and patt and patt - | PaAli of loc and patt and patt - | PaAnt of loc and patt - | PaAny of loc - | PaApp of loc and patt and patt - | PaArr of loc and list patt - | PaChr of loc and string - | 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 option patt - | PaLid of loc and string - | PaOlb of loc and string and option (patt * option expr) - | PaOrp of loc and patt and patt - | PaRng of loc and patt and patt - | PaRec of loc and list (patt * patt) - | PaStr of loc and string - | PaTup of loc and list patt - | PaTyc of loc and patt and ctyp - | PaTyp of loc and list string - | PaUid of loc and string - | PaVrn of loc and string ] -and expr = - [ ExAcc of loc and expr and expr - | ExAnt of loc and expr - | ExApp of loc and expr and expr - | ExAre of loc and expr and expr - | ExArr of loc and list expr - | ExAsf of loc (* assert False *) - | ExAsr of loc and expr (* assert *) - | ExAss of loc and expr and expr (* assignment *) - | ExChr of loc and string - | ExCoe of loc and expr and option ctyp and ctyp - | ExFlo of loc and string - | ExFor of loc and string and expr and expr and bool and list expr - | ExFun of loc and list (patt * option expr * expr) - | ExIfe of loc and expr and expr and expr - | ExInt of loc and string - | ExInt32 of loc and string - | ExInt64 of loc and string - | ExNativeInt of loc and string - | ExLab of loc and string and option expr - | ExLaz of loc and expr - | ExLet of loc and bool and list (patt * expr) and expr - | ExLid of loc and string - | ExLmd of loc and string and module_expr and expr - | ExMat of loc and expr and list (patt * option expr * expr) - | ExNew of loc and list string - | ExObj of loc and option patt and list class_str_item - | ExOlb of loc and string and option expr - | ExOvr of loc and list (string * expr) - | ExRec of loc and list (patt * expr) and option expr - | ExSeq of loc and list expr - | ExSnd of loc and expr and string - | ExSte of loc and expr and expr - | ExStr of loc and string - | ExTry of loc and expr and list (patt * option expr * expr) - | ExTup of loc and list expr - | ExTyc of loc and expr and ctyp - | ExUid of loc and string - | ExVrn of loc and string - | ExWhi of loc and expr and list expr ] -and module_type = - [ MtAcc of loc and module_type and module_type - | MtApp of loc and module_type and module_type - | MtFun of loc and string and module_type and module_type - | MtLid of loc and string - | MtQuo of loc and string - | MtSig of loc and list sig_item - | MtUid of loc and string - | MtWit of loc and module_type and list with_constr ] -and sig_item = - [ SgCls of loc and list (class_infos class_type) - | SgClt of loc and list (class_infos class_type) - | SgDcl of loc and list sig_item - | SgDir of loc and string and option expr - | SgExc of loc and string and list ctyp - | SgExt of loc and string and ctyp and list string - | SgInc of loc and module_type - | SgMod of loc and string and module_type - | SgRecMod of loc and list (string * module_type) - | SgMty of loc and string and module_type - | SgOpn of loc and list string - | SgTyp of loc and list type_decl - | SgUse of loc and string and list (sig_item * loc) - | SgVal of loc and string and ctyp ] -and with_constr = - [ WcTyp of loc and list string and list (string * (bool * bool)) and ctyp - | WcMod of loc and list string and module_expr ] -and module_expr = - [ MeAcc of loc and module_expr and module_expr - | MeApp of loc and module_expr and module_expr - | MeFun of loc and string and module_type and module_expr - | MeStr of loc and list str_item - | MeTyc of loc and module_expr and module_type - | MeUid of loc and string ] -and str_item = - [ StCls of loc and list (class_infos class_expr) - | StClt of loc and list (class_infos class_type) - | StDcl of loc and list str_item - | StDir of loc and string and option expr - | StExc of loc and string and list ctyp and list string - | StExp of loc and expr - | StExt of loc and string and ctyp and list string - | StInc of loc and module_expr - | StMod of loc and string and module_expr - | StRecMod of loc and list (string * module_type * module_expr) - | StMty of loc and string and module_type - | StOpn of loc and list string - | StTyp of loc and list type_decl - | StUse of loc and string and list (str_item * loc) - | StVal of loc and bool and list (patt * expr) ] -and type_decl = - ((loc * string) * list (string * (bool * bool)) * ctyp * list (ctyp * ctyp)) -and class_type = - [ CtCon of loc and list string and list ctyp - | CtFun of loc and ctyp and class_type - | CtSig of loc and option ctyp and list class_sig_item ] -and class_sig_item = - [ CgCtr of loc and ctyp and ctyp - | CgDcl of loc and list class_sig_item - | CgInh of loc and class_type - | CgMth of loc and string and bool and ctyp - | CgVal of loc and string and bool and ctyp - | CgVir of loc and string and bool and ctyp ] -and class_expr = - [ CeApp of loc and class_expr and expr - | CeCon of loc and list string and list ctyp - | CeFun of loc and patt and class_expr - | CeLet of loc and bool and list (patt * expr) and class_expr - | CeStr of loc and option patt and list class_str_item - | CeTyc of loc and class_expr and class_type ] -and class_str_item = - [ CrCtr of loc and ctyp and ctyp - | CrDcl of loc and list class_str_item - | CrInh of loc and class_expr and option string - | CrIni of loc and expr - | CrMth of loc and string and bool and expr and option ctyp - | CrVal of loc and string and bool and expr - | CrVir of loc and string and bool and ctyp ] -; - -external loc_of_ctyp : ctyp -> loc = "%field0"; -external loc_of_patt : patt -> loc = "%field0"; -external loc_of_expr : expr -> loc = "%field0"; -external loc_of_module_type : module_type -> loc = "%field0"; -external loc_of_module_expr : module_expr -> loc = "%field0"; -external loc_of_sig_item : sig_item -> loc = "%field0"; -external loc_of_str_item : str_item -> loc = "%field0"; - -external loc_of_class_type : class_type -> loc = "%field0"; -external loc_of_class_sig_item : class_sig_item -> loc = "%field0"; -external loc_of_class_expr : class_expr -> loc = "%field0"; -external loc_of_class_str_item : class_str_item -> loc = "%field0"; diff --git a/camlp4/camlp4/pcaml.ml b/camlp4/camlp4/pcaml.ml deleted file mode 100644 index ccc055cb..00000000 --- a/camlp4/camlp4/pcaml.ml +++ /dev/null @@ -1,485 +0,0 @@ -(* camlp4r pa_extend.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: pcaml.ml,v 1.16 2005/04/14 09:49:17 mauny Exp $ *) - -value version = Sys.ocaml_version; - -value syntax_name = ref ""; - -value gram = - Grammar.gcreate - {Token.tok_func _ = failwith "no loaded parsing module"; - Token.tok_using _ = (); Token.tok_removing _ = (); - Token.tok_match = fun []; Token.tok_text _ = ""; - Token.tok_comm = None} -; - -value interf = Grammar.Entry.create gram "interf"; -value implem = Grammar.Entry.create gram "implem"; -value top_phrase = Grammar.Entry.create gram "top_phrase"; -value use_file = Grammar.Entry.create gram "use_file"; -value sig_item = Grammar.Entry.create gram "sig_item"; -value str_item = Grammar.Entry.create gram "str_item"; -value module_type = Grammar.Entry.create gram "module_type"; -value module_expr = Grammar.Entry.create gram "module_expr"; -value expr = Grammar.Entry.create gram "expr"; -value patt = Grammar.Entry.create gram "patt"; -value ctyp = Grammar.Entry.create gram "type"; -value let_binding = Grammar.Entry.create gram "let_binding"; -value type_declaration = Grammar.Entry.create gram "type_declaration"; - -value class_sig_item = Grammar.Entry.create gram "class_sig_item"; -value class_str_item = Grammar.Entry.create gram "class_str_item"; -value class_type = Grammar.Entry.create gram "class_type"; -value class_expr = Grammar.Entry.create gram "class_expr"; - -value parse_interf = ref (Grammar.Entry.parse interf); -value parse_implem = ref (Grammar.Entry.parse implem); - -value rec skip_to_eol cs = - match Stream.peek cs with - [ Some '\n' -> () - | Some c -> do { Stream.junk cs; skip_to_eol cs } - | _ -> () ] -; -value sync = ref skip_to_eol; - -value input_file = ref ""; -value output_file = ref None; - -value warning_default_function (bp, ep) txt = - let c1 = bp.Lexing.pos_cnum - bp.Lexing.pos_bol in - let c2 = ep.Lexing.pos_cnum - bp.Lexing.pos_bol in - do { Printf.eprintf " File \"%s\", line %d, chars %d-%d: %s\n" - bp.Lexing.pos_fname bp.Lexing.pos_lnum c1 c2 txt; flush stderr } -; - -value warning = ref warning_default_function; - -value apply_with_var v x f = - let vx = v.val in - try - do { - v.val := x; - let r = f (); - v.val := vx; - r - } - with e -> do { v.val := vx; raise e } -; - -List.iter (fun (n, f) -> Quotation.add n f) - [("id", Quotation.ExStr (fun _ s -> "$0:" ^ s ^ "$")); - ("string", Quotation.ExStr (fun _ s -> "\"" ^ String.escaped s ^ "\""))]; - -value quotation_dump_file = ref (None : option string); - -type err_ctx = - [ Finding | Expanding | ParsingResult of MLast.loc and string | Locating ] -; -exception Qerror of string and err_ctx and exn; - -value expand_quotation loc expander shift name str = - let new_warning = - let warn = warning.val in - fun (bp, ep) txt -> warn (Reloc.adjust_loc shift (bp, ep)) txt - in - apply_with_var warning new_warning - (fun () -> - try expander str with - [ Stdpp.Exc_located loc exc -> - let exc1 = Qerror name Expanding exc in - raise (Stdpp.Exc_located (Reloc.adjust_loc shift loc) exc1) - | exc -> - let exc1 = Qerror name Expanding exc in - raise (Stdpp.Exc_located loc exc1) ]) -; - -value parse_quotation_result entry loc shift name str = - let cs = Stream.of_string str in - try Grammar.Entry.parse entry cs with - [ Stdpp.Exc_located iloc (Qerror _ Locating _ as exc) -> - raise (Stdpp.Exc_located (Reloc.adjust_loc shift iloc) exc) - | Stdpp.Exc_located iloc (Qerror _ Expanding exc) -> - let ctx = ParsingResult iloc str in - let exc1 = Qerror name ctx exc in - raise (Stdpp.Exc_located loc exc1) - | Stdpp.Exc_located _ (Qerror _ _ _ as exc) -> - raise (Stdpp.Exc_located loc exc) - | Stdpp.Exc_located iloc exc -> - let ctx = ParsingResult iloc str in - let exc1 = Qerror name ctx exc in - raise (Stdpp.Exc_located loc exc1) ] -; - -value ghostify (bp, ep) = - let ghost p = { (p) with Lexing.pos_cnum = 0 } in - (ghost bp, ghost ep) -; - -value handle_quotation loc proj in_expr entry reloc (name, str) = - let shift = - match name with - [ "" -> String.length "<<" - | _ -> String.length "<:" + String.length name + String.length "<" ] - in - let shift = Reloc.shift_pos shift (fst loc) in - let expander = - try Quotation.find name with exc -> - let exc1 = Qerror name Finding exc in - raise (Stdpp.Exc_located (fst loc, shift) exc1) - in - let ast = - match expander with - [ Quotation.ExStr f -> - let new_str = expand_quotation loc (f in_expr) shift name str in - parse_quotation_result entry loc shift name new_str - | Quotation.ExAst fe_fp -> - expand_quotation loc (proj fe_fp) shift name str ] - in - (* Warning: below, we use a side-effecting function that produces a real location - on its first call, and ghost ones at subsequent calls. *) - reloc - (let zero = ref None in - fun _ -> match zero.val with [ - None -> do { zero.val := Some (ghostify loc) ; loc } - | Some x -> x ]) - shift ast -; - -value parse_locate entry shift str = - let cs = Stream.of_string str in - try Grammar.Entry.parse entry cs with - [ Stdpp.Exc_located (p1, p2) exc -> - let ctx = Locating in - let exc1 = Qerror (Grammar.Entry.name entry) ctx exc in - raise (Stdpp.Exc_located (Reloc.adjust_loc shift (p1, p2)) exc1) ] -; - -value handle_locate loc entry ast_f (pos, str) = - let s = str in - let loc = (pos, Reloc.shift_pos (String.length s) pos) in - let x = parse_locate entry (fst loc) s in - ast_f loc x -; - -value expr_anti loc e = MLast.ExAnt loc e; -value patt_anti loc p = MLast.PaAnt loc p; -value expr_eoi = Grammar.Entry.create gram "expression"; -value patt_eoi = Grammar.Entry.create gram "pattern"; -EXTEND - expr_eoi: - [ [ x = expr; EOI -> x ] ] - ; - patt_eoi: - [ [ x = patt; EOI -> x ] ] - ; -END; - -value handle_expr_quotation loc x = - handle_quotation loc fst True expr_eoi Reloc.expr x -; - -value handle_expr_locate loc x = handle_locate loc expr_eoi expr_anti x; - -value handle_patt_quotation loc x = - handle_quotation loc snd False patt_eoi Reloc.patt x -; - -value handle_patt_locate loc x = handle_locate loc patt_eoi patt_anti x; - -value expr_reloc = Reloc.expr; -value patt_reloc = Reloc.patt; - -value ctyp_reloc = Reloc.ctyp; -value row_field_reloc = Reloc.row_field; -value class_infos_reloc = Reloc.class_infos; -value module_type_reloc = Reloc.module_type; -value sig_item_reloc = Reloc.sig_item; -value with_constr_reloc = Reloc.with_constr; -value module_expr_reloc = Reloc.module_expr; -value str_item_reloc = Reloc.str_item; -value class_type_reloc = Reloc.class_type; -value class_sig_item_reloc = Reloc.class_sig_item; -value class_expr_reloc = Reloc.class_expr; -value class_str_item_reloc = Reloc.class_str_item; - -value rename_id = ref (fun x -> x); - -value find_line (bp, ep) str = - (bp.Lexing.pos_lnum, - bp.Lexing.pos_cnum - bp.Lexing.pos_bol, - ep.Lexing.pos_cnum - bp.Lexing.pos_bol) -; - -value loc_fmt = - match Sys.os_type with - [ "MacOS" -> - format_of_string "File \"%s\"; line %d; characters %d to %d\n### " - | _ -> - format_of_string "File \"%s\", line %d, characters %d-%d:\n" ] -; - -value report_quotation_error name ctx = - let name = if name = "" then Quotation.default.val else name in - do { - Format.print_flush (); - Format.open_hovbox 2; - Printf.eprintf "While %s \"%s\":" - (match ctx with - [ Finding -> "finding quotation" - | Expanding -> "expanding quotation" - | ParsingResult _ _ -> "parsing result of quotation" - | Locating -> "parsing" ]) - name; - match ctx with - [ ParsingResult (bp, ep) str -> - match quotation_dump_file.val with - [ Some dump_file -> - do { - Printf.eprintf " dumping result...\n"; - flush stderr; - try - let (line, c1, c2) = find_line (bp, ep) str in - let oc = open_out_bin dump_file in - do { - output_string oc str; - output_string oc "\n"; - flush oc; - close_out oc; - Printf.eprintf loc_fmt dump_file line c1 c2; - flush stderr - } - with _ -> - do { - Printf.eprintf "Error while dumping result in file \"%s\"" - dump_file; - Printf.eprintf "; dump aborted.\n"; - flush stderr - } - } - | None -> - do { - if input_file.val = "" then - Printf.eprintf - "\n(consider setting variable Pcaml.quotation_dump_file)\n" - else Printf.eprintf " (consider using option -QD)\n"; - flush stderr - } ] - | _ -> do { Printf.eprintf "\n"; flush stderr } ] - } -; - -value print_format str = - let rec flush ini cnt = - if cnt > ini then Format.print_string (String.sub str ini (cnt - ini)) - else () - in - let rec loop ini cnt = - if cnt == String.length str then flush ini cnt - else - match str.[cnt] with - [ '\n' -> - do { - flush ini cnt; - Format.close_box (); - Format.force_newline (); - Format.open_box 2; - loop (cnt + 1) (cnt + 1) - } - | ' ' -> - do { - flush ini cnt; Format.print_space (); loop (cnt + 1) (cnt + 1) - } - | _ -> loop ini (cnt + 1) ] - in - do { Format.open_box 2; loop 0 0; Format.close_box () } -; - -value print_file_failed file line char = - do { - Format.print_string ", file \""; - Format.print_string file; - Format.print_string "\", line "; - Format.print_int line; - Format.print_string ", char "; - Format.print_int char - } -; - -value print_exn = - fun - [ Out_of_memory -> Format.print_string "Out of memory\n" - | Assert_failure (file, line, char) -> - do { - Format.print_string "Assertion failed"; - print_file_failed file line char; - } - | Match_failure (file, line, char) -> - do { - Format.print_string "Pattern matching failed"; - print_file_failed file line char; - } - | Stream.Error str -> print_format ("Parse error: " ^ str) - | Stream.Failure -> Format.print_string "Parse failure" - | Token.Error str -> - do { Format.print_string "Lexing error: "; Format.print_string str } - | Failure str -> - do { Format.print_string "Failure: "; Format.print_string str } - | Invalid_argument str -> - do { Format.print_string "Invalid argument: "; Format.print_string str } - | Sys_error msg -> - do { Format.print_string "I/O error: "; Format.print_string msg } - | x -> - do { - Format.print_string "Uncaught exception: "; - Format.print_string - (Obj.magic (Obj.field (Obj.field (Obj.repr x) 0) 0)); - if Obj.size (Obj.repr x) > 1 then do { - Format.print_string " ("; - for i = 1 to Obj.size (Obj.repr x) - 1 do { - if i > 1 then Format.print_string ", " else (); - let arg = Obj.field (Obj.repr x) i in - if not (Obj.is_block arg) then - Format.print_int (Obj.magic arg : int) - else if Obj.tag arg = Obj.tag (Obj.repr "a") then do { - Format.print_char '"'; - Format.print_string (Obj.magic arg : string); - Format.print_char '"' - } - else Format.print_char '_' - }; - Format.print_char ')' - } - else () - } ] -; - -value report_error exn = - match exn with - [ Qerror name Finding Not_found -> - let name = if name = "" then Quotation.default.val else name in - do { - Format.print_flush (); - Format.open_hovbox 2; - Format.printf "Unbound quotation: \"%s\"" name; - Format.close_box () - } - | Qerror name ctx exn -> - do { report_quotation_error name ctx; print_exn exn } - | e -> print_exn exn ] -; - -value no_constructors_arity = ref False; - -value arg_spec_list_ref = ref []; -value arg_spec_list () = arg_spec_list_ref.val; -value add_option name spec descr = - arg_spec_list_ref.val := arg_spec_list_ref.val @ [(name, spec, descr)] -; - -(* Printers *) - -open Spretty; - -type printer_t 'a = - { pr_fun : mutable string -> 'a -> string -> kont -> pretty; - pr_levels : mutable list (pr_level 'a) } -and pr_level 'a = - { pr_label : string; - pr_box : 'a -> Stream.t pretty -> pretty; - pr_rules : mutable pr_rule 'a } -and pr_rule 'a = - Extfun.t 'a (curr 'a -> next 'a -> string -> kont -> Stream.t pretty) -and curr 'a = 'a -> string -> kont -> Stream.t pretty -and next 'a = 'a -> string -> kont -> pretty -and kont = Stream.t pretty -; - -value pr_str_item = {pr_fun = fun []; pr_levels = []}; -value pr_sig_item = {pr_fun = fun []; pr_levels = []}; -value pr_module_type = {pr_fun = fun []; pr_levels = []}; -value pr_module_expr = {pr_fun = fun []; pr_levels = []}; -value pr_expr = {pr_fun = fun []; pr_levels = []}; -value pr_patt = {pr_fun = fun []; pr_levels = []}; -value pr_ctyp = {pr_fun = fun []; pr_levels = []}; -value pr_class_sig_item = {pr_fun = fun []; pr_levels = []}; -value pr_class_str_item = {pr_fun = fun []; pr_levels = []}; -value pr_class_type = {pr_fun = fun []; pr_levels = []}; -value pr_class_expr = {pr_fun = fun []; pr_levels = []}; -value pr_expr_fun_args = ref Extfun.empty; - -value pr_fun name pr lab = - loop False pr.pr_levels where rec loop app = - fun - [ [] -> fun x dg k -> failwith ("unable to print " ^ name) - | [lev :: levl] -> - if app || lev.pr_label = lab then - let next = loop True levl in - let rec curr x dg k = Extfun.apply lev.pr_rules x curr next dg k in - fun x dg k -> lev.pr_box x (curr x dg k) - else loop app levl ] -; - -pr_str_item.pr_fun := pr_fun "str_item" pr_str_item; -pr_sig_item.pr_fun := pr_fun "sig_item" pr_sig_item; -pr_module_type.pr_fun := pr_fun "module_type" pr_module_type; -pr_module_expr.pr_fun := pr_fun "module_expr" pr_module_expr; -pr_expr.pr_fun := pr_fun "expr" pr_expr; -pr_patt.pr_fun := pr_fun "patt" pr_patt; -pr_ctyp.pr_fun := pr_fun "ctyp" pr_ctyp; -pr_class_sig_item.pr_fun := pr_fun "class_sig_item" pr_class_sig_item; -pr_class_str_item.pr_fun := pr_fun "class_str_item" pr_class_str_item; -pr_class_type.pr_fun := pr_fun "class_type" pr_class_type; -pr_class_expr.pr_fun := pr_fun "class_expr" pr_class_expr; - -value rec find_pr_level lab = - fun - [ [] -> failwith ("level " ^ lab ^ " not found") - | [lev :: levl] -> - if lev.pr_label = lab then lev else find_pr_level lab levl ] -; - -value undef x = ref (fun _ -> failwith x); -value print_interf = undef "no printer"; -value print_implem = undef "no printer"; - -value top_printer pr x = - do { - Format.force_newline (); - Spretty.print_pretty Format.print_char Format.print_string - Format.print_newline "<< " " " 78 - (fun _ _ -> ("", 0, 0, 0)) 0 (pr.pr_fun "top" x "" [: :]); - Format.print_string " >>"; - } -; - -value buff = Buffer.create 73; -value buffer_char = Buffer.add_char buff; -value buffer_string = Buffer.add_string buff; -value buffer_newline () = Buffer.add_char buff '\n'; - -value string_of pr x = - do { - Buffer.clear buff; - Spretty.print_pretty buffer_char buffer_string buffer_newline "" "" 78 - (fun _ _ -> ("", 0, 0, 0)) 0 (pr.pr_fun "top" x "" [: :]); - Buffer.contents buff - } -; - -value inter_phrases = ref None; - -value position = - ref(ref 0, ref 0, ref "") -; diff --git a/camlp4/camlp4/pcaml.mli b/camlp4/camlp4/pcaml.mli deleted file mode 100644 index 5fefe67d..00000000 --- a/camlp4/camlp4/pcaml.mli +++ /dev/null @@ -1,172 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: pcaml.mli,v 1.9 2005/03/24 17:20:53 doligez Exp $ *) - -(** Language grammar, entries and printers. - - Hold variables to be set by language syntax extensions. Some of them - are provided for quotations management. *) - -value syntax_name : ref string; - -(** {6 Parsers} *) - -value parse_interf : - ref (Stream.t char -> (list (MLast.sig_item * MLast.loc) * bool)); -value parse_implem : - ref (Stream.t char -> (list (MLast.str_item * MLast.loc) * bool)); - (** Called when parsing an interface (mli file) or an implementation - (ml file) to build the syntax tree; the returned list contains the - phrases (signature items or structure items) and their locations; - the boolean tells that the parser has encountered a directive; in - this case, since the directive may change the syntax, the parsing - stops, the directive is evaluated, and this function is called - again. - These functions are references, because they can be changed to - use another technology than the Camlp4 extended grammars. By - default, they use the grammars entries [implem] and [interf] - defined below. *) - -value position: ref (ref int * ref int * ref string); - (** References holding respectively the character number of the beginning - of the current line, the current line number and the name of the file - being parsed. *) - -value gram : Grammar.g; - (** Grammar variable of the OCaml language *) - -value interf : Grammar.Entry.e (list (MLast.sig_item * MLast.loc) * bool); -value implem : Grammar.Entry.e (list (MLast.str_item * MLast.loc) * bool); -value top_phrase : Grammar.Entry.e (option MLast.str_item); -value use_file : Grammar.Entry.e (list MLast.str_item * bool); -value module_type : Grammar.Entry.e MLast.module_type; -value module_expr : Grammar.Entry.e MLast.module_expr; -value sig_item : Grammar.Entry.e MLast.sig_item; -value str_item : Grammar.Entry.e MLast.str_item; -value expr : Grammar.Entry.e MLast.expr; -value patt : Grammar.Entry.e MLast.patt; -value ctyp : Grammar.Entry.e MLast.ctyp; -value let_binding : Grammar.Entry.e (MLast.patt * MLast.expr); -value type_declaration : Grammar.Entry.e MLast.type_decl; -value class_sig_item : Grammar.Entry.e MLast.class_sig_item; -value class_str_item : Grammar.Entry.e MLast.class_str_item; -value class_expr : Grammar.Entry.e MLast.class_expr; -value class_type : Grammar.Entry.e MLast.class_type; - (** Some entries of the language, set by [pa_o.cmo] and [pa_r.cmo]. *) - -value input_file : ref string; - (** The file currently being parsed. *) -value output_file : ref (option string); - (** The output file, stdout if None (default) *) -value report_error : exn -> unit; - (** Prints an error message, using the module [Format]. *) -value quotation_dump_file : ref (option string); - (** [quotation_dump_file] optionally tells the compiler 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 version : string; - (** The current version of Camlp4. *) -value add_option : string -> Arg.spec -> string -> unit; - (** Add an option to the command line options. *) -value no_constructors_arity : ref bool; - (** [True]: dont generate constructor arity. *) - -value sync : ref (Stream.t char -> unit); - -value handle_expr_quotation : MLast.loc -> (string * string) -> MLast.expr; -value handle_expr_locate : MLast.loc -> (Lexing.position * string) -> MLast.expr; - -value handle_patt_quotation : MLast.loc -> (string * string) -> MLast.patt; -value handle_patt_locate : MLast.loc -> (Lexing.position * string) -> MLast.patt; - -(** Relocation functions for abstract syntax trees *) -value expr_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.expr -> MLast.expr; -value patt_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.patt -> MLast.patt; - -value ctyp_reloc : (MLast.loc -> MLast.loc) -> 'a -> MLast.ctyp -> MLast.ctyp; -value row_field_reloc : (MLast.loc -> MLast.loc) -> 'a -> MLast.row_field -> MLast.row_field; -value class_infos_reloc : ((MLast.loc -> MLast.loc) -> 'a -> 'b -> 'c) -> (MLast.loc -> MLast.loc) -> 'a -> MLast.class_infos 'b -> MLast.class_infos 'c; -value module_type_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_type -> MLast.module_type; -value sig_item_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.sig_item -> MLast.sig_item; -value with_constr_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.with_constr -> MLast.with_constr; -value module_expr_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_expr -> MLast.module_expr; -value str_item_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.str_item -> MLast.str_item; -value class_type_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_type -> MLast.class_type; -value class_sig_item_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_sig_item -> MLast.class_sig_item; -value class_expr_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_expr -> MLast.class_expr; -value class_str_item_reloc : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_str_item -> MLast.class_str_item; - -(** To possibly rename identifiers; parsers may call this function - when generating their identifiers; default = identity *) -value rename_id : ref (string -> string); - -(** Allow user to catch exceptions in quotations *) -type err_ctx = - [ Finding | Expanding | ParsingResult of MLast.loc and string | Locating ] -; -exception Qerror of string and err_ctx and exn; - -(** {6 Printers} *) - -open Spretty; - -value print_interf : ref (list (MLast.sig_item * MLast.loc) -> unit); -value print_implem : ref (list (MLast.str_item * MLast.loc) -> unit); - (** Some printers, set by [pr_dump.cmo], [pr_o.cmo] and [pr_r.cmo]. *) - -type printer_t 'a = - { pr_fun : mutable string -> 'a -> string -> kont -> pretty; - pr_levels : mutable list (pr_level 'a) } -and pr_level 'a = - { pr_label : string; - pr_box : 'a -> Stream.t pretty -> pretty; - pr_rules : mutable pr_rule 'a } -and pr_rule 'a = - Extfun.t 'a (curr 'a -> next 'a -> string -> kont -> Stream.t pretty) -and curr 'a = 'a -> string -> kont -> Stream.t pretty -and next 'a = 'a -> string -> kont -> pretty -and kont = Stream.t pretty -; - -value pr_sig_item : printer_t MLast.sig_item; -value pr_str_item : printer_t MLast.str_item; -value pr_module_type : printer_t MLast.module_type; -value pr_module_expr : printer_t MLast.module_expr; -value pr_expr : printer_t MLast.expr; -value pr_patt : printer_t MLast.patt; -value pr_ctyp : printer_t MLast.ctyp; -value pr_class_sig_item : printer_t MLast.class_sig_item; -value pr_class_str_item : printer_t MLast.class_str_item; -value pr_class_type : printer_t MLast.class_type; -value pr_class_expr : printer_t MLast.class_expr; - -value pr_expr_fun_args : - ref (Extfun.t MLast.expr (list MLast.patt * MLast.expr)); - -value find_pr_level : string -> list (pr_level 'a) -> pr_level 'a; - -value top_printer : printer_t 'a -> 'a -> unit; -value string_of : printer_t 'a -> 'a -> string; - -value inter_phrases : ref (option string); - -(**/**) - -(* for system use *) - -value warning : ref (MLast.loc -> string -> unit); -value expr_eoi : Grammar.Entry.e MLast.expr; -value patt_eoi : Grammar.Entry.e MLast.patt; -value arg_spec_list : unit -> list (string * Arg.spec * string); -value no_constructors_arity : ref bool; diff --git a/camlp4/camlp4/quotation.ml b/camlp4/camlp4/quotation.ml deleted file mode 100644 index 4cb75451..00000000 --- a/camlp4/camlp4/quotation.ml +++ /dev/null @@ -1,33 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: quotation.ml,v 1.3 2002/07/19 14:53:44 mauny Exp $ *) - -type expander = - [ ExStr of bool -> string -> string - | ExAst of (string -> MLast.expr * string -> MLast.patt) ] -; - -value expanders_table = ref []; - -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 = List.assoc (expander_name name) expanders_table.val; - -value add name f = expanders_table.val := [(name, f) :: expanders_table.val]; diff --git a/camlp4/camlp4/quotation.mli b/camlp4/camlp4/quotation.mli deleted file mode 100644 index 97c6ebde..00000000 --- a/camlp4/camlp4/quotation.mli +++ /dev/null @@ -1,48 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: quotation.mli,v 1.2 2002/07/19 14:53:44 mauny Exp $ *) - -(** Quotation operations. *) - -type expander = - [ ExStr of bool -> string -> string - | ExAst of (string -> MLast.expr * string -> MLast.patt) ] -; - -(** The type for quotation expanders kind: -- [ExStr exp] for an expander [exp] returning a string which - can be parsed to create a syntax tree. Its boolean parameter - tells whether the quotation is in position of an expression - (True) or in position of a pattern (False). Quotations expanders - created with this way may work for some particular language syntax, - and not for another one (e.g. may work when used with Revised - syntax and not when used with Ocaml syntax, and conversely). -- [ExAst (expr_exp, patt_exp)] for expanders returning directly - syntax trees, therefore not necessiting to be parsed afterwards. - The function [expr_exp] is called when the quotation is in - position of an expression, and [patt_exp] when the quotation is - in position of a pattern. Quotation expanders created with this - way are independant from the language syntax. *) - -value add : string -> expander -> unit; - (** [add name exp] adds the quotation [name] associated with the - expander [exp]. *) - -value find : string -> expander; - (** [find name] returns the expander of the given quotation name. *) - -value default : ref string; - (** [default] holds the default quotation name. *) - -value translate : ref (string -> string); - (** function translating quotation names; default = identity *) diff --git a/camlp4/camlp4/reloc.ml b/camlp4/camlp4/reloc.ml deleted file mode 100644 index 1636775c..00000000 --- a/camlp4/camlp4/reloc.ml +++ /dev/null @@ -1,381 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: reloc.ml,v 1.18 2005/06/29 04:11:26 garrigue Exp $ *) - -open MLast; - -value option_map f = - fun - [ Some x -> Some (f x) - | None -> None ] -; - -value rec ctyp floc sh = - self where rec self = - fun - [ TyAcc loc x1 x2 -> TyAcc (floc loc) (self x1) (self x2) - | TyAli loc x1 x2 -> TyAli (floc loc) (self x1) (self x2) - | TyAny loc -> TyAny (floc loc) - | TyApp loc x1 x2 -> TyApp (floc loc) (self x1) (self x2) - | TyArr loc x1 x2 -> TyArr (floc loc) (self x1) (self x2) - | TyCls loc x1 -> TyCls (floc loc) x1 - | TyLab loc x1 x2 -> TyLab (floc loc) x1 (self x2) - | TyLid loc x1 -> TyLid (floc loc) x1 - | TyMan loc x1 x2 -> TyMan (floc loc) (self x1) (self x2) - | TyObj loc x1 x2 -> - TyObj (floc loc) (List.map (fun (x1, x2) -> (x1, self x2)) x1) x2 - | TyOlb loc x1 x2 -> TyOlb (floc loc) x1 (self x2) - | TyPol loc x1 x2 -> TyPol (floc loc) x1 (self x2) - | TyQuo loc x1 -> TyQuo (floc loc) x1 - | TyRec loc x1 -> - TyRec (floc loc) - (List.map (fun (loc, x1, x2, x3) -> (floc loc, x1, x2, self x3)) x1) - | TySum loc x1 -> - TySum (floc loc) - (List.map (fun (loc, x1, x2) -> (floc loc, x1, List.map self x2)) x1) - | TyPrv loc x1 -> TyPrv (floc loc) (self x1) - | TyTup loc x1 -> TyTup (floc loc) (List.map self x1) - | TyUid loc x1 -> TyUid (floc loc) x1 - | TyVrn loc x1 x2 -> - TyVrn (floc loc) (List.map (row_field floc sh) x1) x2 ] -and row_field floc sh = - fun - [ RfTag x1 x2 x3 -> RfTag x1 x2 (List.map (ctyp floc sh) x3) - | RfInh x1 -> RfInh (ctyp floc sh x1) ] -; - -value class_infos a floc sh x = - {ciLoc = floc x.ciLoc; ciVir = x.ciVir; - ciPrm = - let (x1, x2) = x.ciPrm in - (floc x1, x2); - ciNam = x.ciNam; ciExp = a floc sh x.ciExp} -; - -(* Debugging positions and locations *) -value eprint_pos msg p = - Printf.eprintf "%s: fname=%s; lnum=%d; bol=%d; cnum=%d\n%!" - msg p.Lexing.pos_fname p.Lexing.pos_lnum p.Lexing.pos_bol p.Lexing.pos_cnum -; - -value eprint_loc (bp, ep) = - do { eprint_pos " P1" bp; eprint_pos " P2" ep } -; - -value check_position msg p = - let ok = - if (p.Lexing.pos_lnum < 0 || - p.Lexing.pos_bol < 0 || - p.Lexing.pos_cnum < 0 || - p.Lexing.pos_cnum < p.Lexing.pos_bol) - then - do { - Printf.eprintf "*** Warning: (%s) strange position ***\n" msg; - eprint_pos msg p; - False - } - else - True in - (ok, p) -; - -value check_location msg ((bp, ep) as loc) = - let ok = - let (ok1,_) = check_position " From: " bp in - let (ok2,_) = check_position " To: " ep in - if ((not ok1) || (not ok2) || - bp.Lexing.pos_lnum > ep.Lexing.pos_lnum || - bp.Lexing.pos_bol > ep.Lexing.pos_bol || - bp.Lexing.pos_cnum > ep.Lexing.pos_cnum) - then - do { - Printf.eprintf "*** Warning: (%s) strange location ***\n" msg; - eprint_loc loc; - False - } - else - True in - (ok, loc) -; - -value shift_pos n p = - { (p) with Lexing.pos_cnum = p.Lexing.pos_cnum + n } -; - -value zero_loc = - { (Lexing.dummy_pos) with Lexing.pos_cnum = 0; Lexing.pos_lnum = 0 } -; - -value adjust_pos globpos local_pos = -{ - Lexing.pos_fname = globpos.Lexing.pos_fname; - Lexing.pos_lnum = globpos.Lexing.pos_lnum + local_pos.Lexing.pos_lnum - 1; - Lexing.pos_bol = - if local_pos.Lexing.pos_lnum <= 1 then - globpos.Lexing.pos_bol - else - local_pos.Lexing.pos_bol + globpos.Lexing.pos_cnum; - Lexing.pos_cnum = local_pos.Lexing.pos_cnum + globpos.Lexing.pos_cnum -}; - -value adjust_loc gpos (p1, p2) = - (adjust_pos gpos p1, adjust_pos gpos p2) -; - -(* Note: in the following, the "let nloc = floc loc in" is necessary - in order to force evaluation order: the "floc" function has a side-effect - that changes all locations produced but the first one into ghost locations *) - -value rec patt floc sh = - self where rec self = - fun - [ PaAcc loc x1 x2 -> let nloc = floc loc in PaAcc nloc (self x1) (self x2) - | PaAli loc x1 x2 -> let nloc = floc loc in PaAli nloc (self x1) (self x2) - | PaAnt loc x1 -> (* Note that antiquotations are parsed by the OCaml parser, passing line numbers and begs of lines *) - patt (fun lloc -> adjust_loc (adjust_pos sh (fst loc)) lloc) zero_loc x1 - | PaAny loc -> let nloc = floc loc in PaAny nloc - | PaApp loc x1 x2 -> let nloc = floc loc in PaApp nloc (self x1) (self x2) - | PaArr loc x1 -> let nloc = floc loc in PaArr nloc (List.map self x1) - | PaChr loc x1 -> let nloc = floc loc in PaChr nloc x1 - | PaInt loc x1 -> let nloc = floc loc in PaInt nloc x1 - | PaInt32 loc x1 -> let nloc = floc loc in PaInt32 nloc x1 - | PaInt64 loc x1 -> let nloc = floc loc in PaInt64 nloc x1 - | PaNativeInt loc x1 -> let nloc = floc loc in PaNativeInt nloc x1 - | PaFlo loc x1 -> let nloc = floc loc in PaFlo nloc x1 - | PaLab loc x1 x2 -> let nloc = floc loc in PaLab nloc x1 (option_map self x2) - | PaLid loc x1 -> let nloc = floc loc in PaLid nloc x1 - | PaOlb loc x1 x2 -> - let nloc = floc loc in - PaOlb nloc x1 - (option_map - (fun (x1, x2) -> (self x1, option_map (expr floc sh) x2)) x2) - | PaOrp loc x1 x2 -> let nloc = floc loc in PaOrp nloc (self x1) (self x2) - | PaRng loc x1 x2 -> let nloc = floc loc in PaRng nloc (self x1) (self x2) - | PaRec loc x1 -> - let nloc = floc loc in PaRec nloc (List.map (fun (x1, x2) -> (self x1, self x2)) x1) - | PaStr loc x1 -> let nloc = floc loc in PaStr nloc x1 - | PaTup loc x1 -> let nloc = floc loc in PaTup nloc (List.map self x1) - | PaTyc loc x1 x2 -> let nloc = floc loc in PaTyc nloc (self x1) (ctyp floc sh x2) - | PaTyp loc x1 -> let nloc = floc loc in PaTyp nloc x1 - | PaUid loc x1 -> let nloc = floc loc in PaUid nloc x1 - | PaVrn loc x1 -> let nloc = floc loc in PaVrn nloc x1 ] -and expr floc sh = - self where rec self = - fun - [ ExAcc loc x1 x2 -> let nloc = floc loc in ExAcc nloc (self x1) (self x2) - | ExAnt loc x1 -> (* Note that antiquotations are parsed by the OCaml parser, passing line numbers and begs of lines *) - expr (fun lloc -> (adjust_loc (adjust_pos sh (fst loc)) lloc)) - zero_loc x1 - | ExApp loc x1 x2 -> let nloc = floc loc in ExApp nloc (self x1) (self x2) - | ExAre loc x1 x2 -> let nloc = floc loc in ExAre nloc (self x1) (self x2) - | ExArr loc x1 -> let nloc = floc loc in ExArr nloc (List.map self x1) - | ExAsf loc -> let nloc = floc loc in ExAsf nloc - | ExAsr loc x1 -> let nloc = floc loc in ExAsr nloc (self x1) - | ExAss loc x1 x2 -> let nloc = floc loc in ExAss nloc (self x1) (self x2) - | ExChr loc x1 -> let nloc = floc loc in ExChr nloc x1 - | ExCoe loc x1 x2 x3 -> - let nloc = floc loc in - ExCoe nloc (self x1) (option_map (ctyp floc sh) x2) - (ctyp floc sh x3) - | ExFlo loc x1 -> let nloc = floc loc in ExFlo nloc x1 - | ExFor loc x1 x2 x3 x4 x5 -> - let nloc = floc loc in ExFor nloc x1 (self x2) (self x3) x4 (List.map self x5) - | ExFun loc x1 -> - let nloc = floc loc in - ExFun nloc - (List.map - (fun (x1, x2, x3) -> - (patt floc sh x1, option_map self x2, self x3)) - x1) - | ExIfe loc x1 x2 x3 -> let nloc = floc loc in ExIfe nloc (self x1) (self x2) (self x3) - | ExInt loc x1 -> let nloc = floc loc in ExInt nloc x1 - | ExInt32 loc x1 -> let nloc = floc loc in ExInt32 nloc x1 - | ExInt64 loc x1 -> let nloc = floc loc in ExInt64 nloc x1 - | ExNativeInt loc x1 -> let nloc = floc loc in ExNativeInt nloc x1 - | ExLab loc x1 x2 -> let nloc = floc loc in ExLab nloc x1 (option_map self x2) - | ExLaz loc x1 -> let nloc = floc loc in ExLaz nloc (self x1) - | ExLet loc x1 x2 x3 -> - let nloc = floc loc in - ExLet nloc x1 - (List.map (fun (x1, x2) -> (patt floc sh x1, self x2)) x2) (self x3) - | ExLid loc x1 -> let nloc = floc loc in ExLid nloc x1 - | ExLmd loc x1 x2 x3 -> - let nloc = floc loc in ExLmd nloc x1 (module_expr floc sh x2) (self x3) - | ExMat loc x1 x2 -> - let nloc = floc loc in - ExMat nloc (self x1) - (List.map - (fun (x1, x2, x3) -> - (patt floc sh x1, option_map self x2, self x3)) - x2) - | ExNew loc x1 -> let nloc = floc loc in ExNew nloc x1 - | ExObj loc x1 x2 -> - let nloc = floc loc in ExObj nloc (option_map (patt floc sh) x1) - (List.map (class_str_item floc sh) x2) - | ExOlb loc x1 x2 -> let nloc = floc loc in ExOlb nloc x1 (option_map self x2) - | ExOvr loc x1 -> - let nloc = floc loc in - ExOvr nloc (List.map (fun (x1, x2) -> (x1, self x2)) x1) - | ExRec loc x1 x2 -> - let nloc = floc loc in - ExRec nloc - (List.map (fun (x1, x2) -> (patt floc sh x1, self x2)) x1) - (option_map self x2) - | ExSeq loc x1 -> let nloc = floc loc in ExSeq nloc (List.map self x1) - | ExSnd loc x1 x2 -> let nloc = floc loc in ExSnd nloc (self x1) x2 - | ExSte loc x1 x2 -> let nloc = floc loc in ExSte nloc (self x1) (self x2) - | ExStr loc x1 -> let nloc = floc loc in ExStr nloc x1 - | ExTry loc x1 x2 -> - let nloc = floc loc in - ExTry nloc (self x1) - (List.map - (fun (x1, x2, x3) -> - (patt floc sh x1, option_map self x2, self x3)) - x2) - | ExTup loc x1 -> let nloc = floc loc in ExTup nloc (List.map self x1) - | ExTyc loc x1 x2 -> let nloc = floc loc in ExTyc nloc (self x1) (ctyp floc sh x2) - | ExUid loc x1 -> let nloc = floc loc in ExUid nloc x1 - | ExVrn loc x1 -> let nloc = floc loc in ExVrn nloc x1 - | ExWhi loc x1 x2 -> let nloc = floc loc in ExWhi nloc (self x1) (List.map self x2) ] -and module_type floc sh = - self where rec self = - fun - [ MtAcc loc x1 x2 -> let nloc = floc loc in MtAcc nloc (self x1) (self x2) - | MtApp loc x1 x2 -> let nloc = floc loc in MtApp nloc (self x1) (self x2) - | MtFun loc x1 x2 x3 -> let nloc = floc loc in MtFun nloc x1 (self x2) (self x3) - | MtLid loc x1 -> let nloc = floc loc in MtLid nloc x1 - | MtQuo loc x1 -> let nloc = floc loc in MtQuo nloc x1 - | MtSig loc x1 -> let nloc = floc loc in MtSig nloc (List.map (sig_item floc sh) x1) - | MtUid loc x1 -> let nloc = floc loc in MtUid nloc x1 - | MtWit loc x1 x2 -> - let nloc = floc loc in MtWit nloc (self x1) (List.map (with_constr floc sh) x2) ] -and sig_item floc sh = - self where rec self = - fun - [ SgCls loc x1 -> - let nloc = floc loc in SgCls nloc (List.map (class_infos class_type floc sh) x1) - | SgClt loc x1 -> - let nloc = floc loc in SgClt nloc (List.map (class_infos class_type floc sh) x1) - | SgDcl loc x1 -> let nloc = floc loc in SgDcl nloc (List.map self x1) - | SgDir loc x1 x2 -> let nloc = floc loc in SgDir nloc x1 x2 - | SgExc loc x1 x2 -> let nloc = floc loc in SgExc nloc x1 (List.map (ctyp floc sh) x2) - | SgExt loc x1 x2 x3 -> let nloc = floc loc in SgExt nloc x1 (ctyp floc sh x2) x3 - | SgInc loc x1 -> let nloc = floc loc in SgInc nloc (module_type floc sh x1) - | SgMod loc x1 x2 -> let nloc = floc loc in SgMod nloc x1 (module_type floc sh x2) - | SgRecMod loc xxs - -> let nloc = floc loc in SgRecMod nloc (List.map (fun (x1,x2) -> (x1, (module_type floc sh x2))) xxs) - | SgMty loc x1 x2 -> let nloc = floc loc in SgMty nloc x1 (module_type floc sh x2) - | SgOpn loc x1 -> let nloc = floc loc in SgOpn nloc x1 - | SgTyp loc x1 -> - let nloc = floc loc in - SgTyp nloc - (List.map - (fun ((loc, x1), x2, x3, x4) -> - ((floc loc, x1), x2, ctyp floc sh x3, - List.map (fun (x1, x2) -> (ctyp floc sh x1, ctyp floc sh x2)) - x4)) - x1) - | SgUse loc x1 x2 -> SgUse loc x1 x2 - | SgVal loc x1 x2 -> let nloc = floc loc in SgVal nloc x1 (ctyp floc sh x2) ] -and with_constr floc sh = - self where rec self = - fun - [ WcTyp loc x1 x2 x3 -> let nloc = floc loc in WcTyp nloc x1 x2 (ctyp floc sh x3) - | WcMod loc x1 x2 -> let nloc = floc loc in WcMod nloc x1 (module_expr floc sh x2) ] -and module_expr floc sh = - self where rec self = - fun - [ MeAcc loc x1 x2 -> let nloc = floc loc in MeAcc nloc (self x1) (self x2) - | MeApp loc x1 x2 -> let nloc = floc loc in MeApp nloc (self x1) (self x2) - | MeFun loc x1 x2 x3 -> - let nloc = floc loc in - MeFun nloc x1 (module_type floc sh x2) (self x3) - | MeStr loc x1 -> let nloc = floc loc in MeStr nloc (List.map (str_item floc sh) x1) - | MeTyc loc x1 x2 -> let nloc = floc loc in MeTyc nloc (self x1) (module_type floc sh x2) - | MeUid loc x1 -> let nloc = floc loc in MeUid nloc x1 ] -and str_item floc sh = - self where rec self = - fun - [ StCls loc x1 -> - let nloc = floc loc in StCls nloc (List.map (class_infos class_expr floc sh) x1) - | StClt loc x1 -> - let nloc = floc loc in StClt nloc (List.map (class_infos class_type floc sh) x1) - | StDcl loc x1 -> let nloc = floc loc in StDcl nloc (List.map self x1) - | StDir loc x1 x2 -> let nloc = floc loc in StDir nloc x1 x2 - | StExc loc x1 x2 x3 -> let nloc = floc loc in StExc nloc x1 (List.map (ctyp floc sh) x2) x3 - | StExp loc x1 -> let nloc = floc loc in StExp nloc (expr floc sh x1) - | StExt loc x1 x2 x3 -> let nloc = floc loc in StExt nloc x1 (ctyp floc sh x2) x3 - | StInc loc x1 -> let nloc = floc loc in StInc nloc (module_expr floc sh x1) - | StMod loc x1 x2 -> let nloc = floc loc in StMod nloc x1 (module_expr floc sh x2) - | StRecMod loc nmtmes -> - let nloc = floc loc in StRecMod nloc (List.map (fun (n, mt, me) -> (n, module_type floc sh mt, module_expr floc sh me)) nmtmes) - | StMty loc x1 x2 -> let nloc = floc loc in StMty nloc x1 (module_type floc sh x2) - | StOpn loc x1 -> let nloc = floc loc in StOpn nloc x1 - | StTyp loc x1 -> - let nloc = floc loc in - StTyp nloc - (List.map - (fun ((loc, x1), x2, x3, x4) -> - ((floc loc, x1), x2, ctyp floc sh x3, - List.map (fun (x1, x2) -> (ctyp floc sh x1, ctyp floc sh x2)) - x4)) - x1) - | StUse loc x1 x2 -> StUse loc x1 x2 - | StVal loc x1 x2 -> - let nloc = floc loc in StVal nloc x1 - (List.map (fun (x1, x2) -> (patt floc sh x1, expr floc sh x2)) x2) ] -and class_type floc sh = - self where rec self = - fun - [ CtCon loc x1 x2 -> let nloc = floc loc in CtCon nloc x1 (List.map (ctyp floc sh) x2) - | CtFun loc x1 x2 -> let nloc = floc loc in CtFun nloc (ctyp floc sh x1) (self x2) - | CtSig loc x1 x2 -> - let nloc = floc loc in - CtSig nloc (option_map (ctyp floc sh) x1) - (List.map (class_sig_item floc sh) x2) ] -and class_sig_item floc sh = - self where rec self = - fun - [ CgCtr loc x1 x2 -> let nloc = floc loc in CgCtr nloc (ctyp floc sh x1) (ctyp floc sh x2) - | CgDcl loc x1 -> let nloc = floc loc in CgDcl nloc (List.map (class_sig_item floc sh) x1) - | CgInh loc x1 -> let nloc = floc loc in CgInh nloc (class_type floc sh x1) - | CgMth loc x1 x2 x3 -> let nloc = floc loc in CgMth nloc x1 x2 (ctyp floc sh x3) - | CgVal loc x1 x2 x3 -> let nloc = floc loc in CgVal nloc x1 x2 (ctyp floc sh x3) - | CgVir loc x1 x2 x3 -> let nloc = floc loc in CgVir nloc x1 x2 (ctyp floc sh x3) ] -and class_expr floc sh = - self where rec self = - fun - [ CeApp loc x1 x2 -> let nloc = floc loc in CeApp nloc (self x1) (expr floc sh x2) - | CeCon loc x1 x2 -> let nloc = floc loc in CeCon nloc x1 (List.map (ctyp floc sh) x2) - | CeFun loc x1 x2 -> let nloc = floc loc in CeFun nloc (patt floc sh x1) (self x2) - | CeLet loc x1 x2 x3 -> - let nloc = floc loc in - CeLet nloc x1 - (List.map (fun (x1, x2) -> (patt floc sh x1, expr floc sh x2)) x2) - (self x3) - | CeStr loc x1 x2 -> - let nloc = floc loc in CeStr nloc (option_map (patt floc sh) x1) - (List.map (class_str_item floc sh) x2) - | CeTyc loc x1 x2 -> let nloc = floc loc in CeTyc nloc (self x1) (class_type floc sh x2) ] -and class_str_item floc sh = - self where rec self = - fun - [ CrCtr loc x1 x2 -> let nloc = floc loc in CrCtr nloc (ctyp floc sh x1) (ctyp floc sh x2) - | CrDcl loc x1 -> let nloc = floc loc in CrDcl nloc (List.map (class_str_item floc sh) x1) - | CrInh loc x1 x2 -> let nloc = floc loc in CrInh nloc (class_expr floc sh x1) x2 - | CrIni loc x1 -> let nloc = floc loc in CrIni nloc (expr floc sh x1) - | CrMth loc x1 x2 x3 x4 -> - let nloc = floc loc in CrMth nloc x1 x2 (expr floc sh x3) (option_map (ctyp floc sh) x4) - | CrVal loc x1 x2 x3 -> let nloc = floc loc in CrVal nloc x1 x2 (expr floc sh x3) - | CrVir loc x1 x2 x3 -> let nloc = floc loc in CrVir nloc x1 x2 (ctyp floc sh x3) ] -; diff --git a/camlp4/camlp4/reloc.mli b/camlp4/camlp4/reloc.mli deleted file mode 100644 index 53c21b92..00000000 --- a/camlp4/camlp4/reloc.mli +++ /dev/null @@ -1,32 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: reloc.mli,v 1.5 2005/04/14 09:49:17 mauny Exp $ *) - -value zero_loc : Lexing.position; -value shift_pos : int -> Lexing.position -> Lexing.position; -value adjust_loc : Lexing.position -> MLast.loc -> MLast.loc; - -value ctyp : (MLast.loc -> MLast.loc) -> 'a -> MLast.ctyp -> MLast.ctyp; -value row_field : (MLast.loc -> MLast.loc) -> 'a -> MLast.row_field -> MLast.row_field; -value class_infos : ((MLast.loc -> MLast.loc) -> 'a -> 'b -> 'c) -> (MLast.loc -> MLast.loc) -> 'a -> MLast.class_infos 'b -> MLast.class_infos 'c; -value patt : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.patt -> MLast.patt; -value expr : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.expr -> MLast.expr; -value module_type : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_type -> MLast.module_type; -value sig_item : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.sig_item -> MLast.sig_item; -value with_constr : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.with_constr -> MLast.with_constr; -value module_expr : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_expr -> MLast.module_expr; -value str_item : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.str_item -> MLast.str_item; -value class_type : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_type -> MLast.class_type; -value class_sig_item : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_sig_item -> MLast.class_sig_item; -value class_expr : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_expr -> MLast.class_expr; -value class_str_item : (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_str_item -> MLast.class_str_item; diff --git a/camlp4/camlp4/spretty.ml b/camlp4/camlp4/spretty.ml deleted file mode 100644 index 246d9af2..00000000 --- a/camlp4/camlp4/spretty.ml +++ /dev/null @@ -1,481 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: spretty.ml,v 1.4 2004/11/17 09:07:56 mauny Exp $ *) - -type glue = [ LO | RO | LR | NO ]; -type pretty = - [ S of glue and string - | Hbox of Stream.t pretty - | HVbox of Stream.t pretty - | HOVbox of Stream.t pretty - | HOVCbox of Stream.t pretty - | Vbox of Stream.t pretty - | BEbox of Stream.t pretty - | BEVbox of Stream.t pretty - | LocInfo of (int * int) and pretty ] -; -type prettyL = - [ SL of int and glue and string - | HL of list prettyL - | BL of list prettyL - | PL of list prettyL - | QL of list prettyL - | VL of list prettyL - | BE of list prettyL - | BV of list prettyL - | LI of (string * int * int) and prettyL ] -; -type getcomm = int -> int -> (string * int * int * int); - -value quiet = ref True; -value maxl = ref 20; -value dt = ref 2; -value tol = ref 1; -value sp = ref ' '; -value last_ep = ref 0; -value getcomm = ref (fun _ _ -> ("", 0, 0, 0)); -value prompt = ref ""; -value print_char_fun = ref (output_char stdout); -value print_string_fun = ref (output_string stdout); -value print_newline_fun = ref (fun () -> output_char stdout '\n'); -value lazy_tab = ref (-1); - -value flush_tab () = - if lazy_tab.val >= 0 then do { - print_newline_fun.val (); - print_string_fun.val prompt.val; - for i = 1 to lazy_tab.val do { print_char_fun.val sp.val }; - lazy_tab.val := -1 - } - else () -; -value print_newline_and_tab tab = lazy_tab.val := tab; -value print_char c = do { flush_tab (); print_char_fun.val c }; -value print_string s = do { flush_tab (); print_string_fun.val s }; - -value rec print_spaces nsp = - for i = 1 to nsp do { print_char sp.val } -; - -value end_with_tab s = - loop (String.length s - 1) where rec loop i = - if i >= 0 then - if s.[i] = ' ' then loop (i - 1) - else s.[i] = '\n' - else False -; - -value print_comment tab s nl_bef tab_bef empty_stmt = - if s = "" then () - else do { - let (tab_aft, i_bef_tab) = - loop 0 (String.length s - 1) where rec loop tab_aft i = - if i >= 0 && s.[i] = ' ' then loop (tab_aft + 1) (i - 1) - else (tab_aft, i) - ; - let tab_bef = if nl_bef > 0 then tab_bef else tab in - let len = if empty_stmt then i_bef_tab else String.length s in - loop 0 where rec loop i = - if i = len then () - else do { - print_char_fun.val s.[i]; - let i = - if s.[i] = '\n' && (i+1 = len || s.[i+1] <> '\n') - then - let delta_ind = - if i = i_bef_tab then tab - tab_aft else tab - tab_bef - in - if delta_ind >= 0 then do { - for i = 1 to delta_ind do { print_char_fun.val ' ' }; - i + 1 - } - else - loop delta_ind (i + 1) where rec loop cnt i = - if cnt = 0 then i - else if i = len then i - else if s.[i] = ' ' then loop (cnt + 1) (i + 1) - else i - else i + 1 - in - loop i - } - } -; - -value string_np pos np = pos + np; - -value trace_ov pos = - if not quiet.val && pos > maxl.val then do { - prerr_string " prettych: overflow (length = "; - prerr_int pos; - prerr_endline ")" - } - else () -; - -value tolerate tab pos spc = pos + spc <= tab + dt.val + tol.val; - -value h_print_string pos spc np x = - let npos = string_np (pos + spc) np in - do { print_spaces spc; print_string x; npos } -; - -value n_print_string pos spc np x = - do { print_spaces spc; print_string x; string_np (pos + spc) np } -; - -value rec hnps ((pos, spc) as ps) = - fun - [ SL np RO _ -> (string_np pos np, 1) - | SL np LO _ -> (string_np (pos + spc) np, 0) - | SL np NO _ -> (string_np pos np, 0) - | SL np LR _ -> (string_np (pos + spc) np, 1) - | HL x -> hnps_list ps x - | BL x -> hnps_list ps x - | PL x -> hnps_list ps x - | QL x -> hnps_list ps x - | VL [x] -> hnps ps x - | VL [] -> ps - | VL x -> (maxl.val + 1, 0) - | BE x -> hnps_list ps x - | BV x -> (maxl.val + 1, 0) - | LI _ x -> hnps ps x ] -and hnps_list ((pos, _) as ps) pl = - if pos > maxl.val then (maxl.val + 1, 0) - else - match pl with - [ [p :: pl] -> hnps_list (hnps ps p) pl - | [] -> ps ] -; - -value rec first = - fun - [ SL _ _ s -> Some s - | HL x -> first_in_list x - | BL x -> first_in_list x - | PL x -> first_in_list x - | QL x -> first_in_list x - | VL x -> first_in_list x - | BE x -> first_in_list x - | BV x -> first_in_list x - | LI _ x -> first x ] -and first_in_list = - fun - [ [p :: pl] -> - match first p with - [ Some p -> Some p - | None -> first_in_list pl ] - | [] -> None ] -; - -value first_is_too_big tab p = - match first p with - [ Some s -> tab + String.length s >= maxl.val - | None -> False ] -; - -value too_long tab x p = - if first_is_too_big tab p then False - else - let (pos, spc) = hnps x p in - pos > maxl.val -; - -value rec has_comment = - fun - [ [LI (comm, nl_bef, tab_bef) x :: pl] -> - comm <> "" || has_comment [x :: pl] - | [HL x | BL x | PL x | QL x | VL x | BE x | BV x :: pl] -> - has_comment x || has_comment pl - | [SL _ _ _ :: pl] -> has_comment pl - | [] -> False ] -; - -value rec hprint_pretty tab pos spc = - fun - [ SL np RO x -> (h_print_string pos 0 np x, 1) - | SL np LO x -> (h_print_string pos spc np x, 0) - | SL np NO x -> (h_print_string pos 0 np x, 0) - | SL np LR x -> (h_print_string pos spc np x, 1) - | HL x -> hprint_box tab pos spc x - | BL x -> hprint_box tab pos spc x - | PL x -> hprint_box tab pos spc x - | QL x -> hprint_box tab pos spc x - | VL [x] -> hprint_pretty tab pos spc x - | VL [] -> (pos, spc) - | VL x -> hprint_box tab pos spc x - | BE x -> hprint_box tab pos spc x - | BV x -> - (* This should not occur: should be - invalid_arg "hprint_pretty" instead *) - hprint_box tab pos spc x - | LI (comm, nl_bef, tab_bef) x -> - do { - if lazy_tab.val >= 0 then do { - for i = 2 to nl_bef do { print_char_fun.val '\n' }; - flush_tab () - } - else (); - print_comment tab comm nl_bef tab_bef False; - hprint_pretty tab pos spc x - } ] -and hprint_box tab pos spc = - fun - [ [p :: pl] -> - let (pos, spc) = hprint_pretty tab pos spc p in - hprint_box tab pos spc pl - | [] -> (pos, spc) ] -; - -value rec print_pretty tab pos spc = - fun - [ SL np RO x -> (n_print_string pos 0 np x, 1) - | SL np LO x -> (n_print_string pos spc np x, 0) - | SL np NO x -> (n_print_string pos 0 np x, 0) - | SL np LR x -> (n_print_string pos spc np x, 1) - | HL x -> print_horiz tab pos spc x - | BL x as p -> print_horiz_vertic tab pos spc (too_long tab (pos, spc) p) x - | PL x as p -> print_paragraph tab pos spc (too_long tab (pos, spc) p) x - | QL x as p -> print_sparagraph tab pos spc (too_long tab (pos, spc) p) x - | VL x -> print_vertic tab pos spc x - | BE x as p -> print_begin_end tab pos spc (too_long tab (pos, spc) p) x - | BV x -> print_beg_end tab pos spc x - | LI (comm, nl_bef, tab_bef) x -> - do { - if lazy_tab.val >= 0 then do { - for i = 2 to nl_bef do { print_char_fun.val '\n' }; - if comm <> "" && nl_bef = 0 then - for i = 1 to tab_bef do { print_char_fun.val ' ' } - else if comm = "" && x = BL [] then lazy_tab.val := -1 - else flush_tab () - } - else (); - print_comment tab comm nl_bef tab_bef (x = BL []); - if comm <> "" && nl_bef = 0 then - if end_with_tab comm then lazy_tab.val := -1 else flush_tab () - else (); - print_pretty tab pos spc x - } ] -and print_horiz tab pos spc = - fun - [ [p :: pl] -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [ [] -> True - | _ -> False ] - then - (npos, nspc) - else print_horiz tab npos nspc pl - | [] -> (pos, spc) ] -and print_horiz_vertic tab pos spc ov pl = - if ov || has_comment pl then print_vertic tab pos spc pl - else hprint_box tab pos spc pl -and print_vertic tab pos spc = - fun - [ [p :: pl] -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [ [] -> True - | _ -> False ] - then - (npos, nspc) - else if tolerate tab npos nspc then do { - print_spaces nspc; print_vertic_rest (npos + nspc) pl - } - else do { - print_newline_and_tab (tab + dt.val); - print_vertic_rest (tab + dt.val) pl - } - | [] -> (pos, spc) ] -and print_vertic_rest tab = - fun - [ [p :: pl] -> - let (pos, spc) = print_pretty tab tab 0 p in - if match pl with - [ [] -> True - | _ -> False ] - then - (pos, spc) - else do { - print_newline_and_tab tab; - print_vertic_rest tab pl - } - | [] -> (tab, 0) ] -and print_paragraph tab pos spc ov pl = - if has_comment pl then print_vertic tab pos spc pl - else if ov then print_parag tab pos spc pl - else hprint_box tab pos spc pl -and print_parag tab pos spc = - fun - [ [p :: pl] -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [ [] -> True - | _ -> False ] - then - (npos, nspc) - else if npos == tab then print_parag_rest tab tab 0 pl - else if too_long tab (pos, spc) p then do { - print_newline_and_tab (tab + dt.val); - print_parag_rest (tab + dt.val) (tab + dt.val) 0 pl - } - else if tolerate tab npos nspc then do { - print_spaces nspc; print_parag_rest (npos + nspc) (npos + nspc) 0 pl - } - else print_parag_rest (tab + dt.val) npos nspc pl - | [] -> (pos, spc) ] -and print_parag_rest tab pos spc = - fun - [ [p :: pl] -> - let (pos, spc) = - if pos > tab && too_long tab (pos, spc) p then do { - print_newline_and_tab tab; (tab, 0) - } - else (pos, spc) - in - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [ [] -> True - | _ -> False ] - then - (npos, nspc) - else - let (pos, spc) = - if npos > tab && too_long tab (pos, spc) p then do { - print_newline_and_tab tab; - (tab, 0) - } - else (npos, nspc) - in - print_parag_rest tab pos spc pl - | [] -> (pos, spc) ] -and print_sparagraph tab pos spc ov pl = - if has_comment pl then print_vertic tab pos spc pl - else if ov then print_sparag tab pos spc pl - else hprint_box tab pos spc pl -and print_sparag tab pos spc = - fun - [ [p :: pl] -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [ [] -> True - | _ -> False ] - then - (npos, nspc) - else if tolerate tab npos nspc then do { - print_spaces nspc; print_sparag_rest (npos + nspc) (npos + nspc) 0 pl - } - else print_sparag_rest (tab + dt.val) npos nspc pl - | [] -> (pos, spc) ] -and print_sparag_rest tab pos spc = - fun - [ [p :: pl] -> - let (pos, spc) = - if pos > tab && too_long tab (pos, spc) p then do { - print_newline_and_tab tab; (tab, 0) - } - else (pos, spc) - in - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [ [] -> True - | _ -> False ] - then - (npos, nspc) - else print_sparag_rest tab npos nspc pl - | [] -> (pos, spc) ] -and print_begin_end tab pos spc ov pl = - if ov || has_comment pl then print_beg_end tab pos spc pl - else hprint_box tab pos spc pl -and print_beg_end tab pos spc = - fun - [ [p :: pl] -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [ [] -> True - | _ -> False ] - then - (npos, nspc) - else if tolerate tab npos nspc then do { - let nspc = if npos == tab then nspc + dt.val else nspc in - print_spaces nspc; - print_beg_end_rest tab (npos + nspc) pl - } - else do { - print_newline_and_tab (tab + dt.val); - print_beg_end_rest tab (tab + dt.val) pl - } - | [] -> (pos, spc) ] -and print_beg_end_rest tab pos = - fun - [ [p :: pl] -> - let (pos, spc) = print_pretty (tab + dt.val) pos 0 p in - if match pl with - [ [] -> True - | _ -> False ] - then - (pos, spc) - else do { - print_newline_and_tab tab; - print_beg_end_rest tab tab pl - } - | [] -> (pos, 0) ] -; - -value string_npos s = String.length s; - -value rec conv = - fun - [ S g s -> SL (string_npos s) g s - | Hbox x -> HL (conv_stream x) - | HVbox x -> BL (conv_stream x) - | HOVbox x -> - match conv_stream x with - [ [(PL _ as x)] -> x - | x -> PL x ] - | HOVCbox x -> QL (conv_stream x) - | Vbox x -> VL (conv_stream x) - | BEbox x -> BE (conv_stream x) - | BEVbox x -> BV (conv_stream x) - | LocInfo (bp, ep) x -> - let (comm, nl_bef, tab_bef, cnt) = - let len = bp - last_ep.val in - if len > 0 then getcomm.val last_ep.val len - else ("", 0, 0, 0) - in - do { - last_ep.val := last_ep.val + cnt; - let v = conv x in - last_ep.val := max ep last_ep.val; - LI (comm, nl_bef, tab_bef) v - } ] -and conv_stream = - parser - [ [: `p; s :] -> let x = conv p in [x :: conv_stream s] - | [: :] -> [] ] -; - -value print_pretty pr_ch pr_str pr_nl pr pr2 m lf bp p = - do { - maxl.val := m; - print_char_fun.val := pr_ch; - print_string_fun.val := pr_str; - print_newline_fun.val := pr_nl; - prompt.val := pr2; - getcomm.val := lf; - last_ep.val := bp; - print_string pr; - let _ = print_pretty 0 0 0 (conv p) in - () - } -; diff --git a/camlp4/camlp4/spretty.mli b/camlp4/camlp4/spretty.mli deleted file mode 100644 index 86ef8464..00000000 --- a/camlp4/camlp4/spretty.mli +++ /dev/null @@ -1,54 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: spretty.mli,v 1.2 2002/07/19 14:53:44 mauny Exp $ *) - -(* Hbox: horizontal box - HVbox: horizontal-vertical box - HOVbox and HOVCbox: fill maximum of elements horizontally, line by line; - in HOVbox, if an element has to be displayed vertically (need several - lines), the next element is displayed next line; in HOVCbox, this next - element may be displayed same line if it holds. - Vbox: vertical box - BEbox: begin-end box: horizontal or 2nd element indented, 3rd element not - BEVbox: begin-end box always vertical - LocInfo: call back with location to allow inserting comments *) - -(* In case of box displayed vertically, 2nd line and following are indented - by dt.val spaces, except if first element of the box is empty: to not - indent, put HVbox [: :] as first element *) - -type glue = [ LO | RO | LR | NO ]; -type pretty = - [ S of glue and string - | Hbox of Stream.t pretty - | HVbox of Stream.t pretty - | HOVbox of Stream.t pretty - | HOVCbox of Stream.t pretty - | Vbox of Stream.t pretty - | BEbox of Stream.t pretty - | BEVbox of Stream.t pretty - | LocInfo of (int * int) and pretty ] -; -type getcomm = int -> int -> (string * int * int * int); - -value print_pretty : - (char -> unit) -> (string -> unit) -> (unit -> unit) -> - string -> string -> int -> getcomm -> int -> pretty -> unit; -value quiet : ref bool; - -value dt : ref int; - -(*--*) - -value tol : ref int; -value sp : ref char; diff --git a/camlp4/camlp4lib.mllib b/camlp4/camlp4lib.mllib new file mode 100644 index 00000000..bf5b50f3 --- /dev/null +++ b/camlp4/camlp4lib.mllib @@ -0,0 +1,9 @@ +Camlp4 +Linenum +Misc +Warnings +Location +Config +Camlp4_config +Myocamlbuild_config +Longident diff --git a/camlp4/camlp4prof.ml b/camlp4/camlp4prof.ml new file mode 100644 index 00000000..7e9df17f --- /dev/null +++ b/camlp4/camlp4prof.ml @@ -0,0 +1,24 @@ +module Debug = struct value mode _ = False; end; + +value count = + let h = Hashtbl.create 1007 in + let () = at_exit (fun () -> + let assoc = Hashtbl.fold (fun k v a -> [ (k, v.val) :: a ]) h [] in + let out = open_out "camlp4_profiler.out" in + let () = Marshal.to_channel out assoc [] in + close_out out) in + fun s -> + try incr (Hashtbl.find h s) + with [ Not_found -> Hashtbl.add h s (ref 1) ]; + +value load = Marshal.from_channel; + +value main () = + + let profile = List.sort (fun (_, v1) (_, v2) -> compare v1 v2) (load stdin) in + + List.iter + (fun (k, v) -> Format.printf "%-75s: %d@." k v) + profile; + +if Sys.argv.(0) = "camlp4prof" then main () else (); diff --git a/camlp4/camlp4prof.mli b/camlp4/camlp4prof.mli new file mode 100644 index 00000000..0703ac03 --- /dev/null +++ b/camlp4/camlp4prof.mli @@ -0,0 +1,3 @@ +value count : string -> unit; + +value load : in_channel -> list (string * int); diff --git a/camlp4/compile/.cvsignore b/camlp4/compile/.cvsignore deleted file mode 100644 index 47817cce..00000000 --- a/camlp4/compile/.cvsignore +++ /dev/null @@ -1,4 +0,0 @@ -*.fast -*.fast.opt -o_fast.ml -pa_o_fast.ml diff --git a/camlp4/compile/.depend b/camlp4/compile/.depend deleted file mode 100644 index 696f8ea3..00000000 --- a/camlp4/compile/.depend +++ /dev/null @@ -1,6 +0,0 @@ -comp_trail.cmo: ../camlp4/pcaml.cmi -comp_trail.cmx: ../camlp4/pcaml.cmx -compile.cmo: ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -compile.cmx: ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -pa_o_fast.cmo: ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pa_o_fast.cmx: ../camlp4/pcaml.cmx ../camlp4/mLast.cmi diff --git a/camlp4/compile/Makefile b/camlp4/compile/Makefile deleted file mode 100644 index 80f4ca34..00000000 --- a/camlp4/compile/Makefile +++ /dev/null @@ -1,47 +0,0 @@ -# $Id: Makefile,v 1.13.2.1 2006/09/12 08:58:10 doligez Exp $ - -include ../config/Makefile - -INCLUDES=-I ../camlp4 -I ../boot -OCAMLCFLAGS=-warn-error Ay $(INCLUDES) -SRC=../etc/pa_o.ml ../etc/pa_op.ml -D=o -COMP_OPT=-strict_parsing -COMP_OPT=-e "Grammar.Entry.obj Pcaml.interf" -e "Grammar.Entry.obj Pcaml.implem" -e "Grammar.Entry.obj Pcaml.top_phrase" -e "Grammar.Entry.obj Pcaml.use_file" - -all: out - -out: camlp4$D.fast -opt: camlp4$D.fast.opt - -camlp4$D.fast: pa_$D_fast.cmo - rm -f camlp4$D.fast - cd ../camlp4; $(MAKE) CAMLP4=../compile/camlp4$D.fast CAMLP4M="../compile/pa_$D_fast.cmo ../meta/pr_dump.cmo" - -camlp4$D.fast.opt: pa_$D_fast.cmx - rm -f camlp4$D.fast.opt - cd ../camlp4; $(MAKE) optp4 CAMLP4OPT=../compile/camlp4$D.fast.opt CAMLP4M="../compile/pa_$D_fast.cmx ../meta/pr_dump.cmx" - -pa_$D_fast.ml: comp_head.ml $D_fast.ml comp_trail.ml - cat $(SRC) | sed -e "s/Plexer.make_lexer *()/P.lexer_pos/" -e "/EXTEND/,/END/d" -e "/Grammar.Entry.of_parser/d" -e "/Grammar.Entry.gcreate/d" | cat comp_head.ml - $D_fast.ml comp_trail.ml > pa_$D_fast.ml - -$D_fast.ml: compile.cmo $(SRC) - echo '(* camlp4r *)' >$D_fast.ml - OTOP=$(OTOP) EXE=$(EXE) ./compile.sh $(COMP_OPT) $(SRC) >> $D_fast.ml - -install: - if test -f camlp4$D.fast.opt; then cp camlp4$D.fast.opt $(BINDIR)/camlp4$D.opt$(EXE); fi - for TARG in pa_$D_fast.cmi pa_$D_fast.cmo pa_$D_fast.cmx pa_$D_fast.o ; do if test -f $$TARG; then cp $$TARG "$(LIBDIR)/camlp4/."; fi; done - -clean:: - rm -f *.cm* *.pp[io] *.o *.bak .*.bak *.out *.opt - rm -f *.fast tmp.* pa_*_fast.ml *_fast.ml - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i >> .depend || : ; \ - done - -include .depend diff --git a/camlp4/compile/comp_head.ml b/camlp4/compile/comp_head.ml deleted file mode 100644 index 7c1cbef4..00000000 --- a/camlp4/compile/comp_head.ml +++ /dev/null @@ -1,70 +0,0 @@ -(* camlp4r q_MLast.cmo pa_extend.cmo *) -(* $Id: comp_head.ml,v 1.4 2005/03/24 17:20:53 doligez Exp $ *) - -module P = - struct - value gloc bp strm = Grammar.loc_of_token_interval bp (Stream.count strm); - value list0 symb = - let rec loop al = - parser - [ [: a = symb; s :] -> loop [a :: al] s - | [: :] -> al ] - in - parser [: a = loop [] :] -> List.rev a - ; - value list0sep symb sep = - let rec kont al = - parser - [ [: v = sep; a = symb; s :] -> kont [a :: al] s - | [: :] -> al ] - in - parser - [ [: a = symb; s :] -> List.rev (kont [a] s) - | [: :] -> [] ] - ; - value list1 symb = - let rec loop al = - parser - [ [: a = symb; s :] -> loop [a :: al] s - | [: :] -> al ] - in - parser [: a = symb; s :] -> List.rev (loop [a] s) - ; - value list1sep symb sep = - let rec kont al = - parser - [ [: v = sep; a = symb; s :] -> kont [a :: al] s - | [: :] -> al ] - in - parser [: a = symb; s :] -> List.rev (kont [a] s) - ; - value option f = - parser - [ [: x = f :] -> Some x - | [: :] -> None ] - ; - value token (p_con, p_prm) = - if p_prm = "" then parser [: `(con, prm) when con = p_con :] -> prm - else parser [: `(con, prm) when con = p_con && prm = p_prm :] -> prm - ; - value orzero f f0 = - parser bp - [ [: x = f :] -> x - | [: x = f0 :] ep -> -(* -let (loc1, loc2) = Grammar.loc_of_token_interval bp ep in -let _ = do { Printf.eprintf "recovered or_zero at loc (%d, %d)\n" loc1 loc2; flush stderr } in -*) - x ] - ; - value error entry prev_symb symb = - symb ^ " expected" ^ - (if prev_symb = "" then "" else " after " ^ prev_symb) ^ - " (in [" ^ entry ^ "])" - ; - value ((lexer,pos) as lexer_pos) = Plexer.make_lexer(); - end -; - -(****************************************) - diff --git a/camlp4/compile/comp_trail.ml b/camlp4/compile/comp_trail.ml deleted file mode 100644 index 75f40abb..00000000 --- a/camlp4/compile/comp_trail.ml +++ /dev/null @@ -1,33 +0,0 @@ -(* camlp4r pa_extend.cmo *) -(****************************************) - -value interf_p = - Grammar.Entry.of_parser Pcaml.gram "interf" interf_0 -; - -value implem_p = - Grammar.Entry.of_parser Pcaml.gram "implem" implem_0 -; - -value top_phrase_p = - Grammar.Entry.of_parser Pcaml.gram "top_phrase" top_phrase_0 -; - -value use_file_p = - Grammar.Entry.of_parser Pcaml.gram "use_file" use_file_0 -; - -EXTEND - interf: - [ [ x = interf_p -> x ] ] - ; - implem: - [ [ x = implem_p -> x ] ] - ; - top_phrase: - [ [ x = top_phrase_p -> x ] ] - ; - use_file: - [ [ x = use_file_p -> x ] ] - ; -END; diff --git a/camlp4/compile/compile.ml b/camlp4/compile/compile.ml deleted file mode 100644 index 858f222d..00000000 --- a/camlp4/compile/compile.ml +++ /dev/null @@ -1,580 +0,0 @@ -(* camlp4r *) -(* $Id: compile.ml,v 1.15 2004/11/24 01:55:16 garrigue Exp $ *) - -#load "q_MLast.cmo"; - -open Gramext; - -value strict_parsing = ref False; -value keywords = ref []; - -value _loc = - let nowhere = - {(Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0 } in - (nowhere,nowhere); - -(* Watch the segmentation faults here! the compiled file must have been - loaded in camlp4 with the option pa_extend.cmo -meta_action. *) -value magic_act (act : Obj.t) : MLast.expr = Obj.magic act; - -(* Names of symbols for error messages; code borrowed to grammar.ml *) - -value rec name_of_symbol entry = - fun - [ Snterm e -> "[" ^ e.ename ^ "]" - | Snterml e l -> "[" ^ e.ename ^ " level " ^ l ^ "]" - | Sself | Snext -> "[" ^ entry.ename ^ "]" - | Stoken tok -> entry.egram.glexer.Token.tok_text tok - | _ -> "???" ] -; - -value rec name_of_symbol_failed entry = - fun - [ Slist0 s -> name_of_symbol_failed entry s - | Slist0sep s _ -> name_of_symbol_failed entry s - | Slist1 s -> name_of_symbol_failed entry s - | Slist1sep s _ -> name_of_symbol_failed entry s - | Sopt 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 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 - | _ -> txt ^ " or " ^ name_of_tree_failed entry bro ] - in - txt - | DeadEnd | LocAct _ _ -> "???" ] -; - -value tree_failed entry prev_symb tree = - let (s2, s3) = - let txt = name_of_tree_failed entry tree in - match prev_symb with - [ Slist0 s -> - let txt1 = name_of_symbol_failed entry s in - ("", txt1 ^ " or " ^ txt) - | Slist1 s -> - let txt1 = name_of_symbol_failed entry s in - ("", txt1 ^ " or " ^ txt) - | Slist0sep s sep -> - let txt1 = name_of_symbol_failed entry s in - ("", txt1 ^ " or " ^ txt) - | Slist1sep s sep -> - let txt1 = name_of_symbol_failed entry s in - ("", txt1 ^ " or " ^ txt) - | Sopt _ | Stree _ -> ("", txt) - | _ -> (name_of_symbol entry prev_symb, txt) ] - in - <:expr< - P.error $str:entry.ename$ $str:String.escaped s2$ $str:String.escaped s3$ - >> -; - -(* Compilation *) - -value rec find_act = - fun - [ DeadEnd -> failwith "find_act" - | LocAct act _ -> (magic_act act, 0) - | Node {son = son; brother = bro} -> - let (act, n) = try find_act son with [ Failure _ -> find_act bro ] in - (act, n + 1) ] -; - -value level_number e l = - match e.edesc with - [ Dlevels elevs -> - loop 0 elevs where rec loop n = - fun - [ [lev :: levs] -> if lev.lname = Some l then n else loop (n + 1) levs - | [] -> failwith ("level " ^ l ^ " not found in entry " ^ e.ename) ] - | Dparser _ -> 0 ] -; - -value nth_patt_of_act (e, n) = - let patt_list = - loop e where rec loop = - fun - [ <:expr< fun (_loc : (Lexing.position * Lexing.position)) -> $_$ >> -> - [] - | <:expr< fun ($p$ : $_$) -> $e$ >> -> [p :: loop e] - | <:expr< fun $p$ -> $e$ >> -> [p :: loop e] - | _ -> failwith "nth_patt_of_act" ] - in - List.nth patt_list n -; - -value rec last_patt_of_act = - fun - [ <:expr< fun ($p$ : $_$) (_loc : (Lexing.position * Lexing.position)) -> - $_$ >> -> p - | <:expr< fun $_$ -> $e$ >> -> last_patt_of_act e - | _ -> failwith "last_patt_of_act" ] -; - -value rec final_action = - fun - [ <:expr< fun (_loc : (Lexing.position * Lexing.position)) -> - ($e$ : $_$) >> -> e - | <:expr< fun $_$ -> $e$ >> -> final_action e - | _ -> failwith "final_action" ] -; - -value parse_standard_symbol e rkont fkont ending_act = - <:expr< - match try Some ($e$ strm__) with [ Stream.Failure -> None ] with - [ Some $nth_patt_of_act ending_act$ -> $rkont$ - | _ -> $fkont$ ] - >> -; - -value parse_symbol_no_failure e rkont fkont ending_act = - <:expr< - let $nth_patt_of_act ending_act$ = - try $e$ strm__ with [ Stream.Failure -> raise (Stream.Error "") ] - in - $rkont$ - >> -; - -value rec contain_loc = - fun - [ <:expr< $lid:s$ >> -> (s = "loc") || (s = "_loc") - | <:expr< $uid:_$ >> -> False - | <:expr< $str:_$ >> -> False - | <:expr< ($list:el$) >> -> List.exists contain_loc el - | <:expr< $e1$ $e2$ >> -> contain_loc e1 || contain_loc e2 - | _ -> True ] -; - -value gen_let_loc _loc e = - if contain_loc e then <:expr< let _loc = P.gloc bp strm__ in $e$ >> else e -; - -value phony_entry = Grammar.Entry.obj Pcaml.implem; - -value rec parse_tree entry nlevn alevn (tree, fst_symb) act_kont kont = - match tree with - [ DeadEnd -> kont - | LocAct act _ -> - let act = magic_act act in - act_kont False act - | Node {node = Sself; son = LocAct act _; brother = bro} -> - let act = magic_act act in - let n = entry.ename ^ "_" ^ string_of_int alevn in - let e = - if strict_parsing.val || alevn = 0 || fst_symb then <:expr< $lid:n$ >> - else <:expr< P.orzero $lid:n$ $lid:entry.ename ^ "_0"$ >> - in - let p2 = - match bro with - [ DeadEnd -> kont - | _ -> parse_tree entry nlevn alevn (bro, fst_symb) act_kont kont ] - in - let p1 = act_kont True act in - parse_standard_symbol e p1 p2 (act, 0) - | Node {node = s; son = LocAct act _; brother = bro} -> - let act = magic_act act in - let p2 = parse_tree entry nlevn alevn (bro, fst_symb) act_kont kont in - let p1 = act_kont False act in - parse_symbol entry nlevn s p1 p2 (act, 0) - | Node {node = s; son = son; brother = bro} -> - let p2 = parse_tree entry nlevn alevn (bro, fst_symb) act_kont kont in - let p1 = - let err = - let txt = tree_failed entry s son in - <:expr< raise (Stream.Error $txt$) >> - in - match son with - [ Node {brother = DeadEnd} -> - parse_tree entry nlevn alevn (son, False) act_kont err - | _ -> - let p1 = - parse_tree entry nlevn alevn (son, True) act_kont - <:expr< raise Stream.Failure >> - in - <:expr< try $p1$ with [ Stream.Failure -> $err$ ] >> ] - in - parse_symbol entry nlevn s p1 p2 (find_act son) ] -and parse_symbol entry nlevn s rkont fkont ending_act = - match s with - [ Slist0 s -> - let e = <:expr< P.list0 $symbol_parser entry nlevn s$ >> in - parse_symbol_no_failure e rkont fkont ending_act - | Slist1 s -> - let e = <:expr< P.list1 $symbol_parser entry nlevn s$ >> in - parse_standard_symbol e rkont fkont ending_act - | Slist0sep s sep -> - let e = - <:expr< - P.list0sep $symbol_parser entry nlevn s$ - $symbol_parser entry nlevn sep$ >> - in - parse_symbol_no_failure e rkont fkont ending_act - | Slist1sep s sep -> - let e = - <:expr< - P.list1sep $symbol_parser entry nlevn s$ - $symbol_parser entry nlevn sep$ >> - in - parse_standard_symbol e rkont fkont ending_act - | Sopt s -> - let e = <:expr< P.option $symbol_parser entry nlevn s$ >> in - parse_symbol_no_failure e rkont fkont ending_act - | Stree tree -> - let kont = <:expr< raise Stream.Failure >> in - let act_kont _ act = gen_let_loc _loc (final_action act) in - let e = parse_tree phony_entry 0 0 (tree, True) act_kont kont in - parse_standard_symbol <:expr< fun strm__ -> $e$ >> rkont fkont ending_act - | Snterm e -> - let n = - match e.edesc with - [ Dparser _ -> e.ename - | Dlevels _ -> e.ename ^ "_0" ] - in - parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act - | Snterml e l -> - let n = e.ename ^ "_" ^ string_of_int (level_number e l) in - parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act - | Sself -> - let n = entry.ename ^ "_0" in - parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act - | Snext -> - let n = entry.ename ^ "_" ^ string_of_int nlevn in - parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act - | Stoken tok -> - let _ = - do { - if fst tok = "" && not (List.mem (snd tok) keywords.val) then - keywords.val := [snd tok :: keywords.val] - else () - } - in - let p = - let patt = nth_patt_of_act ending_act in - let p_con = String.escaped (fst tok) in - let p_prm = String.escaped (snd tok) in - if snd tok = "" then - if fst tok = "ANY" then <:patt< (_, $patt$) >> - else <:patt< ($str:p_con$, $patt$) >> - else - let p = <:patt< ($str:p_con$, $str:p_prm$) >> in - match patt with - [ <:patt< _ >> -> <:patt< ($str:p_con$, $str:p_prm$) >> - | _ -> <:patt< ($str:p_con$, ($str:p_prm$ as $patt$)) >> ] - in - <:expr< - match Stream.peek strm__ with - [ Some $p$ -> do { Stream.junk strm__; $rkont$ } - | _ -> $fkont$ ] - >> - | _ -> - parse_standard_symbol <:expr< not_impl >> rkont fkont ending_act ] -and symbol_parser entry nlevn = - fun - [ Snterm e -> - let n = e.ename ^ "_0" in - <:expr< $lid:n$ >> - | Snterml e l -> - let n = e.ename ^ "_" ^ string_of_int (level_number e l) in - <:expr< $lid:n$ >> - | Snext -> - let n = entry.ename ^ "_" ^ string_of_int nlevn in - if strict_parsing.val then <:expr< $lid:n$ >> - else - let n0 = entry.ename ^ "_0" in - <:expr< P.orzero $lid:n$ $lid:n0$ >> - | Stoken tok -> - let _ = - do { - if fst tok = "" && not (List.mem (snd tok) keywords.val) then - keywords.val := [snd tok :: keywords.val] - else () - } - in - let p_con = String.escaped (fst tok) in - let p_prm = String.escaped (snd tok) in - <:expr< P.token ($str:p_con$, $str:p_prm$) >> - | Stree tree -> - let kont = <:expr< raise Stream.Failure >> in - let act_kont _ act = final_action act in - <:expr< - fun strm__ -> - $parse_tree phony_entry 0 0 (tree, True) act_kont kont$ - >> - | _ -> - <:expr< aaa >> ] -; - -value rec start_parser_of_levels entry clevn levs = - let n = entry.ename ^ "_" ^ string_of_int clevn in - let next = entry.ename ^ "_" ^ string_of_int (clevn + 1) in - let p = <:patt< $lid:n$ >> in - match levs with - [ [] -> [Some (p, <:expr< fun strm__ -> raise Stream.Failure >>)] - | [lev :: levs] -> - let pel = start_parser_of_levels entry (succ clevn) levs in - match lev.lprefix with - [ DeadEnd -> - let ncont = - if not strict_parsing.val && clevn = 0 then - entry.ename ^ "_gen_cont" - else entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" - in - let curr = - <:expr< let a = $lid:next$ strm__ in $lid:ncont$ bp a strm__ >> - in - let curr = <:expr< let bp = Stream.count strm__ in $curr$ >> in - let e = <:expr< fun strm__ -> $curr$ >> in - let pel = if levs = [] then [] else pel in - [Some (p, e) :: pel] - | tree -> - let alevn = clevn in - let (kont, pel) = - match levs with - [ [] -> (<:expr< raise Stream.Failure >>, []) - | _ -> - let e = - match (lev.assoc, lev.lsuffix) with - [ (NonA, _) | (_, DeadEnd) -> <:expr< $lid:next$ strm__ >> - | _ -> - let ncont = - entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" - in - <:expr< - let a = $lid:next$ strm__ in - $lid:ncont$ bp a strm__ - >> ] - in - (e, pel) ] - in - let act_kont end_with_self act = - if lev.lsuffix = DeadEnd then gen_let_loc _loc (final_action act) - else - let ncont = entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" in - gen_let_loc _loc - <:expr< $lid:ncont$ bp $final_action act$ strm__ >> - in - let curr = - parse_tree entry (succ clevn) alevn (tree, True) act_kont kont - in - let curr = <:expr< let bp = Stream.count strm__ in $curr$ >> in - let e = <:expr< fun strm__ -> $curr$ >> in - [Some (p, e) :: pel] ] ] -; - -value rec continue_parser_of_levels entry clevn levs = - let n = entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" in - let p = <:patt< $lid:n$ >> in - match levs with - [ [] -> [None] - | [lev :: levs] -> - let pel = continue_parser_of_levels entry (succ clevn) levs in - match lev.lsuffix with - [ DeadEnd -> - [None :: pel] - | tree -> - let alevn = - match lev.assoc with - [ LeftA | NonA -> succ clevn - | RightA -> clevn ] - in - let (kont, pel) = - match levs with - [ [] -> (<:expr< a__ >>, []) - | _ -> (<:expr< a__ >>, pel) ] - in - let act_kont end_with_self act = - let p = last_patt_of_act act in - match lev.assoc with - [ RightA | NonA -> - <:expr< - let $p$ = a__ in - $gen_let_loc _loc (final_action act)$ - >> - | LeftA -> - let ncont = - entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" - in - gen_let_loc _loc - <:expr< - let $p$ = a__ in - $lid:ncont$ bp $final_action act$ strm__ - >> ] - in - let curr = - parse_tree entry (succ clevn) alevn (tree, True) act_kont kont - in - let e = <:expr< fun bp a__ strm__ -> $curr$ >> in - [Some (p, e) :: pel] ] ] -; - -value continue_parser_of_levels_again entry levs = - let n = entry.ename ^ "_gen_cont" in - let e = - loop <:expr< a__ >> 0 levs where rec loop var levn = - fun - [ [] -> <:expr< if x == a__ then x else $lid:n$ bp x strm__ >> - | [lev :: levs] -> - match lev.lsuffix with - [ DeadEnd -> loop var (levn + 1) levs - | _ -> - let n = entry.ename ^ "_" ^ string_of_int levn ^ "_cont" in - let rest = loop <:expr< x >> (levn + 1) levs in - <:expr< let x = $lid:n$ bp $var$ strm__ in $rest$ >> ] ] - in - (<:patt< $lid:n$ >>, <:expr< fun bp a__ strm__ -> $e$ >>) -; - -value empty_entry ename = - let p = <:patt< $lid:ename$ >> in - let e = - <:expr< - fun strm__ -> - raise (Stream.Error $str:"entry [" ^ ename ^ "] is empty"$) >> - in - [Some (p, e)] -; - -value start_parser_of_entry entry = - match entry.edesc with - [ Dlevels [] -> empty_entry entry.ename - | Dlevels elev -> start_parser_of_levels entry 0 elev - | Dparser p -> [] ] -; - -value continue_parser_of_entry entry = - match entry.edesc with - [ Dlevels elev -> continue_parser_of_levels entry 0 elev - | Dparser p -> [] ] -; - -value continue_parser_of_entry_again entry = - if strict_parsing.val then [] - else - match entry.edesc with - [ Dlevels ([_; _ :: _] as levs) -> - [continue_parser_of_levels_again entry levs] - | _ -> [] ] -; - -value rec list_alternate l1 l2 = - match (l1, l2) with - [ ([x1 :: l1], [x2 :: l2]) -> [x1; x2 :: list_alternate l1 l2] - | ([], l2) -> l2 - | (l1, []) -> l1 ] -; - -value compile_entry entry = - let pel1 = start_parser_of_entry entry in - let pel2 = continue_parser_of_entry entry in - let pel = list_alternate pel1 pel2 in - List.fold_right - (fun pe list -> - match pe with - [ Some pe -> [pe :: list] - | None -> list ]) - pel (continue_parser_of_entry_again entry) -; - -(* get all entries connected together *) - -value rec scan_tree list = - fun - [ Node {node = n; son = son; brother = bro} -> - let list = scan_symbol list n in - let list = scan_tree list son in - let list = scan_tree list bro in - list - | LocAct _ _ | DeadEnd -> list ] -and scan_symbol list = - fun - [ Snterm e -> scan_entry list e - | Snterml e l -> scan_entry list e - | Slist0 s -> scan_symbol list s - | Slist0sep s sep -> scan_symbol (scan_symbol list s) sep - | Slist1 s -> scan_symbol list s - | Slist1sep s sep -> scan_symbol (scan_symbol list s) sep - | Sopt s -> scan_symbol list s - | Stree t -> scan_tree list t - | Smeta _ _ _ | Sself | Snext | Stoken _ -> list ] -and scan_level list lev = - let list = scan_tree list lev.lsuffix in - let list = scan_tree list lev.lprefix in - list -and scan_levels list levs = List.fold_left scan_level list levs -and scan_entry list entry = - if List.memq entry list then list - else - match entry.edesc with - [ Dlevels levs -> scan_levels [entry :: list] levs - | Dparser _ -> list ] -; - -value all_entries_in_graph list entry = - List.rev (scan_entry list entry) -; - -(* main *) - -value entries = ref []; - -value rec list_mem_right_assoc x = - fun - [ [] -> False - | [(a, b) :: l] -> x = b || list_mem_right_assoc x l ] -; - -value rec expr_list = - fun - [ [] -> <:expr< [] >> - | [x :: l] -> <:expr< [$str:String.escaped x$ :: $expr_list l$] >> ] -; - -value compile () = - let _ = do { keywords.val := []; } in - let list = List.fold_left all_entries_in_graph [] entries.val in - let list = - List.filter (fun e -> List.memq e list) entries.val @ - List.filter (fun e -> not (List.memq e entries.val)) list - in - let list = - let set = ref [] in - List.fold_right - (fun entry list -> - if List.mem entry.ename set.val then - list - else do { set.val := [entry.ename :: set.val]; [entry :: list] }) - list [] - in - let pell = List.map compile_entry list in - let pel = List.flatten pell in - let si1 = <:str_item< value rec $list:pel$ >> in - let si2 = - let list = List.sort compare keywords.val in - <:str_item< - List.iter (fun kw -> P.lexer.Token.tok_using ("", kw)) - $expr_list list$ - >> - in - let loc = - let l1 = - {(Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 1 } in - (l1,l1) in - ([(si1, loc); (si2, loc)], False) -; - -Pcaml.parse_implem.val := fun _ -> compile (); - -Pcaml.add_option "-strict_parsing" (Arg.Set strict_parsing) - "Don't generate error recovering by trying continuations or first levels" -; diff --git a/camlp4/compile/compile.sh b/camlp4/compile/compile.sh deleted file mode 100755 index 3edbd636..00000000 --- a/camlp4/compile/compile.sh +++ /dev/null @@ -1,26 +0,0 @@ -#!/bin/sh -e - -ARGS= -FILES= -ENTRIES= -while test "" != "$1"; do - case $1 in - -e) - shift; - if test "$ENTRIES" != ""; then ENTRIES="$ENTRIES; "; fi - ENTRIES="$ENTRIES$1";; - *.ml*) FILES="$FILES $1";; - *) ARGS="$ARGS $1";; - esac - shift -done - -cat $FILES | sed -e 's/Pcaml.parse_i.*$//' > tmp.ml -echo "Compile.entries.val := [$ENTRIES];" >> tmp.ml -> tmp.mli -$OTOP/boot/ocamlrun$EXE $OTOP/boot/ocamlc -I $OTOP/boot -c tmp.mli -$OTOP/boot/ocamlrun$EXE ../meta/camlp4r$EXE -I ../meta pa_extend.cmo q_MLast.cmo -meta_action tmp.ml -o tmp.ppo -$OTOP/boot/ocamlrun$EXE $OTOP/boot/ocamlc -I $OTOP/boot -I ../lib -I ../camlp4 -c -impl tmp.ppo -rm tmp.ppo -> tmp.null -$OTOP/boot/ocamlrun$EXE ../camlp4/camlp4$EXE ./compile.cmo ./tmp.cmo ../etc/pr_r.cmo ../etc/pr_rp.cmo $ARGS -sep "\n\n" -impl tmp.null && rm tmp.* diff --git a/camlp4/config/.cvsignore b/camlp4/config/.cvsignore deleted file mode 100644 index f9761cda..00000000 --- a/camlp4/config/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -Makefile.cnf -Makefile diff --git a/camlp4/config/Makefile-nt.cnf b/camlp4/config/Makefile-nt.cnf deleted file mode 100644 index 379f3385..00000000 --- a/camlp4/config/Makefile-nt.cnf +++ /dev/null @@ -1,7 +0,0 @@ -EXE=.exe -OPT= -OTOP=../.. -OLIBDIR=$(OTOP)/boot -BINDIR=C:/ocaml/bin -LIBDIR=C:/ocaml/lib -MANDIR=C:/ocaml/man diff --git a/camlp4/config/Makefile.tpl b/camlp4/config/Makefile.tpl deleted file mode 100644 index 1977c7f1..00000000 --- a/camlp4/config/Makefile.tpl +++ /dev/null @@ -1,48 +0,0 @@ -# $Id: Makefile.tpl,v 1.5 2004/07/13 12:19:11 xleroy Exp $ - -# Change the value of PROFILING to prof for systematically building -# and installing profiled versions of Camlp4 libraries. Then, execute -# `make opt.opt', then `make install' in the OCaml toplevel directory -# (or in the camlp4 subdirectory). - -# Default value is noprof - -#PROFILING=prof -PROFILING=noprof - -########################################################################### - -CAMLP4_COMM=OTOP=$(OTOP) OPT=$(OPT) EXE=$(EXE) ../tools/camlp4_comm.sh -OCAMLC=@OTOP=$(OTOP) OPT=$(OPT) EXE=$(EXE) ../tools/ocamlc.sh -OCAMLOPT=@OTOP=$(OTOP) OPT=$(OPT) EXE=$(EXE) ../tools/ocamlopt.sh -OCAMLCFLAGS= -MKDIR=mkdir -p - -TEST_DIRECTORY=test `basename "$<"` = "$<" || { echo "You are not in the right directory"; exit 1; } - -.SUFFIXES: .cmx .cmo .cmi .ml .mli .p.cmx - -.mli.cmi: - @$(TEST_DIRECTORY) - @$(CAMLP4_COMM) $< -o $*.ppi - $(OCAMLC) $(OCAMLCFLAGS) -c -intf $*.ppi - rm -f $*.ppi - -.ml.cmo: - @$(TEST_DIRECTORY) - @$(CAMLP4_COMM) $< -o $*.ppo - $(OCAMLC) $(OCAMLCFLAGS) -c -impl $*.ppo - rm -f $*.ppo - -.ml.cmx: - @$(TEST_DIRECTORY) - @$(CAMLP4_COMM) $< -o $*.ppo - $(OCAMLOPT) $(OCAMLCFLAGS) -c -impl $*.ppo - rm -f $*.ppo - -.ml.p.cmx: - @$(TEST_DIRECTORY) - @$(CAMLP4_COMM) $< -o $*.ppo - $(OCAMLOPT) $(OCAMLCFLAGS) -c -p -o $*.p.cmx -impl $*.ppo - rm -f $*.ppo - diff --git a/camlp4/config/config.mpw b/camlp4/config/config.mpw deleted file mode 100644 index 62bad2ab..00000000 --- a/camlp4/config/config.mpw +++ /dev/null @@ -1,50 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id: config.mpw,v 1.1 2001/12/13 13:59:23 doligez Exp $ - -set -e P4LIBDIR "{LIBDIR}camlp4:" -set -e MANDIR "{mpw}" -set -e OTOP "`directory `:" -set -e OLIBDIR "{OTOP}boot:" - -set -e CAMLP4_COMM ::tools:camlp4_comm.mpw -set -e OCAMLC ::tools:ocamlc.mpw - -set -e defrules "¶n¶ -.cmi Ä .mli ¶n¶ - ¶{CAMLP4_COMM¶} ¶{depdir¶}¶{default¶}.mli -o ¶{depdir¶}¶{default¶}.ppi ¶n¶ - ¶{OCAMLC¶} ¶{OCAMLCFLAGS¶} -c -intf ¶{depdir¶}¶{default¶}.ppi ¶n¶ - delete -y -i ¶{depdir¶}¶{default¶}.ppi ¶n¶ -¶n¶ -.cmo Ä .ml ¶n¶ - ¶{CAMLP4_COMM¶} ¶{depdir¶}¶{default¶}.ml -o ¶{depdir¶}¶{default¶}.ppo ¶n¶ - ¶{OCAMLC¶} ¶{OCAMLCFLAGS¶} -c -impl ¶{depdir¶}¶{default¶}.ppo ¶n¶ - delete -y -i ¶{depdir¶}¶{default¶}.ppo ¶n¶ -¶n¶ -.cmi Ä .cmo ¶n¶ - set status 0 ¶n¶ -¶n¶ -clean ÄÄ ¶n¶ - begin ¶n¶ - delete -i Å.cm[ioa] || set status 0 ¶n¶ - delete -i Å.pp[io] || set status 0 ¶n¶ - delete -i Å.bak || set status 0 ¶n¶ - end ³ dev:null ¶n¶ -" - -set -e dependrule "¶n¶ -depend Ķn¶ - duplicate -y Makefile.Mac.depend Makefile.Mac.depend.bak || set status 0¶n¶ - for i in Å.mliÇ0,1ȶn¶ - ::tools:apply.mpw pr_depend.cmo -- ¶{INCLUDES¶} ¶{i¶}¶n¶ - end > Makefile.Mac.depend¶n¶ -" diff --git a/camlp4/config/configure_batch b/camlp4/config/configure_batch deleted file mode 100755 index 0fc26df7..00000000 --- a/camlp4/config/configure_batch +++ /dev/null @@ -1,122 +0,0 @@ -#! /bin/sh -# $Id: configure_batch,v 1.9 2004/08/20 17:04:34 doligez Exp $ - -prefix=/usr/local -bindir='' -libdir='' -mandir='' -ocaml_top=../ocaml_stuff - -# Parse command-line arguments - -while : ; do - case "$1" in - "") break;; - -prefix|--prefix) - prefix=$2; shift;; - -bindir|--bindir) - bindir=$2; shift;; - -libdir|--libdir) - libdir=$2; shift;; - -mandir|--mandir) - mandir=$2; shift;; - -ocaml-top) - ocaml_top=$2; shift;; - *) echo "Unknown option \"$1\"." 1>&2; exit 2;; - esac - shift -done - -# Sanity checks - -case "$prefix" in - /*) ;; - *) echo "The -prefix directory must be absolute." 1>&2; exit 2;; -esac -case "$bindir" in - /*) ;; - "") ;; - *) echo "The -bindir directory must be absolute." 1>&2; exit 2;; -esac -case "$libdir" in - /*) ;; - "") ;; - *) echo "The -libdir directory must be absolute." 1>&2; exit 2;; -esac -case "$mandir" in - /*) ;; - "") ;; - *) echo "The -mandir directory must be absolute." 1>&2; exit 2;; -esac - -# Generate the files - -rm -f Makefile.cnf -touch Makefile.cnf - -# Check Ocaml - -for i in utils parsing otherlibs/dynlink; do - if test ! -d "$ocaml_top/$i"; then - echo "Bad value $ocaml_top for option -ocaml-top" - echo "There is no directory $ocaml_top/$i" - echo "Configuration script failed" - exit 1 - fi -done - -echo "EXE=$EXE" >> Makefile.cnf -echo "O=o" >> Makefile.cnf -echo "A=a" >> Makefile.cnf -echo "OPT=" >> Makefile.cnf -echo "OTOP=$ocaml_top" >> Makefile.cnf -if test -r ../../config/auto-aux/Makefile; then - grep '^RANLIB' ../../config/auto-aux/Makefile >> Makefile.cnf -elif test -r ../../config/Makefile; then - grep '^RANLIB' ../../config/Makefile >> Makefile.cnf -else - echo "Could not read OCaml config Makefile" - echo "Configuration script failed!" - exit 1 -fi - -if test "$ocaml_top" = "../ocaml_stuff"; then - if ocamlc -v >/dev/null 2>&1; then - : - else - echo "You need the command ocamlc accessible in the path!" - echo "Configuration script failed!" - exit 1 - fi - OLIBDIR=`ocamlc -where` - echo "OLIBDIR=$OLIBDIR" >> Makefile.cnf -else - echo "OLIBDIR=\$(OTOP)/boot" >> Makefile.cnf -fi - -# Where to install - -echo "PREFIX=$prefix" >> Makefile.cnf -case "$bindir" in - "") echo 'BINDIR=$(PREFIX)/bin' >> Makefile.cnf - bindir="$prefix/bin";; - *) echo "BINDIR=$bindir" >> Makefile.cnf;; -esac -case "$libdir" in - "") echo 'LIBDIR=$(PREFIX)/lib/camlp4' >> Makefile.cnf - libdir="$prefix/lib/camlp4";; - *) echo "LIBDIR=$libdir" >> Makefile.cnf;; -esac -case "$mandir" in - "") echo 'MANDIR=$(PREFIX)/man/man1' >> Makefile.cnf - mandir="$prefix/man/man1";; - *) echo "MANDIR=$mandir" >> Makefile.cnf;; -esac - -rm -f Makefile -cat Makefile.tpl > Makefile -cat Makefile.cnf >> Makefile - -echo "Resulting configuration file (Makefile.cnf):" -echo -cat Makefile.cnf diff --git a/camlp4/etc/.cvsignore b/camlp4/etc/.cvsignore deleted file mode 100644 index 50d8a8ea..00000000 --- a/camlp4/etc/.cvsignore +++ /dev/null @@ -1,7 +0,0 @@ -*.cm[oia] -camlp4o -camlp4sch -camlp4o.opt -version.sh -mkcamlp4.sh -mkcamlp4.mpw diff --git a/camlp4/etc/.depend b/camlp4/etc/.depend deleted file mode 100644 index f7c1e454..00000000 --- a/camlp4/etc/.depend +++ /dev/null @@ -1,45 +0,0 @@ -parserify.cmi: ../camlp4/mLast.cmi -pa_extfold.cmo: ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pa_extfold.cmx: ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -pa_extfun.cmo: ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pa_extfun.cmx: ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -pa_fstream.cmo: ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pa_fstream.cmx: ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -pa_ifdef.cmo: ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pa_ifdef.cmx: ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -pa_o.cmo: ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pa_o.cmx: ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -pa_oop.cmo: ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pa_oop.cmx: ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -pa_op.cmo: ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pa_op.cmx: ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -pa_ru.cmo: ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pa_ru.cmx: ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -parserify.cmo: ../camlp4/mLast.cmi parserify.cmi -parserify.cmx: ../camlp4/mLast.cmi parserify.cmi -pr_depend.cmo: ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pr_depend.cmx: ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -pr_extend.cmo: ../camlp4/spretty.cmi ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pr_extend.cmx: ../camlp4/spretty.cmx ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -pr_extfun.cmo: ../camlp4/spretty.cmi ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pr_extfun.cmx: ../camlp4/spretty.cmx ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -pr_null.cmo: ../camlp4/pcaml.cmi -pr_null.cmx: ../camlp4/pcaml.cmx -pr_o.cmo: ../camlp4/spretty.cmi ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pr_o.cmx: ../camlp4/spretty.cmx ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -pr_op.cmo: ../camlp4/spretty.cmi ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pr_op.cmx: ../camlp4/spretty.cmx ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -pr_op_main.cmo: ../camlp4/spretty.cmi ../camlp4/pcaml.cmi parserify.cmi \ - ../camlp4/mLast.cmi -pr_op_main.cmx: ../camlp4/spretty.cmx ../camlp4/pcaml.cmx parserify.cmx \ - ../camlp4/mLast.cmi -pr_r.cmo: ../camlp4/spretty.cmi ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pr_r.cmx: ../camlp4/spretty.cmx ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -pr_rp.cmo: ../camlp4/spretty.cmi ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pr_rp.cmx: ../camlp4/spretty.cmx ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -pr_rp_main.cmo: ../camlp4/spretty.cmi ../camlp4/pcaml.cmi parserify.cmi \ - ../camlp4/mLast.cmi -pr_rp_main.cmx: ../camlp4/spretty.cmx ../camlp4/pcaml.cmx parserify.cmx \ - ../camlp4/mLast.cmi -q_phony.cmo: ../camlp4/quotation.cmi ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -q_phony.cmx: ../camlp4/quotation.cmx ../camlp4/pcaml.cmx ../camlp4/mLast.cmi diff --git a/camlp4/etc/Makefile b/camlp4/etc/Makefile deleted file mode 100644 index 7c030b5f..00000000 --- a/camlp4/etc/Makefile +++ /dev/null @@ -1,97 +0,0 @@ -# $Id: Makefile,v 1.24 2004/11/30 18:57:03 doligez Exp $ - -include ../config/Makefile - -INCLUDES=-I ../camlp4 -I ../boot -I $(OTOP)/lex -OCAMLCFLAGS=-warn-error A $(INCLUDES) -OBJS=q_phony.cmo pa_o.cmo pa_op.cmo pa_oop.cmo pa_ru.cmo pa_extfold.cmo pa_extfun.cmo pa_fstream.cmo pa_ifdef.cmo pr_r.cmo pr_rp.cmo pr_o.cmo pr_op.cmo pr_extend.cmo pr_extfun.cmo pr_null.cmo pr_depend.cmo - -OBJSX=$(OBJS:.cmo=.cmx) -INTF=pa_o.cmi -CAMLP4OM=pa_o.cmo pa_op.cmo ../meta/pr_dump.cmo -CAMLP4OMX=$(CAMLP4OM:.cmo=.cmx) -SHELL=/bin/sh -COUT=$(OBJS) camlp4o$(EXE) -COPT=$(OBJSX) camlp4o.opt - -all: $(COUT) mkcamlp4.sh -opt: $(COPT) - -pr_rp.cmo: parserify.cmo pr_rp_main.cmo - $(OCAMLC) parserify.cmo pr_rp_main.cmo -a -o $@ - -pr_op.cmo: parserify.cmo pr_op_main.cmo - $(OCAMLC) parserify.cmo pr_op_main.cmo -a -o $@ - -pr_rp.cmx: parserify.cmx pr_rp_main.cmx - $(OCAMLOPT) parserify.cmx pr_rp_main.cmx -a -o pr_rp.cmxa - mv pr_rp.cmxa pr_rp.cmx - mv pr_rp.$(A) pr_rp.$(O) - -pr_op.cmx: parserify.cmx pr_op_main.cmx - $(OCAMLOPT) parserify.cmx pr_op_main.cmx -a -o pr_op.cmxa - mv pr_op.cmxa pr_op.cmx - mv pr_op.$(A) pr_op.$(O) - -camlp4o$(EXE): ../camlp4/camlp4$(EXE) $(CAMLP4OM) - rm -f camlp4o$(EXE) - cd ../camlp4; $(MAKE) CAMLP4=../etc/camlp4o$(EXE) CAMLP4M="-I ../etc $(CAMLP4OM)" - -camlp4o.opt: $(CAMLP4OMX) - rm -f camlp4o.opt - cd ../camlp4; $(MAKE) optp4 CAMLP4OPT=../etc/camlp4o.opt CAMLP4M="-I ../etc $(CAMLP4OMX)" - -mkcamlp4.sh: mkcamlp4.sh.tpl version.sh - sed -e "s!LIBDIR!$(LIBDIR)!g" -e "/define VERSION/r version.sh" \ - mkcamlp4.sh.tpl > mkcamlp4.sh - -version.sh : $(OTOP)/stdlib/sys.ml - sed -n -e 's/;;//' \ - -e '/let *ocaml_version *= */s//VERSION=/p' \ - <$(OTOP)/stdlib/sys.ml >version.sh - -bootstrap_l: - ../boot/camlp4 ./pa_$Lr.cmo ./q_phony.cmo -I ../boot pa_extend.cmo ./pr_r.cmo ./pr_extend.cmo ./pr_rp.cmo pa_$L.ml > tmp - mv pa_$Lr.ml pa_$Lr.ml.old - sed -e 's/^;; \(.*\)$$/(* \1 *)/' -e 's/^; \(.*\)$$/(* \1 *)/' -e 's|./pa_$Lr.cmo|pa_r.cmo pa_rp.cmo|' -e 's/$$Id.*\$$/File generated by pretty print; do not edit!/' tmp > pa_$Lr.ml - rm -f tmp - -compare_l: - ../boot/camlp4 ./pa_$Lr.cmo ./q_phony.cmo -I ../boot pa_extend.cmo ./pr_r.cmo ./pr_extend.cmo ./pr_rp.cmo pa_$L.ml | sed -e 's/^;; \(.*\)$$/(* \1 *)/' -e 's/^; \(.*\)$$/(* \1 *)/' -e 's|./pa_$Lr.cmo|pa_r.cmo pa_rp.cmo|' -e 's/$$Id.*\$$/File generated by pretty print; do not edit!/' | diff -c pa_$Lr.ml - - -clean:: - rm -f *.cm* *.pp[io] *.$(O) *.bak .*.bak *.out *.opt - rm -f mkcamlp4.sh camlp4o$(EXE) camlp4sch$(EXE) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -get_promote: - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" - cp $(OBJS) "$(LIBDIR)/camlp4/." - cp $(INTF) "$(LIBDIR)/camlp4/." - cp camlp4o$(EXE) "$(BINDIR)/." - if test -f camlp4o.opt; then \ - cp camlp4o.opt "$(BINDIR)/camlp4o.opt$(EXE)"; \ - cp $(OBJSX) "$(LIBDIR)/camlp4/."; \ - for file in $(OBJSX); do \ - cp "`echo $$file | sed -e 's/\.cmx$$/.$(O)/'`" "$(LIBDIR)/camlp4/."; \ - done ; \ - fi - cp mkcamlp4.sh "$(BINDIR)/mkcamlp4" - chmod a+x "$(BINDIR)/mkcamlp4" - -pr_extend.cmo: pa_extfun.cmo -pr_o.cmo: pa_extfun.cmo -pr_op.cmo: pa_extfun.cmo -pr_r.cmo: pa_extfun.cmo -pr_rp.cmo: pa_extfun.cmo - -include .depend diff --git a/camlp4/etc/mkcamlp4.mpw.tpl b/camlp4/etc/mkcamlp4.mpw.tpl deleted file mode 100644 index 9877ff2c..00000000 --- a/camlp4/etc/mkcamlp4.mpw.tpl +++ /dev/null @@ -1,33 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id: mkcamlp4.mpw.tpl,v 1.2 2003/07/10 12:28:18 michel Exp $ - -set OLIB OLIBDIR -set LIB LIBDIR - -set INTERFACES "" -set OPTS "" -set INCL "-I :" - -loop - exit if "{1}" == "" - if "{1}" == "-I" - set INCL "{INCL} -I `quote "{2}"`" - shift - else if "{1}" =~ /([Â:])¨0([Â:]*)¨1.cmi/ - set first `echo {¨0} | translate a-z A-Z` - set INTERFACES "{INTERFACES} {first}{¨1}" - else - set OPTS "{OPTS} `quote "{1}"`" - end - shift -end diff --git a/camlp4/etc/mkcamlp4.sh.tpl b/camlp4/etc/mkcamlp4.sh.tpl deleted file mode 100755 index cb33c432..00000000 --- a/camlp4/etc/mkcamlp4.sh.tpl +++ /dev/null @@ -1,34 +0,0 @@ -#!/bin/sh -# $Id: mkcamlp4.sh.tpl,v 1.8.4.1 2006/01/03 17:12:25 mauny Exp $ - -OLIB="`ocamlc -where`" -LIB="LIBDIR/camlp4" - -# automatically define VERSION here: - -INTERFACES= -OPTS= -INCL="-I ." -while test "" != "$1"; do - case "$1" in - -I) INCL="$INCL -I $2"; shift;; - -version) echo "mkcamlp4, version $VERSION"; exit;; - [a-zA-Z]*.cmi) - j=`basename "$1" .cmi` - first="`expr "$j" : '\(.\)' | tr 'a-z' 'A-Z'`" - rest="`expr "$j" : '.\(.*\)'`" - INTERFACES="$INTERFACES $first$rest" - ;; - *) OPTS="$OPTS $1";; - esac - shift -done - -CRC=crc_$$ -set -e -trap 'rm -f $CRC.ml $CRC.cmi $CRC.cmo' 0 2 -$OLIB/extract_crc -I $OLIB $INCL $INTERFACES > $CRC.ml -echo "let _ = Dynlink.add_available_units crc_unit_list" >> $CRC.ml -ocamlc -I $LIB odyl.cma camlp4.cma $CRC.ml $INCL $OPTS odyl.cmo -linkall -rm -f $CRC.ml $CRC.cmi $CRC.cmo - diff --git a/camlp4/etc/pa_extfold.ml b/camlp4/etc/pa_extfold.ml deleted file mode 100644 index 32c3df11..00000000 --- a/camlp4/etc/pa_extfold.ml +++ /dev/null @@ -1,42 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(* $Id: pa_extfold.ml,v 1.2 2004/11/17 09:07:56 mauny Exp $ *) - -open Pcaml; -open Pa_extend; - -value sfold _loc n foldfun f e s = - let styp = STquo _loc (new_type_var ()) in - let e = <:expr< Extfold.$lid:foldfun$ $f$ $e$ >> in - let t = STapp _loc (STapp _loc (STtyp <:ctyp< Extfold.t _ >>) s.styp) styp in - {used = s.used; text = TXmeta _loc n [s.text] e t; styp = styp} -; - -value sfoldsep _loc n foldfun f e s sep = - let styp = STquo _loc (new_type_var ()) in - let e = <:expr< Extfold.$lid:foldfun$ $f$ $e$ >> in - let t = - STapp _loc (STapp _loc (STtyp <:ctyp< Extfold.tsep _ >>) s.styp) styp - in - {used = s.used @ sep.used; text = TXmeta _loc n [s.text; sep.text] e t; - styp = styp} -; - -EXTEND - GLOBAL: symbol; - symbol: LEVEL "top" - [ [ UIDENT "FOLD0"; f = simple_expr; e = simple_expr; s = SELF -> - sfold _loc "FOLD0" "sfold0" f e s - | UIDENT "FOLD1"; f = simple_expr; e = simple_expr; s = SELF -> - sfold _loc "FOLD1" "sfold1" f e s - | UIDENT "FOLD0"; f = simple_expr; e = simple_expr; s = SELF; - UIDENT "SEP"; sep = symbol -> - sfoldsep _loc "FOLD0 SEP" "sfold0sep" f e s sep - | UIDENT "FOLD1"; f = simple_expr; e = simple_expr; s = SELF; - UIDENT "SEP"; sep = symbol -> - sfoldsep _loc "FOLD1 SEP" "sfold1sep" f e s sep ] ] - ; - simple_expr: - [ [ i = LIDENT -> <:expr< $lid:i$ >> - | "("; e = expr; ")" -> e ] ] - ; -END; diff --git a/camlp4/etc/pa_extfun.ml b/camlp4/etc/pa_extfun.ml deleted file mode 100644 index 1803c1ec..00000000 --- a/camlp4/etc/pa_extfun.ml +++ /dev/null @@ -1,123 +0,0 @@ -(* camlp4r q_MLast.cmo pa_extend.cmo *) -(* $Id: pa_extfun.ml,v 1.3 2004/11/17 09:07:56 mauny Exp $ *) - -open Pcaml; - -value not_impl name x = - let desc = - if Obj.is_block (Obj.repr x) then - "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) - else "int_val = " ^ string_of_int (Obj.magic x) - in - do { - print_newline (); failwith ("pa_extfun: not impl " ^ name ^ " " ^ desc) - } -; - -value rec mexpr p = - let _loc = MLast.loc_of_patt p in - match p with - [ <:patt< $p1$ $p2$ >> -> - loop <:expr< [$mexpr p2$] >> p1 where rec loop el = - fun - [ <:patt< $p1$ $p2$ >> -> loop <:expr< [$mexpr p2$ :: $el$] >> p1 - | p -> <:expr< Extfun.Eapp [$mexpr p$ :: $el$] >> ] - | <:patt< $p1$ . $p2$ >> -> - loop <:expr< [$mexpr p2$] >> p1 where rec loop el = - fun - [ <:patt< $p1$ . $p2$ >> -> loop <:expr< [$mexpr p2$ :: $el$] >> p1 - | p -> <:expr< Extfun.Eacc [$mexpr p$ :: $el$] >> ] - | <:patt< ($list:pl$) >> -> <:expr< Extfun.Etup $mexpr_list _loc pl$ >> - | <:patt< $uid:id$ >> -> <:expr< Extfun.Econ $str:id$ >> - | <:patt< ` $id$ >> -> <:expr< Extfun.Econ $str:id$ >> - | <:patt< $int:s$ >> -> <:expr< Extfun.Eint $str:s$ >> - | <:patt< $str:s$ >> -> <:expr< Extfun.Estr $str:s$ >> - | <:patt< ($p1$ as $_$) >> -> mexpr p1 - | <:patt< $lid:_$ >> -> <:expr< Extfun.Evar () >> - | <:patt< _ >> -> <:expr< Extfun.Evar () >> - | <:patt< $p1$ | $p2$ >> -> - Stdpp.raise_with_loc _loc (Failure "or patterns not allowed in extfun") - | p -> not_impl "mexpr" p ] -and mexpr_list _loc = - fun - [ [] -> <:expr< [] >> - | [e :: el] -> <:expr< [$mexpr e$ :: $mexpr_list _loc el$] >> ] -; - -value rec catch_any = - fun - [ <:patt< $uid:id$ >> -> False - | <:patt< ` $_$ >> -> False - | <:patt< $lid:_$ >> -> True - | <:patt< _ >> -> True - | <:patt< ($list:pl$) >> -> List.for_all catch_any pl - | <:patt< $p1$ $p2$ >> -> False - | <:patt< $p1$ | $p2$ >> -> False - | <:patt< $int:_$ >> -> False - | <:patt< $str:_$ >> -> False - | <:patt< ($p1$ as $_$) >> -> catch_any p1 - | p -> not_impl "catch_any" p ] -; - -value conv (p, wo, e) = - let tst = mexpr p in - let _loc = (fst (MLast.loc_of_patt p), snd (MLast.loc_of_expr e)) in - let e = - if wo = None && catch_any p then <:expr< fun $p$ -> Some $e$ >> - else <:expr< fun [ $p$ $when:wo$ -> Some $e$ | _ -> None ] >> - in - let has_when = - match wo with - [ Some _ -> <:expr< True >> - | None -> <:expr< False >> ] - in - <:expr< ($tst$, $has_when$, $e$) >> -; - -value rec conv_list tl = - fun - [ [pe :: pel] -> - let _loc = MLast.loc_of_expr tl in - <:expr< [$conv pe$ :: $conv_list tl pel$] >> - | [] -> tl ] -; - -value rec split_or = - fun - [ [(<:patt< $p1$ | $p2$ >>, wo, e) :: pel] -> - split_or [(p1, wo, e); (p2, wo, e) :: pel] - | [(<:patt< ($p1$ | $p2$ as $p$) >>, wo, e) :: pel] -> - let p1 = - let _loc = MLast.loc_of_patt p1 in - <:patt< ($p1$ as $p$) >> - in - let p2 = - let _loc = MLast.loc_of_patt p2 in - <:patt< ($p2$ as $p$) >> - in - split_or [(p1, wo, e); (p2, wo, e) :: pel] - | [pe :: pel] -> [pe :: split_or pel] - | [] -> [] ] -; - -EXTEND - GLOBAL: expr; - expr: LEVEL "top" - [ [ "extfun"; e = SELF; "with"; "["; list = match_case_list; "]" -> - <:expr< Extfun.extend $e$ $list$ >> ] ] - ; - match_case_list: - [ [ pel = LIST0 match_case SEP "|" -> - conv_list <:expr< [] >> (split_or pel) ] ] - ; - match_case: - [ [ p = patt; aso = OPT [ "as"; p = patt -> p ]; - w = OPT [ "when"; e = expr -> e ]; "->"; e = expr -> - let p = - match aso with - [ Some p2 -> <:patt< ($p$ as $p2$) >> - | _ -> p ] - in - (p, w, e) ] ] - ; -END; diff --git a/camlp4/etc/pa_fstream.ml b/camlp4/etc/pa_fstream.ml deleted file mode 100644 index 2f916cd2..00000000 --- a/camlp4/etc/pa_fstream.ml +++ /dev/null @@ -1,163 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(* $Id: pa_fstream.ml,v 1.4 2004/11/17 09:07:56 mauny Exp $ *) - -open Pcaml; - -type spat_comp = - [ SpTrm of MLast.loc and MLast.patt and option MLast.expr - | SpNtr of MLast.loc and MLast.patt and MLast.expr - | SpStr of MLast.loc and MLast.patt ] -; -type sexp_comp = - [ SeTrm of MLast.loc and MLast.expr - | SeNtr of MLast.loc and MLast.expr ] -; - -(* parsers *) - -value strm_n = "strm__"; -value next_fun _loc = <:expr< Fstream.next >>; - -value rec pattern_eq_expression p e = - match (p, e) with - [ (<:patt< $lid:a$ >>, <:expr< $lid:b$ >>) -> a = b - | (<:patt< $uid:a$ >>, <:expr< $uid:b$ >>) -> a = b - | (<:patt< $p1$ $p2$ >>, <:expr< $e1$ $e2$ >>) -> - pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2 - | (<:patt< ($list:pl$) >>, <:expr< ($list:el$) >>) -> - loop pl el where rec loop pl el = - match (pl, el) with - [ ([p :: pl], [e :: el]) -> - pattern_eq_expression p e && loop pl el - | ([], []) -> True - | _ -> False ] - | _ -> False ] -; - -value stream_pattern_component skont = - fun - [ SpTrm _loc p wo -> - let p = <:patt< Some ($p$, $lid:strm_n$) >> in - if wo = None && pattern_eq_expression p skont then - <:expr< $next_fun _loc$ $lid:strm_n$ >> - else - <:expr< match $next_fun _loc$ $lid:strm_n$ with - [ $p$ $when:wo$ -> $skont$ - | _ -> None ] >> - | SpNtr _loc p e -> - let p = <:patt< Some ($p$, $lid:strm_n$) >> in - if pattern_eq_expression p skont then <:expr< $e$ $lid:strm_n$ >> - else - <:expr< match $e$ $lid:strm_n$ with - [ $p$ -> $skont$ - | _ -> None ] >> - | SpStr _loc p -> - <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ] -; - -value rec stream_pattern _loc epo e = - fun - [ [] -> - let e = - match epo with - [ Some ep -> <:expr< let $ep$ = Fstream.count $lid:strm_n$ in $e$ >> - | None -> e ] - in - <:expr< Some ($e$, $lid:strm_n$) >> - | [spc :: spcl] -> - let skont = stream_pattern _loc epo e spcl in - stream_pattern_component skont spc ] -; - -value rec parser_cases _loc = - fun - [ [] -> <:expr< None >> - | [(spcl, epo, e) :: spel] -> - match parser_cases _loc spel with - [ <:expr< None >> -> stream_pattern _loc epo e spcl - | pc -> - <:expr< match $stream_pattern _loc epo e spcl$ with - [ Some _ as x -> x - | None -> $pc$ ] >> ] ] -; - -value cparser_match _loc me bpo pc = - let pc = parser_cases _loc pc in - let e = - match bpo with - [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >> - | None -> pc ] - in - <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >> -; - -value cparser _loc bpo pc = - let e = parser_cases _loc pc in - let e = - match bpo with - [ Some bp -> <:expr< let $bp$ = Fstream.count $lid:strm_n$ in $e$ >> - | None -> e ] - in - let p = <:patt< ($lid:strm_n$ : Fstream.t _) >> in <:expr< fun $p$ -> $e$ >> -; - -(* streams *) - -value slazy _loc x = <:expr< fun () -> $x$ >>; - -value rec cstream _loc = - fun - [ [] -> <:expr< Fstream.nil >> - | [SeTrm _loc e :: sel] -> - let e2 = cstream _loc sel in - let x = <:expr< Fstream.cons $e$ $e2$ >> in - <:expr< Fstream.flazy $slazy _loc x$ >> - | [SeNtr _loc e] -> - e - | [SeNtr _loc e :: sel] -> - let e2 = cstream _loc sel in - let x = <:expr< Fstream.app $e$ $e2$ >> in - <:expr< Fstream.flazy $slazy _loc x$ >> ] -; - -EXTEND - GLOBAL: expr; - expr: LEVEL "top" - [ [ "fparser"; po = OPT ipatt; "["; pcl = LIST0 parser_case SEP "|"; "]" -> - <:expr< $cparser _loc po pcl$ >> - | "fparser"; po = OPT ipatt; pc = parser_case -> - <:expr< $cparser _loc po [pc]$ >> - | "match"; e = SELF; "with"; "parser"; po = OPT ipatt; "["; - pcl = LIST0 parser_case SEP "|"; "]" -> - <:expr< $cparser_match _loc e po pcl$ >> - | "match"; e = SELF; "with"; "parser"; po = OPT ipatt; - pc = parser_case -> - <:expr< $cparser_match _loc e po [pc]$ >> ] ] - ; - parser_case: - [ [ "[:"; sp = stream_patt; ":]"; po = OPT ipatt; "->"; e = expr -> - (sp, po, e) ] ] - ; - stream_patt: - [ [ spc = stream_patt_comp -> [spc] - | spc = stream_patt_comp; ";"; sp = LIST1 stream_patt_comp SEP ";" -> - [spc :: sp] - | -> [] ] ] - ; - stream_patt_comp: - [ [ "`"; p = patt; eo = OPT [ "when"; e = expr -> e ] -> SpTrm _loc p eo - | p = patt; "="; e = expr -> SpNtr _loc p e - | p = patt -> SpStr _loc p ] ] - ; - ipatt: - [ [ i = LIDENT -> <:patt< $lid:i$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "fstream"; "[:"; se = LIST0 stream_expr_comp SEP ";"; ":]" -> - <:expr< $cstream _loc se$ >> ] ] - ; - stream_expr_comp: - [ [ "`"; e = expr -> SeTrm _loc e - | e = expr -> SeNtr _loc e ] ] - ; -END; diff --git a/camlp4/etc/pa_ifdef.ml b/camlp4/etc/pa_ifdef.ml deleted file mode 100644 index ea08cf56..00000000 --- a/camlp4/etc/pa_ifdef.ml +++ /dev/null @@ -1,91 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(* $Id: pa_ifdef.ml,v 1.2 2004/07/13 12:19:11 xleroy Exp $ *) - -(* This module is deprecated since version 3.07; use pa_macro.ml instead *) - -value _ = - prerr_endline "Warning: pa_ifdef is deprecated since OCaml 3.07. Use pa_macro instead." -; - -type item_or_def 'a = - [ SdStr of 'a | SdDef of string | SdUnd of string | SdNop ] -; - -value list_remove x l = - List.fold_right (fun e l -> if e = x then l else [e :: l]) l [] -; - -value defined = ref ["OCAML_308"; "OCAML_307"; "OCAML_305"; "CAMLP4_300"; "NEWSEQ"]; -value define x = defined.val := [x :: defined.val]; -value undef x = defined.val := list_remove x defined.val; - -EXTEND - GLOBAL: Pcaml.expr Pcaml.str_item Pcaml.sig_item; - Pcaml.expr: LEVEL "top" - [ [ "ifdef"; c = UIDENT; "then"; e1 = Pcaml.expr; "else"; - e2 = Pcaml.expr -> - if List.mem c defined.val then e1 else e2 - | "ifndef"; c = UIDENT; "then"; e1 = Pcaml.expr; "else"; - e2 = Pcaml.expr -> - if List.mem c defined.val then e2 else e1 ] ] - ; - Pcaml.str_item: FIRST - [ [ x = def_undef_str -> - match x with - [ SdStr si -> si - | SdDef x -> do { define x; <:str_item< declare end >> } - | SdUnd x -> do { undef x; <:str_item< declare end >> } - | SdNop -> <:str_item< declare end >> ] ] ] - ; - def_undef_str: - [ [ "ifdef"; c = UIDENT; "then"; e1 = str_item_def_undef; - "else"; e2 = str_item_def_undef -> - if List.mem c defined.val then e1 else e2 - | "ifdef"; c = UIDENT; "then"; e1 = str_item_def_undef -> - if List.mem c defined.val then e1 else SdNop - | "ifndef"; c = UIDENT; "then"; e1 = str_item_def_undef; - "else"; e2 = str_item_def_undef -> - if List.mem c defined.val then e2 else e1 - | "ifndef"; c = UIDENT; "then"; e1 = str_item_def_undef -> - if List.mem c defined.val then SdNop else e1 - | "define"; c = UIDENT -> SdDef c - | "undef"; c = UIDENT -> SdUnd c ] ] - ; - str_item_def_undef: - [ [ d = def_undef_str -> d - | si = Pcaml.str_item -> SdStr si ] ] - ; - Pcaml.sig_item: FIRST - [ [ x = def_undef_sig -> - match x with - [ SdStr si -> si - | SdDef x -> do { define x; <:sig_item< declare end >> } - | SdUnd x -> do { undef x; <:sig_item< declare end >> } - | SdNop -> <:sig_item< declare end >> ] ] ] - ; - def_undef_sig: - [ [ "ifdef"; c = UIDENT; "then"; e1 = sig_item_def_undef; - "else"; e2 = sig_item_def_undef -> - if List.mem c defined.val then e1 else e2 - | "ifdef"; c = UIDENT; "then"; e1 = sig_item_def_undef -> - if List.mem c defined.val then e1 else SdNop - | "ifndef"; c = UIDENT; "then"; e1 = sig_item_def_undef; - "else"; e2 = sig_item_def_undef -> - if List.mem c defined.val then e2 else e1 - | "ifndef"; c = UIDENT; "then"; e1 = sig_item_def_undef -> - if List.mem c defined.val then SdNop else e1 - | "define"; c = UIDENT -> SdDef c - | "undef"; c = UIDENT -> SdUnd c ] ] - ; - sig_item_def_undef: - [ [ d = def_undef_sig -> d - | si = Pcaml.sig_item -> SdStr si ] ] - ; -END; - -Pcaml.add_option "-D" (Arg.String define) - " Define for ifdef instruction." -; -Pcaml.add_option "-U" (Arg.String undef) - " Undefine for ifdef instruction." -; diff --git a/camlp4/etc/pa_o.ml b/camlp4/etc/pa_o.ml deleted file mode 100644 index ea77f9d9..00000000 --- a/camlp4/etc/pa_o.ml +++ /dev/null @@ -1,1307 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: pa_o.ml,v 1.66 2005/06/29 04:11:26 garrigue Exp $ *) - -open Stdpp; -open Pcaml; - -Pcaml.syntax_name.val := "OCaml"; -Pcaml.no_constructors_arity.val := True; - -do { - let odfa = Plexer.dollar_for_antiquotation.val in - Plexer.dollar_for_antiquotation.val := False; - let (lexer, pos) = Plexer.make_lexer () in - Pcaml.position.val := pos; - Grammar.Unsafe.gram_reinit gram lexer; - Plexer.dollar_for_antiquotation.val := odfa; - Grammar.Unsafe.clear_entry interf; - Grammar.Unsafe.clear_entry implem; - Grammar.Unsafe.clear_entry top_phrase; - Grammar.Unsafe.clear_entry use_file; - Grammar.Unsafe.clear_entry module_type; - Grammar.Unsafe.clear_entry module_expr; - Grammar.Unsafe.clear_entry sig_item; - Grammar.Unsafe.clear_entry str_item; - Grammar.Unsafe.clear_entry expr; - Grammar.Unsafe.clear_entry patt; - Grammar.Unsafe.clear_entry ctyp; - Grammar.Unsafe.clear_entry let_binding; - Grammar.Unsafe.clear_entry type_declaration; - Grammar.Unsafe.clear_entry class_type; - Grammar.Unsafe.clear_entry class_expr; - Grammar.Unsafe.clear_entry class_sig_item; - Grammar.Unsafe.clear_entry class_str_item -}; - -Pcaml.parse_interf.val := Grammar.Entry.parse interf; -Pcaml.parse_implem.val := Grammar.Entry.parse implem; - -value o2b = - fun - [ Some _ -> True - | None -> False ] -; - -value mkexprident _loc ids = match ids with - [ [] -> Stdpp.raise_with_loc _loc (Stream.Error "illegal long identifier") - | [ id :: ids ] -> - let rec loop m = fun - [ [ id :: ids ] -> loop <:expr< $m$ . $id$ >> ids - | [] -> m ] - in - loop id ids ] -; - -value mkumin _loc f arg = - match (f, arg) with - [ ("-", <:expr< $int:n$ >>) when int_of_string n > 0 -> - let n = "-" ^ n in - <:expr< $int:n$ >> - | ("-", MLast.ExInt32 loc n) when (Int32.of_string n) > 0l -> - MLast.ExInt32 loc ("-" ^ n) - | ("-", MLast.ExInt64 loc n) when (Int64.of_string n) > 0L -> - MLast.ExInt64 loc ("-" ^ n) - | ("-", MLast.ExNativeInt loc n) when (Nativeint.of_string n) > 0n -> - MLast.ExNativeInt loc ("-" ^ n) - | (_, <:expr< $flo:n$ >>) when float_of_string n > 0.0 -> - let n = "-" ^ n in - <:expr< $flo:n$ >> - | _ -> - let f = "~" ^ f in - <:expr< $lid:f$ $arg$ >> ] -; - - -value mklistexp _loc last = - loop True where rec loop top = - fun - [ [] -> - match last with - [ Some e -> e - | None -> <:expr< [] >> ] - | [e1 :: el] -> - let _loc = if top then _loc else (fst (MLast.loc_of_expr e1), snd _loc) in - <:expr< [$e1$ :: $loop False el$] >> ] -; - -value mklistpat _loc last = - loop True where rec loop top = - fun - [ [] -> - match last with - [ Some p -> p - | None -> <:patt< [] >> ] - | [p1 :: pl] -> - let _loc = if top then _loc else (fst (MLast.loc_of_patt p1), snd _loc) in - <:patt< [$p1$ :: $loop False pl$] >> ] -; - -value is_operator = - let ht = Hashtbl.create 73 in - let ct = Hashtbl.create 73 in - do { - List.iter (fun x -> Hashtbl.add ht x True) - ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"]; - List.iter (fun x -> Hashtbl.add ct x True) - ['!'; '&'; '*'; '+'; '-'; '/'; ':'; '<'; '='; '>'; '@'; '^'; '|'; '~'; - '?'; '%'; '.'; '$']; - fun x -> - try Hashtbl.find ht x with - [ Not_found -> try Hashtbl.find ct x.[0] with _ -> False ] - } -; - -value operator_rparen = - Grammar.Entry.of_parser gram "operator_rparen" - (fun strm -> - match Stream.npeek 2 strm with - [ [("", s); ("", ")")] when is_operator s -> - do { Stream.junk strm; Stream.junk strm; s } - | _ -> raise Stream.Failure ]) -; - -value lident_colon = - Grammar.Entry.of_parser gram "lident_colon" - (fun strm -> - match Stream.npeek 2 strm with - [ [("LIDENT", i); ("", ":")] -> - do { Stream.junk strm; Stream.junk strm; i } - | _ -> raise Stream.Failure ]) -; - -value symbolchar = - let list = - ['!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?'; - '@'; '^'; '|'; '~'] - in - let rec loop s i = - if i == String.length s then True - else if List.mem s.[i] list then loop s (i + 1) - else False - in - loop -; - -value prefixop = - let list = ['!'; '?'; '~'] in - let excl = ["!="; "??"] in - Grammar.Entry.of_parser gram "prefixop" - (parser - [: `("", x) - when - not (List.mem x excl) && String.length x >= 2 && - List.mem x.[0] list && symbolchar x 1 :] -> - x) -; - -value infixop0 = - let list = ['='; '<'; '>'; '|'; '&'; '$'] in - let excl = ["<-"; "||"; "&&"] in - Grammar.Entry.of_parser gram "infixop0" - (parser - [: `("", x) - when - not (List.mem x excl) && String.length x >= 2 && - List.mem x.[0] list && symbolchar x 1 :] -> - x) -; - -value infixop1 = - let list = ['@'; '^'] in - Grammar.Entry.of_parser gram "infixop1" - (parser - [: `("", x) - when - String.length x >= 2 && List.mem x.[0] list && - symbolchar x 1 :] -> - x) -; - -value infixop2 = - let list = ['+'; '-'] in - Grammar.Entry.of_parser gram "infixop2" - (parser - [: `("", x) - when - x <> "->" && String.length x >= 2 && List.mem x.[0] list && - symbolchar x 1 :] -> - x) -; - -value infixop3 = - let list = ['*'; '/'; '%'] in - Grammar.Entry.of_parser gram "infixop3" - (parser - [: `("", x) - when - String.length x >= 2 && List.mem x.[0] list && - symbolchar x 1 :] -> - x) -; - -value infixop4 = - Grammar.Entry.of_parser gram "infixop4" - (parser - [: `("", x) - when - String.length x >= 3 && x.[0] == '*' && x.[1] == '*' && - symbolchar x 2 :] -> - x) -; - -value test_constr_decl = - Grammar.Entry.of_parser gram "test_constr_decl" - (fun strm -> - match Stream.npeek 1 strm with - [ [("UIDENT", _)] -> - match Stream.npeek 2 strm with - [ [_; ("", ".")] -> raise Stream.Failure - | [_; ("", "(")] -> raise Stream.Failure - | [_ :: _] -> () - | _ -> raise Stream.Failure ] - | [("", "|")] -> () - | _ -> raise Stream.Failure ]) -; - -value stream_peek_nth n strm = - loop n (Stream.npeek n strm) where rec loop n = - fun - [ [] -> None - | [x] -> if n == 1 then Some x else None - | [_ :: l] -> loop (n - 1) l ] -; - -(* horrible hack to be able to parse class_types *) - -value test_ctyp_minusgreater = - Grammar.Entry.of_parser gram "test_ctyp_minusgreater" - (fun strm -> - let rec skip_simple_ctyp n = - match stream_peek_nth n strm with - [ Some ("", "->") -> n - | Some ("", "[" | "[<") -> - skip_simple_ctyp (ignore_upto "]" (n + 1) + 1) - | Some ("", "(") -> skip_simple_ctyp (ignore_upto ")" (n + 1) + 1) - | Some - ("", - "as" | "'" | ":" | "*" | "." | "#" | "<" | ">" | ".." | ";" | - "_") -> - skip_simple_ctyp (n + 1) - | Some ("QUESTIONIDENT" | "LIDENT" | "UIDENT", _) -> - skip_simple_ctyp (n + 1) - | Some _ | None -> raise Stream.Failure ] - and ignore_upto end_kwd n = - match stream_peek_nth n strm with - [ Some ("", prm) when prm = end_kwd -> n - | Some ("", "[" | "[<") -> - ignore_upto end_kwd (ignore_upto "]" (n + 1) + 1) - | Some ("", "(") -> ignore_upto end_kwd (ignore_upto ")" (n + 1) + 1) - | Some _ -> ignore_upto end_kwd (n + 1) - | None -> raise Stream.Failure ] - in - match Stream.peek strm with - [ Some (("", "[") | ("LIDENT" | "UIDENT", _)) -> skip_simple_ctyp 1 - | Some ("", "object") -> raise Stream.Failure - | _ -> 1 ]) -; - -value test_label_eq = - Grammar.Entry.of_parser gram "test_label_eq" - (test 1 where rec test lev strm = - match stream_peek_nth lev strm with - [ Some (("UIDENT", _) | ("LIDENT", _) | ("", ".")) -> - test (lev + 1) strm - | Some ("", "=") -> () - | _ -> raise Stream.Failure ]) -; - -value test_typevar_list_dot = - Grammar.Entry.of_parser gram "test_typevar_list_dot" - (let rec test lev strm = - match stream_peek_nth lev strm with - [ Some ("", "'") -> test2 (lev + 1) strm - | Some ("", ".") -> () - | _ -> raise Stream.Failure ] - and test2 lev strm = - match stream_peek_nth lev strm with - [ Some ("UIDENT" | "LIDENT", _) -> test (lev + 1) strm - | _ -> raise Stream.Failure ] - in - test 1) -; - -value constr_arity = ref [("Some", 1); ("Match_Failure", 1)]; - -value rec is_expr_constr_call = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $uid:_$.$e$ >> -> is_expr_constr_call e - | <:expr< $e$ $_$ >> -> is_expr_constr_call e - | _ -> False ] -; - -value rec constr_expr_arity _loc = - fun - [ <:expr< $uid:c$ >> -> - try List.assoc c constr_arity.val with [ Not_found -> 0 ] - | <:expr< $uid:_$.$e$ >> -> constr_expr_arity _loc e - | <:expr< $e$ $_$ >> -> - if is_expr_constr_call e then - Stdpp.raise_with_loc _loc (Stream.Error "currified constructor") - else 1 - | _ -> 1 ] -; - -value rec is_patt_constr_call = - fun - [ <:patt< $uid:_$ >> -> True - | <:patt< $uid:_$.$p$ >> -> is_patt_constr_call p - | <:patt< $p$ $_$ >> -> is_patt_constr_call p - | _ -> False ] -; - -value rec constr_patt_arity _loc = - fun - [ <:patt< $uid:c$ >> -> - try List.assoc c constr_arity.val with [ Not_found -> 0 ] - | <:patt< $uid:_$.$p$ >> -> constr_patt_arity _loc p - | <:patt< $p$ $_$ >> -> - if is_patt_constr_call p then - Stdpp.raise_with_loc _loc (Stream.Error "currified constructor") - else 1 - | _ -> 1 ] -; - -value get_seq = - fun - [ <:expr< do { $list:el$ } >> -> el - | e -> [e] ] -; - -value choose_tvar tpl = - let rec find_alpha v = - let s = String.make 1 v in - if List.mem_assoc s tpl then - if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1)) - else Some (String.make 1 v) - in - let rec make_n n = - let v = "a" ^ string_of_int n in - if List.mem_assoc v tpl then make_n (succ n) else v - in - match find_alpha 'a' with - [ Some x -> x - | None -> make_n 1 ] -; - -value rec patt_lid = - fun - [ <:patt< $p1$ $p2$ >> -> - match p1 with - [ <:patt< $lid:i$ >> -> Some (MLast.loc_of_patt p1, i, [p2]) - | _ -> - match patt_lid p1 with - [ Some (loc, i, pl) -> Some (loc, i, [p2 :: pl]) - | None -> None ] ] - | _ -> None ] -; - -value bigarray_get _loc arr arg = - let coords = - match arg with - [ <:expr< ($list:el$) >> -> el - | _ -> [arg] ] - in - match coords with - [ [c1] -> <:expr< Bigarray.Array1.get $arr$ $c1$ >> - | [c1; c2] -> <:expr< Bigarray.Array2.get $arr$ $c1$ $c2$ >> - | [c1; c2; c3] -> <:expr< Bigarray.Array3.get $arr$ $c1$ $c2$ $c3$ >> - | coords -> <:expr< Bigarray.Genarray.get $arr$ [| $list:coords$ |] >> ] -; - -value bigarray_set _loc var newval = - match var with - [ <:expr< Bigarray.Array1.get $arr$ $c1$ >> -> - Some <:expr< Bigarray.Array1.set $arr$ $c1$ $newval$ >> - | <:expr< Bigarray.Array2.get $arr$ $c1$ $c2$ >> -> - Some <:expr< Bigarray.Array2.set $arr$ $c1$ $c2$ $newval$ >> - | <:expr< Bigarray.Array3.get $arr$ $c1$ $c2$ $c3$ >> -> - Some <:expr< Bigarray.Array3.set $arr$ $c1$ $c2$ $c3$ $newval$ >> - | <:expr< Bigarray.Genarray.get $arr$ [| $list:coords$ |] >> -> - Some <:expr< Bigarray.Genarray.set $arr$ [| $list:coords$ |] $newval$ >> - | _ -> None ] -; - -(* ...works bad... -value rec sync cs = - match cs with parser - [ [: `';' :] -> sync_semi cs - | [: `_ :] -> sync cs ] -and sync_semi cs = - match cs with parser - [ [: `';' :] -> sync_semisemi cs - | [: :] -> sync cs ] -and sync_semisemi cs = - match Stream.peek cs with - [ Some ('\010' | '\013') -> () - | _ -> sync_semi cs ] -; -Pcaml.sync.val := sync; -*) - - -EXTEND - GLOBAL: sig_item str_item ctyp patt expr module_type module_expr class_type - class_expr class_sig_item class_str_item let_binding type_declaration; - module_expr: - [ [ "functor"; "("; i = UIDENT; ":"; t = module_type; ")"; "->"; - me = SELF -> - <:module_expr< functor ( $i$ : $t$ ) -> $me$ >> - | "struct"; st = LIST0 [ s = str_item; OPT ";;" -> s ]; "end" -> - <:module_expr< struct $list:st$ end >> ] - | [ me1 = SELF; me2 = SELF -> <:module_expr< $me1$ $me2$ >> ] - | [ i = mod_expr_ident -> i - | "("; me = SELF; ":"; mt = module_type; ")" -> - <:module_expr< ( $me$ : $mt$ ) >> - | "("; me = SELF; ")" -> <:module_expr< $me$ >> ] ] - ; - - mod_expr_ident: - [ LEFTA - [ i = SELF; "."; j = SELF -> <:module_expr< $i$ . $j$ >> ] - | [ i = UIDENT -> <:module_expr< $uid:i$ >> ] ] - ; - - str_item: - [ "top" - [ "exception"; (_, c, tl) = constructor_declaration; b = rebind_exn -> - <:str_item< exception $c$ of $list:tl$ = $b$ >> - | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING -> - <:str_item< external $i$ : $t$ = $list:pd$ >> - | "external"; "("; i = operator_rparen; ":"; t = ctyp; "="; - pd = LIST1 STRING -> - <:str_item< external $i$ : $t$ = $list:pd$ >> - | "include"; me = module_expr -> <:str_item< include $me$ >> - | "module"; i = UIDENT; mb = module_binding -> - <:str_item< module $i$ = $mb$ >> - | "module"; "rec"; nmtmes = LIST1 module_rec_binding SEP "and" -> - MLast.StRecMod _loc nmtmes - | "module"; "type"; i = UIDENT; "="; mt = module_type -> - <:str_item< module type $i$ = $mt$ >> - | "open"; i = mod_ident -> <:str_item< open $i$ >> - | "type"; tdl = LIST1 type_declaration SEP "and" -> - <:str_item< type $list:tdl$ >> - | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; - x = expr -> - let e = <:expr< let $opt:o2b r$ $list:l$ in $x$ >> in - <:str_item< $exp:e$ >> - | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and" -> - match l with - [ [(<:patt< _ >>, e)] -> <:str_item< $exp:e$ >> - | _ -> <:str_item< value $opt:o2b r$ $list:l$ >> ] - | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = expr -> - <:str_item< let module $m$ = $mb$ in $e$ >> - | e = expr -> <:str_item< $exp:e$ >> ] ] - ; - - rebind_exn: - [ [ "="; sl = mod_ident -> sl - | -> [] ] ] - ; - module_binding: - [ RIGHTA - [ "("; m = UIDENT; ":"; mt = module_type; ")"; mb = SELF -> - <:module_expr< functor ( $m$ : $mt$ ) -> $mb$ >> - | ":"; mt = module_type; "="; me = module_expr -> - <:module_expr< ( $me$ : $mt$ ) >> - | "="; me = module_expr -> <:module_expr< $me$ >> ] ] - ; - module_rec_binding: - [ [ m = UIDENT; ":"; mt = module_type; "="; me = module_expr -> - (m, mt, me) ] ] - ; - (* Module types *) - module_type: - [ [ "functor"; "("; i = UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF -> - <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] - | [ mt = SELF; "with"; wcl = LIST1 with_constr SEP "and" -> - <:module_type< $mt$ with $list:wcl$ >> ] - | [ "sig"; sg = LIST0 [ s = sig_item; OPT ";;" -> s ]; "end" -> - <:module_type< sig $list:sg$ end >> - | i = mod_type_ident -> i - | "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ] - ; - mod_type_ident: - [ LEFTA - [ m1 = SELF; "."; m2 = SELF -> <:module_type< $m1$ . $m2$ >> - | m1 = SELF; "("; m2 = SELF; ")" -> <:module_type< $m1$ $m2$ >> ] - | [ m = UIDENT -> <:module_type< $uid:m$ >> - | m = LIDENT -> <:module_type< $lid:m$ >> ] ] - ; - sig_item: - [ "top" - [ "exception"; (_, c, tl) = constructor_declaration -> - <:sig_item< exception $c$ of $list:tl$ >> - | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING -> - <:sig_item< external $i$ : $t$ = $list:pd$ >> - | "external"; "("; i = operator_rparen; ":"; t = ctyp; "="; - pd = LIST1 STRING -> - <:sig_item< external $i$ : $t$ = $list:pd$ >> - | "include"; mt = module_type -> <:sig_item< include $mt$ >> - | "module"; i = UIDENT; mt = module_declaration -> - <:sig_item< module $i$ : $mt$ >> - | "module"; "rec"; mds = LIST1 module_rec_declaration SEP "and" -> - MLast.SgRecMod _loc mds - | "module"; "type"; i = UIDENT; "="; mt = module_type -> - <:sig_item< module type $i$ = $mt$ >> - | "module"; "type"; i = UIDENT -> - <:sig_item< module type $i$ = 'abstract >> - | "open"; i = mod_ident -> <:sig_item< open $i$ >> - | "type"; tdl = LIST1 type_declaration SEP "and" -> - <:sig_item< type $list:tdl$ >> - | "val"; i = LIDENT; ":"; t = ctyp -> <:sig_item< value $i$ : $t$ >> - | "val"; "("; i = operator_rparen; ":"; t = ctyp -> - <:sig_item< value $i$ : $t$ >> ] ] - ; - module_declaration: - [ RIGHTA - [ ":"; mt = module_type -> <:module_type< $mt$ >> - | "("; i = UIDENT; ":"; t = module_type; ")"; mt = SELF -> - <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] ] - ; - module_rec_declaration: - [ [ m = UIDENT; ":"; mt = module_type -> (m, mt)] ] - ; - (* "with" constraints (additional type equations over signature - components) *) - with_constr: - [ [ "type"; tpl = type_parameters; i = mod_ident; "="; t = ctyp -> - MLast.WcTyp _loc i tpl t - | "module"; i = mod_ident; "="; me = module_expr -> - MLast.WcMod _loc i me ] ] - ; - (* Core expressions *) - expr: - [ "top" RIGHTA - [ e1 = SELF; ";"; e2 = SELF -> - <:expr< do { $list:[e1 :: get_seq e2]$ } >> - | e1 = SELF; ";" -> e1 ] - | "expr1" - [ "let"; o = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; - x = expr LEVEL "top" -> - <:expr< let $opt:o2b o$ $list:l$ in $x$ >> - | "let"; "module"; m = UIDENT; mb = module_binding; "in"; - e = expr LEVEL "top" -> - <:expr< let module $m$ = $mb$ in $e$ >> - | "function"; OPT "|"; l = LIST1 match_case SEP "|" -> - <:expr< fun [ $list:l$ ] >> - | "fun"; p = patt LEVEL "simple"; e = fun_def -> - <:expr< fun [$p$ -> $e$] >> - | "match"; e = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" -> - <:expr< match $e$ with [ $list:l$ ] >> - | "try"; e = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" -> - <:expr< try $e$ with [ $list:l$ ] >> - | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1"; - "else"; e3 = expr LEVEL "expr1" -> - <:expr< if $e1$ then $e2$ else $e3$ >> - | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1" -> - <:expr< if $e1$ then $e2$ else () >> - | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF; - "do"; e = SELF; "done" -> - <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:get_seq e$ } >> - | "while"; e1 = SELF; "do"; e2 = SELF; "done" -> - <:expr< while $e1$ do { $list:get_seq e2$ } >> - | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" -> - (* <:expr< object $opt:cspo$ $list:cf$ end >> *) - MLast.ExObj _loc cspo cf ] - | [ e = SELF; ","; el = LIST1 NEXT SEP "," -> - <:expr< ( $list:[e :: el]$ ) >> ] - | ":=" NONA - [ e1 = SELF; ":="; e2 = expr LEVEL "expr1" -> - <:expr< $e1$.val := $e2$ >> - | e1 = SELF; "<-"; e2 = expr LEVEL "expr1" -> - match bigarray_set _loc e1 e2 with - [ Some e -> e - | None -> <:expr< $e1$ := $e2$ >> ] ] - | "||" RIGHTA - [ e1 = SELF; "or"; e2 = SELF -> <:expr< $lid:"or"$ $e1$ $e2$ >> - | e1 = SELF; "||"; e2 = SELF -> <:expr< $e1$ || $e2$ >> ] - | "&&" RIGHTA - [ e1 = SELF; "&"; e2 = SELF -> <:expr< $lid:"&"$ $e1$ $e2$ >> - | e1 = SELF; "&&"; e2 = SELF -> <:expr< $e1$ && $e2$ >> ] - | "<" LEFTA - [ e1 = SELF; "<"; e2 = SELF -> <:expr< $e1$ < $e2$ >> - | e1 = SELF; ">"; e2 = SELF -> <:expr< $e1$ > $e2$ >> - | e1 = SELF; "<="; e2 = SELF -> <:expr< $e1$ <= $e2$ >> - | e1 = SELF; ">="; e2 = SELF -> <:expr< $e1$ >= $e2$ >> - | e1 = SELF; "="; e2 = SELF -> <:expr< $e1$ = $e2$ >> - | e1 = SELF; "<>"; e2 = SELF -> <:expr< $e1$ <> $e2$ >> - | e1 = SELF; "=="; e2 = SELF -> <:expr< $e1$ == $e2$ >> - | e1 = SELF; "!="; e2 = SELF -> <:expr< $e1$ != $e2$ >> - | e1 = SELF; "$"; e2 = SELF -> <:expr< $lid:"\$"$ $e1$ $e2$ >> - | e1 = SELF; op = infixop0; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ] - | "^" RIGHTA - [ e1 = SELF; "^"; e2 = SELF -> <:expr< $e1$ ^ $e2$ >> - | e1 = SELF; "@"; e2 = SELF -> <:expr< $e1$ @ $e2$ >> - | e1 = SELF; op = infixop1; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ] - | RIGHTA - [ e1 = SELF; "::"; e2 = SELF -> <:expr< [$e1$ :: $e2$] >> ] - | "+" LEFTA - [ e1 = SELF; "+"; e2 = SELF -> <:expr< $e1$ + $e2$ >> - | e1 = SELF; "-"; e2 = SELF -> <:expr< $e1$ - $e2$ >> - | e1 = SELF; op = infixop2; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ] - | "*" LEFTA - [ e1 = SELF; "*"; e2 = SELF -> <:expr< $e1$ * $e2$ >> - | e1 = SELF; "/"; e2 = SELF -> <:expr< $e1$ / $e2$ >> - | e1 = SELF; "%"; e2 = SELF -> <:expr< $lid:"%"$ $e1$ $e2$ >> - | e1 = SELF; "land"; e2 = SELF -> <:expr< $e1$ land $e2$ >> - | e1 = SELF; "lor"; e2 = SELF -> <:expr< $e1$ lor $e2$ >> - | e1 = SELF; "lxor"; e2 = SELF -> <:expr< $e1$ lxor $e2$ >> - | e1 = SELF; "mod"; e2 = SELF -> <:expr< $e1$ mod $e2$ >> - | e1 = SELF; op = infixop3; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ] - | "**" RIGHTA - [ e1 = SELF; "**"; e2 = SELF -> <:expr< $e1$ ** $e2$ >> - | e1 = SELF; "asr"; e2 = SELF -> <:expr< $e1$ asr $e2$ >> - | e1 = SELF; "lsl"; e2 = SELF -> <:expr< $e1$ lsl $e2$ >> - | e1 = SELF; "lsr"; e2 = SELF -> <:expr< $e1$ lsr $e2$ >> - | e1 = SELF; op = infixop4; e2 = SELF -> <:expr< $lid:op$ $e1$ $e2$ >> ] - | "unary minus" NONA - [ "-"; e = SELF -> <:expr< $mkumin _loc "-" e$ >> - | "-."; e = SELF -> <:expr< $mkumin _loc "-." e$ >> ] - | "apply" LEFTA - [ e1 = SELF; e2 = SELF -> - match constr_expr_arity _loc e1 with - [ 1 -> <:expr< $e1$ $e2$ >> - | _ -> - match e2 with - [ <:expr< ( $list:el$ ) >> -> - List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) e1 el - | _ -> <:expr< $e1$ $e2$ >> ] ] - | "assert"; e = SELF -> - match e with - [ <:expr< False >> -> <:expr< assert False >> - | _ -> <:expr< assert ($e$) >> ] - | "lazy"; e = SELF -> - <:expr< lazy ($e$) >> ] - | "." LEFTA - [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >> - | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >> - | e1 = SELF; "."; "{"; e2 = SELF; "}" -> bigarray_get _loc e1 e2 - | e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> ] - | "~-" NONA - [ "!"; e = SELF -> <:expr< $e$ . val>> - | "~-"; e = SELF -> <:expr< ~- $e$ >> - | "~-."; e = SELF -> <:expr< ~-. $e$ >> - | f = prefixop; e = SELF -> <:expr< $lid:f$ $e$ >> ] - | "simple" LEFTA - [ s = INT -> <:expr< $int:s$ >> - | s = INT32 -> MLast.ExInt32 _loc s - | s = INT64 -> MLast.ExInt64 _loc s - | s = NATIVEINT -> MLast.ExNativeInt _loc s - | s = FLOAT -> <:expr< $flo:s$ >> - | s = STRING -> <:expr< $str:s$ >> - | c = CHAR -> <:expr< $chr:c$ >> - | UIDENT "True" -> <:expr< $uid:" True"$ >> - | UIDENT "False" -> <:expr< $uid:" False"$ >> - | ids = expr_ident -> mkexprident _loc ids - | s = "false" -> <:expr< False >> - | s = "true" -> <:expr< True >> - | "["; "]" -> <:expr< [] >> - | "["; el = expr1_semi_list; "]" -> <:expr< $mklistexp _loc None el$ >> - | "[|"; "|]" -> <:expr< [| |] >> - | "[|"; el = expr1_semi_list; "|]" -> <:expr< [| $list:el$ |] >> - | "{"; test_label_eq; lel = lbl_expr_list; "}" -> - <:expr< { $list:lel$ } >> - | "{"; e = expr LEVEL "."; "with"; lel = lbl_expr_list; "}" -> - <:expr< { ($e$) with $list:lel$ } >> - | "("; ")" -> <:expr< () >> - | "("; op = operator_rparen -> <:expr< $lid:op$ >> - | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >> - | "("; e = SELF; ")" -> <:expr< $e$ >> - | "begin"; e = SELF; "end" -> <:expr< $e$ >> - | "begin"; "end" -> <:expr< () >> - | x = LOCATE -> - let x = - try - let i = String.index x ':' in - ({Lexing.pos_fname = ""; - Lexing.pos_lnum = 0; - Lexing.pos_bol = 0; - Lexing.pos_cnum = int_of_string (String.sub x 0 i)}, - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found | Failure _ -> (Token.nowhere, x) ] - in - Pcaml.handle_expr_locate _loc x - | x = QUOTATION -> - let x = - try - let i = String.index x ':' in - (String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found -> ("", x) ] - in - Pcaml.handle_expr_quotation _loc x ] ] - ; - let_binding: - [ [ p = patt; e = fun_binding -> - match patt_lid p with - [ Some (_loc, i, pl) -> - let e = - List.fold_left (fun e p -> <:expr< fun $p$ -> $e$ >>) e pl - in - (<:patt< $lid:i$ >>, e) - | None -> (p, e) ] ] ] - ; - fun_binding: - [ RIGHTA - [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >> - | "="; e = expr -> <:expr< $e$ >> - | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> - | ":>"; t = ctyp; "="; e = expr -> <:expr< ($e$ :> $t$) >> ] ] - ; - match_case: - [ [ x1 = patt; w = OPT [ "when"; e = expr -> e ]; "->"; x2 = expr -> - (x1, w, x2) ] ] - ; - lbl_expr_list: - [ [ le = lbl_expr; ";"; lel = SELF -> [le :: lel] - | le = lbl_expr; ";" -> [le] - | le = lbl_expr -> [le] ] ] - ; - lbl_expr: - [ [ i = patt_label_ident; "="; e = expr LEVEL "expr1" -> (i, e) ] ] - ; - expr1_semi_list: - [ [ e = expr LEVEL "expr1"; ";"; el = SELF -> [e :: el] - | e = expr LEVEL "expr1"; ";" -> [e] - | e = expr LEVEL "expr1" -> [e] ] ] - ; - fun_def: - [ RIGHTA - [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >> - | "->"; e = expr -> <:expr< $e$ >> ] ] - ; - expr_ident: - [ RIGHTA - [ i = LIDENT -> [ <:expr< $lid:i$ >> ] - | i = UIDENT -> [ <:expr< $uid:i$ >> ] - | i = UIDENT; "."; "("; j = operator_rparen -> - [ <:expr< $uid:i$ >> ; <:expr< $lid:j$ >> ] - | i = UIDENT; "."; j = SELF -> [ <:expr< $uid:i$ >> :: j ] - ] - ] - ; - (* Patterns *) - patt: - [ LEFTA - [ p1 = SELF; "as"; i = LIDENT -> <:patt< ($p1$ as $lid:i$) >> ] - | LEFTA - [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ] - | [ p = SELF; ","; pl = LIST1 NEXT SEP "," -> - <:patt< ( $list:[p :: pl]$) >> ] - | NONA - [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ] - | RIGHTA - [ p1 = SELF; "::"; p2 = SELF -> <:patt< [$p1$ :: $p2$] >> ] - | LEFTA - [ p1 = SELF; p2 = SELF -> - match constr_patt_arity _loc p1 with - [ 1 -> <:patt< $p1$ $p2$ >> - | n -> - let p2 = - match p2 with - [ <:patt< _ >> when n > 1 -> - let pl = - loop n where rec loop n = - if n = 0 then [] else [<:patt< _ >> :: loop (n - 1)] - in - <:patt< ( $list:pl$ ) >> - | _ -> p2 ] - in - match p2 with - [ <:patt< ( $list:pl$ ) >> -> - List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>) p1 pl - | _ -> <:patt< $p1$ $p2$ >> ] ] ] - | LEFTA - [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ] - | "simple" - [ s = LIDENT -> <:patt< $lid:s$ >> - | s = UIDENT -> <:patt< $uid:s$ >> - | s = INT -> <:patt< $int:s$ >> - | s = INT32 -> MLast.PaInt32 _loc s - | s = INT64 -> MLast.PaInt64 _loc s - | s = NATIVEINT -> MLast.PaNativeInt _loc s - | "-"; s = INT -> <:patt< $int:"-" ^ s$ >> - | "-"; s = INT32 -> MLast.PaInt32 _loc ("-" ^ s) - | "-"; s = INT64 -> MLast.PaInt64 _loc ("-" ^ s) - | "-"; s = NATIVEINT -> MLast.PaNativeInt _loc ("-" ^ s) - | "-"; s = FLOAT -> <:patt< $flo:"-" ^ s$ >> - | s = FLOAT -> <:patt< $flo:s$ >> - | s = STRING -> <:patt< $str:s$ >> - | s = CHAR -> <:patt< $chr:s$ >> - | UIDENT "True" -> <:patt< $uid:" True"$ >> - | UIDENT "False" -> <:patt< $uid:" False"$ >> - | s = "false" -> <:patt< False >> - | s = "true" -> <:patt< True >> - | "["; "]" -> <:patt< [] >> - | "["; pl = patt_semi_list; "]" -> <:patt< $mklistpat _loc None pl$ >> - | "[|"; "|]" -> <:patt< [| |] >> - | "[|"; pl = patt_semi_list; "|]" -> <:patt< [| $list:pl$ |] >> - | "{"; lpl = lbl_patt_list; "}" -> <:patt< { $list:lpl$ } >> - | "("; ")" -> <:patt< () >> - | "("; op = operator_rparen -> <:patt< $lid:op$ >> - | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> - | "("; p = patt; ")" -> <:patt< $p$ >> - | "_" -> <:patt< _ >> - | "`"; s = ident -> <:patt< ` $s$ >> - | "#"; t = mod_ident -> <:patt< # $list:t$ >> - | x = LOCATE -> - let x = - try - let i = String.index x ':' in - ({Lexing.pos_fname = ""; - Lexing.pos_lnum = 0; - Lexing.pos_bol = 0; - Lexing.pos_cnum = int_of_string (String.sub x 0 i)}, - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found | Failure _ -> (Token.nowhere, x) ] - in - Pcaml.handle_patt_locate _loc x - | x = QUOTATION -> - let x = - try - let i = String.index x ':' in - (String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found -> ("", x) ] - in - Pcaml.handle_patt_quotation _loc x ] ] - ; - - patt_semi_list: - [ [ p = patt; ";"; pl = SELF -> [p :: pl] - | p = patt; ";" -> [p] - | p = patt -> [p] ] ] - ; - lbl_patt_list: - [ [ le = lbl_patt; ";"; lel = SELF -> [le :: lel] - | le = lbl_patt; ";" -> [le] - | le = lbl_patt -> [le] ] ] - ; - lbl_patt: - [ [ i = patt_label_ident; "="; p = patt -> (i, p) ] ] - ; - patt_label_ident: - [ LEFTA - [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ] - | RIGHTA - [ i = UIDENT -> <:patt< $uid:i$ >> - | i = LIDENT -> <:patt< $lid:i$ >> ] ] - ; - (* Type declaration *) - type_declaration: - [ [ tpl = type_parameters; n = type_patt; "="; tk = type_kind; - cl = LIST0 constrain -> - (n, tpl, tk, cl) - | tpl = type_parameters; n = type_patt; cl = LIST0 constrain -> - (n, tpl, <:ctyp< '$choose_tvar tpl$ >>, cl) ] ] - ; - type_patt: - [ [ n = LIDENT -> (_loc, n) ] ] - ; - constrain: - [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ] - ; - type_kind: - [ [ "private"; tk = type_kind -> <:ctyp< private $tk$ >> - | test_constr_decl; OPT "|"; - cdl = LIST1 constructor_declaration SEP "|" -> <:ctyp< [ $list:cdl$ ] >> - | t = ctyp -> <:ctyp< $t$ >> - | t = ctyp; "="; "private"; tk = type_kind -> - <:ctyp< $t$ == private $tk$ >> - | t = ctyp; "="; "{"; ldl = label_declarations; "}" -> - <:ctyp< $t$ == { $list:ldl$ } >> - | t = ctyp; "="; OPT "|"; cdl = LIST1 constructor_declaration SEP "|" -> - <:ctyp< $t$ == [ $list:cdl$ ] >> - | "{"; ldl = label_declarations; "}" -> - <:ctyp< { $list:ldl$ } >> ] ] - ; - type_parameters: - [ [ -> (* empty *) [] - | tp = type_parameter -> [tp] - | "("; tpl = LIST1 type_parameter SEP ","; ")" -> tpl ] ] - ; - type_parameter: - [ [ "'"; i = ident -> (i, (False, False)) - | "+"; "'"; i = ident -> (i, (True, False)) - | "-"; "'"; i = ident -> (i, (False, True)) ] ] - ; - constructor_declaration: - [ [ ci = UIDENT; "of"; cal = LIST1 ctyp LEVEL "ctyp1" SEP "*" -> - (_loc, ci, cal) - | ci = UIDENT -> (_loc, ci, []) ] ] - ; - label_declarations: - [ [ ld = label_declaration; ";"; ldl = SELF -> [ld :: ldl] - | ld = label_declaration; ";" -> [ld] - | ld = label_declaration -> [ld] ] ] - ; - label_declaration: - [ [ i = LIDENT; ":"; t = poly_type -> (_loc, i, False, t) - | "mutable"; i = LIDENT; ":"; t = poly_type -> (_loc, i, True, t) ] ] - ; - (* Core types *) - ctyp: - [ [ t1 = SELF; "as"; "'"; i = ident -> <:ctyp< $t1$ as '$i$ >> ] - | "arrow" RIGHTA - [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ] - | "star" - [ t = SELF; "*"; tl = LIST1 (ctyp LEVEL "ctyp1") SEP "*" -> - <:ctyp< ( $list:[t :: tl]$ ) >> ] - | "ctyp1" - [ t1 = SELF; t2 = SELF -> <:ctyp< $t2$ $t1$ >> ] - | "ctyp2" - [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >> - | t1 = SELF; "("; t2 = SELF; ")" -> <:ctyp< $t1$ $t2$ >> ] - | "simple" - [ "'"; i = ident -> <:ctyp< '$i$ >> - | "_" -> <:ctyp< _ >> - | i = LIDENT -> <:ctyp< $lid:i$ >> - | i = UIDENT -> <:ctyp< $uid:i$ >> - | "("; t = SELF; ","; tl = LIST1 ctyp SEP ","; ")"; - i = ctyp LEVEL "ctyp2" -> - List.fold_left (fun c a -> <:ctyp< $c$ $a$ >>) i [t :: tl] - | "("; t = SELF; ")" -> <:ctyp< $t$ >> ] ] - ; - (* Identifiers *) - ident: - [ [ i = LIDENT -> i - | i = UIDENT -> i ] ] - ; - mod_ident: - [ RIGHTA - [ i = UIDENT -> [i] - | i = LIDENT -> [i] - | i = UIDENT; "."; j = SELF -> [i :: j] ] ] - ; - (* Miscellaneous *) - direction_flag: - [ [ "to" -> True - | "downto" -> False ] ] - ; - (* Objects and Classes *) - str_item: - [ [ "class"; cd = LIST1 class_declaration SEP "and" -> - <:str_item< class $list:cd$ >> - | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" -> - <:str_item< class type $list:ctd$ >> ] ] - ; - sig_item: - [ [ "class"; cd = LIST1 class_description SEP "and" -> - <:sig_item< class $list:cd$ >> - | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" -> - <:sig_item< class type $list:ctd$ >> ] ] - ; - (* Class expressions *) - class_declaration: - [ [ vf = OPT "virtual"; ctp = class_type_parameters; i = LIDENT; - cfb = class_fun_binding -> - {MLast.ciLoc = _loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = i; MLast.ciExp = cfb} ] ] - ; - class_fun_binding: - [ [ "="; ce = class_expr -> ce - | ":"; ct = class_type; "="; ce = class_expr -> - <:class_expr< ($ce$ : $ct$) >> - | p = patt LEVEL "simple"; cfb = SELF -> - <:class_expr< fun $p$ -> $cfb$ >> ] ] - ; - class_type_parameters: - [ [ -> (_loc, []) - | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (_loc, tpl) ] ] - ; - class_fun_def: - [ [ p = patt LEVEL "simple"; "->"; ce = class_expr -> - <:class_expr< fun $p$ -> $ce$ >> - | p = labeled_patt; "->"; ce = class_expr -> - <:class_expr< fun $p$ -> $ce$ >> - | p = patt LEVEL "simple"; cfd = SELF -> - <:class_expr< fun $p$ -> $cfd$ >> - | p = labeled_patt; cfd = SELF -> - <:class_expr< fun $p$ -> $cfd$ >> ] ] - ; - class_expr: - [ "top" - [ "fun"; cfd = class_fun_def -> cfd - | "let"; rf = OPT "rec"; lb = LIST1 let_binding SEP "and"; "in"; - ce = SELF -> - <:class_expr< let $opt:o2b rf$ $list:lb$ in $ce$ >> ] - | "apply" LEFTA - [ ce = SELF; e = expr LEVEL "label" -> - <:class_expr< $ce$ $e$ >> ] - | "simple" - [ "["; ct = ctyp; ","; ctcl = LIST1 ctyp SEP ","; "]"; - ci = class_longident -> - <:class_expr< $list:ci$ [ $list:[ct :: ctcl]$ ] >> - | "["; ct = ctyp; "]"; ci = class_longident -> - <:class_expr< $list:ci$ [ $ct$ ] >> - | ci = class_longident -> <:class_expr< $list:ci$ >> - | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" -> - <:class_expr< object $opt:cspo$ $list:cf$ end >> - | "("; ce = SELF; ":"; ct = class_type; ")" -> - <:class_expr< ($ce$ : $ct$) >> - | "("; ce = SELF; ")" -> ce ] ] - ; - class_structure: - [ [ cf = LIST0 class_str_item -> cf ] ] - ; - class_self_patt: - [ [ "("; p = patt; ")" -> p - | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ] ] - ; - class_str_item: - [ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] -> - <:class_str_item< inherit $ce$ $opt:pb$ >> - | "val"; mf = OPT "mutable"; lab = label; e = cvalue_binding -> - <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >> - | "method"; "private"; "virtual"; l = label; ":"; t = poly_type -> - <:class_str_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; "private"; l = label; ":"; t = poly_type -> - <:class_str_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; l = label; ":"; t = poly_type -> - <:class_str_item< method virtual $l$ : $t$ >> - | "method"; "private"; l = label; ":"; t = poly_type; "="; e = expr -> - MLast.CrMth _loc l True e (Some t) - | "method"; "private"; l = label; sb = fun_binding -> - MLast.CrMth _loc l True sb None - | "method"; l = label; ":"; t = poly_type; "="; e = expr -> - MLast.CrMth _loc l False e (Some t) - | "method"; l = label; sb = fun_binding -> - MLast.CrMth _loc l False sb None - | "constraint"; t1 = ctyp; "="; t2 = ctyp -> - <:class_str_item< type $t1$ = $t2$ >> - | "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ] - ; - cvalue_binding: - [ [ "="; e = expr -> e - | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> - | ":"; t = ctyp; ":>"; t2 = ctyp; "="; e = expr -> - <:expr< ($e$ : $t$ :> $t2$) >> - | ":>"; t = ctyp; "="; e = expr -> - <:expr< ($e$ :> $t$) >> ] ] - ; - label: - [ [ i = LIDENT -> i ] ] - ; - (* Class types *) - class_type: - [ [ test_ctyp_minusgreater; t = ctyp LEVEL "star"; "->"; ct = SELF -> - <:class_type< [ $t$ ] -> $ct$ >> - | cs = class_signature -> cs ] ] - ; - class_signature: - [ [ "["; tl = LIST1 ctyp SEP ","; "]"; id = clty_longident -> - <:class_type< $list:id$ [ $list:tl$ ] >> - | id = clty_longident -> <:class_type< $list:id$ >> - | "object"; cst = OPT class_self_type; csf = LIST0 class_sig_item; - "end" -> - <:class_type< object $opt:cst$ $list:csf$ end >> ] ] - ; - class_self_type: - [ [ "("; t = ctyp; ")" -> t ] ] - ; - class_sig_item: - [ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >> - | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp -> - <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >> - | "method"; "private"; "virtual"; l = label; ":"; t = poly_type -> - <:class_sig_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; "private"; l = label; ":"; t = poly_type -> - <:class_sig_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; l = label; ":"; t = poly_type -> - <:class_sig_item< method virtual $l$ : $t$ >> - | "method"; "private"; l = label; ":"; t = poly_type -> - <:class_sig_item< method private $l$ : $t$ >> - | "method"; l = label; ":"; t = poly_type -> - <:class_sig_item< method $l$ : $t$ >> - | "constraint"; t1 = ctyp; "="; t2 = ctyp -> - <:class_sig_item< type $t1$ = $t2$ >> ] ] - ; - class_description: - [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; ":"; - ct = class_type -> - {MLast.ciLoc = _loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = ct} ] ] - ; - class_type_declaration: - [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; "="; - cs = class_signature -> - {MLast.ciLoc = _loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = cs} ] ] - ; - (* Expressions *) - expr: LEVEL "simple" - [ LEFTA - [ "new"; i = class_longident -> <:expr< new $list:i$ >> ] ] - ; - expr: LEVEL "." - [ [ e = SELF; "#"; lab = label -> <:expr< $e$ # $lab$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" -> - <:expr< ($e$ : $t$ :> $t2$) >> - | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >> - | "{<"; ">}" -> <:expr< {< >} >> - | "{<"; fel = field_expr_list; ">}" -> <:expr< {< $list:fel$ >} >> ] ] - ; - field_expr_list: - [ [ l = label; "="; e = expr LEVEL "expr1"; ";"; fel = SELF -> - [(l, e) :: fel] - | l = label; "="; e = expr LEVEL "expr1"; ";" -> [(l, e)] - | l = label; "="; e = expr LEVEL "expr1" -> [(l, e)] ] ] - ; - (* Core types *) - ctyp: LEVEL "simple" - [ [ "#"; id = class_longident -> <:ctyp< # $list:id$ >> - | "<"; (ml, v) = meth_list; ">" -> <:ctyp< < $list:ml$ $opt:v$ > >> - | "<"; ">" -> <:ctyp< < > >> ] ] - ; - meth_list: - [ [ f = field; ";"; (ml, v) = SELF -> ([f :: ml], v) - | f = field; ";" -> ([f], False) - | f = field -> ([f], False) - | ".." -> ([], True) ] ] - ; - field: - [ [ lab = LIDENT; ":"; t = poly_type -> (lab, t) ] ] - ; - (* Polymorphic types *) - typevar: - [ [ "'"; i = ident -> i ] ] - ; - poly_type: - [ [ test_typevar_list_dot; tpl = LIST1 typevar; "."; t2 = ctyp -> - <:ctyp< ! $list:tpl$ . $t2$ >> - | t = ctyp -> t ] ] - ; - (* Identifiers *) - clty_longident: - [ [ m = UIDENT; "."; l = SELF -> [m :: l] - | i = LIDENT -> [i] ] ] - ; - class_longident: - [ [ m = UIDENT; "."; l = SELF -> [m :: l] - | i = LIDENT -> [i] ] ] - ; - (* Labels *) - ctyp: LEVEL "arrow" - [ RIGHTA - [ i = lident_colon; t1 = ctyp LEVEL "star"; "->"; t2 = SELF -> - <:ctyp< ( ~ $i$ : $t1$ ) -> $t2$ >> - | i = OPTLABEL; t1 = ctyp LEVEL "star"; "->"; t2 = SELF -> - <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >> - | i = QUESTIONIDENT; ":"; t1 = ctyp LEVEL "star"; "->"; t2 = SELF -> - <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >> - | "?"; i=lident_colon;t1 = ctyp LEVEL "star"; "->"; t2 = SELF -> - <:ctyp< ( ? $i$ : $t1$ ) -> $t2$ >> ] ] - ; - ctyp: LEVEL "simple" - [ [ "["; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" -> - <:ctyp< [ = $list:rfl$ ] >> - | "["; ">"; "]" -> <:ctyp< [ > $list:[]$ ] >> - | "["; ">"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" -> - <:ctyp< [ > $list:rfl$ ] >> - | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" -> - <:ctyp< [ < $list:rfl$ ] >> - | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; ">"; - ntl = LIST1 name_tag; "]" -> - <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ] - ; - row_field: - [ [ "`"; i = ident -> MLast.RfTag i True [] - | "`"; i = ident; "of"; ao = OPT "&"; l = LIST1 ctyp SEP "&" -> - MLast.RfTag i (o2b ao) l - | t = ctyp -> MLast.RfInh t ] ] - ; - name_tag: - [ [ "`"; i = ident -> i ] ] - ; - expr: LEVEL "expr1" - [ [ "fun"; p = labeled_patt; e = fun_def -> <:expr< fun $p$ -> $e$ >> ] ] - ; - expr: AFTER "apply" - [ "label" - [ i = LABEL; e = SELF -> <:expr< ~ $i$ : $e$ >> - | i = TILDEIDENT -> <:expr< ~ $i$ >> - | "~"; i = LIDENT -> <:expr< ~ $i$ >> - | i = OPTLABEL; e = SELF -> <:expr< ? $i$ : $e$ >> - | i = QUESTIONIDENT -> <:expr< ? $i$ >> - | "?"; i = LIDENT -> <:expr< ? $i$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "`"; s = ident -> <:expr< ` $s$ >> ] ] - ; - fun_def: - [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ] - ; - fun_binding: - [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ] - ; - labeled_patt: - [ [ i = LABEL; p = patt LEVEL "simple" -> - <:patt< ~ $i$ : $p$ >> - | i = TILDEIDENT -> - <:patt< ~ $i$ >> - | "~"; i=LIDENT -> <:patt< ~ $i$ >> - | "~"; "("; i = LIDENT; ")" -> - <:patt< ~ $i$ >> - | "~"; "("; i = LIDENT; ":"; t = ctyp; ")" -> - <:patt< ~ $i$ : ($lid:i$ : $t$) >> - | i = OPTLABEL; j = LIDENT -> - <:patt< ? $i$ : ($lid:j$) >> - | i = OPTLABEL; "("; p = patt; "="; e = expr; ")" -> - <:patt< ? $i$ : ( $p$ = $e$ ) >> - | i = OPTLABEL; "("; p = patt; ":"; t = ctyp; ")" -> - <:patt< ? $i$ : ( $p$ : $t$ ) >> - | i = OPTLABEL; "("; p = patt; ":"; t = ctyp; "="; - e = expr; ")" -> - <:patt< ? $i$ : ( $p$ : $t$ = $e$ ) >> - | i = QUESTIONIDENT -> <:patt< ? $i$ >> - | "?"; i = LIDENT -> <:patt< ? $i$ >> - | "?"; "("; i = LIDENT; "="; e = expr; ")" -> - <:patt< ? ( $lid:i$ = $e$ ) >> - | "?"; "("; i = LIDENT; ":"; t = ctyp; "="; e = expr; ")" -> - <:patt< ? ( $lid:i$ : $t$ = $e$ ) >> - | "?"; "("; i = LIDENT; ")" -> - <:patt< ? $i$ >> - | "?"; "("; i = LIDENT; ":"; t = ctyp; ")" -> - <:patt< ? ( $lid:i$ : $t$ ) >> ] ] - ; - class_type: - [ [ i = lident_colon; t = ctyp LEVEL "star"; "->"; ct = SELF -> - <:class_type< [ ~ $i$ : $t$ ] -> $ct$ >> - | i = OPTLABEL; t = ctyp LEVEL "star"; "->"; ct = SELF -> - <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> - | i = QUESTIONIDENT; ":"; t = ctyp LEVEL "star"; "->"; ct = SELF -> - <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> - | "?"; i = LIDENT; ":"; t = ctyp LEVEL "star"; "->"; ct = SELF -> - <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> ] ] - ; - class_fun_binding: - [ [ p = labeled_patt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ] - ; -END; - -(* Main entry points *) - -EXTEND - GLOBAL: interf implem use_file top_phrase expr patt; - interf: - [ [ si = sig_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped) - | "#"; n = LIDENT; dp = OPT expr; ";;" -> - ([(<:sig_item< # $n$ $opt:dp$ >>, _loc)], True) - | EOI -> ([], False) ] ] - ; - sig_item_semi: - [ [ si = sig_item; OPT ";;" -> (si, _loc) ] ] - ; - implem: - [ [ si = str_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped) - | "#"; n = LIDENT; dp = OPT expr; ";;" -> - ([(<:str_item< # $n$ $opt:dp$ >>, _loc)], True) - | EOI -> ([], False) ] ] - ; - str_item_semi: - [ [ si = str_item; OPT ";;" -> (si, _loc) ] ] - ; - top_phrase: - [ [ ph = phrase; ";;" -> Some ph - | EOI -> None ] ] - ; - use_file: - [ [ si = str_item; OPT ";;"; (sil, stopped) = SELF -> - ([si :: sil], stopped) - | "#"; n = LIDENT; dp = OPT expr; ";;" -> - ([<:str_item< # $n$ $opt:dp$ >>], True) - | EOI -> ([], False) ] ] - ; - phrase: - [ [ sti = str_item -> sti - | "#"; n = LIDENT; dp = OPT expr -> <:str_item< # $n$ $opt:dp$ >> ] ] - ; -END; diff --git a/camlp4/etc/pa_oop.ml b/camlp4/etc/pa_oop.ml deleted file mode 100644 index 235f2774..00000000 --- a/camlp4/etc/pa_oop.ml +++ /dev/null @@ -1,155 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: pa_oop.ml,v 1.5 2004/11/17 09:07:56 mauny Exp $ *) - -open Pcaml; - -type spat_comp = - [ SpTrm of MLast.loc and MLast.patt and option MLast.expr - | SpNtr of MLast.loc and MLast.patt and MLast.expr - | SpStr of MLast.loc and MLast.patt ] -; -type sexp_comp = - [ SeTrm of MLast.loc and MLast.expr | SeNtr of MLast.loc and MLast.expr ] -; - -value strm_n = "strm__"; -value peek_fun _loc = <:expr< Stream.peek >>; -value junk_fun _loc = <:expr< Stream.junk >>; - -(* Parsers. *) - -value stream_pattern_component skont = - fun - [ SpTrm _loc p wo -> - (<:expr< $peek_fun _loc$ $lid:strm_n$ >>, p, wo, - <:expr< do { $junk_fun _loc$ $lid:strm_n$; $skont$ } >>) - | SpNtr _loc p e -> - (<:expr< try Some ($e$ $lid:strm_n$) with - [ Stream.Failure -> None ] >>, - p, None, skont) - | SpStr _loc p -> - (<:expr< Some $lid:strm_n$ >>, p, None, skont) ] -; - -value rec stream_pattern _loc epo e ekont = - fun - [ [] -> - match epo with - [ Some ep -> <:expr< let $ep$ = Stream.count $lid:strm_n$ in $e$ >> - | _ -> e ] - | [(spc, err) :: spcl] -> - let skont = - let ekont err = - let str = - match err with - [ Some estr -> estr - | _ -> <:expr< "" >> ] - in - <:expr< raise (Stream.Error $str$) >> - in - stream_pattern _loc epo e ekont spcl - in - let (tst, p, wo, e) = stream_pattern_component skont spc in - let ckont = ekont err in - <:expr< match $tst$ with - [ Some $p$ $when:wo$ -> $e$ | _ -> $ckont$ ] >> ] -; - -value rec parser_cases _loc = - fun - [ [] -> <:expr< raise Stream.Failure >> - | [(spcl, epo, e) :: spel] -> - stream_pattern _loc epo e (fun _ -> parser_cases _loc spel) spcl ] -; - -value cparser _loc bpo pc = - let e = parser_cases _loc pc in - let e = - match bpo with - [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >> - | None -> e ] - in - let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in - <:expr< fun $p$ -> $e$ >> -; - -value cparser_match _loc me bpo pc = - let pc = parser_cases _loc pc in - let e = - match bpo with - [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >> - | None -> pc ] - in - <:expr< let $lid:strm_n$ = $me$ in $e$ >> -; - -(* streams *) - -value slazy _loc e = <:expr< fun _ -> $e$ >>; - -value rec cstream gloc = - fun - [ [] -> let _loc = gloc in <:expr< Stream.sempty >> - | [SeTrm _loc e :: secl] -> - <:expr< Stream.lcons $slazy _loc e$ $cstream gloc secl$ >> - | [SeNtr _loc e :: secl] -> - <:expr< Stream.lapp $slazy _loc e$ $cstream gloc secl$ >> ] -; - -(* Syntax extensions in Ocaml grammar *) - - -EXTEND - GLOBAL: expr; - expr: LEVEL "expr1" - [ [ "parser"; po = OPT ipatt; OPT "|"; pcl = LIST1 parser_case SEP "|" -> - <:expr< $cparser _loc po pcl$ >> - | "match"; e = expr; "with"; "parser"; po = OPT ipatt; OPT "|"; - pcl = LIST1 parser_case SEP "|" -> - <:expr< $cparser_match _loc e po pcl$ >> ] ] - ; - parser_case: - [ [ "[<"; sp = stream_patt; ">]"; po = OPT ipatt; "->"; e = expr -> - (sp, po, e) ] ] - ; - stream_patt: - [ [ spc = stream_patt_comp -> [(spc, None)] - | spc = stream_patt_comp; ";"; sp = LIST1 stream_patt_comp_err SEP ";" -> - [(spc, None) :: sp] - | (* empty *) -> [] ] ] - ; - stream_patt_comp_err: - [ [ spc = stream_patt_comp; - eo = OPT [ "??"; e = expr LEVEL "expr1" -> e ] -> - (spc, eo) ] ] - ; - stream_patt_comp: - [ [ "'"; p = patt; eo = OPT [ "when"; e = (expr LEVEL "expr1") -> e ] -> - SpTrm _loc p eo - | p = patt; "="; e = (expr LEVEL "expr1") -> SpNtr _loc p e - | p = patt -> SpStr _loc p ] ] - ; - ipatt: - [ [ i = LIDENT -> <:patt< $lid:i$ >> ] ] - ; - - expr: LEVEL "simple" - [ [ "[<"; se = LIST0 stream_expr_comp SEP ";"; ">]" -> - <:expr< $cstream _loc se$ >> ] ] - ; - stream_expr_comp: - [ [ "'"; e = expr LEVEL "expr1" -> SeTrm _loc e - | e = expr LEVEL "expr1" -> SeNtr _loc e ] ] - ; -END; diff --git a/camlp4/etc/pa_op.ml b/camlp4/etc/pa_op.ml deleted file mode 100644 index d2749751..00000000 --- a/camlp4/etc/pa_op.ml +++ /dev/null @@ -1,330 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: pa_op.ml,v 1.7 2004/11/17 09:07:56 mauny Exp $ *) - -open Pcaml; - -type spat_comp = - [ SpTrm of MLast.loc and MLast.patt and option MLast.expr - | SpNtr of MLast.loc and MLast.patt and MLast.expr - | SpStr of MLast.loc and MLast.patt ] -; -type sexp_comp = - [ SeTrm of MLast.loc and MLast.expr | SeNtr of MLast.loc and MLast.expr ] -; - -value strm_n = "strm__"; -value peek_fun _loc = <:expr< Stream.peek >>; -value junk_fun _loc = <:expr< Stream.junk >>; - -(* Parsers. *) -(* In syntax generated, many cases are optimisations. *) - -value rec pattern_eq_expression p e = - match (p, e) with - [ (<:patt< $lid:a$ >>, <:expr< $lid:b$ >>) -> a = b - | (<:patt< $uid:a$ >>, <:expr< $uid:b$ >>) -> a = b - | (<:patt< $p1$ $p2$ >>, <:expr< $e1$ $e2$ >>) -> - pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2 - | _ -> False ] -; - -value is_raise e = - match e with - [ <:expr< raise $_$ >> -> True - | _ -> False ] -; - -value is_raise_failure e = - match e with - [ <:expr< raise Stream.Failure >> -> True - | _ -> False ] -; - -value rec handle_failure e = - match e with - [ <:expr< try $te$ with [ Stream.Failure -> $e$] >> -> - handle_failure e - | <:expr< match $me$ with [ $list:pel$ ] >> -> - handle_failure me && - List.for_all - (fun - [ (_, None, e) -> handle_failure e - | _ -> False ]) - pel - | <:expr< let $list:pel$ in $e$ >> -> - List.for_all (fun (p, e) -> handle_failure e) pel && handle_failure e - | <:expr< $lid:_$ >> | <:expr< $int:_$ >> | <:expr< $str:_$ >> | - <:expr< $chr:_$ >> | <:expr< fun [ $list:_$ ] >> | <:expr< $uid:_$ >> -> - True - | <:expr< raise $e$ >> -> - match e with - [ <:expr< Stream.Failure >> -> False - | _ -> True ] - | <:expr< $f$ $x$ >> -> - is_constr_apply f && handle_failure f && handle_failure x - | _ -> False ] -and is_constr_apply = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $lid:_$ >> -> False - | <:expr< $x$ $_$ >> -> is_constr_apply x - | _ -> False ] -; - -value rec subst v e = - let _loc = MLast.loc_of_expr e in - match e with - [ <:expr< $lid:x$ >> -> - let x = if x = v then strm_n else x in - <:expr< $lid:x$ >> - | <:expr< $uid:_$ >> -> e - | <:expr< $int:_$ >> -> e - | <:expr< $chr:_$ >> -> e - | <:expr< $str:_$ >> -> e - | <:expr< $_$ . $_$ >> -> e - | <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> - <:expr< let $opt:rf$ $list:List.map (subst_pe v) pel$ in $subst v e$ >> - | <:expr< $e1$ $e2$ >> -> <:expr< $subst v e1$ $subst v e2$ >> - | <:expr< ( $list:el$ ) >> -> <:expr< ( $list:List.map (subst v) el$ ) >> - | _ -> raise Not_found ] -and subst_pe v (p, e) = - match p with - [ <:patt< $lid:v'$ >> -> if v = v' then (p, e) else (p, subst v e) - | _ -> raise Not_found ] -; - -value stream_pattern_component skont ckont = - fun - [ SpTrm _loc p wo -> - <:expr< match $peek_fun _loc$ $lid:strm_n$ with - [ Some $p$ $when:wo$ -> - do { $junk_fun _loc$ $lid:strm_n$; $skont$ } - | _ -> $ckont$ ] >> - | SpNtr _loc p e -> - let e = - match e with - [ <:expr< fun [ ($lid:v$ : Stream.t _) -> $e$ ] >> when v = strm_n -> e - | _ -> <:expr< $e$ $lid:strm_n$ >> ] - in - if pattern_eq_expression p skont then - if is_raise_failure ckont then e - else if handle_failure e then e - else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> - else if is_raise_failure ckont then - <:expr< let $p$ = $e$ in $skont$ >> - else if pattern_eq_expression <:patt< Some $p$ >> skont then - <:expr< try Some $e$ with [ Stream.Failure -> $ckont$ ] >> - else if is_raise ckont then - let tst = - if handle_failure e then e - else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> - in - <:expr< let $p$ = $tst$ in $skont$ >> - else - <:expr< match try Some $e$ with [ Stream.Failure -> None ] with - [ Some $p$ -> $skont$ - | _ -> $ckont$ ] >> - | SpStr _loc p -> - try - match p with - [ <:patt< $lid:v$ >> -> subst v skont - | _ -> raise Not_found ] - with - [ Not_found -> <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ] ] -; - -value rec stream_pattern _loc epo e ekont = - fun - [ [] -> - match epo with - [ Some ep -> <:expr< let $ep$ = Stream.count $lid:strm_n$ in $e$ >> - | _ -> e ] - | [(spc, err) :: spcl] -> - let skont = - let ekont err = - let str = - match err with - [ Some estr -> estr - | _ -> <:expr< "" >> ] - in - <:expr< raise (Stream.Error $str$) >> - in - stream_pattern _loc epo e ekont spcl - in - let ckont = ekont err in stream_pattern_component skont ckont spc ] -; - -value stream_patterns_term _loc ekont tspel = - let pel = - List.map - (fun (p, w, _loc, spcl, epo, e) -> - let p = <:patt< Some $p$ >> in - let e = - let ekont err = - let str = - match err with - [ Some estr -> estr - | _ -> <:expr< "" >> ] - in - <:expr< raise (Stream.Error $str$) >> - in - let skont = stream_pattern _loc epo e ekont spcl in - <:expr< do { $junk_fun _loc$ $lid:strm_n$; $skont$ } >> - in - (p, w, e)) - tspel - in - let pel = pel @ [(<:patt< _ >>, None, ekont ())] in - <:expr< match $peek_fun _loc$ $lid:strm_n$ with [ $list:pel$ ] >> -; - -value rec group_terms = - fun - [ [([(SpTrm _loc p w, None) :: spcl], epo, e) :: spel] -> - let (tspel, spel) = group_terms spel in - ([(p, w, _loc, spcl, epo, e) :: tspel], spel) - | spel -> ([], spel) ] -; - -value rec parser_cases _loc = - fun - [ [] -> <:expr< raise Stream.Failure >> - | spel -> - match group_terms spel with - [ ([], [(spcl, epo, e) :: spel]) -> - stream_pattern _loc epo e (fun _ -> parser_cases _loc spel) spcl - | (tspel, spel) -> - stream_patterns_term _loc (fun _ -> parser_cases _loc spel) tspel ] ] -; - -value cparser _loc bpo pc = - let e = parser_cases _loc pc in - let e = - match bpo with - [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >> - | None -> e ] - in - let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in - <:expr< fun $p$ -> $e$ >> -; - -value cparser_match _loc me bpo pc = - let pc = parser_cases _loc pc in - let e = - match bpo with - [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >> - | None -> pc ] - in - <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >> -; - -(* streams *) - -value rec not_computing = - fun - [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $int:_$ >> | - <:expr< $flo:_$ >> | <:expr< $chr:_$ >> | <:expr< $str:_$ >> -> True - | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y - | _ -> False ] -and is_cons_apply_not_computing = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $lid:_$ >> -> False - | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y - | _ -> False ] -; - -value slazy _loc e = - match e with - [ <:expr< $f$ () >> -> - match f with - [ <:expr< $lid:_$ >> -> f - | _ -> <:expr< fun _ -> $e$ >> ] - | _ -> <:expr< fun _ -> $e$ >> ] -; - -value rec cstream gloc = - fun - [ [] -> let _loc = gloc in <:expr< Stream.sempty >> - | [SeTrm _loc e] -> - if not_computing e then <:expr< Stream.ising $e$ >> - else <:expr< Stream.lsing $slazy _loc e$ >> - | [SeTrm _loc e :: secl] -> - if not_computing e then <:expr< Stream.icons $e$ $cstream gloc secl$ >> - else <:expr< Stream.lcons $slazy _loc e$ $cstream gloc secl$ >> - | [SeNtr _loc e] -> - if not_computing e then e else <:expr< Stream.slazy $slazy _loc e$ >> - | [SeNtr _loc e :: secl] -> - if not_computing e then <:expr< Stream.iapp $e$ $cstream gloc secl$ >> - else <:expr< Stream.lapp $slazy _loc e$ $cstream gloc secl$ >> ] -; - -(* Syntax extensions in Ocaml grammar *) - -EXTEND - GLOBAL: expr; - expr: LEVEL "expr1" - [ [ "parser"; po = OPT ipatt; OPT "|"; pcl = LIST1 parser_case SEP "|" -> - <:expr< $cparser _loc po pcl$ >> - | "match"; e = expr; "with"; "parser"; po = OPT ipatt; OPT "|"; - pcl = LIST1 parser_case SEP "|" -> - <:expr< $cparser_match _loc e po pcl$ >> ] ] - ; - parser_case: - [ [ "[<"; sp = stream_patt; ">]"; po = OPT ipatt; "->"; e = expr -> - (sp, po, e) ] ] - ; - stream_patt: - [ [ spc = stream_patt_comp -> [(spc, None)] - | spc = stream_patt_comp; ";" -> [(spc, None)] - | spc = stream_patt_comp; ";"; sp = stream_patt_comp_err_list -> - [(spc, None) :: sp] - | (* empty *) -> [] ] ] - ; - stream_patt_comp_err_list: - [ [ spc = stream_patt_comp_err -> [spc] - | spc = stream_patt_comp_err; ";" -> [spc] - | spc = stream_patt_comp_err; ";"; sp = stream_patt_comp_err_list -> - [spc :: sp] ] ] - ; - stream_patt_comp: - [ [ "'"; p = patt; eo = OPT [ "when"; e = (expr LEVEL "expr1") -> e ] -> - SpTrm _loc p eo - | p = patt; "="; e = (expr LEVEL "expr1") -> SpNtr _loc p e - | p = patt -> SpStr _loc p ] ] - ; - stream_patt_comp_err: - [ [ spc = stream_patt_comp; - eo = OPT [ "??"; e = expr LEVEL "expr1" -> e ] -> (spc, eo) ] ] - ; - ipatt: - [ [ i = LIDENT -> <:patt< $lid:i$ >> - | "_" -> <:patt< _ >> ] ] - ; - - expr: LEVEL "simple" - [ [ "[<"; ">]" -> <:expr< $cstream _loc []$ >> - | "[<"; sel = stream_expr_comp_list; ">]" -> - <:expr< $cstream _loc sel$ >> ] ] - ; - stream_expr_comp_list: - [ [ se = stream_expr_comp; ";"; sel = stream_expr_comp_list -> [se :: sel] - | se = stream_expr_comp; ";" -> [se] - | se = stream_expr_comp -> [se] ] ] - ; - stream_expr_comp: - [ [ "'"; e = expr LEVEL "expr1" -> SeTrm _loc e - | e = expr LEVEL "expr1" -> SeNtr _loc e ] ] - ; -END; diff --git a/camlp4/etc/pa_ru.ml b/camlp4/etc/pa_ru.ml deleted file mode 100644 index 4db5ec9c..00000000 --- a/camlp4/etc/pa_ru.ml +++ /dev/null @@ -1,46 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: pa_ru.ml,v 1.8 2004/11/17 09:07:56 mauny Exp $ *) - -open Pcaml; - -value o2b = - fun - [ Some _ -> True - | None -> False ] -; - -EXTEND - GLOBAL: expr; - expr: LEVEL "top" - [ [ "do"; "{"; seq = sequence; "}" -> - match seq with - [ [e] -> e - | _ -> <:expr< do { $list:seq$ } >> ] ] ] - ; - sequence: - [ [ "let"; o = OPT "rec"; l = LIST1 let_binding SEP "and"; [ "in" | ";" ]; - el = SELF -> - let e = - match el with - [ [e] -> e - | _ -> <:expr< do { $list:el$ } >> ] - in - [<:expr< let $opt:o2b o$ $list:l$ in $e$ >>] - | e = expr; ";"; el = SELF -> - let e = let _loc = MLast.loc_of_expr e in <:expr< ($e$ : unit) >> in - [e :: el] - | e = expr; ";" -> [e] - | e = expr -> [e] ] ] - ; -END; diff --git a/camlp4/etc/parserify.ml b/camlp4/etc/parserify.ml deleted file mode 100644 index d8f85c18..00000000 --- a/camlp4/etc/parserify.ml +++ /dev/null @@ -1,301 +0,0 @@ -(* camlp4r q_MLast.cmo *) -(* $Id: parserify.ml,v 1.3 2004/11/17 09:07:56 mauny Exp $ *) - -value _loc = (Token.nowhere, Token.nowhere); - -type spc = - [ SPCterm of (MLast.patt * option MLast.expr) - | SPCnterm of MLast.patt and MLast.expr - | SPCsterm of MLast.patt ] -; - -exception NotImpl; - -value rec subst v e = - match e with - [ <:expr< $lid:x$ >> -> if x = "strm__" then <:expr< $lid:v$ >> else e - | <:expr< $uid:_$ >> -> e - | <:expr< $int:_$ >> -> e - | <:expr< $chr:_$ >> -> e - | <:expr< $str:_$ >> -> e - | <:expr< $e1$ . $lab$ >> -> <:expr< $subst v e1$ . $lab$ >> - | <:expr< $x$ $y$ >> -> <:expr< $subst v x$ $subst v y$ >> - | <:expr< let $lid:s1$ = $e1$ in $e2$ >> -> - if s1 = v then <:expr< let $lid:s1$ = $subst v e1$ in $e2$ >> - else <:expr< let $lid:s1$ = $subst v e1$ in $subst v e2$ >> - | <:expr< let _ = $e1$ in $e2$ >> -> - <:expr< let _ = $subst v e1$ in $subst v e2$ >> - | <:expr< ($list:el$) >> -> <:expr< ($list:List.map (subst v) el$) >> - | _ -> raise NotImpl ] -; - -value rec is_free v = - fun - [ <:expr< $lid:x$ >> -> x <> v - | <:expr< $uid:_$ >> -> True - | <:expr< $int:_$ >> -> True - | <:expr< $chr:_$ >> -> True - | <:expr< $str:_$ >> -> True - | <:expr< $e$ . $_$ >> -> is_free v e - | <:expr< $x$ $y$ >> -> is_free v x && is_free v y - | <:expr< let $lid:s1$ = $e1$ in $e2$ >> -> - is_free v e1 && (s1 = v || is_free v e2) - | <:expr< let _ = $e1$ in $e2$ >> -> is_free v e1 && is_free v e2 - | <:expr< ($list:el$) >> -> List.for_all (is_free v) el - | _ -> raise NotImpl ] -; - -value gensym = - let cnt = ref 0 in - fun () -> - do { incr cnt; "pr_rp_symb_" ^ string_of_int cnt.val } -; - -value free_var_in_expr c e = - let rec loop_alpha v = - let x = String.make 1 v in - if is_free x e then Some x - else if v = 'z' then None - else loop_alpha (Char.chr (Char.code v + 1)) - in - let rec loop_count cnt = - let x = String.make 1 c ^ string_of_int cnt in - if is_free x e then x else loop_count (succ cnt) - in - try - match loop_alpha c with - [ Some v -> v - | None -> loop_count 1 ] - with - [ NotImpl -> gensym () ] -; - -value parserify = - fun - [ <:expr< $e$ strm__ >> -> e - | e -> <:expr< fun strm__ -> $e$ >> ] -; - -value is_raise_failure = - fun - [ <:expr< raise Stream.Failure >> -> True - | _ -> False ] -; - -value is_raise_error = - fun - [ <:expr< raise (Stream.Error $_$) >> -> True - | _ -> False ] -; - -value semantic e = - try - if is_free "strm__" e then e - else - let v = free_var_in_expr 's' e in - <:expr< let $lid:v$ = strm__ in $subst v e$ >> - with - [ NotImpl -> e ] -; - -value rewrite_parser = - rewrite True where rec rewrite top ge = - match ge with - [ <:expr< let $p$ = try $e$ with [ Stream.Failure -> raise $exc$ ] in - $sp_kont$ >> -> - let f = parserify e in - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> raise $exc$ ] - >> - | <:expr< let $p$ = Stream.count strm__ in $f$ >> -> - try - if is_free "strm__" f then ge - else - let v = free_var_in_expr 's' f in - <:expr< - let $lid:v$ = strm__ in - let $p$ = Stream.count strm__ in $subst v f$ - >> - with - [ NotImpl -> ge ] - | <:expr< let $p$ = strm__ in $e$ >> -> - <:expr< let $p$ = strm__ in $rewrite False e$ >> - | <:expr< let $p$ = $f$ strm__ in $sp_kont$ >> when top -> - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> raise Stream.Failure ] - >> - | <:expr< let $p$ = $e$ in $sp_kont$ >> -> - if match e with - [ <:expr< match try Some $_$ with [ Stream.Failure -> None ] with - [ $list:_$ ] >> - | <:expr< match Stream.peek strm__ with [ $list:_$ ] >> - | <:expr< try $_$ with [ Stream.Failure -> $_$ ] >> - | <:expr< let $_$ = Stream.count strm__ in $_$ >> -> True - | _ -> False ] - then - let f = rewrite True <:expr< fun strm__ -> $e$ >> in - let exc = - if top then <:expr< Stream.Failure >> - else <:expr< Stream.Error "" >> - in - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> raise $exc$ ] - >> - else semantic ge - | <:expr< match try Some $e$ with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> $p_kont$ ] >> -> - let f = parserify e in - if not top && is_raise_failure p_kont then semantic ge - else - let (p, f, sp_kont, p_kont) = - if top || is_raise_error p_kont then - (p, f, rewrite False sp_kont, rewrite top p_kont) - else - let f = - <:expr< - fun strm__ -> - match - try Some ($f$ strm__) with [ Stream.Failure -> None ] - with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> $rewrite top p_kont$ ] - >> - in - (<:patt< a >>, f, <:expr< a >>, - <:expr< raise (Stream.Error "") >>) - in - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> $p_kont$ ] - >> - | <:expr< match Stream.peek strm__ with [ $list:pel$ ] >> -> - let rec iter pel = - match pel with - [ [(<:patt< Some $p$ >>, eo, - <:expr< do { Stream.junk strm__; $sp_kont$ } >>); - (<:patt< _ >>, None, p_kont) :: _] -> - <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:eo$ -> - do { Stream.junk strm__; $rewrite False sp_kont$ } - | _ -> $rewrite top p_kont$ ] - >> - | [(<:patt< Some $p$ >>, eo, - <:expr< do { Stream.junk strm__; $sp_kont$ } >>) :: pel] -> - let p_kont = iter pel in - <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:eo$ -> - do { Stream.junk strm__; $rewrite False sp_kont$ } - | _ -> $p_kont$ ] - >> - | _ -> - <:expr< match Stream.peek strm__ with [ $list:pel$ ] >> ] - in - iter pel - | <:expr< try Some $e$ with [ Stream.Failure -> $p_kont$ ] >> -> - let f = parserify e in - let e = - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some a -> Some a - | _ -> $p_kont$ ] - >> - in - rewrite top e - | <:expr< try $e$ with [ Stream.Failure -> $p_kont$ ] >> -> - let f = parserify e in - let e = - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some a -> a - | _ -> $rewrite top p_kont$ ] - >> - in - rewrite top e - | <:expr< $f$ strm__ >> -> - if top then - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some a -> a - | _ -> raise Stream.Failure ] - >> - else - let v = free_var_in_expr 's' f in - <:expr< let $lid:v$ = strm__ in $subst v f$ $lid:v$ >> - | e -> semantic e ] -; - -value spc_of_parser = - let rec parser_cases e = - match e with - [ <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> $p_kont$ ] - >> -> - let spc = (SPCnterm p f, None) in - let (sp, epo, e) = kont sp_kont in - [([spc :: sp], epo, e) :: parser_cases p_kont] - | <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ } - | _ -> $p_kont$ ] - >> -> - let spc = (SPCterm (p, wo), None) in - let (sp, epo, e) = kont sp_kont in - [([spc :: sp], epo, e) :: parser_cases p_kont] - | <:expr< let $p$ = strm__ in $sp_kont$ >> -> - let spc = (SPCsterm p, None) in - let (sp, epo, e) = kont sp_kont in - [([spc :: sp], epo, e)] - | <:expr< let $p$ = Stream.count strm__ in $e$ >> -> [([], Some p, e)] - | <:expr< raise Stream.Failure >> -> [] - | _ -> [([], None, e)] ] - and kont e = - match e with - [ <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> raise (Stream.Error $err$) ] - >> -> - let err = - match err with - [ <:expr< "" >> -> None - | _ -> Some err ] - in - let spc = (SPCnterm p f, err) in - let (sp, epo, e) = kont sp_kont in - ([spc :: sp], epo, e) - | <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ } - | _ -> raise (Stream.Error $err$) ] - >> -> - let err = - match err with - [ <:expr< "" >> -> None - | _ -> Some err ] - in - let spc = (SPCterm (p, wo), err) in - let (sp, epo, e) = kont sp_kont in - ([spc :: sp], epo, e) - | <:expr< let $p$ = strm__ in $sp_kont$ >> -> - let spc = (SPCsterm p, None) in - let (sp, epo, e) = kont sp_kont in - ([spc :: sp], epo, e) - | <:expr< let $p$ = Stream.count strm__ in $e$ >> -> ([], Some p, e) - | _ -> ([], None, e) ] - in - parser_cases -; - -value parser_of_expr e = spc_of_parser (rewrite_parser e); diff --git a/camlp4/etc/parserify.mli b/camlp4/etc/parserify.mli deleted file mode 100644 index 704a2467..00000000 --- a/camlp4/etc/parserify.mli +++ /dev/null @@ -1,12 +0,0 @@ -(* camlp4r *) -(* $Id: parserify.mli,v 1.1 2003/07/10 12:28:22 michel Exp $ *) - -type spc = - [ SPCterm of (MLast.patt * option MLast.expr) - | SPCnterm of MLast.patt and MLast.expr - | SPCsterm of MLast.patt ] -; - -value parser_of_expr : - MLast.expr -> - list (list (spc * option MLast.expr) * option MLast.patt * MLast.expr); diff --git a/camlp4/etc/pr_depend.ml b/camlp4/etc/pr_depend.ml deleted file mode 100644 index 41f2526d..00000000 --- a/camlp4/etc/pr_depend.ml +++ /dev/null @@ -1,328 +0,0 @@ -(* camlp4r *) -(* $Id: pr_depend.ml,v 1.14 2005/06/29 04:11:26 garrigue Exp $ *) - -open MLast; - -value not_impl name x = - let desc = - if Obj.is_block (Obj.repr x) then - "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) - else "int_val = " ^ string_of_int (Obj.magic x) - in - do { - Printf.eprintf "pr_depend: not impl: %s; %s\n" name desc; flush stderr; - } -; - -module StrSet = - Set.Make (struct type t = string; value compare = compare; end) -; - -value fset = ref StrSet.empty; -value addmodule s = fset.val := StrSet.add s fset.val; - -value list = List.iter; - -value option f = - fun - [ Some x -> f x - | None -> () ] -; - -value longident = - fun - [ [s; _ :: _] -> addmodule s - | _ -> () ] -; - -value rec ctyp = - fun - [ TyAcc _ t _ -> ctyp_module t - | TyAli _ t1 t2 -> do { ctyp t1; ctyp t2; } - | TyApp _ t1 t2 -> do { ctyp t1; ctyp t2; } - | TyAny _ -> () - | TyArr _ t1 t2 -> do { ctyp t1; ctyp t2; } - | TyCls _ li -> longident li - | TyLab _ _ t -> ctyp t - | TyLid _ _ -> () - | TyMan _ t1 t2 -> do { ctyp t1; ctyp t2; } - | TyOlb _ _ t -> ctyp t - | TyQuo _ _ -> () - | TyRec _ ldl -> list label_decl ldl - | TySum _ cdl -> list constr_decl cdl - | TyPrv _ t -> ctyp t - | TyTup _ tl -> list ctyp tl - | TyVrn _ sbtll _ -> list variant sbtll - | x -> not_impl "ctyp" x ] -and constr_decl (_, _, tl) = list ctyp tl -and label_decl (_, _, _, t) = ctyp t -and variant = - fun - [ RfTag _ _ tl -> list ctyp tl - | RfInh t -> ctyp t ] -and ctyp_module = - fun - [ TyAcc _ t _ -> ctyp_module t - | TyApp _ t1 t2 -> do { ctyp t1; ctyp t2; } - | TyUid _ m -> addmodule m - | x -> not_impl "ctyp_module" x ] -; - -value rec patt = - fun - [ PaAcc _ p _ -> patt_module p - | PaAli _ p1 p2 -> do { patt p1; patt p2; } - | PaAny _ -> () - | PaApp _ p1 p2 -> do { patt p1; patt p2; } - | PaArr _ pl -> list patt pl - | PaChr _ _ -> () - | PaInt _ _ -> () - | PaLab _ _ po -> option patt po - | PaLid _ _ -> () - | PaOlb _ _ peoo -> - option (fun (p, eo) -> do { patt p; option expr eo }) peoo - | PaOrp _ p1 p2 -> do { patt p1; patt p2; } - | PaRec _ lpl -> list label_patt lpl - | PaRng _ p1 p2 -> do { patt p1; patt p2; } - | PaStr _ _ -> () - | PaTup _ pl -> list patt pl - | PaTyc _ p t -> do { patt p; ctyp t; } - | PaUid _ _ -> () - | PaVrn _ _ -> () - | x -> not_impl "patt" x ] -and patt_module = - fun - [ PaUid _ m -> addmodule m - | PaAcc _ p _ -> patt_module p - | x -> not_impl "patt_module" x ] -and label_patt (p1, p2) = do { patt p1; patt p2; } -and expr = - fun - [ ExAcc _ e1 e2 -> do { expr_module e1; expr e2; } - | ExApp _ e1 e2 -> do { expr e1; expr e2; } - | ExAre _ e1 e2 -> do { expr e1; expr e2; } - | ExArr _ el -> list expr el - | ExAsf _ -> () - | ExAsr _ e -> do { expr e; } - | ExAss _ e1 e2 -> do { expr e1; expr e2; } - | ExChr _ _ -> () - | ExCoe _ e t1 t2 -> do { expr e; option ctyp t1; ctyp t2 } - | ExFor _ _ e1 e2 _ el -> do { expr e1; expr e2; list expr el; } - | ExFun _ pwel -> list match_case pwel - | ExIfe _ e1 e2 e3 -> do { expr e1; expr e2; expr e3; } - | ExInt _ _ -> () - | ExInt32 _ _ -> () - | ExInt64 _ _ -> () - | ExNativeInt _ _ -> () - | ExFlo _ _ -> () - | ExLab _ _ eo -> option expr eo - | ExLaz _ e -> expr e - | ExLet _ _ pel e -> do { list let_binding pel; expr e; } - | ExLid _ _ -> () - | ExLmd _ _ me e -> do { module_expr me; expr e; } - | ExMat _ e pwel -> do { expr e; list match_case pwel; } - | ExNew _ li -> longident li - | ExOlb _ _ eo -> option expr eo - | ExRec _ lel w -> do { list label_expr lel; option expr w; } - | ExSeq _ el -> list expr el - | ExSnd _ e _ -> expr e - | ExSte _ e1 e2 -> do { expr e1; expr e2; } - | ExStr _ _ -> () - | ExTry _ e pwel -> do { expr e; list match_case pwel; } - | ExTup _ el -> list expr el - | ExTyc _ e t -> do { expr e; ctyp t; } - | ExUid _ _ -> () - | ExVrn _ _ -> () - | ExWhi _ e el -> do { expr e; list expr el; } - | x -> not_impl "expr" x ] -and expr_module = - fun - [ ExUid _ m -> addmodule m - | e -> expr e ] -and let_binding (p, e) = do { patt p; expr e } -and label_expr (p, e) = do { patt p; expr e } -and match_case (p, w, e) = do { patt p; option expr w; expr e; } -and module_type = - fun - [ MtAcc _ (MtUid _ m) _ -> addmodule m - | MtFun _ _ mt1 mt2 -> do { module_type mt1; module_type mt2; } - | MtSig _ sil -> list sig_item sil - | MtUid _ _ -> () - | MtWit _ mt wc -> do { module_type mt; list with_constr wc; } - | x -> not_impl "module_type" x ] -and with_constr = - fun - [ WcTyp _ _ _ t -> ctyp t - | x -> not_impl "with_constr" x ] -and sig_item = - fun - [ SgDcl _ sil -> list sig_item sil - | SgExc _ _ tl -> list ctyp tl - | SgExt _ _ t _ -> ctyp t - | SgMod _ _ mt -> module_type mt - | SgRecMod _ mts -> list (fun (_, mt) -> module_type mt) mts - | SgMty _ _ mt -> module_type mt - | SgOpn _ [s :: _] -> addmodule s - | SgTyp _ tdl -> list type_decl tdl - | SgVal _ _ t -> ctyp t - | x -> not_impl "sig_item" x ] -and module_expr = - fun - [ MeAcc _ (MeUid _ m) _ -> addmodule m - | MeApp _ me1 me2 -> do { module_expr me1; module_expr me2; } - | MeFun _ _ mt me -> do { module_type mt; module_expr me; } - | MeStr _ sil -> list str_item sil - | MeTyc _ me mt -> do { module_expr me; module_type mt; } - | MeUid _ _ -> () - | x -> not_impl "module_expr" x ] -and str_item = - fun - [ StCls _ cil -> list (fun ci -> class_expr ci.ciExp) cil - | StDcl _ sil -> list str_item sil - | StDir _ _ _ -> () - | StExc _ _ tl _ -> list ctyp tl - | StExp _ e -> expr e - | StExt _ _ t _ -> ctyp t - | StMod _ _ me -> module_expr me - | StRecMod _ nmtmes -> list (fun (_, mt, me) -> do { module_expr me; module_type mt; }) nmtmes - | StMty _ _ mt -> module_type mt - | StOpn _ [s :: _] -> addmodule s - | StTyp _ tdl -> list type_decl tdl - | StVal _ _ pel -> list let_binding pel - | x -> not_impl "str_item" x ] -and type_decl (_, _, t, _) = ctyp t -and class_expr = - fun - [ CeApp _ ce e -> do { class_expr ce; expr e; } - | CeCon _ li tl -> do { longident li; list ctyp tl; } - | CeFun _ p ce -> do { patt p; class_expr ce; } - | CeLet _ _ pel ce -> do { list let_binding pel; class_expr ce; } - | CeStr _ po csil -> do { option patt po; list class_str_item csil; } - | x -> not_impl "class_expr" x ] -and class_str_item = - fun - [ CrInh _ ce _ -> class_expr ce - | CrIni _ e -> expr e - | CrMth _ _ _ e None -> expr e - | CrMth _ _ _ e (Some t) -> do { expr e; ctyp t } - | CrVal _ _ _ e -> expr e - | CrVir _ _ _ t -> ctyp t - | x -> not_impl "class_str_item" x ] -; - -(* Print dependencies *) - -value load_path = ref [""]; - -value find_in_path path name = - if not (Filename.is_implicit name) then - if Sys.file_exists name then name else raise Not_found - else - let rec try_dir = - fun - [ [] -> raise Not_found - | [dir :: rem] -> - let fullname = Filename.concat dir name in - if Sys.file_exists fullname then fullname else try_dir rem ] - in - try_dir path -; - -value find_depend modname (byt_deps, opt_deps) = - let name = String.uncapitalize modname in - try - let filename = find_in_path load_path.val (name ^ ".mli") in - let basename = Filename.chop_suffix filename ".mli" in - let byt_dep = basename ^ ".cmi" in - let opt_dep = - if Sys.file_exists (basename ^ ".ml") then basename ^ ".cmx" - else basename ^ ".cmi" - in - ([byt_dep :: byt_deps], [opt_dep :: opt_deps]) - with - [ Not_found -> - try - let filename = find_in_path load_path.val (name ^ ".ml") in - let basename = Filename.chop_suffix filename ".ml" in - ([basename ^ ".cmo" :: byt_deps], [basename ^ ".cmx" :: opt_deps]) - with - [ Not_found -> (byt_deps, opt_deps) ] ] -; - -value (depends_on, escaped_eol) = - match Sys.os_type with - [ "Unix" | "Win32" | "Cygwin" -> (": ", "\\\n ") - | "MacOS" -> ("\196 ", "\182\n ") - | _ -> assert False ] -; - -value print_depend target_file deps = - match deps with - [ [] -> () - | _ -> - do { - print_string target_file; - print_string depends_on; - let rec print_items pos = - fun - [ [] -> print_string "\n" - | [dep :: rem] -> - if pos + String.length dep <= 77 then do { - print_string dep; - print_string " "; - print_items (pos + String.length dep + 1) rem - } - else do { - print_string escaped_eol; - print_string dep; - print_string " "; - print_items (String.length dep + 5) rem - } ] - in - print_items (String.length target_file + 2) deps - } ] -; - -(* Main *) - -value depend_sig ast = - do { - fset.val := StrSet.empty; - List.iter (fun (si, _) -> sig_item si) ast; - let basename = Filename.chop_suffix Pcaml.input_file.val ".mli" in - let (byt_deps, opt_deps) = StrSet.fold find_depend fset.val ([], []) in - print_depend (basename ^ ".cmi") byt_deps; - } -; - -value depend_str ast = - do { - fset.val := StrSet.empty; - List.iter (fun (si, _) -> str_item si) ast; - let basename = - if Filename.check_suffix Pcaml.input_file.val ".ml" then - Filename.chop_suffix Pcaml.input_file.val ".ml" - else - try - let len = String.rindex Pcaml.input_file.val '.' in - String.sub Pcaml.input_file.val 0 len - with - [ Failure _ | Not_found -> Pcaml.input_file.val ] - in - let init_deps = - if Sys.file_exists (basename ^ ".mli") then - let cmi_name = basename ^ ".cmi" in ([cmi_name], [cmi_name]) - else ([], []) - in - let (byt_deps, opt_deps) = StrSet.fold find_depend fset.val init_deps in - print_depend (basename ^ ".cmo") byt_deps; - print_depend (basename ^ ".cmx") opt_deps; - } -; - -Pcaml.print_interf.val := depend_sig; -Pcaml.print_implem.val := depend_str; - -Pcaml.add_option "-I" - (Arg.String (fun dir -> load_path.val := load_path.val @ [dir])) - " Add to the list of include directories."; diff --git a/camlp4/etc/pr_extend.ml b/camlp4/etc/pr_extend.ml deleted file mode 100644 index 75e5d821..00000000 --- a/camlp4/etc/pr_extend.ml +++ /dev/null @@ -1,516 +0,0 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: pr_extend.ml,v 1.14 2004/11/17 09:07:56 mauny Exp $ *) - -open Pcaml; -open Spretty; - -value no_slist = ref False; - -value expr e dg k = pr_expr.pr_fun "top" e dg k; -value patt e dg k = pr_patt.pr_fun "top" e dg k; - -(* Utilities *) - -value rec list elem el k = - match el with - [ [] -> k - | [x] -> [: `elem x k :] - | [x :: l] -> [: `elem x [: :]; list elem l k :] ] -; - -value rec listws elem sep el k = - match el with - [ [] -> k - | [x] -> [: `elem x k :] - | [x :: l] -> [: `elem x [: `sep :]; listws elem sep l k :] ] -; - -value rec listwbws elem b sep el dg k = - match el with - [ [] -> [: b; k :] - | [x] -> [: `elem b x dg k :] - | [x :: l] -> - let sdg = - match sep with - [ S _ x -> x - | _ -> "" ] - in - [: `elem b x sdg [: :]; listwbws elem [: `sep :] sep l dg k :] ] -; - -(* Extracting *) - -value rec get_globals = - fun - [ [(<:patt< _ >>, <:expr< ($e$ : $uid:gmod1$.Entry.e '$_$) >>) :: pel] -> - let (gmod, gl) = get_globals pel in - if gmod = "" || gmod = gmod1 then (gmod1, [e :: gl]) - else raise Not_found - | [] -> ("", []) - | _ -> raise Not_found ] -; - -value rec get_locals = - fun - [ [(<:patt< $_$ >>, - <:expr< (grammar_entry_create $_$ : $_$) >>) :: pel] -> - get_locals pel - | [] -> () - | _ -> raise Not_found ] -; - -value unposition = - fun - [ <:expr< None >> -> None - | <:expr< Some Gramext.First >> -> Some Gramext.First - | <:expr< Some Gramext.Last >> -> Some Gramext.Last - | <:expr< Some (Gramext.Before $str:s$) >> -> Some (Gramext.Before s) - | <:expr< Some (Gramext.After $str:s$) >> -> Some (Gramext.After s) - | <:expr< Some (Gramext.Level $str:s$) >> -> Some (Gramext.Level s) - | _ -> raise Not_found ] -; - -value unlabel = - fun - [ <:expr< None >> -> None - | <:expr< Some $str:s$ >> -> Some s - | _ -> raise Not_found ] -; - -value unassoc = - fun - [ <:expr< None >> -> None - | <:expr< Some Gramext.NonA >> -> Some Gramext.NonA - | <:expr< Some Gramext.LeftA >> -> Some Gramext.LeftA - | <:expr< Some Gramext.RightA >> -> Some Gramext.RightA - | _ -> raise Not_found ] -; - -value rec unaction = - fun - [ <:expr< fun ($lid:locp$ : (Lexing.position * Lexing.position)) -> ($a$ : $_$) >> - when locp = Stdpp.loc_name.val -> - let ao = - match a with - [ <:expr< () >> -> None - | _ -> Some a ] - in - ([], ao) - | <:expr< fun ($p$ : $_$) -> $e$ >> -> - let (pl, a) = unaction e in ([p :: pl], a) - | <:expr< fun _ -> $e$ >> -> - let (pl, a) = unaction e in - (let _loc = (Token.nowhere, Token.nowhere) in [<:patt< _ >> :: pl], a) - | _ -> raise Not_found ] -; - -value untoken = - fun - [ <:expr< ($str:x$, $str:y$) >> -> (x, y) - | _ -> raise Not_found ] -; - -type symbol = - [ Snterm of MLast.expr - | Snterml of MLast.expr and string - | Slist0 of symbol - | Slist0sep of symbol and symbol - | Slist1 of symbol - | Slist1sep of symbol and symbol - | Sopt of symbol - | Sself - | Snext - | Stoken of Token.pattern - | Srules of list (list (option MLast.patt * symbol) * option MLast.expr) ] -; - -value rec unsymbol = - fun - [ <:expr< Gramext.Snterm ($uid:_$.Entry.obj ($e$ : $_$)) >> -> Snterm e - | <:expr< Gramext.Snterml ($uid:_$.Entry.obj ($e$ : $_$)) $str:s$ >> -> - Snterml e s - | <:expr< Gramext.Snterml ($uid:_$.Entry.obj ($e$ : $_$), $str:s$) >> -> - Snterml e s - | <:expr< Gramext.Slist0 $e$ >> -> Slist0 (unsymbol e) - | <:expr< Gramext.Slist0sep $e1$ $e2$ >> -> - Slist0sep (unsymbol e1) (unsymbol e2) - | <:expr< Gramext.Slist0sep ($e1$, $e2$) >> -> - Slist0sep (unsymbol e1) (unsymbol e2) - | <:expr< Gramext.Slist1 $e$ >> -> Slist1 (unsymbol e) - | <:expr< Gramext.Slist1sep $e1$ $e2$ >> -> - Slist1sep (unsymbol e1) (unsymbol e2) - | <:expr< Gramext.Slist1sep ($e1$, $e2$) >> -> - Slist1sep (unsymbol e1) (unsymbol e2) - | <:expr< Gramext.Sopt $e$ >> -> Sopt (unsymbol e) - | <:expr< Gramext.Sself >> -> Sself - | <:expr< Gramext.Snext >> -> Snext - | <:expr< Gramext.Stoken $e$ >> -> Stoken (untoken e) - | <:expr< Gramext.srules $e$ >> -> Srules (unrule_list [] e) - | _ -> raise Not_found ] -and unpsymbol_list pl e = - match (pl, e) with - [ ([], <:expr< [] >>) -> [] - | ([p :: pl], <:expr< [$e$ :: $el$] >>) -> - let op = - match p with - [ <:patt< _ >> -> None - | _ -> Some p ] - in - [(op, unsymbol e) :: unpsymbol_list pl el] - | _ -> raise Not_found ] -and unrule = - fun - [ <:expr< ($e1$, Gramext.action $e2$) >> -> - let (pl, a) = - match unaction e2 with - [ ([], None) -> let _loc = (Token.nowhere, Token.nowhere) in ([], Some <:expr< () >>) - | x -> x ] - in - let sl = unpsymbol_list (List.rev pl) e1 in - (sl, a) - | _ -> raise Not_found ] -and unrule_list rl = - fun - [ <:expr< [$e$ :: $el$] >> -> unrule_list [unrule e :: rl] el - | <:expr< [] >> -> rl - | _ -> raise Not_found ] -; - -value unlevel = - fun - [ <:expr< ($e1$, $e2$, $e3$) >> -> - (unlabel e1, unassoc e2, unrule_list [] e3) - | _ -> raise Not_found ] -; - -value rec unlevel_list = - fun - [ <:expr< [$e$ :: $el$] >> -> [unlevel e :: unlevel_list el] - | <:expr< [] >> -> [] - | _ -> raise Not_found ] -; - -value unentry = - fun - [ <:expr< (Grammar.Entry.obj ($e$ : Grammar.Entry.e '$_$), $pos$, $ll$) >> -> - (e, unposition pos, unlevel_list ll) - | _ -> raise Not_found ] -; - -value rec unentry_list = - fun - [ <:expr< [$e$ :: $el$] >> -> [unentry e :: unentry_list el] - | <:expr< [] >> -> [] - | _ -> raise Not_found ] -; - -value unextend_body e = - let ((_, globals), e) = - match e with - [ <:expr< let $list:pel$ in $e1$ >> -> - try (get_globals pel, e1) with - [ Not_found -> (("", []), e) ] - | _ -> (("", []), e) ] - in - let e = - match e with - [ <:expr< - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry $_$) s - in - $e$ >> -> - let e = - match e with - [ <:expr< let $list:pel$ in $e1$ >> -> - try let _ = get_locals pel in e1 with - [ Not_found -> e ] - | _ -> e ] - in - e - | _ -> e ] - in - let el = unentry_list e in - (globals, el) -; - -value ungextend_body e = - let e = - match e with - [ <:expr< - let grammar_entry_create = Gram.Entry.create in - let $list:ll$ in $e$ - >> -> - let _ = get_locals ll in e - | _ -> e ] - in - match e with - [ <:expr< do { $list:el$ } >> -> - List.map - (fun - [ <:expr< $uid:_$.extend ($e$ : $uid:_$.Entry.e '$_$) $pos$ $ll$ >> -> - (e, unposition pos, unlevel_list ll) - | _ -> raise Not_found ]) - el - | _ -> raise Not_found ] -; - -(* Printing *) - -value ident s k = HVbox [: `S LR s; k :]; -value string s k = HVbox [: `S LR ("\"" ^ s ^ "\""); k :]; - -value position = - fun - [ None -> [: :] - | Some Gramext.First -> [: `S LR "FIRST" :] - | Some Gramext.Last -> [: `S LR "LAST" :] - | Some (Gramext.Before s) -> [: `S LR "BEFORE"; `string s [: :] :] - | Some (Gramext.After s) -> [: `S LR "AFTER"; `string s [: :] :] - | Some (Gramext.Level s) -> [: `S LR "LEVEL"; `string s [: :] :] ] -; - -value action expr a dg k = - expr a dg k -; - -value token (con, prm) k = - if con = "" then string prm k - else if prm = "" then HVbox [: `S LR con; k :] - else HVbox [: `S LR con; `string prm k :] -; - -value simplify_rules rl = - try - List.map - (fun - [ ([(Some <:patt< $lid:x$ >>, s)], Some <:expr< $lid:y$ >>) -> - if x = y then ([(None, s)], None) else raise Exit - | ([], _) as r -> r - | _ -> raise Exit ]) - rl - with - [ Exit -> rl ] -; - -value rec symbol s k = - match s with - [ Snterm e -> expr e "" k - | Snterml e s -> HVbox [: `expr e "" [: :]; `S LR "LEVEL"; `string s k :] - | Slist0 s -> HVbox [: `S LR "LIST0"; `symbol s k :] - | Slist0sep s sep -> - HVbox - [: `S LR "LIST0"; `symbol s [: :]; `S LR "SEP"; - `symbol sep k :] - | Slist1 s -> HVbox [: `S LR "LIST1"; `symbol s k :] - | Slist1sep s sep -> - HVbox - [: `S LR "LIST1"; `symbol s [: :]; `S LR "SEP"; - `symbol sep k :] - | Sopt s -> HVbox [: `S LR "OPT"; `symbol s k :] - | Sself -> HVbox [: `S LR "SELF"; k :] - | Snext -> HVbox [: `S LR "NEXT"; k :] - | Stoken tok -> token tok k - | Srules - [([(Some <:patt< a >>, Snterm <:expr< a_list >>)], Some <:expr< a >>); - ([(Some <:patt< a >>, - ((Slist0 _ | Slist1 _ | Slist0sep _ _ | Slist1sep _ _) as s))], - Some <:expr< Qast.List a >>)] - when not no_slist.val - -> - match s with - [ Slist0 s -> HVbox [: `S LR "SLIST0"; `simple_symbol s k :] - | Slist1 s -> HVbox [: `S LR "SLIST1"; `simple_symbol s k :] - | Slist0sep s sep -> - HVbox - [: `S LR "SLIST0"; `simple_symbol s [: :]; `S LR "SEP"; - `symbol sep k :] - | Slist1sep s sep -> - HVbox - [: `S LR "SLIST1"; `simple_symbol s [: :]; `S LR "SEP"; - `simple_symbol sep k :] - | _ -> assert False ] - | Srules - [([(Some <:patt< a >>, Snterm <:expr< a_opt >>)], Some <:expr< a >>); - ([(Some <:patt< a >>, Sopt s)], Some <:expr< Qast.Option a >>)] - when not no_slist.val - -> - let s = - match s with - [ Srules - [([(Some <:patt< x >>, Stoken ("", str))], - Some <:expr< Qast.Str x >>)] -> - Stoken ("", str) - | s -> s ] - in - HVbox [: `S LR "SOPT"; `simple_symbol s k :] - | Srules rl -> - let rl = simplify_rules rl in - HVbox [: `HVbox [: :]; rule_list rl k :] ] -and simple_symbol s k = - match s with - [ Snterml _ _ -> HVbox [: `S LO "("; `symbol s [: `S RO ")"; k :] :] - | s -> symbol s k ] -and psymbol (p, s) k = - match p with - [ None -> symbol s k - | Some p -> HVbox [: `patt p "" [: `S LR "=" :]; `symbol s k :] ] -and psymbol_list sl k = - listws psymbol (S RO ";") sl k -and rule b (sl, a) dg k = - match a with - [ None -> HVbox [: b; `HOVbox [: psymbol_list sl k :] :] - | Some a -> - HVbox - [: b; - `HOVbox - [: `HOVbox - [: `HVbox [: :]; - psymbol_list sl [: `S LR "->" :] :]; - `action expr a dg k :] :] ] -and rule_list ll k = - listwbws rule [: `S LR "[" :] (S LR "|") ll "" - [: `S LR "]"; k :] -; - -value label = - fun - [ Some s -> [: `S LR ("\"" ^ s ^ "\"") :] - | None -> [: :] ] -; - -value intloc loc = ((fst loc).Lexing.pos_cnum, (snd loc).Lexing.pos_cnum); - -value assoc = - fun - [ Some Gramext.NonA -> [: `S LR "NONA" :] - | Some Gramext.LeftA -> [: `S LR "LEFTA" :] - | Some Gramext.RightA -> [: `S LR "RIGHTA" :] - | None -> [: :] ] -; - -value level b (lab, ass, rl) dg k = - let s = - if rl = [] then [: `S LR "[ ]"; k :] - else [: `Vbox [: `HVbox [: :]; rule_list rl k :] :] - in - match (lab, ass) with - [ (None, None) -> HVbox [: b; s :] - | _ -> - Vbox - [: `HVbox [: b; label lab; assoc ass :]; - `HVbox [: `HVbox [: :]; s :] :] ] -; - -value level_list ll k = - Vbox - [: `HVbox [: :]; - listwbws level [: `S LR "[" :] (S LR "|") ll "" - [: `S LR "]"; k :] :] -; - -value entry (e, pos, ll) k = - BEbox - [: `LocInfo (intloc(MLast.loc_of_expr e)) - (HVbox [: `expr e "" [: `S RO ":" :]; position pos :]); - `level_list ll [: :]; - `HVbox [: `S RO ";"; k :] :] -; - -value entry_list el k = - Vbox [: `HVbox [: :]; list entry el k :] -; - -value extend_body (globals, e) k = - let s = entry_list e k in - match globals with - [ [] -> s - | sl -> - HVbox - [: `HVbox [: :]; - `HOVbox - [: `S LR "GLOBAL"; `S RO ":"; - list (fun e k -> HVbox [: `expr e "" k :]) sl - [: `S RO ";" :] :]; - `s :] ] -; - -value extend e dg k = - match e with - [ <:expr< Grammar.extend $e$ >> -> - try - let ex = unextend_body e in - BEbox - [: `S LR "EXTEND"; `extend_body ex [: :]; - `HVbox [: `S LR "END"; k :] :] - with - [ Not_found -> - HVbox - [: `S LR "Grammar.extend"; - `HOVbox - [: `S LO "("; - `expr e "" [: `HVbox [: `S RO ")"; k :] :] :] :] ] - | _ -> expr e "" k ] -; - -value get_gextend = - fun - [ <:expr< let $list:gl$ in $e$ >> -> - try - let (gmod, gl) = get_globals gl in - let el = ungextend_body e in - Some (gmod, gl, el) - with - [ Not_found -> None ] - | _ -> None ] -; - -value gextend e dg k = - match get_gextend e with - [ Some (gmod, gl, el) -> - BEbox - [: `HVbox [: `S LR "GEXTEND"; `S LR gmod :]; - `extend_body (gl, el) [: :]; - `HVbox [: `S LR "END"; k :] :] - | None -> expr e "" k ] -; - -value is_gextend e = get_gextend e <> None; - -(* Printer extensions *) - -let lev = - try find_pr_level "expr1" pr_expr.pr_levels with - [ Failure _ -> find_pr_level "top" pr_expr.pr_levels ] -in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< let $list:_$ in $_$ >> as e when is_gextend e -> - fun curr next _ k -> [: `next e "" k :] ]; - -let lev = find_pr_level "apply" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Grammar.extend $_$ >> as e -> - fun curr next _ k -> [: `next e "" k :] ]; - -let lev = find_pr_level "simple" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Grammar.extend $_$ >> as e -> - fun curr next _ k -> [: `extend e "" k :] - | <:expr< let $list:_$ in $_$ >> as e when is_gextend e -> - fun curr next _ k -> [: `gextend e "" k :] ]; - -Pcaml.add_option "-no_slist" (Arg.Set no_slist) - "Don't reconstruct SLIST and SOPT"; diff --git a/camlp4/etc/pr_extfun.ml b/camlp4/etc/pr_extfun.ml deleted file mode 100644 index c41c20af..00000000 --- a/camlp4/etc/pr_extfun.ml +++ /dev/null @@ -1,92 +0,0 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(* $Id: pr_extfun.ml,v 1.4 2004/11/17 09:07:56 mauny Exp $ *) - -open Pcaml; -open Spretty; - -value _loc = (Token.nowhere, Token.nowhere); - -value expr e dg k = pr_expr.pr_fun "top" e dg k; -value patt e dg k = pr_patt.pr_fun "top" e dg k; - -value rec un_extfun rpel = - fun - [ <:expr< [ ($_$, $_$, fun [ $list:pel$ ]) :: $el$ ] >> -> - let (p, wo, e) = - match pel with - [ [(p, wo, <:expr< Some $e$ >>); - (<:patt< _ >>, None, <:expr< None >>)] -> - (p, wo, e) - | [(p, wo, <:expr< Some $e$ >>)] -> (p, wo, e) - | _ -> raise Not_found ] - in - let rpel = - match rpel with - [ [(p1, wo1, e1) :: pel] -> - if wo1 = wo && e1 = e then - let p = - match (p1, p) with - [ (<:patt< ($x1$ as $x2$) >>, <:patt< ($y1$ as $y2$) >>) -> - if x2 = y2 then <:patt< ($x1$ | $y1$ as $x2$) >> - else <:patt< $p1$ | $p$ >> - | _ -> <:patt< $p1$ | $p$ >> ] - in - [(p, wo, e) :: pel] - else [(p, wo, e) :: rpel] - | [] -> [(p, wo, e)] ] - in - un_extfun rpel el - | <:expr< [] >> -> List.rev rpel - | _ -> raise Not_found ] -; - -value rec listwbws elem b sep el k = - match el with - [ [] -> [: b; k :] - | [x] -> [: `elem b x k :] - | [x :: l] -> [: `elem b x [: :]; listwbws elem [: `sep :] sep l k :] ] -; - -value rec match_assoc_list pwel k = - match pwel with - [ [pwe] -> match_assoc [: `S LR "[" :] pwe [: `S LR "]"; k :] - | pel -> - Vbox - [: `HVbox [: :]; - listwbws match_assoc [: `S LR "[" :] (S LR "|") pel - [: `S LR "]"; k :] :] ] -and match_assoc b (p, w, e) k = - let s = - let (p, k) = - match p with - [ <:patt< ($p$ as $p2$) >> -> (p, [: `S LR "as"; `patt p2 "" [: :] :]) - | _ -> (p, [: :]) ] - in - match w with - [ Some e1 -> - [: `HVbox - [: `HVbox [: :]; `patt p "" k; - `HVbox [: `S LR "when"; `expr e1 "" [: `S LR "->" :] :] :] :] - | _ -> [: `patt p "" [: k; `S LR "->" :] :] ] - in - HVbox [: b; `HVbox [: `HVbox s; `expr e "" k :] :] -; - -let lev = find_pr_level "top" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Extfun.extend $e$ $list$ >> as ge -> - fun curr next dg k -> - try - let pel = un_extfun [] list in - [: `HVbox [: :]; - `BEbox [: `S LR "extfun"; `expr e "" [: :]; `S LR "with" :]; - `match_assoc_list pel k :] - with - [ Not_found -> [: `next ge dg k :] ] ]; - -let lev = find_pr_level "apply" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Extfun.extend $e$ $list$ >> as ge -> - fun curr next dg k -> [: `next ge dg k :] ]; diff --git a/camlp4/etc/pr_null.ml b/camlp4/etc/pr_null.ml deleted file mode 100644 index e8ed06a7..00000000 --- a/camlp4/etc/pr_null.ml +++ /dev/null @@ -1,16 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: pr_null.ml,v 1.2 2002/07/19 14:53:46 mauny Exp $ *) - -Pcaml.print_interf.val := fun _ -> (); -Pcaml.print_implem.val := fun _ -> (); diff --git a/camlp4/etc/pr_o.ml b/camlp4/etc/pr_o.ml deleted file mode 100644 index ab78e728..00000000 --- a/camlp4/etc/pr_o.ml +++ /dev/null @@ -1,2056 +0,0 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: pr_o.ml,v 1.49.2.2 2006/01/05 10:44:21 mauny Exp $ *) - -open Pcaml; -open Spretty; -open Stdpp; - -value no_ss = ref True; - -value not_impl name x = - let desc = - if Obj.is_block (Obj.repr x) then - "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) - else "int_val = " ^ string_of_int (Obj.magic x) - in - HVbox [: `S NO ("") :] -; - -value apply_it l f = - apply_it_f l where rec apply_it_f = - fun - [ [] -> f - | [a :: l] -> a (apply_it_f l) ] -; - -value rec list elem = - fun - [ [] -> fun _ k -> k - | [x] -> fun dg k -> [: `elem x dg k :] - | [x :: l] -> fun dg k -> [: `elem x "" [: :]; list elem l dg k :] ] -; - -value rec listws elem sep el dg k = - match el with - [ [] -> k - | [x] -> [: `elem x dg k :] - | [x :: l] -> - let sdg = - match sep with - [ S _ x -> x - | _ -> "" ] - in - [: `elem x sdg [: `sep :]; listws elem sep l dg k :] ] -; - -value rec listwbws elem b sep el dg k = - match el with - [ [] -> [: b; k :] - | [x] -> [: `elem b x dg k :] - | [x :: l] -> - let sdg = - match sep with - [ S _ x -> x - | _ -> "" ] - in - [: `elem b x sdg [: :]; listwbws elem [: `sep :] sep l dg k :] ] -; - -value level box elem next e dg k = - let rec curr e dg k = elem curr next e dg k in - box (curr e dg k) -; - -value is_infix = - let infixes = Hashtbl.create 73 in - do { - List.iter (fun s -> Hashtbl.add infixes s True) - ["=="; "!="; "+"; "+."; "-"; "-."; "*"; "*."; "/"; "/."; "**"; "**."; - "="; "=."; "<>"; "<>."; "<"; "<."; ">"; ">."; "<="; "<=."; ">="; ">=."; - "^"; "@"; "asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; - "&&"; "||"; "~-"; "~-."]; - fun s -> try Hashtbl.find infixes s with [ Not_found -> False ] - } -; - -value is_keyword = - let keywords = Hashtbl.create 301 in - do { - List.iter (fun s -> Hashtbl.add keywords s True) - ["!"; "!="; "#"; "$"; "%"; "&"; "&&"; "'"; "("; ")"; "*"; "**"; "+"; - ","; "-"; "-."; "->"; "."; ".."; "/"; ":"; "::"; ":="; ":>"; ";"; ";;"; - "<"; "<-"; "<="; "<>"; "="; "=="; ">"; ">="; ">]"; ">}"; "?"; "??"; - "@"; "["; "[<"; "[|"; "]"; "^"; "_"; "`"; "and"; "as"; "assert"; "asr"; - "begin"; "class"; "constraint"; "do"; "done"; "downto"; "else"; "end"; - "exception"; "external"; "false"; "for"; "fun"; "function"; "functor"; - "if"; "in"; "include"; "inherit"; "initializer"; "land"; "lazy"; "let"; - "lor"; "lsl"; "lsr"; "lxor"; "match"; "method"; "mod"; "module"; - "mutable"; "new"; "object"; "of"; "open"; "or"; "parser"; "private"; - "rec"; "sig"; "struct"; "then"; "to"; "true"; "try"; "type"; "val"; - "virtual"; "when"; "while"; "with"; "{"; "{<"; "|"; "|]"; "||"; "}"; - "~"; "~-"; "~-."]; - fun s -> try Hashtbl.find keywords s with [ Not_found -> False ] - } -; - -value has_special_chars v = - match v.[0] with - [ 'a'..'z' | 'A'..'Z' | '\192'..'\214' | '\216'..'\246' | '\248'..'\255' | - '_' -> - False - | _ -> - if String.length v >= 2 && v.[0] == '<' && - (v.[1] == '<' || v.[1] == ':') - then - False - else True ] -; - -value var_escaped v = - if v = "" then "$lid:\"\"$" else - if v = "val" then "contents" else - if has_special_chars v || is_infix v then "( " ^ v ^ " )" else - if is_keyword v then v ^ "__" - else v -; - -value flag n f = if f then [: `S LR n :] else [: :]; - -value conv_con = - fun - [ "True" -> "true" - | "False" -> "false" - | " True" -> "True" - | " False" -> "False" - | x -> x ] -; - -value conv_lab = var_escaped; - -(* default global loc *) - -value _loc = (Token.nowhere, Token.nowhere); - -value id_var s = - if has_special_chars s || is_infix s then - HVbox [: `S LR "("; `S LR s; `S LR ")" :] - else if s = "val" then HVbox [: `S LR "contents" :] - else if s = "contents" then HVbox [: `S LR "contents__" :] - else if is_keyword s then HVbox [: `S LR (s ^ "__") :] - else HVbox [: `S LR s :] -; - -value virtual_flag = - fun - [ True -> [: `S LR "virtual" :] - | _ -> [: :] ] -; - -value rec_flag = - fun - [ True -> [: `S LR "rec" :] - | _ -> [: :] ] -; - -(* extensible printers *) - -value sig_item x dg k = - let k = if no_ss.val then k else [: `S RO ";;"; k :] in - pr_sig_item.pr_fun "top" x "" k -; -value str_item x dg k = - let k = if no_ss.val then k else [: `S RO ";;"; k :] in - pr_str_item.pr_fun "top" x "" k -; -value module_type e k = pr_module_type.pr_fun "top" e "" k; -value module_expr e dg k = pr_module_expr.pr_fun "top" e "" k; -value expr e dg k = pr_expr.pr_fun "top" e dg k; -value patt e dg k = pr_patt.pr_fun "top" e dg k; -value expr1 e dg k = pr_expr.pr_fun "expr1" e dg k; -value simple_expr e dg k = pr_expr.pr_fun "simple" e dg k; -value patt1 e dg k = pr_patt.pr_fun "patt1" e dg k; -value simple_patt e dg k = pr_patt.pr_fun "simple" e dg k; -value ctyp e dg k = pr_ctyp.pr_fun "top" e dg k; -value simple_ctyp e dg k = pr_ctyp.pr_fun "simple" e dg k; -value expr_fun_args ge = Extfun.apply pr_expr_fun_args.val ge; -value class_sig_item x dg k = pr_class_sig_item.pr_fun "top" x "" k; -value class_str_item x dg k = pr_class_str_item.pr_fun "top" x "" k; -value class_type x k = pr_class_type.pr_fun "top" x "" k; -value class_expr x k = pr_class_expr.pr_fun "top" x "" k; - -(* type core *) - -value mutable_flag = - fun - [ True -> [: `S LR "mutable" :] - | _ -> [: :] ] -; - -value private_flag = - fun - [ True -> [: `S LR "private" :] - | _ -> [: :] ] -; - -value intloc loc = ((fst loc).Lexing.pos_cnum, (snd loc).Lexing.pos_cnum); - -value rec labels loc b vl _ k = - match vl with - [ [] -> [: b; k :] - | [v] -> - [: `label True b v "" k; `LocInfo (intloc(snd loc, snd loc)) (HVbox [: :]) :] - | [v :: l] -> [: `label False b v "" [: :]; labels loc [: :] l "" k :] ] -and label is_last b (loc, f, m, t) _ k = - let m = flag "mutable" m in - let k = [: if is_last then [: :] else [: `S RO ";" :]; k :] in - Hbox - [: `LocInfo (intloc loc) - (HVbox - [: `HVbox [: b; m; `S LR (conv_lab f); `S LR ":" :]; - `ctyp t "" [: :] :]); - k :] -; - -value rec ctyp_list tel _ k = listws simple_ctyp (S LR "*") tel "" k; - -value rec variants loc b vl dg k = - match vl with - [ [] -> [: b; k :] - | [v] -> [: `variant b v "" k; `LocInfo (intloc(snd loc, snd loc)) (HVbox [: :]) :] - | [v :: l] -> - [: `variant b v "" [: :]; variants loc [: `S LR "|" :] l "" k :] ] -and variant b (loc, c, tl) _ k = - match tl with - [ [] -> HVbox [: `LocInfo (intloc loc) (HVbox b); `HOVbox [: `S LR c; k :] :] - | _ -> - HVbox - [: `LocInfo (intloc loc) (HVbox b); - `HOVbox [: `S LR c; `S LR "of"; ctyp_list tl "" k :] :] ] -; - -value rec row_fields b rfl _ k = listwbws row_field b (S LR "|") rfl "" k -and row_field b rf _ k = - match rf with - [ MLast.RfTag c ao tl -> - let c = "`" ^ c in - match tl with - [ [] -> HVbox [: b; `HOVbox [: `S LR c; k :] :] - | _ -> - let ao = if ao then [: `S LR "&" :] else [: :] in - HVbox - [: b; - `HOVbox [: `S LR c; `S LR "of"; ao; ctyp_list tl "" k :] :] ] - | MLast.RfInh t -> HVbox [: b; `ctyp t "" k :] ] -; - -value rec get_type_args t tl = - match t with - [ <:ctyp< $t1$ $t2$ >> -> get_type_args t1 [t2 :: tl] - | _ -> (t, tl) ] -; - -value module_pref = - apply_it - [level (fun x -> HOVbox x) - (fun curr next t _ k -> - match t with - [ <:ctyp< $t1$ $t2$ >> -> - let (t, tl) = get_type_args t1 [t2] in - [: curr t "" [: :]; - list - (fun t _ k -> - HOVbox [: `S NO "("; curr t "" [: :]; `S RO ")"; k :]) - tl "" k :] - | <:ctyp< $t1$ . $t2$ >> -> - [: curr t1 "" [: `S NO "." :]; `next t2 "" k :] - | _ -> [: `next t "" k :] ])] - simple_ctyp -; - -value rec class_longident sl dg k = - match sl with - [ [i] -> HVbox [: `S LR i; k :] - | [m :: sl] -> HVbox [: `S LR m; `S NO "."; `class_longident sl dg k :] - | _ -> HVbox [: `not_impl "class_longident" sl; k :] ] -; - -value rec clty_longident sl dg k = - match sl with - [ [i] -> HVbox [: `S LR i; k :] - | [m :: sl] -> HVbox [: `S LR m; `S NO "."; `clty_longident sl dg k :] - | _ -> HVbox [: `not_impl "clty_longident" sl; k :] ] -; - -value rec meth_list (ml, v) dg k = - match (ml, v) with - [ ([f], False) -> [: `field f dg k :] - | ([], _) -> [: `S LR ".."; k :] - | ([f :: ml], v) -> - [: `field f "" [: `S RO ";" :]; meth_list (ml, v) dg k :] ] -and field (lab, t) dg k = - HVbox [: `S LR (var_escaped lab); `S LR ":"; `ctyp t dg k :] -; - -(* patterns *) - -value rec get_patt_args a al = - match a with - [ <:patt< $a1$ $a2$ >> -> get_patt_args a1 [a2 :: al] - | _ -> (a, al) ] -; - -value rec is_irrefut_patt = - fun - [ <:patt< $lid:_$ >> -> True - | <:patt< () >> -> True - | <:patt< _ >> -> True - | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y - | <:patt< { $list:fpl$ } >> -> - List.for_all (fun (_, p) -> is_irrefut_patt p) fpl - | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p - | <:patt< ($list:pl$) >> -> List.for_all is_irrefut_patt pl - | <:patt< ? $_$ : ($p$) >> -> is_irrefut_patt p - | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p - | <:patt< ~ $_$ >> -> True - | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p - | _ -> False ] -; - -(* expressions *) - -pr_expr_fun_args.val := - extfun Extfun.empty with - [ <:expr< fun [$p$ -> $e$] >> as ge -> - if is_irrefut_patt p then - let (pl, e) = expr_fun_args e in - ([p :: pl], e) - else ([], ge) - | ge -> ([], ge) ]; - -value raise_match_failure (bp, ep) k = - let (fname, line, char, _) = - if Pcaml.input_file.val <> "-" then - Stdpp.line_of_loc Pcaml.input_file.val (bp, ep) - else - ("-", bp.Lexing.pos_lnum, bp.Lexing.pos_cnum - bp.Lexing.pos_bol, ep.Lexing.pos_cnum - ep.Lexing.pos_bol) - in - HOVbox - [: `S LR "raise"; `S LO "("; `S LR "Match_failure"; `S LO "("; - `S LR ("\"" ^ fname ^ "\""); `S RO ","; - `S LR (string_of_int line); `S RO ","; `S LR (string_of_int char); - `S RO ")"; `S RO ")"; k :] -; - -value rec bind_list b pel _ k = - match pel with - [ [pe] -> let_binding b pe "" k - | pel -> - Vbox [: `HVbox [: :]; listwbws let_binding b (S LR "and") pel "" k :] ] -and let_binding b (p, e) _ k = - let loc = - let (bp1, ep1) = MLast.loc_of_patt p in - let (bp2, ep2) = MLast.loc_of_expr e in - (min bp1 bp2, max ep1 ep2) - in - LocInfo (intloc loc) (BEbox (let_binding0 b p e k)) -and let_binding0 b p e k = - let (pl, e) = - match p with - [ <:patt< ($_$ : $_$) >> -> ([], e) - | _ -> expr_fun_args e ] - in - let b = [: b; `simple_patt p "" [: :] :] in - match (p, e) with - [ (<:patt< $lid:_$ >>, <:expr< ($e$ : $t$) >>) -> - [: `HVbox - [: `HVbox b; `HVbox (list simple_patt pl "" [: `S LR ":" :]); - `ctyp t "" [: `S LR "=" :] :]; - `expr e "" [: :]; k :] - | _ -> - [: `HVbox - [: `HVbox b; `HOVbox (list simple_patt pl "" [: `S LR "=" :]) :]; - `expr e "" [: :]; k :] ] -and match_assoc_list loc pel dg k = - match pel with - [ [] -> - HVbox - [: `HVbox [: `S LR "_"; `S LR "->" :]; `raise_match_failure loc k :] - | _ -> - BEVbox - [: `HVbox [: :]; listwbws match_assoc [: :] (S LR "|") pel dg k :] ] -and match_assoc b (p, w, e) dg k = - let s = - match w with - [ Some e1 -> - [: `HVbox - [: `HVbox [: :]; `patt p "" [: :]; - `HVbox [: `S LR "when"; `expr e1 "" [: `S LR "->" :] :] :] :] - | _ -> [: `patt p "" [: `S LR "->" :] :] ] - in - HVbox [: b; `HVbox [: `HVbox s; `expr e dg k :] :] -; - -value rec get_expr_args a al = - match a with - [ <:expr< $a1$ $a2$ >> -> get_expr_args a1 [a2 :: al] - | _ -> (a, al) ] -; - -value label lab = S LR (var_escaped lab); - -value field_expr (lab, e) dg k = - HVbox [: `label lab; `S LR "="; `expr e dg k :] -; - -value type_params sl _ k = - match sl with - [ [] -> k - | [(s, vari)] -> - let b = - match vari with - [ (True, False) -> [: `S LO "+" :] - | (False, True) -> [: `S LO "-" :] - | _ -> [: :] ] - in - [: b; `S LO "'"; `S LR s; k :] - | sl -> - [: `S LO "("; - listws (fun (s, _) _ k -> HVbox [: `S LO "'"; `S LR s; k :]) - (S RO ",") sl "" [: `S RO ")"; k :] :] ] -; - -value constrain (t1, t2) _ k = - HVbox [: `S LR "constraint"; `ctyp t1 "" [: `S LR "=" :]; `ctyp t2 "" k :] -; - -value type_list b tdl _ k = - HVbox - [: `HVbox [: :]; - listwbws - (fun b ((_, tn), tp, te, cl) _ k -> - let tn = var_escaped tn in - let cstr = list constrain cl "" k in - match te with - [ <:ctyp< '$s$ >> when not (List.mem_assoc s tp) -> - HVbox [: b; type_params tp "" [: :]; `S LR tn; cstr :] - | <:ctyp< [ $list:[]$ ] >> -> - HVbox [: b; type_params tp "" [: :]; `S LR tn; cstr :] - | _ -> - HVbox - [: `HVbox - [: b; type_params tp "" [: :]; `S LR tn; `S LR "=" :]; - `ctyp te "" [: :]; cstr :] ]) - b (S LR "and") tdl "" [: :]; - k :] -; - -value external_def (s, t, pl) _ k = - let ls = - list (fun s _ k -> HVbox [: `S LR ("\"" ^ s ^ "\""); k :]) pl "" k - in - HVbox - [: `HVbox [: `S LR "external"; `S LR (var_escaped s); `S LR ":" :]; - `ctyp t "" [: `S LR "="; ls :] :] -; - -value value_description (s, t) _ k = - HVbox - [: `HVbox [: `S LR "val"; `S LR (var_escaped s); `S LR ":" :]; - `ctyp t "" k :] -; - -value typevar s _ k = HVbox [: `S LR ("'" ^ s); k :]; - -value rec mod_ident sl _ k = - match sl with - [ [] -> k - | [s] -> [: `S LR s; k :] - | [s :: sl] -> [: `S LR s; `S NO "."; mod_ident sl "" k :] ] -; - -value rec module_declaration b mt k = - match mt with - [ <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> -> - module_declaration - [: `HVbox - [: b; - `HVbox - [: `S LO "("; `S LR i; `S LR ":"; - `module_type t [: `S RO ")" :] :] :] :] - mt k - | _ -> - HVbox - [: `HVbox [: :]; - `HVbox [: `HVbox [: b; `S LR ":" :]; `module_type mt [: :] :]; - k :] ] -and module_rec_declaration b (n,mt) _ k = - HVbox - [: `HVbox - [: b; `S LR n; `S LR ":"; `module_type mt [: :] :]; - k :] -and modtype_declaration (s, mt) _ k = - match mt with - [ <:module_type< ' $_$ >> -> - HVbox [: `HVbox [: `S LR "module"; `S LR "type"; `S LR s; k :] :] - | _ -> - HVbox - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `S LR "module"; `S LR "type"; `S LR s; `S LR "=" :]; - `module_type mt [: :] :]; - k :] ] -and with_constraints b icl _ k = - HVbox [: `HVbox [: :]; listwbws with_constraint b (S LR "and") icl "" k :] -and with_constraint b wc _ k = - match wc with - [ MLast.WcTyp _ p al e -> - let params = - match al with - [ [] -> [: :] - | [s] -> [: `S LO "'"; `S LR (fst s) :] - | sl -> [: `S LO "("; type_params sl "" [: `S RO ")" :] :] ] - in - HVbox - [: `HVbox - [: `HVbox b; `S LR "type"; params; - mod_ident p "" [: `S LR "=" :] :]; - `ctyp e "" k :] - | MLast.WcMod _ sl me -> - HVbox - [: b; `S LR "module"; mod_ident sl "" [: `S LR "=" :]; - `module_expr me "" k :] ] -; - -value rec module_binding b me k = - match me with - [ <:module_expr< functor ($s$ : $mt$) -> $mb$ >> -> - module_binding - [: `HVbox - [: b; - `HVbox - [: `HVbox [: `S LO "("; `S LR s; `S LR ":" :]; - `module_type mt [: `S RO ")" :] :] :] :] - mb k - | <:module_expr< ( $me$ : $mt$ ) >> -> - HVbox - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `HVbox [: b; `S LR ":" :]; - `module_type mt [: `S LR "=" :] :]; - `module_expr me "" [: :] :]; - k :] - | _ -> - HVbox - [: `HVbox [: :]; - `HVbox [: `HVbox [: b; `S LR "=" :]; `module_expr me "" [: :] :]; - k :] ] -and module_rec_binding b (n, mt,me) _ k = - HVbox - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `HVbox [: b; `S LR n; `S LR ":" :]; - `module_type mt [: `S LR "=" :] :]; - `module_expr me "" [: :] :]; - k :] -and class_declaration b ci _ k = - class_fun_binding - [: b; virtual_flag ci.MLast.ciVir; class_type_parameters ci.MLast.ciPrm; - `S LR ci.MLast.ciNam :] - ci.MLast.ciExp k -and class_fun_binding b ce k = - match ce with - [ MLast.CeFun _ p cfb -> - class_fun_binding [: b; `simple_patt p "" [: :] :] cfb k - | ce -> HVbox [: `HVbox [: b; `S LR "=" :]; `class_expr ce k :] ] -and class_type_parameters (loc, tpl) = - match tpl with - [ [] -> [: :] - | tpl -> - [: `S LO "["; - listws type_parameter (S RO ",") tpl "" [: `S RO "]" :] :] ] -and type_parameter tp dg k = HVbox [: `S LO "'"; `S LR (fst tp); k :] -and class_self_patt_opt csp = - match csp with - [ Some p -> HVbox [: `S LO "("; `patt p "" [: `S RO ")" :] :] - | None -> HVbox [: :] ] -and cvalue b (lab, mf, e) k = - HVbox - [: `HVbox [: b; mutable_flag mf; `label lab; `S LR "=" :]; `expr e "" k :] -and fun_binding b fb k = - match fb with - [ <:expr< fun $p$ -> $e$ >> -> - fun_binding [: b; `simple_patt p "" [: :] :] e k - | e -> HVbox [: `HVbox [: b; `S LR "=" :]; `expr e "" k :] ] -and class_signature cs k = - match cs with - [ MLast.CtCon _ id [] -> clty_longident id "" k - | MLast.CtCon _ id tl -> - HVbox - [: `S LO "["; listws ctyp (S RO ",") tl "" [: `S RO "]" :]; - `clty_longident id "" k :] - | MLast.CtSig _ cst csf -> - let ep = snd (MLast.loc_of_class_type cs) in - class_self_type [: `S LR "object" :] cst - [: `HVbox - [: `HVbox [: :]; list class_sig_item csf "" [: :]; - `LocInfo (intloc(ep, ep)) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] - | _ -> HVbox [: `not_impl "class_signature" cs; k :] ] -and class_self_type b cst k = - BEbox - [: `HVbox - [: b; - match cst with - [ None -> [: :] - | Some t -> [: `S LO "("; `ctyp t "" [: `S RO ")" :] :] ] :]; - k :] -and class_description b ci _ k = - HVbox - [: `HVbox - [: b; virtual_flag ci.MLast.ciVir; - class_type_parameters ci.MLast.ciPrm; `S LR ci.MLast.ciNam; - `S LR ":" :]; - `class_type ci.MLast.ciExp k :] -and class_type_declaration b ci _ k = - HVbox - [: `HVbox - [: b; virtual_flag ci.MLast.ciVir; - class_type_parameters ci.MLast.ciPrm; `S LR ci.MLast.ciNam; - `S LR "=" :]; - `class_signature ci.MLast.ciExp k :] -; - -pr_module_type.pr_levels := - [{pr_label = "top"; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >> -> - fun curr next dg k -> - let head = - HVbox - [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":"; - `HVbox (curr mt1 "" [: `S RO ")" :]); `S LR "->" :] - in - [: `head; curr mt2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $mt$ with $list:icl$ >> -> - fun curr next dg k -> - [: curr mt "" [: :]; - `with_constraints [: `S LR "with" :] icl "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< sig $list:s$ end >> as mt -> - fun curr next dg k -> - let ep = snd (MLast.loc_of_module_type mt) in - [: `BEbox - [: `S LR "sig"; - `HVbox - [: `HVbox [: :]; list sig_item s "" [: :]; - `LocInfo (intloc(ep, ep)) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $mt1$ $mt2$ >> -> - fun curr next dg k -> - [: curr mt1 "" [: :]; `S LO "("; - `next mt2 "" [: `S RO ")"; k :] :] - | <:module_type< $mt1$ . $mt2$ >> -> - fun curr next dg k -> - [: curr mt1 "" [: `S NO "." :]; `next mt2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $lid:s$ >> -> fun curr next dg k -> [: `S LR s; k :] - | <:module_type< $uid:s$ >> -> fun curr next dg k -> [: `S LR s; k :] - | mt -> - fun curr next dg k -> - [: `S LO "("; `module_type mt [: `S RO ")"; k :] :] ]}]; - -pr_module_expr.pr_levels := - [{pr_label = "top"; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< struct $list:s$ end >> as me -> - fun curr next dg k -> - let ep = snd (MLast.loc_of_module_expr me) in - [: `HVbox [: :]; - `HVbox - [: `S LR "struct"; list str_item s "" [: :]; - `LocInfo (intloc(ep, ep)) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] - | <:module_expr< functor ($s$ : $mt$) -> $me$ >> -> - fun curr next dg k -> - let head = - HVbox - [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":"; - `module_type mt [: `S RO ")" :]; `S LR "->" :] - in - [: `head; curr me "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box mt x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< $me1$ $me2$ >> -> - fun curr next dg k -> - [: curr me1 "" [: :]; - `HVbox - [: `S LO "("; `module_expr me2 "" [: `S RO ")"; k :] :] :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< $me1$ . $me2$ >> -> - fun curr next dg k -> - [: curr me1 "" [: `S NO "." :]; `next me2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box mt x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< $uid:s$ >> -> fun curr next dg k -> [: `S LR s; k :] - | <:module_expr< ( $me$ : $mt$ ) >> -> - fun curr next dg k -> - [: `S LO "("; `module_expr me "" [: `S LR ":" :]; - `module_type mt [: `S RO ")"; k :] :] - | <:module_expr< struct $list:_$ end >> | - <:module_expr< functor ($_$ : $_$) -> $_$ >> | - <:module_expr< $_$ $_$ >> | <:module_expr< $_$ . $_$ >> as me -> - fun curr next dg k -> - [: `S LO "("; `module_expr me "" [: `S RO ")"; k :] :] ]}]; - -pr_sig_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (intloc(MLast.loc_of_sig_item s)) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ <:sig_item< type $list:stl$ >> -> - fun curr next dg k -> [: `type_list [: `S LR "type" :] stl "" k :] - | <:sig_item< declare $list:s$ end >> -> - fun curr next dg k -> - if s = [] then [: `S LR "(* *)" :] - else [: `HVbox [: :]; list sig_item s "" [: :] :] - | MLast.SgDir _ _ _ as si -> - fun curr next dg k -> [: `not_impl "sig_item" si :] - | <:sig_item< exception $c$ of $list:tl$ >> -> - fun curr next dg k -> - [: `variant [: `S LR "exception" :] (_loc, c, tl) "" k :] - | <:sig_item< value $s$ : $t$ >> -> - fun curr next dg k -> [: `value_description (s, t) "" k :] - | <:sig_item< external $s$ : $t$ = $list:pl$ >> -> - fun curr next dg k -> [: `external_def (s, t, pl) "" k :] - | <:sig_item< include $mt$ >> -> - fun curr next dg k -> [: `S LR "include"; `module_type mt k :] - | <:sig_item< module $s$ : $mt$ >> -> - fun curr next dg k -> - [: `module_declaration [: `S LR "module"; `S LR s :] mt k :] - | <:sig_item< module rec $list:nmts$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws module_rec_declaration [: `S LR "module rec" :] (S LR "and") nmts - "" k :] - | <:sig_item< module type $s$ = $mt$ >> -> - fun curr next dg k -> [: `modtype_declaration (s, mt) "" k :] - | <:sig_item< open $sl$ >> -> - fun curr next dg k -> [: `S LR "open"; mod_ident sl "" k :] - | MLast.SgCls _ cd -> - fun curr next dg k -> - [: `HVbox [: :]; - listwbws class_description [: `S LR "class" :] (S LR "and") cd - "" k :] - | MLast.SgClt _ cd -> - fun curr next dg k -> - [: `HVbox [: :]; - listwbws class_type_declaration - [: `S LR "class"; `S LR "type" :] (S LR "and") cd "" - k :] - | MLast.SgUse _ _ _ -> - fun curr next dg k -> [: :] ]}]; - -pr_str_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (intloc(MLast.loc_of_str_item s)) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ <:str_item< open $i$ >> -> - fun curr next dg k -> [: `S LR "open"; mod_ident i "" k :] - | <:str_item< $exp:e$ >> -> - fun curr next dg k -> - if no_ss.val then - [: `HVbox [: `S LR "let"; `S LR "_"; `S LR "=" :]; - `expr e "" k :] - else [: `HVbox [: :]; `expr e "" k :] - | <:str_item< declare $list:s$ end >> -> - fun curr next dg k -> - if s = [] then [: `S LR "(* *)" :] - else [: `HVbox [: :]; list str_item s "" [: :] :] - | <:str_item< # $s$ $opt:x$ >> -> - fun curr next dg k -> - let s = - "(* #" ^ s ^ " " ^ - (match x with - [ Some <:expr< $str:s$ >> -> "\"" ^ s ^ "\"" - | _ -> "?" ]) ^ - " *)" - in - [: `S LR s :] - | <:str_item< exception $c$ of $list:tl$ = $b$ >> -> - fun curr next dg k -> - match b with - [ [] -> [: `variant [: `S LR "exception" :] (_loc, c, tl) "" k :] - | _ -> - [: `variant [: `S LR "exception" :] (_loc, c, tl) "" - [: `S LR "=" :]; - mod_ident b "" k :] ] - | <:str_item< include $me$ >> -> - fun curr next dg k -> [: `S LR "include"; `module_expr me "" k :] - | <:str_item< type $list:tdl$ >> -> - fun curr next dg k -> [: `type_list [: `S LR "type" :] tdl "" k :] - | <:str_item< value $opt:rf$ $list:pel$ >> -> - fun curr next dg k -> - [: `bind_list - [: `S LR "let"; if rf then [: `S LR "rec" :] else [: :] :] - pel "" k :] - | <:str_item< external $s$ : $t$ = $list:pl$ >> -> - fun curr next dg k -> [: `external_def (s, t, pl) "" k :] - | <:str_item< module $s$ = $me$ >> -> - fun curr next dg k -> - [: `module_binding [: `S LR "module"; `S LR s :] me k :] - | <:str_item< module rec $list:nmtmes$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws module_rec_binding [: `S LR "module rec" :] (S LR "and") nmtmes - "" k :] - | <:str_item< module type $s$ = $mt$ >> -> - fun curr next dg k -> - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `S LR "module"; `S LR "type"; `S LR s; - `S LR "=" :]; - `module_type mt [: :] :]; - k :] - | MLast.StCls _ cd -> - fun curr next dg k -> - [: `HVbox [: :]; - listwbws class_declaration [: `S LR "class" :] (S LR "and") cd - "" k :] - | MLast.StClt _ cd -> - fun curr next dg k -> - [: `HVbox [: :]; - listwbws class_type_declaration - [: `S LR "class"; `S LR "type" :] (S LR "and") cd "" - k :] - | MLast.StUse _ _ _ -> - fun curr next dg k -> [: :] ]}]; - -value ocaml_char = - fun - [ "'" -> "\\'" - | "\"" -> "\\\"" - | c -> c ] -; - -pr_expr.pr_levels := - [{pr_label = "top"; pr_box e x = LocInfo (intloc(MLast.loc_of_expr e)) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:expr< do { $list:el$ } >> -> - fun curr next dg k -> - [: `HVbox [: `HVbox [: :]; listws next (S RO ";") el dg k :] :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = "expr1"; pr_box e x = LocInfo (intloc(MLast.loc_of_expr e)) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:expr< let $opt:r$ $p1$ = $e1$ in $e$ >> -> - fun curr next dg k -> - let r = if r then [: `S LR "rec" :] else [: :] in - if dg <> ";" then - [: `HVbox - [: `HVbox [: :]; - `let_binding [: `S LR "let"; r :] (p1, e1) "" - [: `S LR "in" :]; - `expr e dg k :] :] - else - let pel = [(p1, e1)] in - [: `BEbox - [: `S LR "begin"; - `HVbox - [: `HVbox [: :]; - listwbws - (fun b (p, e) _ k -> let_binding b (p, e) "" k) - [: `S LR "let"; r :] (S LR "and") pel "" - [: `S LR "in" :]; - `expr e "" [: :] :]; - `HVbox [: `S LR "end"; k :] :] :] - | <:expr< let $opt:r$ $list:pel$ in $e$ >> -> - fun curr next dg k -> - let r = if r then [: `S LR "rec" :] else [: :] in - if dg <> ";" then - [: `Vbox - [: `HVbox [: :]; - listwbws - (fun b (p, e) _ k -> let_binding b (p, e) "" k) - [: `S LR "let"; r :] (S LR "and") pel "" - [: `S LR "in" :]; - `expr e dg k :] :] - else - [: `BEbox - [: `S LR "begin"; - `HVbox - [: `HVbox [: :]; - listwbws - (fun b (p, e) _ k -> let_binding b (p, e) "" k) - [: `S LR "let"; r :] (S LR "and") pel "" - [: `S LR "in" :]; - `expr e "" [: :] :]; - `HVbox [: `S LR "end"; k :] :] :] - | <:expr< let module $m$ = $mb$ in $e$ >> -> - fun curr next dg k -> - if dg <> ";" then - [: `HVbox - [: `HVbox [: :]; - `module_binding - [: `S LR "let"; `S LR "module"; `S LR m :] mb [: :]; - `S LR "in"; `expr e dg k :] :] - else - [: `BEbox - [: `module_binding - [: `S LR "begin let"; `S LR "module"; `S LR m :] mb - [: :]; - `HVbox - [: `HVbox [: :]; `S LR "in"; `expr e dg [: :] :]; - `HVbox [: `S LR "end"; k :] :] :] - | <:expr< fun [ $list:pel$ ] >> as e -> - fun curr next dg k -> - let loc = MLast.loc_of_expr e in - if not (List.mem dg ["|"; ";"]) then - match pel with - [ [] -> - [: `S LR "fun"; `S LR "_"; `S LR "->"; - `raise_match_failure loc k :] - | [(p, None, e)] -> - let (pl, e) = expr_fun_args e in - [: `BEbox - [: `HOVbox - [: `S LR "fun"; - list simple_patt [p :: pl] "" - [: `S LR "->" :] :]; - `expr e dg k :] :] - | _ -> - [: `Vbox - [: `HVbox [: :]; `S LR "function"; - `match_assoc_list loc pel dg k :] :] ] - else - match pel with - [ [] -> - [: `S LR "(fun"; `S LR "_"; `S LR "->"; - `raise_match_failure loc [: `S RO ")"; k :] :] - | [(p, None, e)] -> - if is_irrefut_patt p then - let (pl, e) = expr_fun_args e in - [: `S LO "("; - `BEbox - [: `HOVbox - [: `S LR "fun"; - list simple_patt [p :: pl] "" - [: `S LR "->" :] :]; - `expr e "" [: `S RO ")"; k :] :] :] - else - [: `HVbox - [: `S LR "fun ["; `patt p "" [: `S LR "->" :] :]; - `expr e "" [: `S LR "]"; k :] :] - | _ -> - [: `Vbox - [: `HVbox [: :]; `S LR "begin function"; - `match_assoc_list loc pel "" k; - `HVbox [: `S LR "end"; k :] :] :] ] - | <:expr< match $e$ with [ $list:pel$ ] >> as ge -> - fun curr next dg k -> - let loc = MLast.loc_of_expr ge in - if not (List.mem dg ["|"; ";"]) then - [: `HVbox - [: `HVbox [: :]; - `BEbox - [: `S LR "match"; `expr e "" [: :]; `S LR "with" :]; - `match_assoc_list loc pel "" k :] :] - else - [: `HVbox - [: `HVbox [: :]; - `BEbox - [: `S LR "begin match"; `expr e "" [: :]; - `S LR "with" :]; - `match_assoc_list loc pel "" [: :]; - `HVbox [: `S LR "end"; k :] :] :] - | <:expr< try $e$ with [ $list:pel$ ] >> as ge -> - fun curr next dg k -> - let loc = MLast.loc_of_expr ge in - if not (List.mem dg ["|"; ";"]) then - [: `HVbox - [: `HVbox [: :]; - `BEbox - [: `S LR "try"; `expr e "" [: :]; `S LR "with" :]; - `match_assoc_list loc pel "" k :] :] - else - [: `HVbox - [: `HVbox [: :]; - `BEbox - [: `S LR "begin try"; `expr e "" [: :]; - `S LR "with" :]; - `match_assoc_list loc pel "" [: :]; - `HVbox [: `S LR "end"; k :] :] :] - | <:expr< if $e1$ then $e2$ else $e3$ >> as e -> - fun curr next dg k -> - let eel_e = - elseif e3 where rec elseif e = - match e with - [ <:expr< if $e1$ then $e2$ else $e3$ >> -> - let (eel, e) = elseif e3 in - ([(e1, e2) :: eel], e) - | _ -> ([], e) ] - in - if not (List.mem dg ["else"]) then - match eel_e with - [ ([], <:expr< () >>) -> - [: `BEbox [: `S LR "if"; `expr e1 "" [: :]; `S LR "then" :]; - `expr1 e2 dg k :] - | (eel, <:expr< () >>) -> - let (eel, (e1f, e2f)) = - let r = List.rev eel in - (List.rev (List.tl r), List.hd r) - in - [: `HVbox - [: `HVbox [: :]; - `HVbox - [: `BEbox - [: `S LR "if"; `expr e1 "" [: :]; - `S LR "then" :]; - `expr1 e2 "else" [: :] :]; - list - (fun (e1, e2) _ k -> - HVbox - [: `BEbox - [: `HVbox - [: `S LR "else"; `S LR "if" :]; - `expr e1 "" [: :]; `S LR "then" :]; - `expr1 e2 "else" k :]) - eel "" [: :]; - `HVbox - [: `BEbox - [: `HVbox [: `S LR "else"; `S LR "if" :]; - `expr e1f "" [: :]; `S LR "then" :]; - `expr1 e2f dg k :] :] :] - | (eel, e) -> - [: `HVbox - [: `HVbox [: :]; - `HVbox - [: `BEbox - [: `S LR "if"; `expr e1 "" [: :]; - `S LR "then" :]; - `expr1 e2 "else" [: :] :]; - list - (fun (e1, e2) _ k -> - HVbox - [: `BEbox - [: `HVbox - [: `S LR "else"; `S LR "if" :]; - `expr e1 "" [: :]; `S LR "then" :]; - `expr1 e2 "else" k :]) - eel "" [: :]; - `HVbox [: `S LR "else"; `expr1 e dg k :] :] :] ] - else - match eel_e with - [ (_, <:expr< () >>) -> [: `simple_expr e "" k :] - | (eel, e) -> - [: `HVbox - [: `HVbox [: :]; - `HVbox - [: `BEbox - [: `S LR "if"; `expr e1 "" [: :]; - `S LR "then" :]; - `expr1 e2 "" [: :] :]; - list - (fun (e1, e2) _ k -> - HVbox - [: `BEbox - [: `HVbox - [: `S LR "else"; `S LR "if" :]; - `expr e1 "" [: :]; `S LR "then" :]; - `expr1 e2 "" [: :] :]) - eel "" [: :]; - `HVbox [: `S LR "else"; `expr1 e "" k :] :] :] ] - | <:expr< for $i$ = $e1$ $to:d$ $e2$ do { $list:el$ } >> -> - fun curr next dg k -> - let d = if d then "to" else "downto" in - [: `BEbox - [: `HOVbox - [: `S LR "for"; `S LR i; `S LR "="; - `expr e1 "" [: `S LR d :]; - `expr e2 "" [: `S LR "do" :] :]; - `HVbox - [: `HVbox [: :]; - listws expr (S RO ";") el "" [: :] :]; - `HVbox [: `S LR "done"; k :] :] :] - | <:expr< while $e1$ do { $list:el$ } >> -> - fun curr next dg k -> - [: `BEbox - [: `BEbox - [: `S LR "while"; `expr e1 "" [: :]; `S LR "do" :]; - `HVbox - [: `HVbox [: :]; - listws expr (S RO ";") el "" [: :] :]; - `HVbox [: `S LR "done"; k :] :] :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< ($list:el$) >> -> - fun curr next dg k -> - [: `HVbox [: :]; listws next (S RO ",") el "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $x$.val := $y$ >> -> - fun curr next dg k -> - [: `next x "" [: `S LR ":=" :]; `expr y dg k :] - | <:expr< $x$ := $y$ >> -> - fun curr next dg k -> - [: `next x "" [: `S LR "<-" :]; `expr y dg k :] - | e -> fun curr next dg k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:("||" as f)$ $x$ $y$ >> -> - fun curr next dg k -> [: `next x "" [: `S LR f :]; curr y "" k :] - | <:expr< $lid:("or" as f)$ $x$ $y$ >> -> - fun curr next dg k -> [: `next x "" [: `S LR f :]; curr y "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:(("&&") as f)$ $x$ $y$ >> -> - fun curr next dg k -> [: `next x "" [: `S LR f :]; curr y "" k :] - | <:expr< $lid:(("&") as f)$ $x$ $y$ >> -> - fun curr next dg k -> [: `next x "" [: `S LR f :]; curr y "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next dg k -> - match op with - [ "=" | "<>" | "<" | "<." | "<=" | ">" | ">=" | ">=." | "==" | - "!=" -> - [: curr x "" [: `S LR op :]; `next y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next dg k -> - match op with - [ "^" | "@" -> [: `next x "" [: `S LR op :]; curr y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< [$_$ :: $_$] >> as e -> - fun curr next dg k -> - let (el, c) = - make_list e where rec make_list e = - match e with - [ <:expr< [$e$ :: $y$] >> -> - let (el, c) = make_list y in - ([e :: el], c) - | <:expr< [] >> -> ([], None) - | x -> ([], Some e) ] - in - match c with - [ None -> [: `next e "" k :] - | Some x -> - [: listws next (S LR "::") el "" [: `S LR "::" :]; - `next x "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next dg k -> - match op with - [ "+" | "+." | "-" | "-." -> - [: curr x "" [: `S LR op :]; `next y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next dg k -> - match op with - [ "*" | "/" | "*." | "/." | "land" | "lor" | "lxor" | "mod" -> - [: curr x "" [: `S LR op :]; `next y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next dg k -> - match op with - [ "**" | "asr" | "lsl" | "lsr" -> - [: `next x "" [: `S LR op :]; curr y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:"~-"$ $x$ >> -> - fun curr next dg k -> [: `S LR "-"; curr x "" k :] - | <:expr< $lid:"~-."$ $x$ >> -> - fun curr next dg k -> [: `S LR "-."; curr x "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ ( <:expr< $int:x$ >> | <:expr< $flo:x$ >> ) - -> fun curr next dg k -> [: `S LR x; k :] - | MLast.ExInt32 _ x -> fun curr next dg k -> [: `S LR (x^"l"); k :] - | MLast.ExInt64 _ x -> fun curr next dg k -> [: `S LR (x^"L"); k :] - | MLast.ExNativeInt _ x -> fun curr next dg k -> [: `S LR (x^"n"); k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = "apply"; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< [$_$ :: $_$] >> as e -> - fun curr next dg k -> [: `next e "" k :] - | <:expr< lazy ($x$) >> -> - fun curr next dg k -> [: `S LR "lazy"; `next x "" k :] - | MLast.ExAsf _ -> -(* | <:expr< assert False >> -> *) - fun curr next dg k -> [: `S LR "assert"; `S LR "false"; k :] - | MLast.ExAsr _ e -> -(* | <:expr< assert ($e$) >> -> *) - fun curr next dg k -> [: `S LR "assert"; `next e "" k :] - | <:expr< $lid:n$ $x$ $y$ >> as e -> - fun curr next dg k -> - let _loc = MLast.loc_of_expr e in - if is_infix n then [: `next e "" k :] - else [: curr <:expr< $lid:n$ $x$ >> "" [: :]; `next y "" k :] - | <:expr< $x$ $y$ >> -> - fun curr next dg k -> - match get_expr_args x [y] with - [ (_, [_]) -> [: curr x "" [: :]; `next y "" k :] - | ((<:expr< $uid:_$ >> | <:expr< $_$ . $uid:_$ >> as a), al) -> - [: curr a "" [: :]; - `HOVbox - [: `S LO "("; - listws (fun x _ k -> HOVbox [: curr x "" k :]) - (S RO ",") al "" [: `S RO ")"; k :] :] :] - | _ -> [: curr x "" [: :]; `next y "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = "dot"; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $x$ . ( $y$ ) >> -> - fun curr next dg k -> - [: curr x "" [: :]; `S NO ".("; `expr y "" [: `S RO ")"; k :] :] - | <:expr< $x$ . [ $y$ ] >> -> - fun curr next dg k -> - [: curr x "" [: :]; `S NO ".["; `expr y "" [: `S RO "]"; k :] :] - | <:expr< $e$. val >> -> - fun curr next dg k -> [: `S LO "!"; `next e "" k :] - | <:expr< $e1$ . $e2$ >> -> - fun curr next dg k -> - [: curr e1 "" [: :]; `S NO "."; curr e2 "" k :] - | <:expr< $e$ # $lab$ >> -> - fun curr next dg k -> - [: curr e "" [: :]; `S NO "#"; `label lab; k :] - | e -> fun curr next dg k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< [$_$ :: $_$] >> as e -> - fun curr next dg k -> - let (el, c) = - make_list e where rec make_list e = - match e with - [ <:expr< [$e$ :: $y$] >> -> - let (el, c) = make_list y in - ([e :: el], c) - | <:expr< [] >> -> ([], None) - | x -> ([], Some e) ] - in - match c with - [ None -> - [: `S LO "["; - listws expr (S RO ";") el "" [: `S RO "]"; k :] :] - | Some x -> [: `next e "" k :] ] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = "simple"; - pr_box e x = LocInfo (intloc(MLast.loc_of_expr e)) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ ( <:expr< $int:x$ >> | <:expr< $flo:x$ >> ) - -> fun curr next dg k -> - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | MLast.ExInt32 _ x -> - fun curr next dg k -> - let x = x^"l" in - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | MLast.ExInt64 _ x -> - let x = x^"L" in - fun curr next dg k -> - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | MLast.ExNativeInt _ x -> - let x = x^"n" in - fun curr next dg k -> - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | <:expr< $str:s$ >> -> - fun curr next dg k -> [: `S LR ("\"" ^ s ^ "\""); k :] - | <:expr< $chr:c$ >> -> - fun curr next dg k -> - let c = ocaml_char c in - [: `S LR ("'" ^ c ^ "'"); k :] - | <:expr< $uid:s$ >> -> - fun curr next dg k -> [: `S LR (conv_con s); k :] - | <:expr< $lid:s$ >> -> - fun curr next dg k -> [: `S LR (var_escaped s); k :] - | <:expr< ` $i$ >> -> fun curr next dg k -> [: `S LR ("`" ^ i); k :] - | <:expr< ~ $i$ >> -> - fun curr next dg k -> [: `S LR ("~" ^ i); k :] - | <:expr< ~ $i$ : $e$ >> -> - fun curr next dg k -> [: `S LO ("~" ^ i ^ ":"); curr e "" k :] - | <:expr< ? $i$ >> -> - fun curr next dg k -> [: `S LR ("?" ^ i); k :] - | <:expr< ? $i$ : $e$ >> -> - fun curr next dg k -> [: `S LO ("?" ^ i ^ ":"); curr e "" k :] - | <:expr< [| $list:el$ |] >> -> - fun curr next dg k -> - [: `S LR "[|"; listws expr (S RO ";") el "" [: `S LR "|]"; k :] :] - | <:expr< { $list:fel$ } >> -> - fun curr next dg k -> - [: `S LO "{"; - listws - (fun (lab, e) dg k -> - HVbox [: `patt lab "" [: `S LR "=" :]; `expr1 e dg k :]) - (S RO ";") fel "" [: `S RO "}"; k :] :] - | <:expr< { ($e$) with $list:fel$ } >> -> - fun curr next dg k -> - [: `HVbox [: `S LO "{"; curr e "" [: `S LR "with" :] :]; - listws - (fun (lab, e) dg k -> - HVbox [: `patt lab "" [: `S LR "=" :]; `expr1 e dg k :]) - (S RO ";") fel "" [: `S RO "}"; k :] :] - | <:expr< ($e$ : $t$) >> -> - fun curr next dg k -> - [: `S LO "("; `expr e "" [: `S LR ":" :]; - `ctyp t "" [: `S RO ")"; k :] :] - | <:expr< ($e$ : $t1$ :> $t2$) >> -> - fun curr next dg k -> - [: `S LO "("; `expr e "" [: `S LR ":" :]; - `ctyp t1 "" [: `S LR ":>" :]; `ctyp t2 "" [: `S RO ")"; k :] :] - | <:expr< ($e$ :> $t2$) >> -> - fun curr next dg k -> - [: `S LO "("; `expr e "" [: `S LR ":>" :]; - `ctyp t2 "" [: `S RO ")"; k :] :] - | <:expr< new $list:sl$ >> -> - fun curr next dg k -> [: `S LR "new"; `class_longident sl "" k :] - | <:expr< {< >} >> -> fun curr next dg k -> [: `S LR "{< >}"; k :] - | <:expr< {< $list:fel$ >} >> -> - fun curr next dg k -> - [: `S LR "{<"; - listws field_expr (S RO ";") fel dg [: `S LR ">}"; k :] :] - | <:expr< do { $list:el$ } >> -> - fun curr next dg k -> - match el with - [ [e] -> curr e dg k - | _ -> - [: `BEbox - [: `S LR "begin"; - `HVbox - [: `HVbox [: :]; - listws expr1 (S RO ";") el "" [: :] :]; - `HVbox [: `S LR "end"; k :] :] :] ] - | <:expr< $_$ $_$ >> | <:expr< $_$ . $_$ >> | <:expr< $_$ . ( $_$ ) >> | - <:expr< $_$ . [ $_$ ] >> | <:expr< $_$ := $_$ >> | - <:expr< $_$ # $_$ >> | - <:expr< fun [ $list:_$ ] >> | <:expr< match $_$ with [ $list:_$ ] >> | - <:expr< try $_$ with [ $list:_$ ] >> | - <:expr< if $_$ then $_$ else $_$ >> | - <:expr< for $_$ = $_$ $to:_$ $_$ do { $list:_$ } >> | - <:expr< while $_$ do { $list:_$ } >> | <:expr< ($list: _$) >> | - <:expr< let $opt:_$ $list:_$ in $_$ >> | - <:expr< let module $_$ = $_$ in $_$ >> | - (* Note: `new' is treated differently in pa_o and in pa_r, - and should not occur at this level *) - <:expr< assert $_$ >> | <:expr< lazy $_$ >> as e -> - fun curr next dg k -> - [: `S LO "("; `expr e "" [: `HVbox [: `S RO ")"; k :] :] :] - | e -> fun curr next _ k -> [: `not_impl "expr" e :] ]}]; - -pr_patt.pr_levels := - [{pr_label = "top"; pr_box p x = LocInfo (intloc(MLast.loc_of_patt p)) (HOVCbox x); - pr_rules = - extfun Extfun.empty with - [ <:patt< ($x$ as $lid:y$) >> -> - fun curr next dg k -> - [: curr x "" [: :]; `S LR "as"; `S LR (var_escaped y); k :] - | <:patt< ($x$ as $y$) >> -> - fun curr next dg k -> - [: curr y "" [: :]; `S LR "as"; `next x "" k :] - | p -> fun curr next dg k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:patt< $x$ | $y$ >> -> - fun curr next dg k -> [: curr x "" [: `S LR "|" :]; `next y "" k :] - | p -> fun curr next dg k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVCbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:patt< ($list:pl$) >> -> - fun curr next dg k -> - [: `HVbox [: :]; listws next (S RO ",") pl "" k :] - | p -> fun curr next dg k -> [: `next p "" k :] ]}; - {pr_label = "patt1"; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:patt< $x$ .. $y$ >> -> - fun curr next dg k -> [: curr x "" [: `S NO ".." :]; `next y "" k :] - | p -> fun curr next dg k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVCbox x; - pr_rules = - extfun Extfun.empty with - [ <:patt< [$_$ :: $_$] >> as p -> - fun curr next dg k -> - let (pl, c) = - make_list p where rec make_list p = - match p with - [ <:patt< [$p$ :: $y$] >> -> - let (pl, c) = make_list y in - ([p :: pl], c) - | <:patt< [] >> -> ([], None) - | x -> ([], Some p) ] - in - match c with - [ None -> - [: `S LO "["; - listws patt (S RO ";") pl "" [: `S RO "]"; k :] :] - | Some x -> - [: `HVbox [: :]; listws next (S LR "::") (pl @ [x]) "" k :] ] - | p -> fun curr next dg k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:patt< [$_$ :: $_$] >> as p -> - fun curr next dg k -> [: `next p "" k :] - | <:patt< $x$ $y$ >> -> - fun curr next dg k -> - match get_patt_args x [y] with - [ (_, [_]) -> [: curr x "" [: :]; `next y "" k :] - | ((<:patt< $uid:_$ >> | <:patt< $_$ . $uid:_$ >> as a), al) -> - [: curr a "" [: :]; - `HOVbox - [: `S LO "("; - listws (fun x _ k -> HOVbox [: curr x "" k :]) - (S RO ",") al "" [: `S RO ")"; k :] :] :] - | _ -> [: curr x "" [: :]; `next y "" k :] ] - | p -> fun curr next dg k -> [: `next p "" k :] ]}; - {pr_label = "simple"; - pr_box p x = LocInfo (intloc(MLast.loc_of_patt p)) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:patt< $x$ . $y$ >> -> - fun curr next dg k -> [: curr x "" [: :]; `S NO "."; - `simple_patt y "" k :] - | <:patt< [| $list:pl$ |] >> -> - fun curr next dg k -> - [: `S LR "[|"; listws patt (S RO ";") pl "" [: `S LR "|]"; k :] :] - | <:patt< { $list:fpl$ } >> -> - fun curr next dg k -> - [: `HVbox - [: `S LO "{"; - listws - (fun (lab, p) _ k -> - HVbox - [: `patt lab "" [: `S LR "=" :]; `patt p "" k :]) - (S RO ";") fpl "" [: `S RO "}"; k :] :] :] - | <:patt< [$_$ :: $_$] >> as p -> - fun curr next dg k -> - let (pl, c) = - make_list p where rec make_list p = - match p with - [ <:patt< [$p$ :: $y$] >> -> - let (pl, c) = make_list y in - ([p :: pl], c) - | <:patt< [] >> -> ([], None) - | x -> ([], Some p) ] - in - match c with - [ None -> - [: `S LO "["; - listws patt (S RO ";") pl "" [: `S RO "]"; k :] :] - | Some x -> - [: `S LO "("; `patt p "" [: `HVbox [: `S RO ")"; k :] :] :] ] - | <:patt< ($p$ : $ct$) >> -> - fun curr next dg k -> - [: `S LO "("; `patt p "" [: `S LR ":" :]; - `ctyp ct "" [: `S RO ")"; k :] :] - | ( <:patt< $int:s$ >> | <:patt< $flo:s$ >> ) - -> fun curr next dg k -> [: `S LR s; k :] - | MLast.PaInt32 _ s - -> fun curr next dg k -> [: `S LR (s^"l"); k :] - | MLast.PaInt64 _ s - -> fun curr next dg k -> [: `S LR (s^"L"); k :] - | MLast.PaNativeInt _ s - -> fun curr next dg k -> [: `S LR (s^"n"); k :] - | <:patt< $str:s$ >> -> - fun curr next dg k -> [: `S LR ("\"" ^ s ^ "\""); k :] - | <:patt< $chr:c$ >> -> - fun curr next dg k -> - let c = ocaml_char c in - [: `S LR ("'" ^ c ^ "'"); k :] - | <:patt< $lid:i$ >> -> fun curr next dg k -> [: `id_var i; k :] - | <:patt< $uid:i$ >> -> - fun curr next dg k -> [: `S LR (conv_con i); k :] - | <:patt< ` $i$ >> -> fun curr next dg k -> [: `S LR ("`" ^ i); k :] - | <:patt< # $list:sl$ >> -> - fun curr next dg k -> [: `S LO "#"; mod_ident sl dg k :] - | <:patt< ~ $i$ >> -> - fun curr next dg k -> [: `S LR ("~" ^ i); k :] - | <:patt< ~ $i$ : $p$ >> -> - fun curr next dg k -> - [: `S LO ("~" ^ i ^ ":"); `simple_patt p "" k :] - | <:patt< ? $i$ >> -> - fun curr next _ k -> [: `S LR ("?" ^ i); k :] - | <:patt< ? $i$ : ($p$) >> -> - fun curr next dg k -> - if i = "" then [: `S LO "?"; `simple_patt p "" k :] - else [: `S LO ("?" ^ i ^ ":"); `simple_patt p "" k :] - | <:patt< ? $i$ : ($p$ = $e$) >> -> - fun curr next dg k -> - if i = "" then - [: `S LO "?"; `S LO "("; `patt p "" [: `S LR "=" :]; - `expr e "" [: `S RO ")"; k :] :] - else - [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p "" [: `S LR "=" :]; - `expr e "" [: `S RO ")"; k :] :] - | <:patt< ? $i$ : ($p$ : $t$ = $e$) >> -> - fun curr next dg k -> - if i = "" then - [: `S LO "?"; `S LO "("; `patt p "" [: `S LR "=" :]; - `expr e "" [: `S RO ")"; k :] :] - else - [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p "" [: `S LR "=" :]; - `expr e "" [: `S RO ")"; k :] :] - | <:patt< _ >> -> fun curr next dg k -> [: `S LR "_"; k :] - | <:patt< $_$ $_$ >> | <:patt< ($_$ as $_$) >> | <:patt< $_$ | $_$ >> | - <:patt< ($list:_$) >> | <:patt< $_$ .. $_$ >> as p -> - fun curr next dg k -> - [: `S LO "("; `patt p "" [: `HVbox [: `S RO ")"; k :] :] :] - | p -> fun curr next dg k -> [: `next p "" k :] ]}]; - -pr_ctyp.pr_levels := - [{pr_label = "top"; pr_box t x = LocInfo (intloc(MLast.loc_of_ctyp t)) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $x$ as $y$ >> -> - fun curr next dg k -> [: curr x "" [: `S LR "as" :]; `next y "" k :] - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $x$ -> $y$ >> -> - fun curr next dg k -> [: `next x "" [: `S LR "->" :]; curr y "" k :] - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< ? $lab$ : $t$ >> -> - fun curr next dg k -> - [: `S LO "?"; `S LR lab; `S RO ":"; `next t "" k :] - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< ($list:tl$) >> -> - fun curr next dg k -> listws next (S LR "*") tl "" k - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = "simple"; - pr_box t x = LocInfo (intloc(MLast.loc_of_ctyp t)) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $t1$ == $t2$ >> -> - fun curr next dg k -> - [: curr t1 "=" [: `S LR "=" :]; `next t2 "" k :] - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< ? $lab$ : $t$ >> -> - fun curr next dg k -> - [: `S LO "?"; `S LR lab; `S RO ":"; `next t "" k :] - | <:ctyp< ~ $lab$ : $t$ >> -> - fun curr next dg k -> [: `S LO (lab ^ ":"); `next t "" k :] - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $t1$ $t2$ >> -> - fun curr next dg k -> - let (t, tl) = get_type_args t1 [t2] in - match tl with - [ [<:ctyp< $_$ $_$ >>] -> [: curr t2 "" [: :]; curr t1 "" k :] - | [_] -> [: `next t2 "" [: :]; curr t1 "" k :] - | _ -> - [: `S LO "("; - listws (fun x _ k -> HOVbox [: curr x "" k :]) (S RO ",") - tl "" [: `S RO ")" :]; - curr t "" k :] ] - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $t1$ . $t2$ >> -> - fun curr next dg k -> - [: `module_pref t1 "" [: `S NO "." :]; `next t2 "" k :] - | t -> fun curr next dg k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< '$s$ >> -> - fun curr next dg k -> [: `S LO "'"; `S LR (var_escaped s); k :] - | <:ctyp< $lid:s$ >> -> - fun curr next dg k -> [: `S LR (var_escaped s); k :] - | <:ctyp< $uid:s$ >> -> fun curr next dg k -> [: `S LR s; k :] - | <:ctyp< _ >> -> fun curr next dg k -> [: `S LR "_"; k :] - | <:ctyp< { $list:ftl$ } >> as t -> - fun curr next dg k -> - let loc = MLast.loc_of_ctyp t in - [: `HVbox - [: labels loc [: `S LR "{" :] ftl "" [: `S LR "}" :]; - k :] :] - | <:ctyp< private $ty$ >> -> - fun curr next dg k -> - [: `HVbox - [: `HVbox [:`S LR "private" :]; - `ctyp ty "" k :] :] - | <:ctyp< [ $list:ctl$ ] >> as t -> - fun curr next dg k -> - let loc = MLast.loc_of_ctyp t in - [: `Vbox - [: `HVbox [: :]; variants loc [: `S LR " " :] ctl "" [: :]; - k :] :] - | <:ctyp< [ = $list:rfl$ ] >> -> - fun curr next dg k -> - [: `HVbox - [: `HVbox [: :]; - row_fields [: `S LR "[" :] rfl "" [: `S LR "]" :]; - k :] :] - | <:ctyp< [ > $list:rfl$ ] >> -> - fun curr next dg k -> - [: `HVbox - [: `HVbox [: :]; - row_fields [: `S LR "[>" :] rfl "" [: `S LR "]" :]; - k :] :] - | <:ctyp< [ < $list:rfl$ > $list:sl$ ] >> -> - fun curr next dg k -> - let k1 = [: `S LR "]" :] in - let k1 = - match sl with - [ [] -> k1 - | l -> - [: `S LR ">"; - list (fun x _ k -> HVbox [: `S LR x; k :]) l "" k1 :] ] - in - [: `HVbox - [: `HVbox [: :]; row_fields [: `S LR "[<" :] rfl "" k1; - k :] :] - | MLast.TyCls _ id -> - fun curr next dg k -> [: `S LO "#"; `class_longident id "" k :] - | MLast.TyObj _ [] False -> fun curr next dg k -> [: `S LR "<>"; k :] - | MLast.TyObj _ ml v -> - fun curr next dg k -> - [: `S LR "<"; meth_list (ml, v) "" [: `S LR ">"; k :] :] - | MLast.TyPol _ pl t -> - fun curr next dg k -> - if pl = [] then [: `ctyp t "" k :] - else [: list typevar pl "" [: `S LR "." :]; `ctyp t "" k :] - | <:ctyp< $_$ -> $_$ >> | <:ctyp< $_$ $_$ >> | <:ctyp< $_$ == $_$ >> | - <:ctyp< $_$ . $_$ >> | <:ctyp< ($list:_$) >> | <:ctyp< $_$ as $_$ >> | - <:ctyp< ~ $_$ : $_$ >> | <:ctyp< ? $_$ : $_$ >> as t -> - fun curr next dg k -> - [: `S LO "("; `ctyp t "" [: `HVbox [: `S RO ")"; k :] :] :] - | t -> fun curr next dg k -> [: `next t "" k :] ]}]; - -pr_class_str_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (intloc(MLast.loc_of_class_str_item s)) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ MLast.CrDcl _ s -> - fun curr next dg k -> [: `HVbox [: :]; list class_str_item s "" k :] - | MLast.CrInh _ ce pb -> - fun curr next dg k -> - [: `S LR "inherit"; `class_expr ce [: :]; - match pb with - [ Some i -> [: `S LR "as"; `S LR i :] - | _ -> [: :] ]; - k :] - | MLast.CrVal _ lab mf e -> - fun curr next dg k -> [: `cvalue [: `S LR "val" :] (lab, mf, e) k :] - | MLast.CrVir _ lab pf t -> - fun curr next dg k -> - [: `S LR "method"; `S LR "virtual"; private_flag pf; `label lab; - `S LR ":"; `ctyp t "" k :] - | MLast.CrMth _ lab pf fb None -> - fun curr next dg k -> - [: `fun_binding [: `S LR "method"; private_flag pf; `label lab :] - fb k :] - | MLast.CrMth _ lab pf fb (Some t) -> - fun curr next dg k -> - [: `HOVbox - [: `S LR "method"; private_flag pf; `label lab; `S LR ":"; - `ctyp t "" [: `S LR "=" :] :]; - `expr fb "" k :] - | MLast.CrCtr _ t1 t2 -> - fun curr next dg k -> - [: `HVbox [: `S LR "constraint"; `ctyp t1 "" [: `S LR "=" :] :]; - `ctyp t2 "" k :] - | MLast.CrIni _ se -> - fun curr next dg k -> [: `S LR "initializer"; `expr se "" k :] - | csi -> fun curr next dg k -> [: `next csi "" k :] ]}]; - -pr_class_sig_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (intloc(MLast.loc_of_class_sig_item s)) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ MLast.CgCtr _ t1 t2 -> - fun curr next dg k -> - [: `S LR "constraint"; `ctyp t1 "" [: `S LR "=" :]; - `ctyp t2 "" k :] - | MLast.CgDcl _ s -> - fun curr next dg k -> - [: `HVbox [: :]; list class_sig_item s "" [: :] :] - | MLast.CgInh _ ce -> - fun curr next dg k -> [: `S LR "inherit"; `class_type ce k :] - | MLast.CgMth _ lab pf t -> - fun curr next dg k -> - [: `HVbox - [: `S LR "method"; private_flag pf; `label lab; - `S LR ":" :]; - `ctyp t "" k :] - | MLast.CgVal _ lab mf t -> - fun curr next dg k -> - [: `HVbox - [: `S LR "val"; mutable_flag mf; `label lab; `S LR ":" :]; - `ctyp t "" k :] - | MLast.CgVir _ lab pf t -> - fun curr next dg k -> - [: `HVbox - [: `S LR "method"; `S LR "virtual"; private_flag pf; - `label lab; `S LR ":" :]; - `ctyp t "" k :] - | csi -> fun curr next dg k -> [: `next csi "" k :] ]}]; - -pr_class_type.pr_levels := - [{pr_label = "top"; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CtFun _ t ct -> - fun curr next dg k -> - [: `ctyp t "" [: `S LR "->" :]; curr ct "" k :] - | ct -> fun curr next dg k -> [: `class_signature ct k :] ]}]; - -pr_class_expr.pr_levels := - [{pr_label = "top"; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CeFun _ p ce -> - fun curr next dg k -> - [: `S LR "fun"; `simple_patt p "" [: `S LR "->" :]; - `class_expr ce k :] - | MLast.CeLet _ rf lb ce -> - fun curr next dg k -> - [: `Vbox - [: `HVbox [: :]; - `bind_list [: `S LR "let"; rec_flag rf :] lb "" - [: `S LR "in" :]; - `class_expr ce k :] :] - | x -> fun curr next dg k -> [: `next x "" k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CeApp _ ce e -> - fun curr next dg k -> [: curr ce "" [: :]; `simple_expr e "" k :] - | x -> fun curr next dg k -> [: `next x "" k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CeCon _ ci [] -> - fun curr next dg k -> [: `class_longident ci "" k :] - | MLast.CeCon _ ci ctcl -> - fun curr next dg k -> - [: `S LO "["; listws ctyp (S RO ",") ctcl "" [: `S RO "]" :]; - `class_longident ci "" k :] - | MLast.CeStr _ csp cf as ce -> - let ep = snd (MLast.loc_of_class_expr ce) in - fun curr next dg k -> - [: `BEbox - [: `HVbox [: `S LR "object"; `class_self_patt_opt csp :]; - `HVbox - [: `HVbox [: :]; list class_str_item cf "" [: :]; - `LocInfo (intloc(ep, ep)) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] :] - | MLast.CeTyc _ ce ct -> - fun curr next dg k -> - [: `S LO "("; `class_expr ce [: `S LR ":" :]; - `class_type ct [: `S RO ")"; k :] :] - | MLast.CeFun _ _ _ as ce -> - fun curr next dg k -> - [: `S LO "("; `class_expr ce [: `S RO ")"; k :] :] - | ce -> fun curr next dg k -> [: `not_impl "class_expr" ce; k :] ]}]; - -value output_string_eval oc s = - loop 0 where rec loop i = - if i == String.length s then () - else if i == String.length s - 1 then output_char oc s.[i] - else - match (s.[i], s.[i + 1]) with - [ ('\\', 'n') -> do { output_char oc '\n'; loop (i + 2) } - | (c, _) -> do { output_char oc c; loop (i + 1) } ] -; - -value maxl = ref 78; -value sep = Pcaml.inter_phrases; -value ncip = ref True; - -value input_source ic len = - let buff = Buffer.create 20 in - try - let rec loop i = - if i >= len then Buffer.contents buff - else do { let c = input_char ic in Buffer.add_char buff c; loop (i + 1) } - in - loop 0 - with - [ End_of_file -> - let s = Buffer.contents buff in - if s = "" then - match sep.val with - [ Some s -> s - | None -> "\n" ] - else s ] -; - -value copy_source ic oc first bp ep = - match sep.val with - [ Some str -> - if first then () - else if ep == in_channel_length ic then output_string oc "\n" - else output_string_eval oc str - | None -> - do { - seek_in ic bp; let s = input_source ic (ep - bp) in output_string oc s - } ] -; - -value copy_to_end ic oc first bp = - let ilen = in_channel_length ic in - if bp < ilen then copy_source ic oc first bp ilen else output_string oc "\n" -; - -module Buff = - struct - value buff = ref (String.create 80); - value store len x = - do { - if len >= String.length buff.val then - buff.val := buff.val ^ String.create (String.length buff.val) - else (); - buff.val.[len] := x; - succ len - } - ; - value mstore len s = - add_rec len 0 where rec add_rec len i = - if i == String.length s then len - else add_rec (store len s.[i]) (succ i) - ; - value get len = String.sub buff.val 0 len; - end -; - -value extract_comment strm = - let rec find_comm nl_bef tab_bef = - parser - [ [: `'('; a = find_star nl_bef tab_bef :] -> a - | [: `' '; s :] -> find_comm nl_bef (tab_bef + 1) s - | [: `'\t'; s :] -> find_comm nl_bef (tab_bef + 8) s - | [: `'\n'; s :] -> find_comm (nl_bef + 1) 0 s - | [: `_; s :] -> find_comm 0 0 s - | [: :] -> ("", nl_bef, tab_bef) ] - and find_star nl_bef tab_bef = - parser - [ [: `'*'; a = insert (Buff.mstore 0 "(*") :] -> (a, nl_bef, tab_bef) - | [: a = find_comm 0 0 :] -> a ] - and insert len = - parser - [ [: `'*'; a = rparen (Buff.store len '*') :] -> a - | [: `'('; len = find_star2 (Buff.store len '('); s :] -> insert len s - | [: `'\t'; s :] -> insert (Buff.mstore len (String.make 8 ' ')) s - | [: `x; s :] -> insert (Buff.store len x) s - | [: :] -> "" ] - and rparen len = - parser - [ [: `')'; s :] -> while_space (Buff.store len ')') s - | [: a = insert len :] -> a ] - and while_space len = - parser - [ [: `' '; a = while_space (Buff.store len ' ') :] -> a - | [: `'\t'; a = while_space (Buff.mstore len (String.make 8 ' ')) :] -> a - | [: `'\n'; a = while_space (Buff.store len '\n') :] -> a - | [: `'('; a = find_star_again len :] -> a - | [: :] -> Buff.get len ] - and find_star_again len = - parser - [ [: `'*'; a = insert (Buff.mstore len "(*") :] -> a - | [: :] -> Buff.get len ] - and find_star2 len = - parser - [ [: `'*'; a = insert2 (Buff.store len '*') :] -> a - | [: :] -> len ] - and insert2 len = - parser - [ [: `'*'; a = rparen2 (Buff.store len '*') :] -> a - | [: `'('; len = find_star2 (Buff.store len '('); s :] -> insert2 len s - | [: `x; s :] -> insert2 (Buff.store len x) s - | [: :] -> 0 ] - and rparen2 len = - parser - [ [: `')' :] -> Buff.store len ')' - | [: a = insert2 len :] -> a ] - in - find_comm 0 0 strm -; - -value get_no_comment _ _ = ("", 0, 0, 0); - -value get_comment ic beg len = - do { - seek_in ic beg; - let strm = - Stream.from (fun i -> if i >= len then None else Some (input_char ic)) - in - let (s, nl_bef, tab_bef) = extract_comment strm in - (s, nl_bef, tab_bef, Stream.count strm) - } -; - -value apply_printer printer ast = - let oc = - match Pcaml.output_file.val with - [ Some f -> open_out_bin f - | None -> stdout ] - in - let cleanup () = - match Pcaml.output_file.val with - [ Some _ -> close_out oc - | None -> () ] - in - let pr_ch = output_char oc in - let pr_str = output_string oc in - let pr_nl () = output_char oc '\n' in - if Pcaml.input_file.val <> "-" && Pcaml.input_file.val <> "" then do { - let ic = open_in_bin Pcaml.input_file.val in - let getcom = - if not ncip.val && sep.val = None then get_comment ic - else get_no_comment - in - try - let (first, last_pos) = - List.fold_left - (fun (first, last_pos) (si, (bp, ep)) -> - do { - copy_source ic oc first last_pos.Lexing.pos_cnum bp.Lexing.pos_cnum; - flush oc; - print_pretty pr_ch pr_str pr_nl "" "" maxl.val getcom bp.Lexing.pos_cnum - (printer si "" [: :]); - flush oc; - (False, ep) - }) - (True, Token.nowhere) ast - in - do { copy_to_end ic oc first last_pos.Lexing.pos_cnum; flush oc } - with x -> - do { close_in ic; cleanup (); raise x }; - close_in ic; - cleanup () - } - else do { - List.iter - (fun (si, _) -> - do { - print_pretty pr_ch pr_str pr_nl "" "" maxl.val get_no_comment 0 - (printer si "" [: :]); - match sep.val with - [ Some str -> output_string_eval oc str - | None -> output_char oc '\n' ]; - flush oc - }) - ast; - cleanup () - } -; - -Pcaml.print_interf.val := apply_printer sig_item; -Pcaml.print_implem.val := apply_printer str_item; - -Pcaml.add_option "-l" (Arg.Int (fun x -> maxl.val := x)) - " line length for pretty printing."; - -Pcaml.add_option "-ss" (Arg.Clear no_ss) "Print double semicolons."; - -Pcaml.add_option "-no_ss" (Arg.Set no_ss) - "Do not print double semicolons (default)."; - -Pcaml.add_option "-sep_src" (Arg.Unit (fun () -> sep.val := None)) - "Read source file for text between phrases (default)."; - -Pcaml.add_option "-sep" (Arg.String (fun x -> sep.val := Some x)) - " Use this string between phrases instead of reading source."; - -Pcaml.add_option "-cip" (Arg.Clear ncip) "Add comments in phrases."; - -Pcaml.add_option "-ncip" (Arg.Set ncip) "No comments in phrases (default)."; - -Pcaml.add_option "-tc" (Arg.Clear ncip) - "Deprecated since version 3.05; equivalent to -cip."; diff --git a/camlp4/etc/pr_op.ml b/camlp4/etc/pr_op.ml deleted file mode 100644 index b2c8ae2f..00000000 --- a/camlp4/etc/pr_op.ml +++ /dev/null @@ -1,501 +0,0 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: pr_op.ml,v 1.5 2004/11/17 09:07:56 mauny Exp $ *) - -open Pcaml; -open Spretty; - -value expr e dg k = pr_expr.pr_fun "top" e dg k; -value patt e dg k = pr_patt.pr_fun "top" e dg k; - -value spatt p dg k = - match p with - [ <:patt< $lid:s$ >> -> - if String.length s >= 2 && s.[1] == ''' then - HVbox [: `S LR (" " ^ s); k :] - else patt p dg k - | _ -> patt p dg k ] -; - -(* Streams *) - -value stream e _ k = - let rec get = - fun - [ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y] - | <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y] - | <:expr< Stream.ising $x$ >> -> [(True, x)] - | <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y] - | <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y] - | <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)] - | <:expr< Stream.sempty >> -> [] - | <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)] - | <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)] - | e -> [(False, e)] ] - in - let elem e dg k = - match e with - [ (True, e) -> [: `HOVbox [: `S LO "'"; `expr e dg k :] :] - | (False, e) -> [: `expr e dg k :] ] - in - let rec glop e k = - match e with - [ [] -> k - | [e] -> [: elem e "" k :] - | [e :: el] -> [: elem e ";" [: `S RO ";" :]; glop el k :] ] - in - HOVbox [: `S LR "[<"; glop (get e) [: `S LR ">]"; k :] :] -; - -(* Parsers *) - -type spc = - [ SPCterm of (MLast.patt * option MLast.expr) - | SPCnterm of MLast.patt and MLast.expr - | SPCsterm of MLast.patt ] -; - -exception NotImpl; - -value rec subst v e = - match e with - [ <:expr< $lid:x$ >> -> if x = "strm__" then <:expr< $lid:v$ >> else e - | <:expr< $uid:_$ >> -> e - | <:expr< $int:_$ >> -> e - | <:expr< $chr:_$ >> -> e - | <:expr< $str:_$ >> -> e - | <:expr< $e1$ . $lab$ >> -> <:expr< $subst v e1$ . $lab$ >> - | <:expr< $x$ $y$ >> -> <:expr< $subst v x$ $subst v y$ >> - | <:expr< let $lid:s1$ = $e1$ in $e2$ >> -> - if s1 = v then <:expr< let $lid:s1$ = $subst v e1$ in $e2$ >> - else <:expr< let $lid:s1$ = $subst v e1$ in $subst v e2$ >> - | <:expr< let _ = $e1$ in $e2$ >> -> - <:expr< let _ = $subst v e1$ in $subst v e2$ >> - | <:expr< ($list:el$) >> -> <:expr< ($list:List.map (subst v) el$) >> - | _ -> raise NotImpl ] -; - -value rec is_free v = - fun - [ <:expr< $lid:x$ >> -> x <> v - | <:expr< $uid:_$ >> -> True - | <:expr< $int:_$ >> -> True - | <:expr< $chr:_$ >> -> True - | <:expr< $str:_$ >> -> True - | <:expr< $e$ . $_$ >> -> is_free v e - | <:expr< $x$ $y$ >> -> is_free v x && is_free v y - | <:expr< let $lid:s1$ = $e1$ in $e2$ >> -> - is_free v e1 && (s1 = v || is_free v e2) - | <:expr< let _ = $e1$ in $e2$ >> -> is_free v e1 && is_free v e2 - | <:expr< ($list:el$) >> -> List.for_all (is_free v) el - | _ -> raise NotImpl ] -; - -value free_var_in_expr c e = - let rec loop_alpha v = - let x = String.make 1 v in - if is_free x e then Some x - else if v = 'z' then None - else loop_alpha (Char.chr (Char.code v + 1)) - in - let rec loop_count cnt = - let x = String.make 1 c ^ string_of_int cnt in - if is_free x e then x else loop_count (succ cnt) - in - try - match loop_alpha c with - [ Some v -> v - | None -> loop_count 1 ] - with - [ NotImpl -> "\\%a" ] -; - -value parserify = - fun - [ <:expr< $e$ strm__ >> -> e - | e -> <:expr< fun strm__ -> $e$ >> ] -; - -value is_raise_failure = - fun - [ <:expr< raise Stream.Failure >> -> True - | _ -> False ] -; - -value is_raise_error = - fun - [ <:expr< raise (Stream.Error $_$) >> -> True - | _ -> False ] -; - -value semantic e = - try - if is_free "strm__" e then e - else - let v = free_var_in_expr 's' e in - <:expr< let $lid:v$ = strm__ in $subst v e$ >> - with - [ NotImpl -> e ] -; - -value rewrite_parser = - rewrite True where rec rewrite top ge = - match ge with - [ <:expr< let $p$ = try $e$ with [ Stream.Failure -> raise $exc$ ] in - $sp_kont$ >> -> - let f = parserify e in - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> raise $exc$ ] - >> - | <:expr< let $p$ = Stream.count strm__ in $f$ >> -> - try - if is_free "strm__" f then ge - else - let v = free_var_in_expr 's' f in - <:expr< - let $lid:v$ = strm__ in - let $p$ = Stream.count strm__ in $subst v f$ - >> - with - [ NotImpl -> ge ] - | <:expr< let $p$ = strm__ in $e$ >> -> - <:expr< let $p$ = strm__ in $rewrite False e$ >> - | <:expr< let $p$ = $f$ strm__ in $sp_kont$ >> when top -> - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> raise Stream.Failure ] - >> - | <:expr< let $p$ = $e$ in $sp_kont$ >> -> - if match e with - [ <:expr< match try Some $_$ with [ Stream.Failure -> None ] with - [ $list:_$ ] >> - | <:expr< match Stream.peek strm__ with [ $list:_$ ] >> - | <:expr< try $_$ with [ Stream.Failure -> $_$ ] >> - | <:expr< let $_$ = Stream.count strm__ in $_$ >> -> True - | _ -> False ] - then - let f = rewrite True <:expr< fun strm__ -> $e$ >> in - let exc = - if top then <:expr< Stream.Failure >> - else <:expr< Stream.Error "" >> - in - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> raise $exc$ ] - >> - else semantic ge - | <:expr< match try Some $e$ with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> $p_kont$ ] >> -> - let f = parserify e in - if not top && is_raise_failure p_kont then semantic ge - else - let (p, f, sp_kont, p_kont) = - if top || is_raise_error p_kont then - (p, f, rewrite False sp_kont, rewrite top p_kont) - else - let f = - <:expr< - fun strm__ -> - match - try Some ($f$ strm__) with [ Stream.Failure -> None ] - with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> $rewrite top p_kont$ ] - >> - in - (<:patt< a >>, f, <:expr< a >>, - <:expr< raise (Stream.Error "") >>) - in - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> $p_kont$ ] - >> - | <:expr< match Stream.peek strm__ with [ $list:pel$ ] >> -> - let rec iter pel = - match pel with - [ [(<:patt< Some $p$ >>, eo, - <:expr< do { Stream.junk strm__; $sp_kont$ } >>); - (<:patt< _ >>, None, p_kont) :: _] -> - <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:eo$ -> - do { Stream.junk strm__; $rewrite False sp_kont$ } - | _ -> $rewrite top p_kont$ ] - >> - | [(<:patt< Some $p$ >>, eo, - <:expr< do { Stream.junk strm__; $sp_kont$ } >>) :: pel] -> - let p_kont = iter pel in - <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:eo$ -> - do { Stream.junk strm__; $rewrite False sp_kont$ } - | _ -> $p_kont$ ] - >> - | _ -> - <:expr< match Stream.peek strm__ with [ $list:pel$ ] >> ] - in - iter pel - | <:expr< try Some $e$ with [ Stream.Failure -> $p_kont$ ] >> -> - let f = parserify e in - let e = - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some a -> Some a - | _ -> $p_kont$ ] - >> - in - rewrite top e - | <:expr< try $e$ with [ Stream.Failure -> $p_kont$ ] >> -> - let f = parserify e in - let e = - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some a -> a - | _ -> $rewrite top p_kont$ ] - >> - in - rewrite top e - | <:expr< $f$ strm__ >> -> - if top then - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some a -> a - | _ -> raise Stream.Failure ] - >> - else - let v = free_var_in_expr 's' f in - <:expr< let $lid:v$ = strm__ in $f$ $lid:v$ >> - | e -> semantic e ] -; - -value parser_of_expr = - let rec parser_cases e = - match e with - [ <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> $p_kont$ ] - >> -> - let spc = (SPCnterm p f, None) in - let (sp, epo, e) = kont sp_kont in - [([spc :: sp], epo, e) :: parser_cases p_kont] - | <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ } - | _ -> $p_kont$ ] - >> -> - let spc = (SPCterm (p, wo), None) in - let (sp, epo, e) = kont sp_kont in - [([spc :: sp], epo, e) :: parser_cases p_kont] - | <:expr< let $p$ = strm__ in $sp_kont$ >> -> - let spc = (SPCsterm p, None) in - let (sp, epo, e) = kont sp_kont in - [([spc :: sp], epo, e)] - | <:expr< let $p$ = Stream.count strm__ in $e$ >> -> [([], Some p, e)] - | <:expr< raise Stream.Failure >> -> [] - | _ -> [([], None, e)] ] - and kont e = - match e with - [ <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> raise (Stream.Error $err$) ] - >> -> - let err = - match err with - [ <:expr< "" >> -> None - | _ -> Some err ] - in - let spc = (SPCnterm p f, err) in - let (sp, epo, e) = kont sp_kont in - ([spc :: sp], epo, e) - | <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ } - | _ -> raise (Stream.Error $err$) ] - >> -> - let err = - match err with - [ <:expr< "" >> -> None - | _ -> Some err ] - in - let spc = (SPCterm (p, wo), err) in - let (sp, epo, e) = kont sp_kont in - ([spc :: sp], epo, e) - | <:expr< let $p$ = strm__ in $sp_kont$ >> -> - let spc = (SPCsterm p, None) in - let (sp, epo, e) = kont sp_kont in - ([spc :: sp], epo, e) - | <:expr< let $p$ = Stream.count strm__ in $e$ >> -> ([], Some p, e) - | _ -> ([], None, e) ] - in - parser_cases -; - -value parser_cases b spel dg k = - let rec parser_cases b spel dg k = - match spel with - [ [] -> [: `HVbox [: b; k :] :] - | [(sp, epo, e)] -> [: `parser_case b sp epo e dg k :] - | [(sp, epo, e) :: spel] -> - [: `parser_case b sp epo e "|" [: :]; - parser_cases [: `S LR "|" :] spel dg k :] ] - and parser_case b sp epo e dg k = - let epo = - match epo with - [ Some p -> [: `patt p "" [: `S LR "->" :] :] - | _ -> [: `S LR "->" :] ] - in - HVbox - [: b; - `HOVbox - [: `HOVbox - [: `S LR "[<"; - stream_patt [: :] sp [: `S LR ">]"; epo :] :]; - `expr e dg k :] :] - and stream_patt b sp k = - match sp with - [ [] -> [: `HVbox [: b; k :] :] - | [(spc, None)] -> [: `stream_patt_comp b spc "" k :] - | [(spc, Some e)] -> - [: `HVbox - [: `stream_patt_comp b spc "" [: :]; - `HVbox [: `S LR "??"; `expr e "" k :] :] :] - | [(spc, None) :: spcl] -> - [: `stream_patt_comp b spc ";" [: `S RO ";" :]; - stream_patt [: :] spcl k :] - | [(spc, Some e) :: spcl] -> - [: `HVbox - [: `stream_patt_comp b spc "" [: :]; - `HVbox [: `S LR "??"; `expr e ";" [: `S RO ";" :] :] :]; - stream_patt [: :] spcl k :] ] - and stream_patt_comp b spc dg k = - match spc with - [ SPCterm (p, w) -> - HVbox [: b; `S LO "'"; `spatt p "" (when_opt w k) :] - | SPCnterm p e -> - HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e dg k :] :] - | SPCsterm p -> HVbox [: b; `patt p "" k :] ] - and when_opt wo k = - match wo with - [ Some e -> [: `S LR "when"; `expr e "" k :] - | _ -> k ] - in - parser_cases b spel dg k -; - -value parser_body e dg k = - let (bp, e) = - match e with - [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) - | e -> (None, e) ] - in - let e = rewrite_parser e in - match parser_of_expr e with - [ [] -> - let spe = ([], None, <:expr< raise Stream.Failure >>) in - HVbox - [: `HVbox - [: `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - parser_cases [: :] [spe] dg k :] - | spel -> - BEVbox - [: `HVbox - [: `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - parser_cases [: :] spel dg k :] ] -; - -value pmatch e dg k = - let (me, e) = - match e with - [ <:expr< let (strm__ : Stream.t _) = $me$ in $e$ >> -> (me, e) - | _ -> failwith "Pr_op.pmatch" ] - in - let (bp, e) = - match e with - [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) - | e -> (None, e) ] - in - let e = rewrite_parser e in - let spel = parser_of_expr e in - Vbox - [: `HVbox [: :]; - `HVbox - [: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - `BEbox [: `HVbox [: :]; parser_cases [: :] spel dg k :] :] -; - -(* Printer extensions *) - -pr_expr_fun_args.val := - extfun pr_expr_fun_args.val with - [ <:expr< fun strm__ -> $_$ >> as ge -> ([], ge) - | <:expr< fun [(strm__ : $_$) -> $_$] >> as ge -> ([], ge) ]; - -let lev = find_pr_level "expr1" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< let (strm__ : Stream.t _) = $_$ in $_$ >> as e -> - fun curr next dg k -> - if not (List.mem dg ["|"; ";"]) then [: `pmatch e dg k :] - else [: `S LO "("; `pmatch e "" [: `S RO ")"; k :] :] - | <:expr< fun strm__ -> $x$ >> -> - fun curr next dg k -> - if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :] - else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :] - | <:expr< fun [ (strm__ : $_$) -> $x$ ] >> -> - fun curr next dg k -> - if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :] - else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :] ]; - -let lev = find_pr_level "apply" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | - <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | - <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | - <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | - <:expr< Stream.slazy $_$ >> as e -> - fun curr next dg k -> [: `next e "" k :] ]; - -let lev = find_pr_level "dot" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.sempty >> as e -> - fun curr next dg k -> [: `next e "" k :] ]; - -let lev = find_pr_level "simple" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | - <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | - <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | - <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | - <:expr< Stream.slazy $_$ >> as e -> - fun curr next dg k -> - [: `stream e "" k :] ]; diff --git a/camlp4/etc/pr_op_main.ml b/camlp4/etc/pr_op_main.ml deleted file mode 100644 index 322268fc..00000000 --- a/camlp4/etc/pr_op_main.ml +++ /dev/null @@ -1,214 +0,0 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: pr_op_main.ml,v 1.3 2004/11/17 09:07:56 mauny Exp $ *) - -open Pcaml; -open Spretty; - -value _loc = (Token.nowhere, Token.nowhere); - -value expr e dg k = pr_expr.pr_fun "top" e dg k; -value patt e dg k = pr_patt.pr_fun "top" e dg k; - -value spatt p dg k = - match p with - [ <:patt< $lid:s$ >> -> - if String.length s >= 2 && s.[1] == ''' then - HVbox [: `S LR (" " ^ s); k :] - else patt p dg k - | _ -> patt p dg k ] -; - -(* Streams *) - -value stream e _ k = - let rec get = - fun - [ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y] - | <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y] - | <:expr< Stream.ising $x$ >> -> [(True, x)] - | <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y] - | <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y] - | <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)] - | <:expr< Stream.sempty >> -> [] - | <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)] - | <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)] - | e -> [(False, e)] ] - in - let elem e dg k = - match e with - [ (True, e) -> [: `HOVbox [: `S LO "'"; `expr e dg k :] :] - | (False, e) -> [: `expr e dg k :] ] - in - let rec glop e k = - match e with - [ [] -> k - | [e] -> [: elem e "" k :] - | [e :: el] -> [: elem e ";" [: `S RO ";" :]; glop el k :] ] - in - HOVbox [: `S LR "[<"; glop (get e) [: `S LR ">]"; k :] :] -; - -(* Parsers *) - -open Parserify; - -value parser_cases b spel dg k = - let rec parser_cases b spel dg k = - match spel with - [ [] -> [: `HVbox [: b; k :] :] - | [(sp, epo, e)] -> [: `parser_case b sp epo e dg k :] - | [(sp, epo, e) :: spel] -> - [: `parser_case b sp epo e "|" [: :]; - parser_cases [: `S LR "|" :] spel dg k :] ] - and parser_case b sp epo e dg k = - let epo = - match epo with - [ Some p -> [: `patt p "" [: `S LR "->" :] :] - | _ -> [: `S LR "->" :] ] - in - HVbox - [: b; - `HOVbox - [: `HOVbox - [: `S LR "[<"; - stream_patt [: :] sp [: `S LR ">]"; epo :] :]; - `expr e dg k :] :] - and stream_patt b sp k = - match sp with - [ [] -> [: `HVbox [: b; k :] :] - | [(spc, None)] -> [: `stream_patt_comp b spc "" k :] - | [(spc, Some e)] -> - [: `HVbox - [: `stream_patt_comp b spc "" [: :]; - `HVbox [: `S LR "??"; `expr e "" k :] :] :] - | [(spc, None) :: spcl] -> - [: `stream_patt_comp b spc ";" [: `S RO ";" :]; - stream_patt [: :] spcl k :] - | [(spc, Some e) :: spcl] -> - [: `HVbox - [: `stream_patt_comp b spc "" [: :]; - `HVbox [: `S LR "??"; `expr e ";" [: `S RO ";" :] :] :]; - stream_patt [: :] spcl k :] ] - and stream_patt_comp b spc dg k = - match spc with - [ SPCterm (p, w) -> - HVbox [: b; `S LO "'"; `spatt p "" (when_opt w k) :] - | SPCnterm p e -> - HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e dg k :] :] - | SPCsterm p -> HVbox [: b; `patt p "" k :] ] - and when_opt wo k = - match wo with - [ Some e -> [: `S LR "when"; `expr e "" k :] - | _ -> k ] - in - parser_cases b spel dg k -; - -value parser_body e dg k = - let (bp, e) = - match e with - [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) - | e -> (None, e) ] - in - match parser_of_expr e with - [ [] -> - let spe = ([], None, <:expr< raise Stream.Failure >>) in - HVbox - [: `HVbox - [: `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - parser_cases [: :] [spe] dg k :] - | spel -> - BEVbox - [: `HVbox - [: `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - parser_cases [: :] spel dg k :] ] -; - -value pmatch e dg k = - let (me, e) = - match e with - [ <:expr< let (strm__ : Stream.t _) = $me$ in $e$ >> -> (me, e) - | _ -> failwith "Pr_op.pmatch" ] - in - let (bp, e) = - match e with - [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) - | e -> (None, e) ] - in - let spel = parser_of_expr e in - Vbox - [: `HVbox [: :]; - `HVbox - [: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - `BEbox [: `HVbox [: :]; parser_cases [: :] spel dg k :] :] -; - -(* Printer extensions *) - -pr_expr_fun_args.val := - extfun pr_expr_fun_args.val with - [ <:expr< fun strm__ -> $_$ >> as ge -> ([], ge) - | <:expr< fun [(strm__ : $_$) -> $_$] >> as ge -> ([], ge) ]; - -let lev = find_pr_level "expr1" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< let (strm__ : Stream.t _) = $_$ in $_$ >> as e -> - fun curr next dg k -> - if not (List.mem dg ["|"; ";"]) then [: `pmatch e dg k :] - else [: `S LO "("; `pmatch e "" [: `S RO ")"; k :] :] - | <:expr< fun strm__ -> $x$ >> -> - fun curr next dg k -> - if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :] - else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :] - | <:expr< fun [ (strm__ : $_$) -> $x$ ] >> -> - fun curr next dg k -> - if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :] - else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :] ]; - -let lev = find_pr_level "apply" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | - <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | - <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | - <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | - <:expr< Stream.slazy $_$ >> as e -> - fun curr next dg k -> [: `next e "" k :] ]; - -let lev = find_pr_level "dot" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.sempty >> as e -> - fun curr next dg k -> [: `next e "" k :] ]; - -let lev = find_pr_level "simple" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | - <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | - <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | - <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | - <:expr< Stream.slazy $_$ >> as e -> - fun curr next dg k -> - [: `stream e "" k :] ]; diff --git a/camlp4/etc/pr_r.ml b/camlp4/etc/pr_r.ml deleted file mode 100644 index 39deb823..00000000 --- a/camlp4/etc/pr_r.ml +++ /dev/null @@ -1,1953 +0,0 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: pr_r.ml,v 1.53.2.1 2006/01/03 18:12:30 mauny Exp $ *) - -open Pcaml; -open Spretty; - -value not_impl name x = - let desc = - if Obj.is_block (Obj.repr x) then - "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) - else "int_val = " ^ string_of_int (Obj.magic x) - in - HVbox [: `S NO ("") :] -; - -value gen_where = ref True; -value old_sequences = ref False; -value expand_declare = ref False; - -value no_curried_constructors = ref False; - -value constructors_are_curried () = - not no_curried_constructors.val -; - -external is_printable : char -> bool = "caml_is_printable"; - -value char_escaped = - fun - [ '\\' -> "\\\\" - | '\b' -> "\\b" - | '\n' -> "\\n" - | '\r' -> "\\r" - | '\t' -> "\\t" - | c -> - if is_printable c then String.make 1 c - else do { - let n = Char.code c in - let s = String.create 4 in - String.unsafe_set s 0 '\\'; - String.unsafe_set s 1 (Char.unsafe_chr (48 + n / 100)); - String.unsafe_set s 2 (Char.unsafe_chr (48 + n / 10 mod 10)); - String.unsafe_set s 3 (Char.unsafe_chr (48 + n mod 10)); - s - } ] -; - -value rec list elem el k = - match el with - [ [] -> k - | [x] -> [: `elem x k :] - | [x :: l] -> [: `elem x [: :]; list elem l k :] ] -; - -value rec listws elem sep el k = - match el with - [ [] -> k - | [x] -> [: `elem x k :] - | [x :: l] -> [: `elem x [: `sep :]; listws elem sep l k :] ] -; - -value rec listwbws elem b sep el k = - match el with - [ [] -> [: b; k :] - | [x] -> [: `elem b x k :] - | [x :: l] -> [: `elem b x [: :]; listwbws elem [: `sep :] sep l k :] ] -; - -value is_infix = - let infixes = Hashtbl.create 73 in - do { - List.iter (fun s -> Hashtbl.add infixes s True) - ["=="; "!="; "+"; "+."; "-"; "-."; "*"; "*."; "/"; "/."; "**"; - "="; "=."; "<>"; "<>."; "<"; "<."; ">"; ">."; "<="; "<=."; ">="; ">=."; - "^"; "@"; "asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; - "&&"; "||"; "~-"; "~-."]; - fun s -> try Hashtbl.find infixes s with [ Not_found -> False ] - } -; - -value is_keyword = - let keywords = Hashtbl.create 301 in - do { - List.iter (fun s -> Hashtbl.add keywords s True) - ["!"; "!="; "#"; "&"; "&&"; "'"; "("; ")"; "*"; "**"; "*."; "+"; "+."; - ","; "-"; "-."; "->"; "."; ".."; "/"; "/."; ":"; "::"; ":="; ":>"; - ":]"; ";"; "<"; "<="; "<>"; "="; "=="; ">"; ">="; ">}"; "?"; "@"; "["; - "[:"; "[|"; "]"; "^"; "_"; "`"; "and"; "as"; "asr"; "assert"; "class"; - "constraint"; "declare"; "do"; "done"; "downto"; "else"; "end"; - "exception"; "external"; "for"; "fun"; "functor"; "if"; "in"; - "include"; "inherit"; "initializer"; "land"; "lazy"; "let"; "lor"; - "lsl"; "lsr"; "lxor"; "match"; "method"; "mod"; "module"; "mutable"; - "new"; "object"; "of"; "open"; "parser"; "private"; "rec"; "return"; - "sig"; "struct"; "then"; "to"; "try"; "type"; "value"; "virtual"; - "when"; "where"; "while"; "with"; "{"; "{<"; "|"; "|]"; "||"; "}"; - "~-"; "~-."]; - fun s -> try Hashtbl.find keywords s with [ Not_found -> False ] - } -; - -value has_special_chars v = - match v.[0] with - [ 'a'..'z' | 'A'..'Z' | '\192'..'\214' | '\216'..'\246' | '\248'..'\255' | - '_' -> - False - | _ -> - if String.length v >= 2 && v.[0] == '<' && - (v.[1] == '<' || v.[1] == ':') - then - False - else True ] -; - -value var_escaped v = - if v = "" then "$lid:\"\"$" - else if has_special_chars v || is_infix v then "\\" ^ v - else if is_keyword v then v ^ "__" - else v -; - -value flag n f = if f then [: `S LR n :] else [: :]; - -(* default global loc *) - -value _loc = (Token.nowhere, Token.nowhere); - -(* extensible printers *) - -value module_type e k = pr_module_type.pr_fun "top" e "" k; -value module_expr e k = pr_module_expr.pr_fun "top" e "" k; -value sig_item x k = pr_sig_item.pr_fun "top" x "" [: `S RO ";"; k :]; -value str_item x k = pr_str_item.pr_fun "top" x "" [: `S RO ";"; k :]; -value expr x k = pr_expr.pr_fun "top" x "" k; -value patt x k = pr_patt.pr_fun "top" x "" k; -value ctyp x k = pr_ctyp.pr_fun "top" x "" k; -value expr_fun_args ge = Extfun.apply pr_expr_fun_args.val ge; -value simple_expr x k = pr_expr.pr_fun "simple" x "" k; -value class_sig_item x k = - pr_class_sig_item.pr_fun "top" x "" [: `S RO ";"; k :] -; -value class_str_item x k = - pr_class_str_item.pr_fun "top" x "" [: `S RO ";"; k :] -; -value class_type x k = pr_class_type.pr_fun "top" x "" k; -value class_expr x k = pr_class_expr.pr_fun "top" x "" k; - - -value intloc loc = ((fst loc).Lexing.pos_cnum, (snd loc).Lexing.pos_cnum); - -(* type core *) - -value rec labels loc b vl k = - match vl with - [ [] -> [: b; k :] - | [v] -> - [: `HVbox - [: `HVbox [: :]; `label True b v [: :]; - `LocInfo (intloc(snd loc, snd loc)) (HVbox k) :] :] - | [v :: l] -> [: `label False b v [: :]; labels loc [: :] l k :] ] -and label is_last b (loc, f, m, t) k = - let m = flag "mutable" m in - let k = [: if is_last then [: :] else [: `S RO ";" :]; k :] in - Hbox - [: `LocInfo (intloc loc) - (HVbox - [: `HVbox [: b; `S LR f; `S LR ":" :]; - `HVbox [: m; `ctyp t [: :] :] :]); - k :] -; - -value rec ctyp_list tel k = - if constructors_are_curried() then - listws ctyp (S LR "and") tel k else - if List.length tel > 1 then - [: `S LO "("; listws ctyp (S LR "*") tel [: `S RO ")"; k :] :] - else - listws ctyp (S LR "*") tel k -; - -value rec variants loc b vl k = - match vl with - [ [] -> [: b; k :] - | [v] -> - [: `HVbox - [: `HVbox [: :]; `variant b v [: :]; - `LocInfo (intloc(snd loc, snd loc)) (HVbox k) :] :] - | [v :: l] -> [: `variant b v [: :]; variants loc [: `S LR "|" :] l k :] ] -and variant b (loc, c, tl) k = - match tl with - [ [] -> HVbox [: `LocInfo (intloc loc) (HVbox b); `HOVbox [: `S LR c; k :] :] - | _ -> - HVbox - [: `LocInfo (intloc loc) (HVbox b); - `HOVbox [: `S LR c; `S LR "of"; ctyp_list tl k :] :] ] -; - -value rec row_fields b rfl k = listwbws row_field b (S LR "|") rfl k -and row_field b rf k = - match rf with - [ MLast.RfTag c ao tl -> - let c = "`" ^ c in - match tl with - [ [] -> HVbox [: b; `HOVbox [: `S LR c; k :] :] - | _ -> - let ao = if ao then [: `S LR "&" :] else [: :] in - HVbox - [: b; `HOVbox [: `S LR c; `S LR "of"; ao; ctyp_list tl k :] :] ] - | MLast.RfInh t -> HVbox [: b; `ctyp t k :] ] -; - -(* *) - -value rec class_longident sl k = - match sl with - [ [i] -> HVbox [: `S LR i; k :] - | [m :: sl] -> HVbox [: `S LR m; `S NO "."; `class_longident sl k :] - | _ -> HVbox [: `not_impl "class_longident" sl; k :] ] -; - -value rec clty_longident sl k = - match sl with - [ [i] -> HVbox [: `S LR i; k :] - | [m :: sl] -> HVbox [: `S LR m; `S NO "."; `clty_longident sl k :] - | _ -> HVbox [: `not_impl "clty_longident" sl; k :] ] -; - -value rec meth_list (ml, v) k = - match (ml, v) with - [ ([f], False) -> [: `field f k :] - | ([], _) -> [: `S LR ".."; k :] - | ([f :: ml], v) -> [: `field f [: `S RO ";" :]; meth_list (ml, v) k :] ] -and field (lab, t) k = - HVbox [: `S LR (var_escaped lab); `S LR ":"; `ctyp t k :] -; - -value rec data_constructor_app e = match e with - [ <:expr< $uid:_$ >> | <:expr< $uid:_$ $_$ >> -> True - | <:expr< $a$ $_$ >> -> data_constructor_app a - | _ -> False ] -; - -value uncurry_expr fe last_arg = - let rec linearize fe result = match fe with - [ <:expr< $f$ $x$ >> -> linearize f [ x :: result ] - | _ -> (fe, result) ] in - linearize fe [last_arg] -; - -(* patterns *) - -value uncurry_patt pat last_arg = - let rec linearize pat result = match pat with - [ <:patt< $p$ $x$ >> -> linearize p [ x :: result ] - | _ -> (pat, result) ] in - linearize pat [last_arg] -; - - -value rec is_irrefut_patt = - fun - [ <:patt< $lid:_$ >> -> True - | <:patt< () >> -> True - | <:patt< _ >> -> True - | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y - | <:patt< { $list:fpl$ } >> -> - List.for_all (fun (_, p) -> is_irrefut_patt p) fpl - | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p - | <:patt< ($list:pl$) >> -> List.for_all 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 - | _ -> False ] -; - -value rec get_defined_ident = - fun - [ <:patt< $_$ . $_$ >> -> [] - | <:patt< _ >> -> [] - | <:patt< $lid:x$ >> -> [x] - | <:patt< ($p1$ as $p2$) >> -> get_defined_ident p1 @ get_defined_ident p2 - | <:patt< $int:_$ >> -> [] - | (MLast.PaNativeInt _ _ | MLast.PaInt64 _ _ | MLast.PaInt32 _ _) -> [] - | <:patt< $flo:_$ >> -> [] - | <:patt< $str:_$ >> -> [] - | <:patt< $chr:_$ >> -> [] - | <:patt< [| $list:pl$ |] >> -> List.flatten (List.map get_defined_ident pl) - | <:patt< ($list:pl$) >> -> List.flatten (List.map get_defined_ident pl) - | <:patt< $uid:_$ >> -> [] - | <:patt< ` $_$ >> -> [] - | <:patt< # $list:_$ >> -> [] - | <:patt< $p1$ $p2$ >> -> get_defined_ident p1 @ get_defined_ident p2 - | <:patt< { $list:lpl$ } >> -> - List.flatten (List.map (fun (lab, p) -> get_defined_ident p) lpl) - | <:patt< $p1$ | $p2$ >> -> get_defined_ident p1 @ get_defined_ident p2 - | <:patt< $p1$ .. $p2$ >> -> get_defined_ident p1 @ get_defined_ident p2 - | <:patt< ($p$ : $_$) >> -> get_defined_ident p - | <:patt< ~ $_$ >> -> [] - | <:patt< ~ $_$ : $p$ >> -> get_defined_ident p - | <:patt< ? $_$ >> -> [] - | <:patt< ? $_$ : ($p$) >> -> get_defined_ident p - | <:patt< ? $_$ : ($p$ = $e$) >> -> get_defined_ident p - | <:patt< $anti:p$ >> -> get_defined_ident p ] -; - -value un_irrefut_patt p = - match get_defined_ident p with - [ [] -> (<:patt< _ >>, <:expr< () >>) - | [i] -> (<:patt< $lid:i$ >>, <:expr< $lid:i$ >>) - | il -> - let (upl, uel) = - List.fold_right - (fun i (upl, uel) -> - ([<:patt< $lid:i$ >> :: upl], [<:expr< $lid:i$ >> :: uel])) - il ([], []) - in - (<:patt< ($list:upl$) >>, <:expr< ($list:uel$) >>) ] -; - -(* expressions *) - -pr_expr_fun_args.val := - extfun Extfun.empty with - [ <:expr< fun [$p$ -> $e$] >> as ge -> - if is_irrefut_patt p then - let (pl, e) = expr_fun_args e in - ([p :: pl], e) - else ([], ge) - | ge -> ([], ge) ]; - -value rec bind_list b pel k = - match pel with - [ [pe] -> let_binding b pe k - | pel -> - Vbox [: `HVbox [: :]; listwbws let_binding b (S LR "and") pel k :] ] -and let_binding b (p, e) k = - let (p, e) = - if is_irrefut_patt p then (p, e) - else - let (up, ue) = un_irrefut_patt p in - (up, <:expr< match $e$ with [ $p$ -> $ue$ ] >>) - in - let loc = - let (bp1, ep1) = MLast.loc_of_patt p in - let (bp2, ep2) = MLast.loc_of_expr e in - (min bp1 bp2, max ep1 ep2) - in - LocInfo (intloc loc) (BEbox [: let_binding0 [: b; `patt p [: :] :] e [: :]; k :]) -and let_binding0 b e k = - let (pl, e) = expr_fun_args e in - match e with - [ <:expr< let $opt:r$ $lid:f$ = fun [ $list:pel$ ] in $e$ >> - when - let rec call_f = - fun - [ <:expr< $lid:f'$ >> -> f = f' - | <:expr< $e$ $_$ >> -> call_f e - | _ -> False ] - in - gen_where.val && call_f e -> - let (pl1, e1) = expr_fun_args <:expr< fun [ $list:pel$ ] >> in - [: `HVbox [: `HVbox b; `HOVbox (list patt pl [: `S LR "=" :]) :]; - `HVbox - [: `HOVbox - [: `expr e [: :]; `S LR "where"; flag "rec" r; `S LR f; - `HVbox (list patt pl1 [: `S LR "=" :]) :]; - `expr e1 k :] :] - | <:expr< ($e$ : $t$) >> -> - [: `HVbox - [: `HVbox b; `HOVbox (list patt pl [: `S LR ":" :]); - `ctyp t [: `S LR "=" :] :]; - `expr e k :] - | _ -> - [: `HVbox [: `HVbox b; `HOVbox (list patt pl [: `S LR "=" :]) :]; - `expr e k :] ] -and match_assoc_list pwel k = - match pwel with - [ [pwe] -> match_assoc [: `S LR "[" :] pwe [: `S LR "]"; k :] - | pel -> - Vbox - [: `HVbox [: :]; - listwbws match_assoc [: `S LR "[" :] (S LR "|") pel - [: `S LR "]"; k :] :] ] -and match_assoc b (p, w, e) k = - let s = - let (p, k) = - match p with - [ <:patt< ($p$ as $p2$) >> -> (p, [: `S LR "as"; `patt p2 [: :] :]) - | _ -> (p, [: :]) ] - in - match w with - [ Some e1 -> - [: `HVbox - [: `HVbox [: :]; `patt p k; - `HVbox [: `S LR "when"; `expr e1 [: `S LR "->" :] :] :] :] - | _ -> [: `patt p [: k; `S LR "->" :] :] ] - in - HVbox [: b; `HVbox [: `HVbox s; `expr e k :] :] -; - -value label lab = S LR (var_escaped lab); - -value field_expr (lab, e) k = HVbox [: `label lab; `S LR "="; `expr e k :]; - -value rec sequence_loop = - fun - [ [<:expr< let $opt:r$ $list:pel$ in $e$ >>] -> - let el = - match e with - [ <:expr< do { $list:el$ } >> -> el - | _ -> [e] ] - in - let r = flag "rec" r in - [: listwbws (fun b (p, e) k -> let_binding b (p, e) k) - [: `S LR "let"; r :] (S LR "and") pel [: `S LR "in" :]; - sequence_loop el :] - | [(<:expr< let $opt:_$ $list:_$ in $_$ >> as e) :: el] -> - [: `simple_expr e [: `S RO ";" :]; sequence_loop el :] - | [e] -> [: `expr e [: :] :] - | [e :: el] -> [: `expr e [: `S RO ";" :]; sequence_loop el :] - | [] -> [: :] ] -; - -value sequence b1 b2 b3 el k = - BEbox - [: `BEbox [: b1; b2; `HVbox [: b3; `S LR "do {" :] :]; - `HVbox [: `HVbox [: :]; sequence_loop el :]; - `HVbox [: `S LR "}"; k :] :] -; - -value rec let_sequence e = - match e with - [ <:expr< do { $list:el$ } >> -> Some el - | <:expr< let $opt:_$ $list:_$ in $e1$ >> -> - match let_sequence e1 with - [ Some _ -> Some [e] - | None -> None ] - | _ -> None ] -; - -value ifbox b1 b2 b3 e k = - if old_sequences.val then HVbox [: `HOVbox [: b1; b2; b3 :]; `expr e k :] - else - match let_sequence e with - [ Some el -> sequence b1 b2 b3 el k - | None -> HVbox [: `BEbox [: b1; b2; b3 :]; `expr e k :] ] -; - -value rec type_params sl k = - list - (fun (s, vari) k -> - let b = - match vari with - [ (True, False) -> [: `S LO "+" :] - | (False, True) -> [: `S LO "-" :] - | _ -> [: :] ] - in - HVbox [: b; `S LO "'"; `S LR s; k :]) - sl k -; - -value constrain (t1, t2) k = - HVbox [: `S LR "constraint"; `ctyp t1 [: `S LR "=" :]; `ctyp t2 k :] -; - -value type_list b tdl k = - HVbox - [: `HVbox [: :]; - listwbws - (fun b ((_, tn), tp, te, cl) k -> - let tn = var_escaped tn in - HVbox - [: `HVbox [: b; `S LR tn; type_params tp [: `S LR "=" :] :]; - `ctyp te [: :]; list constrain cl k :]) - b (S LR "and") tdl [: :]; - k :] -; - -value external_def s t pl k = - let ls = list (fun s k -> HVbox [: `S LR ("\"" ^ s ^ "\""); k :]) pl k in - HVbox - [: `HVbox [: `S LR "external"; `S LR (var_escaped s); `S LR ":" :]; - `ctyp t [: `S LR "="; ls :] :] -; - -value value_description s t k = - HVbox - [: `HVbox [: `S LR "value"; `S LR (var_escaped s); `S LR ":" :]; - `ctyp t k :] -; - -value typevar s k = HVbox [: `S LR ("'" ^ s); k :]; - -value rec mod_ident sl k = - match sl with - [ [] -> k - | [s] -> [: `S LR (var_escaped s); k :] - | [s :: sl] -> [: `S LR s; `S NO "."; mod_ident sl k :] ] -; - -value rec module_declaration b mt k = - match mt with - [ <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> -> - module_declaration - [: `HVbox - [: b; - `HVbox - [: `S LO "("; `S LR i; `S LR ":"; - `module_type t [: `S RO ")" :] :] :] :] - mt k - | _ -> - HVbox - [: `HVbox [: :]; - `HVbox [: `HVbox [: b; `S LR ":" :]; `module_type mt [: :] :]; - k :] ] -and module_rec_declaration b (n,mt) k = - HVbox - [: `HVbox - [: b; `S LR n; `S LR ":"; `module_type mt [: :] :]; - k :] -and modtype_declaration s mt k = - HVbox - [: `HVbox [: :]; - `HVbox - [: `HVbox [: `S LR "module"; `S LR "type"; `S LR s; `S LR "=" :]; - `module_type mt [: :] :]; - k :] -and with_constraints b icl k = - HVbox [: `HVbox [: :]; listwbws with_constraint b (S LR "and") icl k :] -and with_constraint b wc k = - match wc with - [ <:with_constr< type $p$ $list:al$ = $e$ >> -> - let params = - match al with - [ [] -> [: :] - | [s] -> [: `S LO "'"; `S LR (fst s) :] - | sl -> [: `S LO "("; type_params sl [: `S RO ")" :] :] ] - in - HVbox - [: `HVbox - [: `HVbox b; `S LR "type"; params; - mod_ident p [: `S LR "=" :] :]; - `ctyp e k :] - | <:with_constr< module $sl$ = $me$ >> -> - HVbox - [: b; `S LR "module"; mod_ident sl [: `S LR "=" :]; - `module_expr me k :] ] -and module_binding b me k = - match me with - [ <:module_expr< functor ($s$ : $mt$) -> $mb$ >> -> - module_binding - [: `HVbox - [: b; - `HVbox - [: `HVbox [: `S LO "("; `S LR s; `S LR ":" :]; - `module_type mt [: `S RO ")" :] :] :] :] - mb k - | <:module_expr< ( $me$ : $mt$ ) >> -> - HVbox - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `HVbox [: b; `S LR ":" :]; - `module_type mt [: `S LR "=" :] :]; - `module_expr me [: :] :]; - k :] - | _ -> - HVbox - [: `HVbox [: :]; - `HVbox [: `HVbox [: b; `S LR "=" :]; `module_expr me [: :] :]; - k :] ] -and module_rec_binding b (n, mt,me) k = - HVbox - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `HVbox [: b; `S LR n; `S LR ":" :]; - `module_type mt [: `S LR "=" :] :]; - `module_expr me [: :] :]; - k :] -and class_declaration b ci k = - class_fun_binding - [: b; flag "virtual" ci.MLast.ciVir; `S LR ci.MLast.ciNam; - class_type_parameters ci.MLast.ciPrm :] - ci.MLast.ciExp k -and class_fun_binding b ce k = - match ce with - [ <:class_expr< fun $p$ -> $cfb$ >> -> - class_fun_binding [: b; `patt p [: :] :] cfb k - | ce -> HVbox [: `HVbox [: b; `S LR "=" :]; `class_expr ce k :] ] -and class_type_parameters (loc, tpl) = - match tpl with - [ [] -> [: :] - | tpl -> - [: `S LO "["; listws type_parameter (S RO ",") tpl [: `S RO "]" :] :] ] -and type_parameter tp k = HVbox [: `S LO "'"; `S LR (fst tp); k :] -and simple_expr e k = - match e with - [ <:expr< $lid:_$ >> -> expr e k - | _ -> HVbox [: `S LO "("; `expr e [: `S RO ")"; k :] :] ] -and class_self_patt_opt csp = - match csp with - [ Some p -> HVbox [: `S LO "("; `patt p [: `S RO ")" :] :] - | None -> HVbox [: :] ] -and label lab = S LR (var_escaped lab) -and cvalue b (lab, mf, e) k = - HVbox - [: `HVbox [: b; flag "mutable" mf; `label lab; `S LR "=" :]; `expr e k :] -and fun_binding b fb k = - match fb with - [ <:expr< fun $p$ -> $e$ >> -> fun_binding [: b; `simple_patt p [: :] :] e k - | e -> HVbox [: `HVbox [: b; `S LR "=" :]; `expr e k :] ] -and simple_patt p k = - match p with - [ <:patt< $lid:_$ >> | <:patt< ~ $_$ : $_$ >> | - <:patt< ? $_$ : ($_$ $opt:_$) >> -> patt p k - | _ -> HVbox [: `S LO "("; `patt p [: `S RO ")"; k :] :] ] -and class_signature cs k = - match cs with - [ <:class_type< $list:id$ >> -> clty_longident id k - | <:class_type< $list:id$ [ $list:tl$ ] >> -> - HVbox - [: `clty_longident id [: :]; `S LO "["; - listws ctyp (S RO ",") tl [: `S RO "]"; k :] :] - | <:class_type< object $opt:cst$ $list:csf$ end >> -> - let ep = snd (MLast.loc_of_class_type cs) in - class_self_type [: `S LR "object" :] cst - [: `HVbox - [: `HVbox [: :]; list class_sig_item csf [: :]; - `LocInfo (intloc(ep, ep)) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] - | _ -> HVbox [: `not_impl "class_signature" cs; k :] ] -and class_self_type b cst k = - BEbox - [: `HVbox - [: b; - match cst with - [ None -> [: :] - | Some t -> [: `S LO "("; `ctyp t [: `S RO ")" :] :] ] :]; - k :] -and class_description b ci k = - HVbox - [: `HVbox - [: b; flag "virtual" ci.MLast.ciVir; `S LR ci.MLast.ciNam; - class_type_parameters ci.MLast.ciPrm; `S LR ":" :]; - `class_type ci.MLast.ciExp k :] -and class_type_declaration b ci k = - HVbox - [: `HVbox - [: b; flag "virtual" ci.MLast.ciVir; `S LR ci.MLast.ciNam; - class_type_parameters ci.MLast.ciPrm; `S LR "=" :]; - `class_signature ci.MLast.ciExp k :] -; - -pr_module_type.pr_levels := - [{pr_label = "top"; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< functor ( $s$ : $mt1$ ) -> $mt2$ >> -> - fun curr next _ k -> - let head = - HVbox - [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":"; - `module_type mt1 [: `S RO ")" :]; `S LR "->" :] - in - [: `head; `module_type mt2 k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $mt$ with $list:icl$ >> -> - fun curr next _ k -> - [: curr mt "" [: :]; `with_constraints [: `S LR "with" :] icl k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< sig $list:s$ end >> as mt -> - fun curr next _ k -> - let ep = snd (MLast.loc_of_module_type mt) in - [: `BEbox - [: `S LR "sig"; - `HVbox - [: `HVbox [: :]; list sig_item s [: :]; - `LocInfo (intloc(ep, ep)) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $mt1$ $mt2$ >> -> - fun curr next _ k -> [: curr mt1 "" [: :]; `next mt2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $mt1$ . $mt2$ >> -> - fun curr next _ k -> - [: curr mt1 "" [: `S NO "." :]; `next mt2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_type< $lid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:module_type< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:module_type< ' $s$ >> -> - fun curr next _ k -> [: `S LR ("'" ^ s); k :] - | mt -> - fun curr next _ k -> - [: `S LO "("; `module_type mt [: `S RO ")"; k :] :] ]}]; - -pr_module_expr.pr_levels := - [{pr_label = "top"; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< struct $list:s$ end >> as me -> - fun curr next _ k -> - let ep = snd (MLast.loc_of_module_expr me) in - [: `HVbox [: :]; - `HVbox - [: `S LR "struct"; list str_item s [: :]; - `LocInfo (intloc(ep, ep)) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] - | <:module_expr< functor ($s$ : $mt$) -> $me$ >> -> - fun curr next _ k -> - let head = - HVbox - [: `S LR "functor"; `S LO "("; `S LR s; `S LR ":"; - `module_type mt [: `S RO ")" :]; `S LR "->" :] - in - [: `head; curr me "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< $me1$ $me2$ >> -> - fun curr next _ k -> [: curr me1 "" [: :]; `next me2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< $me1$ . $me2$ >> -> - fun curr next _ k -> - [: curr me1 "" [: `S NO "." :]; `next me2 "" k :] - | e -> fun curr next dg k -> [: `next e dg k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:module_expr< ( $me$ : $mt$ ) >> -> - fun curr next _ k -> - [: `S LO "("; `module_expr me [: `S LR ":" :]; - `module_type mt [: `S RO ")"; k :] :] - | <:module_expr< struct $list:_$ end >> | - <:module_expr< functor ($_$ : $_$) -> $_$ >> | - <:module_expr< $_$ $_$ >> | <:module_expr< $_$ . $_$ >> as me -> - fun curr next _ k -> - [: `S LO "("; `module_expr me [: `S RO ")"; k :] :] ]}]; - -pr_sig_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (intloc(MLast.loc_of_sig_item s)) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ <:sig_item< type $list:stl$ >> -> - fun curr next _ k -> [: `type_list [: `S LR "type" :] stl k :] - | <:sig_item< declare $list:s$ end >> -> - fun curr next _ k -> - if expand_declare.val then - if s = [] then [: `S LR "(* *)" :] - else [: `HVbox [: :]; list sig_item s [: :] :] - else - [: `BEbox - [: `S LR "declare"; - `HVbox [: `HVbox [: :]; list sig_item s [: :] :]; - `HVbox [: `S LR "end"; k :] :] :] - | <:sig_item< # $_$ $opt:_$ >> as si -> - fun curr next _ k -> [: `not_impl "sig_item1" si :] - | <:sig_item< exception $c$ of $list:tl$ >> -> - fun curr next _ k -> - [: `variant [: `S LR "exception" :] (_loc, c, tl) k :] - | <:sig_item< value $s$ : $t$ >> -> - fun curr next _ k -> [: `value_description s t k :] - | <:sig_item< include $mt$ >> -> - fun curr next _ k -> [: `S LR "include"; `module_type mt k :] - | <:sig_item< external $s$ : $t$ = $list:pl$ >> -> - fun curr next _ k -> [: `external_def s t pl k :] - | <:sig_item< module $s$ : $mt$ >> -> - fun curr next _ k -> - [: `module_declaration [: `S LR "module"; `S LR s :] mt k :] - | <:sig_item< module rec $list:nmts$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws module_rec_declaration [: `S LR "module rec" :] (S LR "and") nmts - k :] - | <:sig_item< module type $s$ = $mt$ >> -> - fun curr next _ k -> [: `modtype_declaration s mt k :] - | <:sig_item< open $sl$ >> -> - fun curr next _ k -> [: `S LR "open"; mod_ident sl k :] - | <:sig_item< class $list:cd$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws class_description [: `S LR "class" :] (S LR "and") cd - k :] - | <:sig_item< class type $list:cd$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws class_type_declaration - [: `S LR "class"; `S LR "type" :] (S LR "and") cd k :] - | MLast.SgUse _ _ _ -> - fun curr next _ k -> [: :] ]}]; - -pr_str_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (intloc(MLast.loc_of_str_item s)) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ <:str_item< open $i$ >> -> - fun curr next _ k -> [: `S LR "open"; mod_ident i k :] - | <:str_item< $exp:e$ >> -> - fun curr next _ k -> [: `HVbox [: :]; `expr e k :] - | <:str_item< declare $list:s$ end >> -> - fun curr next _ k -> - if expand_declare.val then - if s = [] then [: `S LR "(* *)" :] - else [: `HVbox [: :]; list str_item s [: :] :] - else - [: `BEbox - [: `S LR "declare"; - `HVbox [: `HVbox [: :]; list str_item s [: :] :]; - `HVbox [: `S LR "end"; k :] :] :] - | <:str_item< # $s$ $opt:x$ >> -> - fun curr next _ k -> - let s = - "(* #" ^ s ^ " " ^ - (match x with - [ Some <:expr< $str:s$ >> -> "\"" ^ s ^ "\"" - | _ -> "?" ]) ^ - " *)" - in - [: `S LR s :] - | <:str_item< exception $c$ of $list:tl$ = $b$ >> -> - fun curr next _ k -> - match b with - [ [] -> [: `variant [: `S LR "exception" :] (_loc, c, tl) k :] - | _ -> - [: `variant [: `S LR "exception" :] (_loc, c, tl) - [: `S LR "=" :]; - mod_ident b k :] ] - | <:str_item< include $me$ >> -> - fun curr next _ k -> [: `S LR "include"; `module_expr me k :] - | <:str_item< type $list:tdl$ >> -> - fun curr next _ k -> [: `type_list [: `S LR "type" :] tdl k :] - | <:str_item< value $opt:rf$ $list:pel$ >> -> - fun curr next _ k -> - [: `bind_list [: `S LR "value"; flag "rec" rf :] pel k :] - | <:str_item< external $s$ : $t$ = $list:pl$ >> -> - fun curr next _ k -> [: `external_def s t pl k :] - | <:str_item< module $s$ = $me$ >> -> - fun curr next _ k -> - [: `module_binding [: `S LR "module"; `S LR s :] me k :] - | <:str_item< module rec $list:nmtmes$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws module_rec_binding [: `S LR "module rec" :] (S LR "and") nmtmes - k :] - | <:str_item< module type $s$ = $mt$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - `HVbox - [: `HVbox - [: `S LR "module"; `S LR "type"; `S LR s; - `S LR "=" :]; - `module_type mt [: :] :]; - k :] - | <:str_item< class $list:cd$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws class_declaration [: `S LR "class" :] (S LR "and") cd - k :] - | <:str_item< class type $list:cd$ >> -> - fun curr next _ k -> - [: `HVbox [: :]; - listwbws class_type_declaration - [: `S LR "class"; `S LR "type" :] (S LR "and") cd k :] - | MLast.StUse _ _ _ -> - fun curr next _ k -> [: :] ]}]; - -(* -EXTEND_PRINTER - pr_expr: - [ "top" (fun e x -> LocInfo (MLast.loc_of_expr e) (HOVbox x)) - [ <:expr< let $rec:r$ $p1$ = $e1$ in $e$ >> -> - let r = flag "rec" r in - [: `Vbox - [: `HVbox [: :]; - `let_binding [: `S LR "let"; r :] (p1, e1) - [: `S LR "in" :]; - `expr e k :] :] - | <:expr< let $rec:r$ $list:pel$ in $e$ >> -> - let r = flag "rec" r in - [: `Vbox - [: `HVbox [: :]; - listwbws (fun b (p, e) k -> let_binding b (p, e) k) - [: `S LR "let"; r :] (S LR "and") pel [: `S LR "in" :]; - `expr e k :] :] ] ] - ; -END; -*) - -pr_expr.pr_levels := - [{pr_label = "top"; pr_box e x = LocInfo (intloc(MLast.loc_of_expr e)) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:expr< let $opt:r$ $p1$ = $e1$ in $e$ >> -> - fun curr next _ k -> - let r = flag "rec" r in - [: `Vbox - [: `HVbox [: :]; - `let_binding [: `S LR "let"; r :] (p1, e1) - [: `S LR "in" :]; - `expr e k :] :] - | <:expr< let $opt:r$ $list:pel$ in $e$ >> -> - fun curr next _ k -> - let r = flag "rec" r in - [: `Vbox - [: `HVbox [: :]; - listwbws (fun b (p, e) k -> let_binding b (p, e) k) - [: `S LR "let"; r :] (S LR "and") pel [: `S LR "in" :]; - `expr e k :] :] - | <:expr< let module $m$ = $mb$ in $e$ >> -> - fun curr next _ k -> - [: `HVbox - [: `HVbox [: :]; - `module_binding - [: `S LR "let"; `S LR "module"; `S LR m :] mb - [: `S LR "in" :]; - `expr e k :] :] - | <:expr< fun [ $list:pel$ ] >> -> - fun curr next _ k -> - match pel with - [ [] -> [: `S LR "fun"; `S LR "[]"; k :] - | [(p, None, e)] -> - if is_irrefut_patt p then - let (pl, e) = expr_fun_args e in - [: `BEbox - [: `HOVbox - [: `S LR "fun"; - list patt [p :: pl] [: `S LR "->" :] :]; - `expr e k :] :] - else - [: `HVbox [: `S LR "fun ["; `patt p [: `S LR "->" :] :]; - `expr e [: `S LR "]"; k :] :] - | _ -> - [: `Vbox - [: `HVbox [: :]; `S LR "fun"; - listwbws match_assoc [: `S LR "[" :] (S LR "|") pel - [: `S LR "]"; k :] :] :] ] - | <:expr< match $e$ with $p1$ -> $e1$ >> when is_irrefut_patt p1 -> - fun curr next _ k -> - [: `BEbox - [: `S LR "match"; `expr e [: :]; - `HVbox [: `S LR "with"; `patt p1 [: `S LR "->" :] :] :]; - `expr e1 k :] - | <:expr< match $e$ with [ ] >> -> - fun curr next _ k -> - [: `HVbox [: :]; - `BEbox - [: `S LR "match"; `expr e [: :]; `S LR "with"; `S LR "[]"; - k :] :] - | <:expr< match $e$ with [ $list:pel$ ] >> -> - fun curr next _ k -> - [: `HVbox [: :]; - `BEbox [: `S LR "match"; `expr e [: :]; `S LR "with" :]; - `match_assoc_list pel k :] - | <:expr< try $e$ with [ ] >> -> - fun curr next _ k -> - [: `HVbox [: :]; - `BEbox - [: `S LR "try"; `expr e [: :]; `S LR "with"; `S LR "[]"; - k :] :] - | <:expr< try $e$ with $p1$ -> $e1$ >> when is_irrefut_patt p1 -> - fun curr next _ k -> - [: `BEbox - [: `S LR "try"; `expr e [: :]; - `HVbox [: `S LR "with"; `patt p1 [: `S LR "->" :] :] :]; - `expr e1 k :] - | <:expr< try $e$ with [ $list:pel$ ] >> -> - fun curr next _ k -> - [: `HVbox [: :]; - `BEbox [: `S LR "try"; `expr e [: :]; `S LR "with" :]; - `match_assoc_list pel k :] - | <:expr< if $e1$ then $e2$ else $e3$ >> -> - fun curr next _ k -> - let (eel, e) = - elseif e3 where rec elseif e = - match e with - [ <:expr< if $e1$ then $e2$ else $e3$ >> -> - let (eel, e) = elseif e3 in - ([(e1, e2) :: eel], e) - | _ -> ([], e) ] - in - [: `HVbox - [: `HVbox [: :]; - `ifbox [: `S LR "if" :] [: `expr e1 [: :] :] - [: `S LR "then" :] e2 [: :]; - list - (fun (e1, e2) k -> - ifbox [: `HVbox [: `S LR "else"; `S LR "if" :] :] - [: `expr e1 [: :] :] [: `S LR "then" :] e2 k) - eel [: :]; - `ifbox [: `S LR "else" :] [: :] [: :] e k :] :] - | <:expr< do { $list:el$ } >> when old_sequences.val -> - fun curr next _ k -> - let (el, e) = - match List.rev el with - [ [e :: el] -> (List.rev el, e) - | [] -> ([], <:expr< () >>) ] - in - [: `HOVCbox - [: `HVbox [: :]; - `BEbox - [: `S LR "do"; - `HVbox - [: `HVbox [: :]; - list (fun e k -> expr e [: `S RO ";"; k :]) - el [: :] :]; - `S LR "return" :]; - `expr e k :] :] - | <:expr< do { $list:el$ } >> -> - fun curr next _ k -> [: `sequence [: :] [: :] [: :] el k :] - | <:expr< for $i$ = $e1$ $to:d$ $e2$ do { $list:el$ } >> - when old_sequences.val -> - fun curr next _ k -> - let d = if d then "to" else "downto" in - [: `BEbox - [: `HOVbox - [: `S LR "for"; `S LR i; `S LR "="; - `expr e1 [: `S LR d :]; - `expr e2 [: `S LR "do" :] :]; - `HVbox - [: `HVbox [: :]; - list (fun e k -> expr e [: `S RO ";"; k :]) el - [: :] :]; - `HVbox [: `S LR "done"; k :] :] :] - | <:expr< for $i$ = $e1$ $to:d$ $e2$ do { $list:el$ } >> -> - fun curr next _ k -> - let d = if d then "to" else "downto" in - [: `sequence - [: `HOVbox - [: `S LR "for"; `S LR i; `S LR "="; - `expr e1 [: `S LR d :]; `expr e2 [: :] :] :] - [: :] [: :] el k :] - | <:expr< while $e1$ do { $list:el$ } >> when old_sequences.val -> - fun curr next _ k -> - [: `BEbox - [: `BEbox [: `S LR "while"; `expr e1 [: :]; `S LR "do" :]; - `HVbox - [: `HVbox [: :]; - list (fun e k -> expr e [: `S RO ";"; k :]) el - [: :] :]; - `HVbox [: `S LR "done"; k :] :] :] - | <:expr< while $e1$ do { $list:el$ } >> -> - fun curr next _ k -> - [: `sequence [: `S LR "while"; `expr e1 [: :] :] [: :] [: :] el - k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $x$ := $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR ":=" :]; `expr y k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:"||"$ $x$ $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR "||" :]; curr y "" k :] - | <:expr< $lid:"or"$ $x$ $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR "||" :]; curr y "" k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:"&&"$ $x$ $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR "&&" :]; curr y "" k :] - | <:expr< $lid:"&"$ $x$ $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR "&&" :]; curr y "" k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next _ k -> - match op with - [ "<" | ">" | "<=" | ">=" | ">=." | "=" | "<>" | "==" | "!=" -> - [: curr x "" [: `S LR op :]; `next y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next _ k -> - match op with - [ "^" | "@" -> [: `next x "" [: `S LR op :]; curr y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next _ k -> - match op with - [ "+" | "+." | "-" | "-." -> - [: curr x "" [: `S LR op :]; `next y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next _ k -> - match op with - [ "*" | "/" | "*." | "/." | "land" | "lor" | "lxor" | "mod" -> - [: curr x "" [: `S LR op :]; `next y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:op$ $x$ $y$ >> as e -> - fun curr next _ k -> - match op with - [ "**" | "asr" | "lsl" | "lsr" -> - [: `next x "" [: `S LR op :]; curr y "" k :] - | _ -> [: `next e "" k :] ] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $lid:"~-"$ $x$ >> -> - fun curr next _ k -> [: `S LR "-"; curr x "" k :] - | <:expr< $lid:"~-."$ $x$ >> -> - fun curr next _ k -> [: `S LR "-."; curr x "" k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $int:x$ >> -> fun curr next _ k -> [: `S LR x; k :] - | MLast.ExInt32 _ x -> fun curr next _ k -> [: `S LR (x^"l"); k :] - | MLast.ExInt64 _ x -> fun curr next _ k -> [: `S LR (x^"L"); k :] - | MLast.ExNativeInt _ x -> fun curr next _ k -> [: `S LR (x^"n"); k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = "apply"; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< [$_$ :: $_$] >> as e -> - fun curr next _ k -> [: `next e "" k :] - | <:expr< lazy ($x$) >> -> - fun curr next _ k -> [: `S LR "lazy"; `next x "" k :] - | <:expr< assert False >> -> - fun curr next _ k -> [: `S LR "assert"; `S LR "False"; k :] - | <:expr< assert ($e$) >> -> - fun curr next _ k -> [: `S LR "assert"; `next e "" k :] - | <:expr< $lid:n$ $x$ $y$ >> as e -> - fun curr next _ k -> - if is_infix n then [: `next e "" k :] - else [: curr <:expr< $lid:n$ $x$ >> "" [: :]; `next y "" k :] - | <:expr< $x$ $y$ >> -> - if constructors_are_curried() || (not(data_constructor_app x)) then - fun curr next _ k -> [: curr x "" [: :]; `next y "" k :] - else - match uncurry_expr x y with - [ (f, ( [_;_::_] as args )) -> - fun curr next _ k -> - [: curr f "" [: :]; - `HOVCbox - [: `S LO "("; - listws expr (S RO ",") args [: `S RO ")"; k :] :] :] - | (f, [ arg ]) -> - fun curr next _ k -> [: curr f "" [: :]; `next arg "" k :] - | (f, []) -> failwith "patt@pr_r" ] - | <:expr< new $list:sl$ >> -> - fun curr next _ k -> [: `S LR "new"; `class_longident sl k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = "dot"; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:expr< $x$ . ( $y$ ) >> -> - fun curr next _ k -> - [: curr x "" [: :]; `S NO ".("; `expr y [: `S RO ")"; k :] :] - | <:expr< $x$ . [ $y$ ] >> -> - fun curr next _ k -> - [: curr x "" [: :]; `S NO ".["; `expr y [: `S RO "]"; k :] :] - | <:expr< $e1$ . $e2$ >> -> - fun curr next _ k -> [: curr e1 "" [: :]; `S NO "."; curr e2 "" k :] - | <:expr< $e$ # $lab$ >> -> - fun curr next _ k -> [: curr e "" [: :]; `S NO "#"; `label lab; k :] - | e -> fun curr next _ k -> [: `next e "" k :] ]}; - {pr_label = "simple"; - pr_box e x = LocInfo (intloc(MLast.loc_of_expr e)) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ ( <:expr< $int:x$ >> | <:expr< $flo:x$ >> ) -> - fun curr next _ k -> - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | MLast. ExInt32 _ x -> - fun curr next _ k -> - let x = x^"l" in - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | MLast.ExInt64 _ x -> - fun curr next _ k -> - let x = x^"L" in - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | MLast.ExNativeInt _ x -> - fun curr next _ k -> - let x = x^"n" in - if x.[0] = '-' then [: `S LO "("; `S LR x; `S RO ")"; k :] - else [: `S LR x; k :] - | <:expr< $str:s$ >> -> - fun curr next _ k -> [: `S LR ("\"" ^ s ^ "\""); k :] - | <:expr< $chr:c$ >> -> - fun curr next _ k -> [: `S LR ("'" ^ c ^ "'"); k :] - | <:expr< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:expr< $lid:s$ >> -> - fun curr next _ k -> [: `S LR (var_escaped s); k :] - | <:expr< ` $i$ >> -> fun curr next _ k -> [: `S LR ("`" ^ i); k :] - | <:expr< ~ $i$ >> -> - fun curr next _ k -> [: `S LR ("~" ^ i); k :] - | <:expr< ~ $i$ : $e$ >> -> - fun curr next _ k -> [: `S LO ("~" ^ i ^ ":"); curr e "" k :] - | <:expr< ? $i$ >> -> - fun curr next _ k -> [: `S LR ("?" ^ i); k :] - | <:expr< ? $i$ : $e$ >> -> - fun curr next _ k -> [: `S LO ("?" ^ i ^ ":"); curr e "" k :] - | <:expr< [$_$ :: $_$] >> as e -> - fun curr next _ k -> - let (el, c) = - make_list e where rec make_list e = - match e with - [ <:expr< [$e$ :: $y$] >> -> - let (el, c) = make_list y in - ([e :: el], c) - | <:expr< [] >> -> ([], None) - | x -> ([], Some e) ] - in - match c with - [ None -> - [: `S LO "["; listws expr (S RO ";") el [: `S RO "]"; k :] :] - | Some x -> - [: `S LO "["; listws expr (S RO ";") el [: `S LR "::" :]; - `expr x [: `S RO "]"; k :] :] ] - | <:expr< [| $list:el$ |] >> -> - fun curr next _ k -> - [: `S LR "[|"; listws expr (S RO ";") el [: `S LR "|]"; k :] :] - | <:expr< { $list:fel$ } >> -> - fun curr next _ k -> - [: `S LO "{"; - listws - (fun (lab, e) k -> - HVbox [: let_binding0 [: `patt lab [: :] :] e k :]) - (S RO ";") fel [: `S RO "}"; k :] :] - | <:expr< { ($e$) with $list:fel$ } >> -> - fun curr next _ k -> - [: `HVbox - [: `S LO "{"; `S LO "("; - `expr e [: `S RO ")"; `S LR "with" :] :]; - listws - (fun (lab, e) k -> - HVbox [: `patt lab [: `S LR "=" :]; `expr e k :]) - (S RO ";") fel [: `S RO "}"; k :] :] - | <:expr< ($e$ : $t$) >> -> - fun curr next _ k -> - [: `S LO "("; `expr e [: `S LR ":" :]; - `ctyp t [: `S RO ")"; k :] :] - | <:expr< ($e$ : $t1$ :> $t2$) >> -> - fun curr next _ k -> - [: `S LO "("; `expr e [: `S LR ":" :]; `ctyp t1 [: `S LR ":>" :]; - `ctyp t2 [: `S RO ")"; k :] :] - | <:expr< ($e$ :> $t2$) >> -> - fun curr next _ k -> - [: `S LO "("; `expr e [: `S LR ":>" :]; - `ctyp t2 [: `S RO ")"; k :] :] - | <:expr< {< >} >> -> fun curr next _ k -> [: `S LR "{< >}"; k :] - | <:expr< {< $list:fel$ >} >> -> - fun curr next _ k -> - [: `S LR "{<"; - listws field_expr (S RO ";") fel [: `S LR ">}"; k :] :] - | <:expr< ($list:el$) >> -> - fun curr next _ k -> - [: `S LO "("; listws expr (S RO ",") el [: `S RO ")"; k :] :] - | <:expr< $_$ $_$ >> | <:expr< $_$ . $_$ >> | <:expr< $_$ . ( $_$ ) >> | - <:expr< $_$ . [ $_$ ] >> | <:expr< $_$ := $_$ >> | - <:expr< $_$ # $_$ >> | - <:expr< fun [ $list:_$ ] >> | <:expr< match $_$ with [ $list:_$ ] >> | - <:expr< try $_$ with [ $list:_$ ] >> | - <:expr< if $_$ then $_$ else $_$ >> | <:expr< do { $list:_$ } >> | - <:expr< for $_$ = $_$ $to:_$ $_$ do { $list:_$ } >> | - <:expr< while $_$ do { $list:_$ } >> | - <:expr< let $opt:_$ $list:_$ in $_$ >> | - <:expr< let module $_$ = $_$ in $_$ >> | - <:expr< new $list:_$ >> | - <:expr< assert $_$ >> | <:expr< lazy $_$ >> as e -> - fun curr next _ k -> - [: `S LO "("; `expr e [: `HVbox [: `S RO ")"; k :] :] :] - | e -> fun curr next _ k -> [: `not_impl "expr" e :] ]}]; - -pr_patt.pr_levels := - [{pr_label = "top"; - pr_box p x = LocInfo (intloc(MLast.loc_of_patt p)) (HOVbox [: `HVbox [: :]; x :]); - pr_rules = - extfun Extfun.empty with - [ <:patt< $x$ | $y$ >> -> - fun curr next _ k -> [: curr x "" [: `S LR "|" :]; `next y "" k :] - | p -> fun curr next _ k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox [: `HVbox [: :]; x :]; - pr_rules = - extfun Extfun.empty with - [ <:patt< $x$ .. $y$ >> -> - fun curr next _ k -> [: curr x "" [: `S NO ".." :]; `next y "" k :] - | p -> fun curr next _ k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:patt< [$_$ :: $_$] >> as p -> - fun curr next _ k -> [: `next p "" k :] - | <:patt< $x$ $y$ >> -> - if constructors_are_curried() then - fun curr next _ k -> [: curr x "" [: :]; `next y "" k :] - else - match uncurry_patt x y with - [ (constr, ( [_;_::_] as args )) -> - fun curr next _ k -> - [: curr constr "" [: :]; - `HOVCbox - [: `S LO "("; - listws patt (S RO ",") args [: `S RO ")"; k :] :] :] - | (constr, [ arg ]) -> - fun curr next _ k -> [: curr constr "" [: :]; `next arg "" k :] - | (constr, []) -> failwith "patt@pr_r" ] - | p -> fun curr next _ k -> [: `next p "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:patt< $x$ . $y$ >> -> - fun curr next _ k -> [: curr x "" [: `S NO "." :]; `next y "" k :] - | p -> fun curr next _ k -> [: `next p "" k :] ]}; - {pr_label = "simple"; - pr_box p x = LocInfo (intloc(MLast.loc_of_patt p)) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:patt< [$_$ :: $_$] >> as p -> - fun curr next _ k -> - let (pl, c) = - make_list p where rec make_list p = - match p with - [ <:patt< [$p$ :: $y$] >> -> - let (pl, c) = make_list y in - ([p :: pl], c) - | <:patt< [] >> -> ([], None) - | x -> ([], Some p) ] - in - [: `HOVCbox - [: `S LO "["; - let rec glop pl k = - match pl with - [ [] -> failwith "simple_patt" - | [p] -> - match c with - [ None -> [: `patt p k :] - | Some x -> - [: `patt p [: `S LR "::" :]; `patt x k :] ] - | [p :: pl] -> - [: `patt p [: `S RO ";" :]; glop pl k :] ] - in - glop pl [: `S RO "]"; k :] :] :] - | <:patt< [| $list:pl$ |] >> -> - fun curr next _ k -> - [: `S LR "[|"; listws patt (S RO ";") pl [: `S LR "|]"; k :] :] - | <:patt< { $list:fpl$ } >> -> - fun curr next _ k -> - [: `HVbox - [: `S LO "{"; - listws - (fun (lab, p) k -> - HVbox [: `patt lab [: `S LR "=" :]; `patt p k :]) - (S RO ";") fpl [: `S RO "}"; k :] :] :] - | <:patt< ($list:[p::pl]$) >> -> - fun curr next _ k -> - [: `HOVCbox - [: `S LO "("; - listws patt (S RO ",") [p :: pl] [: `S RO ")"; k :] :] :] - | <:patt< ($p$ : $ct$) >> -> - fun curr next _ k -> - [: `S LO "("; `patt p [: `S LR ":" :]; - `ctyp ct [: `S RO ")"; k :] :] - | <:patt< ($x$ as $y$) >> -> - fun curr next _ k -> - [: `S LO "("; `patt x [: `S LR "as" :]; - `patt y [: `S RO ")"; k :] :] - | ( <:patt< $int:s$ >> | <:patt< $flo:s$ >> ) -> - fun curr next _ k -> [: `S LR s; k :] - | MLast.PaInt32 _ s -> fun curr next _ k -> [: `S LR (s^"l"); k :] - | MLast.PaInt64 _ s -> fun curr next _ k -> [: `S LR (s^"L"); k :] - | MLast.PaNativeInt _ s -> fun curr next _ k -> [: `S LR (s^"n"); k :] - | <:patt< $str:s$ >> -> - fun curr next _ k -> [: `S LR ("\"" ^ s ^ "\""); k :] - | <:patt< $chr:c$ >> -> - fun curr next _ k -> [: `S LR ("'" ^ c ^ "'"); k :] - | <:patt< $lid:s$ >> -> - fun curr next _ k -> [: `S LR (var_escaped s); k :] - | <:patt< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:patt< ` $i$ >> -> fun curr next _ k -> [: `S LR ("`" ^ i); k :] - | <:patt< # $list:sl$ >> -> - fun curr next _ k -> [: `S LO "#"; mod_ident sl k :] - | <:patt< ~ $i$ >> -> - fun curr next _ k -> [: `S LR ("~" ^ i); k :] - | <:patt< ~ $i$ : $p$ >> -> - fun curr next _ k -> [: `S LO ("~" ^ i ^ ":"); curr p "" k :] - | <:patt< ? $i$ >> -> - fun curr next _ k -> [: `S LR ("?" ^ i); k :] - | <:patt< ? $i$ : ($p$ : $t$) >> -> - fun curr next _ k -> - [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p [: `S LR ":" :]; - `ctyp t [: `S RO ")"; k :] :] - | <:patt< ? $i$ : ($p$) >> -> - fun curr next _ k -> - if i = "" then [: `S LO "?"; curr p "" k :] - else - [: `S LO ("?" ^ i ^ ":"); `S LO "("; - `patt p [: `S RO ")"; k :] :] - | <:patt< ? $i$ : ($p$ : $t$ = $e$) >> -> - fun curr next _ k -> - if i = "" then - [: `S LO "?"; `S LO "("; `patt p [: `S LR ":" :]; - `ctyp t [: `S LR "=" :]; `expr e [: `S RO ")"; k :] :] - else - [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p [: `S LR ":" :]; - `ctyp t [: `S LR "=" :]; `expr e [: `S RO ")"; k :] :] - | <:patt< ? $i$ : ($p$ = $e$) >> -> - fun curr next _ k -> - if i = "" then - [: `S LO "?"; `S LO "("; `patt p [: `S LR "=" :]; - `expr e [: `S RO ")"; k :] :] - else - [: `S LO ("?" ^ i ^ ":"); `S LO "("; `patt p [: `S LR "=" :]; - `expr e [: `S RO ")"; k :] :] - | <:patt< _ >> -> fun curr next _ k -> [: `S LR "_"; k :] - | <:patt< $_$ $_$ >> | <:patt< $_$ .. $_$ >> | - <:patt< $_$ | $_$ >> as p -> - fun curr next _ k -> - [: `S LO "("; `patt p [: `HVbox [: `S RO ")"; k :] :] :] - | p -> fun curr next _ k -> [: `next p "" k :] ]}]; - -pr_ctyp.pr_levels := - [{pr_label = "top"; pr_box t x = LocInfo (intloc(MLast.loc_of_ctyp t)) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $t1$ == $t2$ >> -> - fun curr next _ k -> - [: curr t1 "" [: `S LR "==" :]; `next t2 "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $x$ as $y$ >> -> - fun curr next _ k -> [: curr x "" [: `S LR "as" :]; `next y "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< ! $list:pl$ . $t$ >> -> - fun curr next dg k -> - if pl = [] then [: `ctyp t k :] - else - [: `HVbox [: `S LR "!"; list typevar pl [: `S LR "." :] :]; - `ctyp t k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $x$ -> $y$ >> -> - fun curr next _ k -> [: `next x "" [: `S LR "->" :]; curr y "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $t1$ $t2$ >> -> - fun curr next _ k -> [: curr t1 "" [: :]; `next t2 "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< ? $lab$ : $t$ >> -> - fun curr next _ k -> - [: `S LO "?"; `S LR lab; `S RO ":"; `next t "" k :] - | <:ctyp< ~ $lab$ : $t$ >> -> - fun curr next _ k -> [: `S LO ("~" ^ lab ^ ":"); `next t "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = ""; pr_box _ x = HOVbox x; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< $t1$ . $t2$ >> -> - fun curr next _ k -> - [: curr t1 "" [: :]; `S NO "."; `next t2 "" k :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}; - {pr_label = "simple"; - pr_box t x = LocInfo (intloc(MLast.loc_of_ctyp t)) (HOVbox x); - pr_rules = - extfun Extfun.empty with - [ <:ctyp< ($list:tl$) >> -> - fun curr next _ k -> - [: `S LO "("; listws ctyp (S LR "*") tl [: `S RO ")"; k :] :] - | <:ctyp< '$s$ >> -> - fun curr next _ k -> [: `S LO "'"; `S LR (var_escaped s); k :] - | <:ctyp< $lid:s$ >> -> - fun curr next _ k -> [: `S LR (var_escaped s); k :] - | <:ctyp< $uid:s$ >> -> fun curr next _ k -> [: `S LR s; k :] - | <:ctyp< _ >> -> fun curr next _ k -> [: `S LR "_"; k :] - | <:ctyp< private $ty$ >> -> - fun curr next dg k -> - [: `HVbox - [: `HVbox [:`S LR "private" :]; - `ctyp ty k :] :] - | <:ctyp< { $list: ftl$ } >> as t -> - fun curr next _ k -> - let loc = MLast.loc_of_ctyp t in - [: `HVbox - [: labels loc [: `S LR "{" :] ftl [: `S LR "}" :]; k :] :] - | <:ctyp< [ $list:ctl$ ] >> as t -> - fun curr next _ k -> - let loc = MLast.loc_of_ctyp t in - [: `Vbox - [: `HVbox [: :]; - variants loc [: `S LR "[" :] ctl [: `S LR "]" :]; k :] :] - | <:ctyp< [ = $list:rfl$ ] >> -> - fun curr next _ k -> - [: `HVbox - [: `HVbox [: :]; - row_fields [: `S LR "[ =" :] rfl [: `S LR "]" :]; k :] :] - | <:ctyp< [ > $list:rfl$ ] >> -> - fun curr next _ k -> - [: `HVbox - [: `HVbox [: :]; - row_fields [: `S LR "[ >" :] rfl [: `S LR "]" :]; k :] :] - | <:ctyp< [ < $list:rfl$ > $list:sl$ ] >> -> - fun curr next _ k -> - let k1 = [: `S LR "]" :] in - let k1 = - match sl with - [ [] -> k1 - | l -> - [: `S LR ">"; - list (fun x k -> HVbox [: `S LR x; k :]) l k1 :] ] - in - [: `HVbox - [: `HVbox [: :]; row_fields [: `S LR "[ <" :] rfl k1; - k :] :] - | <:ctyp< # $list:id$ >> -> - fun curr next _ k -> [: `S LO "#"; `class_longident id k :] - | <:ctyp< < > >> -> fun curr next _ k -> [: `S LR "<>"; k :] - | <:ctyp< < $list:ml$ $opt:v$ > >> -> - fun curr next _ k -> - [: `S LR "<"; meth_list (ml, v) [: `S LR ">"; k :] :] - | <:ctyp< $_$ -> $_$ >> | <:ctyp< $_$ $_$ >> | <:ctyp< $_$ == $_$ >> | - <:ctyp< $_$ . $_$ >> | <:ctyp< $_$ as $_$ >> | - <:ctyp< ? $_$ : $_$ >> | <:ctyp< ~ $_$ : $_$ >> | - <:ctyp< ! $list:_$ . $_$ >> as t -> - fun curr next _ k -> - [: `S LO "("; `ctyp t [: `HVbox [: `S RO ")"; k :] :] :] - | t -> fun curr next _ k -> [: `next t "" k :] ]}]; - -pr_class_sig_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (intloc(MLast.loc_of_class_sig_item s)) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ <:class_sig_item< type $t1$ = $t2$ >> -> - fun curr next _ k -> - [: `S LR "type"; `ctyp t1 [: `S LR "=" :]; `ctyp t2 k :] - | <:class_sig_item< declare $list:s$ end >> -> - fun curr next _ k -> [: `HVbox [: :]; list class_sig_item s k :] - | <:class_sig_item< inherit $ce$ >> -> - fun curr next _ k -> [: `S LR "inherit"; `class_type ce k :] - | <:class_sig_item< method $lab$ : $t$ >> -> - fun curr next _ k -> - [: `HVbox - [: `S LR "method"; `label lab; `S LR ":" :]; - `ctyp t k :] - | <:class_sig_item< method private $lab$ : $t$ >> -> - fun curr next _ k -> - [: `HVbox - [: `S LR "method"; `S LR "private"; `label lab; - `S LR ":" :]; - `ctyp t k :] - | <:class_sig_item< value $opt:mf$ $lab$ : $t$ >> -> - fun curr next _ k -> - [: `HVbox - [: `S LR "value"; flag "mutable" mf; `label lab; - `S LR ":" :]; - `ctyp t k :] - | <:class_sig_item< method virtual $lab$ : $t$ >> -> - fun curr next _ k -> - [: `HVbox - [: `S LR "method"; `S LR "virtual"; `label lab; - `S LR ":" :]; - `ctyp t k :] - | <:class_sig_item< method virtual private $lab$ : $t$ >> -> - fun curr next _ k -> - [: `HVbox - [: `S LR "method"; `S LR "virtual"; `S LR "private"; - `label lab; `S LR ":" :]; - `ctyp t k :] - | csi -> fun curr next dg k -> [: `next csi "" k :] ]}]; - -pr_class_str_item.pr_levels := - [{pr_label = "top"; - pr_box s x = LocInfo (intloc(MLast.loc_of_class_str_item s)) (HVbox x); - pr_rules = - extfun Extfun.empty with - [ MLast.CrDcl _ s -> - fun curr next _ k -> [: `HVbox [: :]; list class_str_item s [: :] :] - | MLast.CrInh _ ce pb -> - fun curr next _ k -> - [: `S LR "inherit"; `class_expr ce [: :]; - match pb with - [ Some i -> [: `S LR "as"; `S LR i :] - | _ -> [: :] ]; - k :] - | MLast.CrVal _ lab mf e -> - fun curr next _ k -> - [: `cvalue [: `S LR "value" :] (lab, mf, e) k :] - | MLast.CrVir _ lab pf t -> - fun curr next _ k -> - [: `S LR "method"; `S LR "virtual"; flag "private" pf; `label lab; - `S LR ":"; `ctyp t k :] - | MLast.CrMth _ lab pf fb None -> - fun curr next _ k -> - [: `fun_binding - [: `S LR "method"; flag "private" pf; `label lab :] fb k :] - | MLast.CrMth _ lab pf fb (Some t) -> - fun curr next dg k -> - [: `HOVbox - [: `S LR "method"; flag "private" pf; `label lab; `S LR ":"; - `ctyp t [: `S LR "=" :] :]; - `expr fb k :] - | MLast.CrCtr _ t1 t2 -> - fun curr next _ k -> - [: `HVbox [: `S LR "type"; `ctyp t1 [: `S LR "=" :] :]; - `ctyp t2 k :] - | MLast.CrIni _ se -> - fun curr next _ k -> [: `S LR "initializer"; `expr se k :] - | csi -> fun curr next dg k -> [: `next csi "" k :] ]}]; - -pr_class_type.pr_levels := - [{pr_label = "top"; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CtFun _ t ct -> - fun curr next _ k -> - [: `S LR "["; `ctyp t [: `S LR "]"; `S LR "->" :]; - `class_type ct k :] - | ct -> fun curr next _ k -> [: `class_signature ct k :] ]}]; - -pr_class_expr.pr_levels := - [{pr_label = "top"; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CeFun _ p ce -> - fun curr next _ k -> - [: `S LR "fun"; `simple_patt p [: `S LR "->" :]; - `class_expr ce k :] - | MLast.CeLet _ rf lb ce -> - fun curr next _ k -> - [: `Vbox - [: `HVbox [: :]; - `bind_list [: `S LR "let"; flag "rec" rf :] lb - [: `S LR "in" :]; - `class_expr ce k :] :] - | x -> fun curr next dg k -> [: `next x "" k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CeApp _ ce e -> - fun curr next _ k -> [: curr ce "" [: :]; `simple_expr e k :] - | x -> fun curr next dg k -> [: `next x "" k :] ]}; - {pr_label = ""; pr_box s x = HVbox x; - pr_rules = - extfun Extfun.empty with - [ MLast.CeCon _ ci [] -> - fun curr next _ k -> [: `class_longident ci k :] - | MLast.CeCon _ ci ctcl -> - fun curr next _ k -> - [: `class_longident ci [: :]; `S LO "["; - listws ctyp (S RO ",") ctcl [: `S RO "]"; k :] :] - | MLast.CeStr _ csp cf as ce -> - fun curr next _ k -> - let ep = snd (MLast.loc_of_class_expr ce) in - [: `BEbox - [: `HVbox [: `S LR "object"; `class_self_patt_opt csp :]; - `HVbox - [: `HVbox [: :]; list class_str_item cf [: :]; - `LocInfo (intloc(ep, ep)) (HVbox [: :]) :]; - `HVbox [: `S LR "end"; k :] :] :] - | MLast.CeTyc _ ce ct -> - fun curr next _ k -> - [: `S LO "("; `class_expr ce [: `S LR ":" :]; - `class_type ct [: `S RO ")"; k :] :] - | MLast.CeFun _ _ _ as ce -> - fun curr next _ k -> - [: `S LO "("; `class_expr ce [: `S RO ")"; k :] :] - | ce -> fun curr next _ k -> [: `not_impl "class_expr" ce; k :] ]}]; - -value output_string_eval oc s = - loop 0 where rec loop i = - if i == String.length s then () - else if i == String.length s - 1 then output_char oc s.[i] - else - match (s.[i], s.[i + 1]) with - [ ('\\', 'n') -> do { output_char oc '\n'; loop (i + 2) } - | (c, _) -> do { output_char oc c; loop (i + 1) } ] -; - -value maxl = ref 78; -value sep = Pcaml.inter_phrases; -value ncip = ref True; - -value input_source ic len = - let buff = Buffer.create 20 in - try - let rec loop i = - if i >= len then Buffer.contents buff - else do { let c = input_char ic in Buffer.add_char buff c; loop (i + 1) } - in - loop 0 - with - [ End_of_file -> - let s = Buffer.contents buff in - if s = "" then - match sep.val with - [ Some s -> s - | None -> "\n" ] - else s ] -; - -value copy_source ic oc first bp ep = - match sep.val with - [ Some str -> - if first then () - else if ep == in_channel_length ic then output_string oc "\n" - else output_string_eval oc str - | None -> - do { - seek_in ic bp; - let s = input_source ic (ep - bp) in - output_string oc s - } ] -; - -value copy_to_end ic oc first bp = - let ilen = in_channel_length ic in - if bp < ilen then copy_source ic oc first bp ilen else output_string oc "\n" -; - -module Buff = - struct - value buff = ref (String.create 80); - value store len x = - do { - if len >= String.length buff.val then - buff.val := buff.val ^ String.create (String.length buff.val) - else (); - buff.val.[len] := x; - succ len - } - ; - value mstore len s = - add_rec len 0 where rec add_rec len i = - if i == String.length s then len - else add_rec (store len s.[i]) (succ i) - ; - value get len = String.sub buff.val 0 len; - end -; - -value extract_comment strm = - let rec find_comm nl_bef tab_bef = - parser - [ [: `'('; a = find_star nl_bef tab_bef :] -> a - | [: `' '; s :] -> find_comm nl_bef (tab_bef + 1) s - | [: `'\t'; s :] -> find_comm nl_bef (tab_bef + 8) s - | [: `'\n'; s :] -> find_comm (nl_bef + 1) 0 s - | [: `_; s :] -> find_comm 0 0 s - | [: :] -> ("", nl_bef, tab_bef) ] - and find_star nl_bef tab_bef = - parser - [ [: `'*'; a = insert (Buff.mstore 0 "(*") :] -> (a, nl_bef, tab_bef) - | [: a = find_comm 0 0 :] -> a ] - and insert len = - parser - [ [: `'*'; a = rparen (Buff.store len '*') :] -> a - | [: `'('; len = find_star2 (Buff.store len '('); s :] -> insert len s - | [: `'\t'; s :] -> insert (Buff.mstore len (String.make 8 ' ')) s - | [: `x; s :] -> insert (Buff.store len x) s - | [: :] -> "" ] - and rparen len = - parser - [ [: `')'; s :] -> while_space (Buff.store len ')') s - | [: a = insert len :] -> a ] - and while_space len = - parser - [ [: `' '; a = while_space (Buff.store len ' ') :] -> a - | [: `'\t'; a = while_space (Buff.mstore len (String.make 8 ' ')) :] -> a - | [: `'\n'; a = while_space (Buff.store len '\n') :] -> a - | [: `'('; a = find_star_again len :] -> a - | [: :] -> Buff.get len ] - and find_star_again len = - parser - [ [: `'*'; a = insert (Buff.mstore len "(*") :] -> a - | [: :] -> Buff.get len ] - and find_star2 len = - parser - [ [: `'*'; a = insert2 (Buff.store len '*') :] -> a - | [: :] -> len ] - and insert2 len = - parser - [ [: `'*'; a = rparen2 (Buff.store len '*') :] -> a - | [: `'('; len = find_star2 (Buff.store len '('); s :] -> insert2 len s - | [: `x; s :] -> insert2 (Buff.store len x) s - | [: :] -> 0 ] - and rparen2 len = - parser - [ [: `')' :] -> Buff.store len ')' - | [: a = insert2 len :] -> a ] - in - find_comm 0 0 strm -; - -value get_no_comment _ _ = ("", 0, 0, 0); - -value get_comment ic beg len = - do { - seek_in ic beg; - let strm = - Stream.from (fun i -> if i >= len then None else Some (input_char ic)) - in - let (s, nl_bef, tab_bef) = extract_comment strm in - (s, nl_bef, tab_bef, Stream.count strm) - } -; - -value apply_printer printer ast = - let oc = - match Pcaml.output_file.val with - [ Some f -> open_out_bin f - | None -> stdout ] - in - let cleanup () = - match Pcaml.output_file.val with - [ Some _ -> close_out oc - | None -> () ] - in - let pr_ch = output_char oc in - let pr_str = output_string oc in - let pr_nl () = output_char oc '\n' in - if Pcaml.input_file.val <> "-" && Pcaml.input_file.val <> "" then do { - let ic = open_in_bin Pcaml.input_file.val in - let getcom = - if not ncip.val && sep.val = None then get_comment ic - else get_no_comment - in - try - let (first, last_pos) = - List.fold_left - (fun (first, last_pos) (si, (bp, ep)) -> - do { - copy_source ic oc first last_pos.Lexing.pos_cnum bp.Lexing.pos_cnum; - flush oc; - print_pretty pr_ch pr_str pr_nl "" "" maxl.val getcom bp.Lexing.pos_cnum - (printer si [: :]); - flush oc; - (False, ep) - }) - (True, Token.nowhere) ast - in - do { copy_to_end ic oc first last_pos.Lexing.pos_cnum; flush oc } - with x -> - do { close_in ic; cleanup (); raise x }; - close_in ic; - cleanup () - } - else do { - List.iter - (fun (si, _) -> - do { - print_pretty pr_ch pr_str pr_nl "" "" maxl.val get_no_comment 0 - (printer si [: :]); - match sep.val with - [ Some str -> output_string_eval oc str - | None -> output_char oc '\n' ]; - flush oc - }) - ast; - cleanup () - } -; - -Pcaml.print_interf.val := apply_printer sig_item; -Pcaml.print_implem.val := apply_printer str_item; - -Pcaml.add_option "-l" (Arg.Int (fun x -> maxl.val := x)) - " Maximum line length for pretty printing."; - -Pcaml.add_option "-sep_src" (Arg.Unit (fun () -> sep.val := None)) - "Read source file for text between phrases (default)."; - -Pcaml.add_option "-sep" (Arg.String (fun x -> sep.val := Some x)) - " Use this string between phrases instead of reading source."; - -Pcaml.add_option "-no_where" (Arg.Clear gen_where) - "Dont generate \"where\" statements"; - -Pcaml.add_option "-cip" (Arg.Clear ncip) "Add comments in phrases."; - -Pcaml.add_option "-ncip" (Arg.Set ncip) "No comments in phrases (default)."; - -Pcaml.add_option "-old_seq" (Arg.Set old_sequences) - "Pretty print with old syntax for sequences."; - -Pcaml.add_option "-exp_dcl" (Arg.Set expand_declare) - "Expand the \"declare\" items."; - -Pcaml.add_option "-tc" (Arg.Clear ncip) - "Deprecated since version 3.05; equivalent to -cip."; - -Pcaml.add_option "-no_curried_constructors" (Arg.Set no_curried_constructors) - "Considers all non constant data constructors as unary."; diff --git a/camlp4/etc/pr_rp.ml b/camlp4/etc/pr_rp.ml deleted file mode 100644 index 3edb6338..00000000 --- a/camlp4/etc/pr_rp.ml +++ /dev/null @@ -1,504 +0,0 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: pr_rp.ml,v 1.6 2004/11/17 09:07:56 mauny Exp $ *) - -open Pcaml; -open Spretty; - -value _loc = (Token.nowhere, Token.nowhere); - -value expr e dg k = pr_expr.pr_fun "top" e dg k; -value patt e dg k = pr_patt.pr_fun "top" e dg k; - -(* Streams *) - -value stream e dg k = - let rec get = - fun - [ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y] - | <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y] - | <:expr< Stream.ising $x$ >> -> [(True, x)] - | <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y] - | <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y] - | <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)] - | <:expr< Stream.sempty >> -> [] - | <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)] - | <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)] - | e -> [(False, e)] ] - in - let elem e k = - match e with - [ (True, e) -> [: `HOVbox [: `S LO "`"; `expr e "" k :] :] - | (False, e) -> [: `expr e "" k :] ] - in - let rec glop e k = - match e with - [ [] -> k - | [e] -> [: elem e k :] - | [e :: el] -> [: elem e [: `S RO ";" :]; glop el k :] ] - in - HOVbox [: `S LR "[:"; glop (get e) [: `S LR ":]"; k :] :] -; - -(* Parsers *) - -type spc = - [ SPCterm of (MLast.patt * option MLast.expr) - | SPCnterm of MLast.patt and MLast.expr - | SPCsterm of MLast.patt ] -; - -exception NotImpl; - -value rec subst v e = - match e with - [ <:expr< $lid:x$ >> -> if x = "strm__" then <:expr< $lid:v$ >> else e - | <:expr< $uid:_$ >> -> e - | <:expr< $int:_$ >> -> e - | <:expr< $chr:_$ >> -> e - | <:expr< $str:_$ >> -> e - | <:expr< $e1$ . $lab$ >> -> <:expr< $subst v e1$ . $lab$ >> - | <:expr< $x$ $y$ >> -> <:expr< $subst v x$ $subst v y$ >> - | <:expr< let $lid:s1$ = $e1$ in $e2$ >> -> - if s1 = v then <:expr< let $lid:s1$ = $subst v e1$ in $e2$ >> - else <:expr< let $lid:s1$ = $subst v e1$ in $subst v e2$ >> - | <:expr< let _ = $e1$ in $e2$ >> -> - <:expr< let _ = $subst v e1$ in $subst v e2$ >> - | <:expr< ($list:el$) >> -> <:expr< ($list:List.map (subst v) el$) >> - | _ -> raise NotImpl ] -; - -value rec is_free v = - fun - [ <:expr< $lid:x$ >> -> x <> v - | <:expr< $uid:_$ >> -> True - | <:expr< $int:_$ >> -> True - | <:expr< $chr:_$ >> -> True - | <:expr< $str:_$ >> -> True - | <:expr< $e$ . $_$ >> -> is_free v e - | <:expr< $x$ $y$ >> -> is_free v x && is_free v y - | <:expr< let $lid:s1$ = $e1$ in $e2$ >> -> - is_free v e1 && (s1 = v || is_free v e2) - | <:expr< let _ = $e1$ in $e2$ >> -> is_free v e1 && is_free v e2 - | <:expr< ($list:el$) >> -> List.for_all (is_free v) el - | _ -> raise NotImpl ] -; - -value gensym = - let cnt = ref 0 in - fun () -> - do { incr cnt; "pr_rp_symb_" ^ string_of_int cnt.val } -; - -value free_var_in_expr c e = - let rec loop_alpha v = - let x = String.make 1 v in - if is_free x e then Some x - else if v = 'z' then None - else loop_alpha (Char.chr (Char.code v + 1)) - in - let rec loop_count cnt = - let x = String.make 1 c ^ string_of_int cnt in - if is_free x e then x else loop_count (succ cnt) - in - try - match loop_alpha c with - [ Some v -> v - | None -> loop_count 1 ] - with - [ NotImpl -> gensym () ] -; - -value parserify = - fun - [ <:expr< $e$ strm__ >> -> e - | e -> <:expr< fun strm__ -> $e$ >> ] -; - -value is_raise_failure = - fun - [ <:expr< raise Stream.Failure >> -> True - | _ -> False ] -; - -value is_raise_error = - fun - [ <:expr< raise (Stream.Error $_$) >> -> True - | _ -> False ] -; - -value semantic e = - try - if is_free "strm__" e then e - else - let v = free_var_in_expr 's' e in - <:expr< let $lid:v$ = strm__ in $subst v e$ >> - with - [ NotImpl -> e ] -; - -value rewrite_parser = - rewrite True where rec rewrite top ge = - match ge with - [ <:expr< let $p$ = try $e$ with [ Stream.Failure -> raise $exc$ ] in - $sp_kont$ >> -> - let f = parserify e in - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> raise $exc$ ] - >> - | <:expr< let $p$ = Stream.count strm__ in $f$ >> -> - try - if is_free "strm__" f then ge - else - let v = free_var_in_expr 's' f in - <:expr< - let $lid:v$ = strm__ in - let $p$ = Stream.count strm__ in $subst v f$ - >> - with - [ NotImpl -> ge ] - | <:expr< let $p$ = strm__ in $e$ >> -> - <:expr< let $p$ = strm__ in $rewrite False e$ >> - | <:expr< let $p$ = $f$ strm__ in $sp_kont$ >> when top -> - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> raise Stream.Failure ] - >> - | <:expr< let $p$ = $e$ in $sp_kont$ >> -> - if match e with - [ <:expr< match try Some $_$ with [ Stream.Failure -> None ] with - [ $list:_$ ] >> - | <:expr< match Stream.peek strm__ with [ $list:_$ ] >> - | <:expr< try $_$ with [ Stream.Failure -> $_$ ] >> - | <:expr< let $_$ = Stream.count strm__ in $_$ >> -> True - | _ -> False ] - then - let f = rewrite True <:expr< fun strm__ -> $e$ >> in - let exc = - if top then <:expr< Stream.Failure >> - else <:expr< Stream.Error "" >> - in - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> raise $exc$ ] - >> - else semantic ge - | <:expr< match try Some $e$ with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> $p_kont$ ] >> -> - let f = parserify e in - if not top && is_raise_failure p_kont then semantic ge - else - let (p, f, sp_kont, p_kont) = - if top || is_raise_error p_kont then - (p, f, rewrite False sp_kont, rewrite top p_kont) - else - let f = - <:expr< - fun strm__ -> - match - try Some ($f$ strm__) with [ Stream.Failure -> None ] - with - [ Some $p$ -> $rewrite False sp_kont$ - | _ -> $rewrite top p_kont$ ] - >> - in - (<:patt< a >>, f, <:expr< a >>, - <:expr< raise (Stream.Error "") >>) - in - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> $p_kont$ ] - >> - | <:expr< match Stream.peek strm__ with [ $list:pel$ ] >> -> - let rec iter pel = - match pel with - [ [(<:patt< Some $p$ >>, eo, - <:expr< do { Stream.junk strm__; $sp_kont$ } >>); - (<:patt< _ >>, None, p_kont) :: _] -> - <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:eo$ -> - do { Stream.junk strm__; $rewrite False sp_kont$ } - | _ -> $rewrite top p_kont$ ] - >> - | [(<:patt< Some $p$ >>, eo, - <:expr< do { Stream.junk strm__; $sp_kont$ } >>) :: pel] -> - let p_kont = iter pel in - <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:eo$ -> - do { Stream.junk strm__; $rewrite False sp_kont$ } - | _ -> $p_kont$ ] - >> - | _ -> - <:expr< match Stream.peek strm__ with [ $list:pel$ ] >> ] - in - iter pel - | <:expr< try Some $e$ with [ Stream.Failure -> $p_kont$ ] >> -> - let f = parserify e in - let e = - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some a -> Some a - | _ -> $p_kont$ ] - >> - in - rewrite top e - | <:expr< try $e$ with [ Stream.Failure -> $p_kont$ ] >> -> - let f = parserify e in - let e = - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some a -> a - | _ -> $rewrite top p_kont$ ] - >> - in - rewrite top e - | <:expr< $f$ strm__ >> -> - if top then - <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some a -> a - | _ -> raise Stream.Failure ] - >> - else - let v = free_var_in_expr 's' f in - <:expr< let $lid:v$ = strm__ in $f$ $lid:v$ >> - | e -> semantic e ] -; - -value parser_of_expr = - let rec parser_cases e = - match e with - [ <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> $p_kont$ ] - >> -> - let spc = (SPCnterm p f, None) in - let (sp, epo, e) = kont sp_kont in - [([spc :: sp], epo, e) :: parser_cases p_kont] - | <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ } - | _ -> $p_kont$ ] - >> -> - let spc = (SPCterm (p, wo), None) in - let (sp, epo, e) = kont sp_kont in - [([spc :: sp], epo, e) :: parser_cases p_kont] - | <:expr< let $p$ = strm__ in $sp_kont$ >> -> - let spc = (SPCsterm p, None) in - let (sp, epo, e) = kont sp_kont in - [([spc :: sp], epo, e)] - | <:expr< let $p$ = Stream.count strm__ in $e$ >> -> [([], Some p, e)] - | <:expr< raise Stream.Failure >> -> [] - | _ -> [([], None, e)] ] - and kont e = - match e with - [ <:expr< - match try Some ($f$ strm__) with [ Stream.Failure -> None ] with - [ Some $p$ -> $sp_kont$ - | _ -> raise (Stream.Error $err$) ] - >> -> - let err = - match err with - [ <:expr< "" >> -> None - | _ -> Some err ] - in - let spc = (SPCnterm p f, err) in - let (sp, epo, e) = kont sp_kont in - ([spc :: sp], epo, e) - | <:expr< - match Stream.peek strm__ with - [ Some $p$ $when:wo$ -> do { Stream.junk strm__; $sp_kont$ } - | _ -> raise (Stream.Error $err$) ] - >> -> - let err = - match err with - [ <:expr< "" >> -> None - | _ -> Some err ] - in - let spc = (SPCterm (p, wo), err) in - let (sp, epo, e) = kont sp_kont in - ([spc :: sp], epo, e) - | <:expr< let $p$ = strm__ in $sp_kont$ >> -> - let spc = (SPCsterm p, None) in - let (sp, epo, e) = kont sp_kont in - ([spc :: sp], epo, e) - | <:expr< let $p$ = Stream.count strm__ in $e$ >> -> ([], Some p, e) - | _ -> ([], None, e) ] - in - parser_cases -; - -value parser_cases b spel k = - let rec parser_cases b spel k = - match spel with - [ [] -> [: `HVbox [: b; k :] :] - | [(sp, epo, e)] -> [: `parser_case b sp epo e k :] - | [(sp, epo, e) :: spel] -> - [: `parser_case b sp epo e [: :]; - parser_cases [: `S LR "|" :] spel k :] ] - and parser_case b sp epo e k = - let epo = - match epo with - [ Some p -> [: `patt p "" [: `S LR "->" :] :] - | _ -> [: `S LR "->" :] ] - in - HVbox - [: b; - `HOVbox - [: `HOVbox - [: `S LR "[:"; - stream_patt [: :] sp [: `S LR ":]"; epo :] :]; - `expr e "" k :] :] - and stream_patt b sp k = - match sp with - [ [] -> [: `HVbox [: b; k :] :] - | [(spc, None)] -> [: `stream_patt_comp b spc k :] - | [(spc, Some e)] -> - [: `HVbox - [: `stream_patt_comp b spc [: :]; - `HVbox [: `S LR "?"; `expr e "" k :] :] :] - | [(spc, None) :: spcl] -> - [: `stream_patt_comp b spc [: `S RO ";" :]; - stream_patt [: :] spcl k :] - | [(spc, Some e) :: spcl] -> - [: `HVbox - [: `stream_patt_comp b spc [: :]; - `HVbox [: `S LR "?"; `expr e "" [: `S RO ";" :] :] :]; - stream_patt [: :] spcl k :] ] - and stream_patt_comp b spc k = - match spc with - [ SPCterm (p, w) -> - HVbox [: b; `S LO "`"; `patt p "" [: :]; `HVbox [: when_opt w k :] :] - | SPCnterm p e -> - HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e "" k :] :] - | SPCsterm p -> HVbox [: b; `patt p "" k :] ] - and when_opt wo k = - match wo with - [ Some e -> [: `S LR "when"; `expr e "" k :] - | _ -> k ] - in - parser_cases b spel k -; - -value parser_body e dg k = - let (bp, e) = - match e with - [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) - | e -> (None, e) ] - in - let e = rewrite_parser e in - match parser_of_expr e with - [ [] -> - HVbox - [: `HVbox - [: `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - `HVbox [: `S LR "[]"; k :] :] - | [spe] -> - HVbox - [: `HVbox - [: `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - parser_cases [: :] [spe] k :] - | spel -> - Vbox - [: `HVbox [: :]; - `HVbox - [: `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :] ] -; - -value pmatch e dg k = - let (me, e) = - match e with - [ <:expr< let (strm__ : Stream.t _) = $me$ in $e$ >> -> (me, e) - | <:expr< match $_$ strm__ with [ $list:_$ ] >> -> (<:expr< strm__ >>, e) - | _ -> failwith "Pr_rp.pmatch" ] - in - let (bp, e) = - match e with - [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) - | e -> (None, e) ] - in - let e = rewrite_parser e in - let spel = parser_of_expr e in - Vbox - [: `HVbox [: :]; - `HVbox - [: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :] -; - -(* Printer extensions *) - -pr_expr_fun_args.val := - extfun pr_expr_fun_args.val with - [ <:expr< fun strm__ -> $_$ >> as ge -> ([], ge) - | <:expr< fun [(strm__ : $_$) -> $_$] >> as ge -> ([], ge) ]; - -let lev = find_pr_level "top" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< let (strm__ : Stream.t _) = $_$ in $_$ >> as e -> - fun curr next _ k -> [: `pmatch e "" k :] - | <:expr< match $_$ strm__ with [ $list:_$ ] >> as e -> - fun curr next _ k -> [: `pmatch e "" k :] - | <:expr< fun strm__ -> $x$ >> -> - fun curr next _ k -> [: `parser_body x "" k :] - | <:expr< fun (strm__ : $_$) -> $x$ >> -> - fun curr next _ k -> [: `parser_body x "" k :] ]; - -let lev = find_pr_level "apply" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | - <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | - <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | - <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | - <:expr< Stream.slazy $_$ >> as e -> - fun curr next _ k -> [: `next e "" k :] ]; - -let lev = find_pr_level "dot" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.sempty >> as e -> - fun curr next _ k -> [: `next e "" k :] ]; - -let lev = find_pr_level "simple" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | - <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | - <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | - <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | - <:expr< Stream.slazy $_$ >> as e -> - fun curr next _ k -> [: `stream e "" k :] ]; diff --git a/camlp4/etc/pr_rp_main.ml b/camlp4/etc/pr_rp_main.ml deleted file mode 100644 index f7aae915..00000000 --- a/camlp4/etc/pr_rp_main.ml +++ /dev/null @@ -1,206 +0,0 @@ -(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: pr_rp_main.ml,v 1.3 2004/11/17 09:07:56 mauny Exp $ *) - -open Pcaml; -open Spretty; - -value _loc = (Token.nowhere, Token.nowhere); - -value expr e dg k = pr_expr.pr_fun "top" e dg k; -value patt e dg k = pr_patt.pr_fun "top" e dg k; - -(* Streams *) - -value stream e dg k = - let rec get = - fun - [ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y] - | <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y] - | <:expr< Stream.ising $x$ >> -> [(True, x)] - | <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y] - | <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y] - | <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)] - | <:expr< Stream.sempty >> -> [] - | <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)] - | <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)] - | e -> [(False, e)] ] - in - let elem e k = - match e with - [ (True, e) -> [: `HOVbox [: `S LO "`"; `expr e "" k :] :] - | (False, e) -> [: `expr e "" k :] ] - in - let rec glop e k = - match e with - [ [] -> k - | [e] -> [: elem e k :] - | [e :: el] -> [: elem e [: `S RO ";" :]; glop el k :] ] - in - HOVbox [: `S LR "[:"; glop (get e) [: `S LR ":]"; k :] :] -; - -(* Parsers *) - -open Parserify; - -value parser_cases b spel k = - let rec parser_cases b spel k = - match spel with - [ [] -> [: `HVbox [: b; k :] :] - | [(sp, epo, e)] -> [: `parser_case b sp epo e k :] - | [(sp, epo, e) :: spel] -> - [: `parser_case b sp epo e [: :]; - parser_cases [: `S LR "|" :] spel k :] ] - and parser_case b sp epo e k = - let epo = - match epo with - [ Some p -> [: `patt p "" [: `S LR "->" :] :] - | _ -> [: `S LR "->" :] ] - in - HVbox - [: b; - `HOVbox - [: `HOVbox - [: `S LR "[:"; - stream_patt [: :] sp [: `S LR ":]"; epo :] :]; - `expr e "" k :] :] - and stream_patt b sp k = - match sp with - [ [] -> [: `HVbox [: b; k :] :] - | [(spc, None)] -> [: `stream_patt_comp b spc k :] - | [(spc, Some e)] -> - [: `HVbox - [: `stream_patt_comp b spc [: :]; - `HVbox [: `S LR "?"; `expr e "" k :] :] :] - | [(spc, None) :: spcl] -> - [: `stream_patt_comp b spc [: `S RO ";" :]; - stream_patt [: :] spcl k :] - | [(spc, Some e) :: spcl] -> - [: `HVbox - [: `stream_patt_comp b spc [: :]; - `HVbox [: `S LR "?"; `expr e "" [: `S RO ";" :] :] :]; - stream_patt [: :] spcl k :] ] - and stream_patt_comp b spc k = - match spc with - [ SPCterm (p, w) -> - HVbox [: b; `S LO "`"; `patt p "" [: :]; `HVbox [: when_opt w k :] :] - | SPCnterm p e -> - HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e "" k :] :] - | SPCsterm p -> HVbox [: b; `patt p "" k :] ] - and when_opt wo k = - match wo with - [ Some e -> [: `S LR "when"; `expr e "" k :] - | _ -> k ] - in - parser_cases b spel k -; - -value parser_body e dg k = - let (bp, e) = - match e with - [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) - | e -> (None, e) ] - in - match parser_of_expr e with - [ [] -> - HVbox - [: `HVbox - [: `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - `HVbox [: `S LR "[]"; k :] :] - | [spe] -> - HVbox - [: `HVbox - [: `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - parser_cases [: :] [spe] k :] - | spel -> - Vbox - [: `HVbox [: :]; - `HVbox - [: `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :] ] -; - -value pmatch e dg k = - let (me, e) = - match e with - [ <:expr< let (strm__ : Stream.t _) = $me$ in $e$ >> -> (me, e) - | _ -> failwith "Pr_rp.pmatch" ] - in - let (bp, e) = - match e with - [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) - | e -> (None, e) ] - in - let spel = parser_of_expr e in - Vbox - [: `HVbox [: :]; - `HVbox - [: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser"; - match bp with - [ Some p -> [: `patt p "" [: :] :] - | _ -> [: :] ] :]; - parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :] -; - -(* Printer extensions *) - -pr_expr_fun_args.val := - extfun pr_expr_fun_args.val with - [ <:expr< fun strm__ -> $_$ >> as ge -> ([], ge) - | <:expr< fun [(strm__ : $_$) -> $_$] >> as ge -> ([], ge) ]; - -let lev = find_pr_level "top" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< let (strm__ : Stream.t _) = $_$ in $_$ >> as e -> - fun curr next _ k -> [: `pmatch e "" k :] - | <:expr< fun strm__ -> $x$ >> -> - fun curr next _ k -> [: `parser_body x "" k :] - | <:expr< fun (strm__ : $_$) -> $x$ >> -> - fun curr next _ k -> [: `parser_body x "" k :] ]; - -let lev = find_pr_level "apply" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | - <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | - <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | - <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | - <:expr< Stream.slazy $_$ >> as e -> - fun curr next _ k -> [: `next e "" k :] ]; - -let lev = find_pr_level "dot" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.sempty >> as e -> - fun curr next _ k -> [: `next e "" k :] ]; - -let lev = find_pr_level "simple" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | - <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | - <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | - <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | - <:expr< Stream.slazy $_$ >> as e -> - fun curr next _ k -> [: `stream e "" k :] ]; diff --git a/camlp4/etc/q_phony.ml b/camlp4/etc/q_phony.ml deleted file mode 100644 index cd1d9de6..00000000 --- a/camlp4/etc/q_phony.ml +++ /dev/null @@ -1,49 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: q_phony.ml,v 1.5 2004/11/17 09:07:56 mauny Exp $ *) - -open Pcaml; - -value t = ref ""; - -Quotation.add "" - (Quotation.ExAst - (fun s -> - let t = - if t.val = "" then "<<" ^ s ^ ">>" - else "<:" ^ t.val ^ "<" ^ s ^ ">>" - in - let _loc = (Token.nowhere, Token.nowhere) in - <:expr< $uid:t$ >>, - fun s -> - let t = - if t.val = "" then "<<" ^ s ^ ">>" - else "<:" ^ t.val ^ "<" ^ s ^ ">>" - in - let _loc = (Token.nowhere, Token.nowhere) in - <:patt< $uid:t$ >>)) -; - -Quotation.default.val := ""; -Quotation.translate.val := fun s -> do { t.val := s; "" }; - -if Pcaml.syntax_name.val <> "Scheme" then - EXTEND - expr: LEVEL "top" - [ [ "IFDEF"; c = UIDENT; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" -> - <:expr< if DEF $uid:c$ then $e1$ else $e2$ >> - | "IFNDEF"; c = UIDENT; "THEN"; e1 = expr; "ELSE"; e2 = expr; "END" -> - <:expr< if NDEF $uid:c$ then $e1$ else $e2$ >> ] ] - ; - END -else (); diff --git a/camlp4/examples/expression_closure.ml b/camlp4/examples/expression_closure.ml new file mode 100644 index 00000000..58f15448 --- /dev/null +++ b/camlp4/examples/expression_closure.ml @@ -0,0 +1,24 @@ +#default_quotation "expr"; + +open Camlp4.PreCast; +open Format; + +module FV = Camlp4.Struct.FreeVars.Make Ast; +module PP = Camlp4.Printers.OCaml.Make Syntax; +module S = FV.S; + +value _loc = Loc.ghost; + +value pervasives = + let list = + [ "+"; "-"; "/"; "*" (* ... *) ] + in List.fold_right S.add list S.empty; + +value f e = + let fv = FV.free_vars pervasives e in + S.fold (fun x acc -> << fun ~ $x$ -> $acc$ >>) fv e; + +value print_expr = (new PP.printer ())#expr; + +printf "%a@." print_expr (f <>); + diff --git a/camlp4/examples/expression_closure_filter.ml b/camlp4/examples/expression_closure_filter.ml new file mode 100644 index 00000000..fb1fbe07 --- /dev/null +++ b/camlp4/examples/expression_closure_filter.ml @@ -0,0 +1,50 @@ +(* camlp4r *) +#default_quotation "expr"; + +open Camlp4.PreCast; +open Format; + +module FV = Camlp4.Struct.FreeVars.Make Ast; +module S = FV.S; + +value _loc = Loc.ghost; + +value pervasives = + let list = + [ "+"; "-"; "/"; "*" (* ... *) ] + in List.fold_right S.add list S.empty; + +value collect_free_vars_sets = + object (self) + inherit FV.fold_free_vars [S.t] S.add ~env_init:pervasives S.empty as super; + value free_sets = []; + method set_free free = {< free = free >}; + method expr = + fun + [ << close_expr $e$ >> -> (self#expr e)#add_current_free#set_free free + | e -> super#expr e ]; + method add_current_free = {< free_sets = [ free :: free_sets ] >}; + method free_sets = free_sets; + end; + +value apply_close_expr next_free_set = + object (self) + inherit Ast.map as super; + method expr = + fun + [ << close_expr $e$ >> -> + let e = self#expr e in + let fv = next_free_set () in + S.fold (fun x acc -> << fun ~ $x$ -> $acc$ >>) fv e + | e -> super#expr e ]; + end; + +value f st = + let fv_sets = ref (collect_free_vars_sets#str_item st)#free_sets in + let next_free_set () = + match fv_sets.val with + [ [] -> assert False + | [x::xs] -> let () = fv_sets.val := xs in x ] + in (apply_close_expr next_free_set)#str_item st; + +AstFilters.register_str_item_filter f; diff --git a/camlp4/examples/free_vars_test.ml b/camlp4/examples/free_vars_test.ml new file mode 100644 index 00000000..9d98f53e --- /dev/null +++ b/camlp4/examples/free_vars_test.ml @@ -0,0 +1,70 @@ +open Format; +open Camlp4.PreCast; + +module FV = Camlp4.Struct.FreeVars.Make Ast; + +#default_quotation "expr"; + +value print_set f s = do { + fprintf f "@[<2>{ "; + FV.S.iter (fprintf f "%s@ ") s; + fprintf f "}@]"; +}; + +module PP = Camlp4.Printers.OCamlr.Make Syntax; +value print_expr = (new PP.printer ())#expr; + +value print_status f st = pp_print_string f (if st then "PASS" else "FAIL"); + +value _loc = Loc.ghost; + +value atoms e = + let o = object + inherit Ast.fold as super; + value accu = FV.S.empty; + method accu = accu; + method expr = + fun + [ << $lid:s$ >> -> {< accu = FV.S.add s accu >} + | e -> super#expr e ]; + end in (o#expr e)#accu; + +value fv e ref = + let s = FV.free_vars FV.S.empty e in + let ref = atoms ref in + let st = FV.S.equal s ref in do { + printf "%a: @[fv << %a >> = %a" + print_status st + print_expr e print_set s; + if st then () else printf "@ ref = %a@ diff = %a" + print_set ref print_set (FV.S.diff ref s); + printf "@]@ "; +}; + +printf "@["; + +fv << x >> << x >>; +fv << x y >> << x y >>; +fv << fun x -> x y >> << y >>; +fv << fun y -> fun x -> x y >> <<>>; +fv << let x = 42 and y = 44 in x y z >> << z >>; +fv << let z = g in let x = 42 and y = 44 in x y z >> << g >>; +fv << let rec f x = g (x + 1) and g y = f (y - 1) in fun x -> g x * f x >> << \+ \- \* >>; +fv << let rec f x = g (x + 1) and g y = f (g (y - 1)) in fun x -> g x * f x >> << \+ \- \* >>; + +fv << let i = 42 in let module M = struct value f x = y x; end in M.h >> << y >>; + +fv << fun [ A x -> x y ] >> << y >>; + +fv << fun [ A x -> x y | _ -> x ] >> << x y >>; + +fv << fun [ { x = A z; y = y } as q -> x z y a q ] >> << x a >>; + +fv << let module M = struct value a = 42; value b = a + 1; end in () >> <<\+>>; + +fv << let module M = struct value rec a = 42; value b = a + 1; end in () >> <<\+>>; + +fv << let rec f x = x and g = x in y >> << x y >>; +fv << let f x = x in x >> << x >>; + +printf "@]@."; diff --git a/camlp4/examples/global_handler.ml b/camlp4/examples/global_handler.ml new file mode 100644 index 00000000..f23ab61e --- /dev/null +++ b/camlp4/examples/global_handler.ml @@ -0,0 +1,22 @@ +open Camlp4.PreCast; + +value ghost = Loc.ghost; + +value global_handler_ref = ref <:expr@ghost<>>; + +value find_global_handler = object + inherit Ast.map as super; + method str_item st = do { + match st with + [ <:str_item< value global_handler = $f$ >> -> global_handler_ref.val := f + | _ -> () ]; + super#str_item st + }; +end; + +AstFilters.register_str_item_filter + (fun st -> + let _ = find_global_handler#str_item st in + <:str_item@ghost< try let module Main = struct $st$ end in () + with e -> $global_handler_ref.val$ e >>); + diff --git a/camlp4/examples/global_handler_test.ml b/camlp4/examples/global_handler_test.ml new file mode 100644 index 00000000..882af494 --- /dev/null +++ b/camlp4/examples/global_handler_test.ml @@ -0,0 +1,12 @@ +open Format;; +let f1 x = printf "f1 %d@." x;; +let f2 x = printf "f2 %f@." x;; +let f3 x = printf "f3 %s@." x;; +f1 1;; +f2 1.1;; +f3 "1.1.1";; +raise (Failure "test");; +let global_handler e = + (* Note that I need to give the complete name for eprintf since + Format is not opened in the new environment of global_handler. *) + Format.eprintf "global_handler: %s@." (Printexc.to_string e) diff --git a/camlp4/lib/.cvsignore b/camlp4/lib/.cvsignore deleted file mode 100644 index c77a681d..00000000 --- a/camlp4/lib/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -*.cm[oiax] -*.cmxa -*.lib diff --git a/camlp4/lib/.depend b/camlp4/lib/.depend deleted file mode 100644 index 286b4c5b..00000000 --- a/camlp4/lib/.depend +++ /dev/null @@ -1,21 +0,0 @@ -extfold.cmi: gramext.cmi -gramext.cmi: token.cmi -grammar.cmi: token.cmi gramext.cmi -plexer.cmi: token.cmi -stdpp.cmi: token.cmi -extfold.cmo: grammar.cmi gramext.cmi extfold.cmi -extfold.cmx: grammar.cmx gramext.cmx extfold.cmi -extfun.cmo: extfun.cmi -extfun.cmx: extfun.cmi -fstream.cmo: fstream.cmi -fstream.cmx: fstream.cmi -gramext.cmo: token.cmi gramext.cmi -gramext.cmx: token.cmx gramext.cmi -grammar.cmo: token.cmi stdpp.cmi gramext.cmi grammar.cmi -grammar.cmx: token.cmx stdpp.cmx gramext.cmx grammar.cmi -plexer.cmo: token.cmi stdpp.cmi plexer.cmi -plexer.cmx: token.cmx stdpp.cmx plexer.cmi -stdpp.cmo: token.cmi stdpp.cmi -stdpp.cmx: token.cmx stdpp.cmi -token.cmo: token.cmi -token.cmx: token.cmi diff --git a/camlp4/lib/Makefile b/camlp4/lib/Makefile deleted file mode 100644 index 9d3b4aae..00000000 --- a/camlp4/lib/Makefile +++ /dev/null @@ -1,62 +0,0 @@ -# $Id: Makefile,v 1.15.4.2 2006/09/14 15:32:20 doligez Exp $ - -include ../config/Makefile - -INCLUDES= -OCAMLCFLAGS=-warn-error A $(INCLUDES) -OBJS=stdpp.cmo token.cmo plexer.cmo gramext.cmo grammar.cmo extfold.cmo extfun.cmo fstream.cmo -SHELL=/bin/sh -TARGET=gramlib.cma - -.PHONY: opt all clean depend promote compare install installopt - -all: $(TARGET) -opt: opt$(PROFILING) - -optnoprof: $(TARGET:.cma=.cmxa) -optprof: optnoprof $(TARGET:.cma=.p.cmxa) - -$(TARGET): $(OBJS) - $(OCAMLC) $(OBJS) -a -o $(TARGET) - -$(TARGET:.cma=.cmxa): $(OBJS:.cmo=.cmx) - $(OCAMLOPT) $(OBJS:.cmo=.cmx) -a -o $(TARGET:.cma=.cmxa) - -$(TARGET:.cma=.p.cmxa): $(OBJS:.cmo=.p.cmx) - $(OCAMLOPT) $(OBJS:.cmo=.p.cmx) -a -o $(TARGET:.cma=.p.cmxa) - -clean:: - rm -f *.cm[ioax] *.cmxa *.pp[io] *.$(O) *.$(A) *.bak .*.bak $(TARGET) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i >> .depend; \ - done - -promote: - cp $(OBJS) $(OBJS:.cmo=.cmi) ../boot/. - -compare: - @for j in $(OBJS) $(OBJS:.cmo=.cmi); do \ - if cmp $$j ../boot/$$j; then :; else exit 1; fi; \ - done - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" - cp $(TARGET) *.mli "$(LIBDIR)/camlp4/." - cp *.cmi *.cmo "$(LIBDIR)/camlp4/." - test -f $(TARGET:.cma=.cmxa) && $(MAKE) installopt LIBDIR="$(LIBDIR)" || true - -installopt: - for f in $(TARGET:.cma=.cmxa) $(TARGET:.cma=.p.cmxa) *.cmx *.o ; do \ - test -f $$f && cp $$f "$(LIBDIR)/camlp4/." || true ; \ - done - # Special treatment for this one: some versions of make don't like $(A) in $(TARGET:.cma=.$(A)) - target="`echo $(TARGET) | sed -e 's/\.cma$$/.$(A)/'`" ; \ - if test -f $$target ; then \ - cp $$target "$(LIBDIR)/camlp4/." && ( cd "$(LIBDIR)/camlp4/." && $(RANLIB) $$target ) \ - fi - -include .depend diff --git a/camlp4/lib/extfold.ml b/camlp4/lib/extfold.ml deleted file mode 100644 index 3c48299b..00000000 --- a/camlp4/lib/extfold.ml +++ /dev/null @@ -1,91 +0,0 @@ -(* camlp4r *) -(* $Id: extfold.ml,v 1.1 2002/07/19 14:53:47 mauny Exp $ *) - -type t 'te 'a 'b = - Gramext.g_entry 'te -> list (Gramext.g_symbol 'te) -> - (Stream.t 'te -> 'a) -> Stream.t 'te -> 'b -; - -type tsep 'te 'a 'b = - Gramext.g_entry 'te -> list (Gramext.g_symbol 'te) -> - (Stream.t 'te -> 'a) -> (Stream.t 'te -> unit) -> Stream.t 'te -> 'b -; - -value gen_fold0 final f e entry symbl psymb = - let rec fold accu = - parser - [ [: a = psymb; s :] -> fold (f a accu) s - | [: :] -> accu ] - in - parser [: a = fold e :] -> final a -; - -value gen_fold1 final 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) :] -> final a -; - -value gen_fold0sep final f e entry symbl psymb psep = - let failed = - fun - [ [symb; sep] -> Grammar.symb_failed_txt entry sep symb - | _ -> "failed" ] - in - let rec kont accu = - parser - [ [: v = psep; a = psymb ? failed symbl; s :] -> kont (f a accu) s - | [: :] -> accu ] - in - parser - [ [: a = psymb; s :] -> final (kont (f a e) s) - | [: :] -> e ] -; - -value gen_fold1sep final f e entry symbl psymb psep = - let failed = - fun - [ [symb; sep] -> Grammar.symb_failed_txt entry sep symb - | _ -> "failed" ] - in - let parse_top = - fun - [ [symb; _] -> Grammar.parse_top_symb entry symb - | _ -> raise Stream.Failure ] - in - let rec kont accu = - parser - [ [: v = 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 :] -> final (kont (f a e) s) -; - -value sfold0 f e = gen_fold0 (fun x -> x) f e; -value sfold1 f e = gen_fold1 (fun x -> x) f e; -value sfold0sep f e = gen_fold0sep (fun x -> x) f e; -value sfold1sep f e = gen_fold1sep (fun x -> x) f e; - -value cons x y = [x :: y]; -value nil = []; - -value slist0 entry = gen_fold0 List.rev cons nil entry; -value slist1 entry = gen_fold1 List.rev cons nil entry; -value slist0sep entry = gen_fold0sep List.rev cons nil entry; -value slist1sep entry = gen_fold1sep List.rev cons nil entry; - -value sopt entry symbl psymb = - parser - [ [: a = psymb :] -> Some a - | [: :] -> None ] -; diff --git a/camlp4/lib/extfold.mli b/camlp4/lib/extfold.mli deleted file mode 100644 index c183fe03..00000000 --- a/camlp4/lib/extfold.mli +++ /dev/null @@ -1,24 +0,0 @@ -(* camlp4r *) -(* $Id: extfold.mli,v 1.1 2002/07/19 14:53:47 mauny Exp $ *) - -type t 'te 'a 'b = - Gramext.g_entry 'te -> list (Gramext.g_symbol 'te) -> - (Stream.t 'te -> 'a) -> Stream.t 'te -> 'b -; - -type tsep 'te 'a 'b = - Gramext.g_entry 'te -> list (Gramext.g_symbol 'te) -> - (Stream.t 'te -> 'a) -> (Stream.t 'te -> unit) -> Stream.t 'te -> 'b -; - -value sfold0 : ('a -> 'b -> 'b) -> 'b -> t _ 'a 'b; -value sfold1 : ('a -> 'b -> 'b) -> 'b -> t _ 'a 'b; -value sfold0sep : ('a -> 'b -> 'b) -> 'b -> tsep _ 'a 'b; -value sfold1sep : ('a -> 'b -> 'b) -> 'b -> tsep _ 'a 'b; - -value slist0 : t _ 'a (list 'a); -value slist1 : t _ 'a (list 'a); -value slist0sep : tsep _ 'a (list 'a); -value slist1sep : tsep _ 'a (list 'a); - -value sopt : t _ 'a (option 'a); diff --git a/camlp4/lib/extfun.ml b/camlp4/lib/extfun.ml deleted file mode 100644 index 833cb72f..00000000 --- a/camlp4/lib/extfun.ml +++ /dev/null @@ -1,107 +0,0 @@ -(* camlp4r *) -(* $Id: extfun.ml,v 1.4 2005/06/29 13:19:14 mauny Exp $ *) -(* Copyright 2001 INRIA *) - -(* Extensible Functions *) - -type t 'a 'b = list (matching 'a 'b) -and matching 'a 'b = { patt : patt; has_when : bool; expr : expr 'a 'b } -and patt = - [ Eapp of list patt - | Eacc of list patt - | Econ of string - | Estr of string - | Eint of string - | Etup of list patt - | Evar of unit ] -and expr 'a 'b = 'a -> option 'b -; - -exception Failure; - -value empty = []; - -(*** Apply ***) - -value rec apply_matchings a = - fun - [ [m :: ml] -> - match m.expr a with - [ None -> apply_matchings a ml - | x -> x ] - | [] -> None ] -; - -value apply ef a = - match apply_matchings a ef with - [ Some x -> x - | None -> raise Failure ] -; - -(*** Trace ***) - -value rec list_iter_sep f s = - fun - [ [] -> () - | [x] -> f x - | [x :: l] -> do { f x; s (); list_iter_sep f s l } ] -; - -value rec print_patt = - fun - [ Eapp pl -> list_iter_sep print_patt2 (fun () -> print_string " ") pl - | p -> print_patt2 p ] -and print_patt2 = - fun - [ Eacc pl -> list_iter_sep print_patt1 (fun () -> print_string ".") pl - | p -> print_patt1 p ] -and print_patt1 = - fun - [ Econ s -> print_string s - | Estr s -> do { print_string "\""; print_string s; print_string "\"" } - | Eint s -> print_string s - | Evar () -> print_string "_" - | Etup pl -> - do { - print_string "("; - list_iter_sep print_patt (fun () -> print_string ", ") pl; - print_string ")" - } - | Eapp _ | Eacc _ as p -> - do { print_string "("; print_patt p; print_string ")" } ] -; - -value print ef = - List.iter - (fun m -> - do { - print_patt m.patt; - if m.has_when then print_string " when ..." else (); - print_newline () - }) - ef -; - -(*** Extension ***) - -value insert_matching matchings (patt, has_when, expr) = - let m1 = {patt = patt; has_when = has_when; expr = expr} in - let rec loop = - fun - [ [m :: ml] as gml -> - if m1.has_when && not m.has_when then [m1 :: gml] else - if not m1.has_when && m.has_when then [m :: loop ml] else - (* either both or none have a when clause *) - if compare m1.patt m.patt = 0 then - if not m1.has_when then [m1 :: ml] else [m1 :: gml] - else [m :: loop ml] - | [] -> [m1] ] - in - loop matchings -; - -(* available extension function *) - -value extend ef matchings_def = - List.fold_left insert_matching ef matchings_def -; diff --git a/camlp4/lib/extfun.mli b/camlp4/lib/extfun.mli deleted file mode 100644 index c66e99cd..00000000 --- a/camlp4/lib/extfun.mli +++ /dev/null @@ -1,36 +0,0 @@ -(* camlp4r *) -(* $Id: extfun.mli,v 1.2 2002/07/19 14:53:48 mauny Exp $ *) - -(** Extensible functions. - - This module implements pattern matching extensible functions. - To extend, use syntax [pa_extfun.cmo]: - - [extfun e with [ pattern_matching ]] *) - -type t 'a 'b = 'x; - (** The type of the extensible functions of type ['a -> 'b] *) -value empty : t 'a 'b; - (** Empty extensible function *) -value apply : t 'a 'b -> 'a -> 'b; - (** Apply an extensible function *) -exception Failure; - (** Match failure while applying an extensible function *) -value print : t 'a 'b -> unit; - (** Print patterns in the order they are recorded *) - -(**/**) - -type matching 'a 'b = { patt : patt; has_when : bool; expr : expr 'a 'b } -and patt = - [ Eapp of list patt - | Eacc of list patt - | Econ of string - | Estr of string - | Eint of string - | Etup of list patt - | Evar of unit ] -and expr 'a 'b = 'a -> option 'b -; - -value extend : t 'a 'b -> list (patt * bool * expr 'a 'b) -> t 'a 'b; diff --git a/camlp4/lib/fstream.ml b/camlp4/lib/fstream.ml deleted file mode 100644 index 30a72ef4..00000000 --- a/camlp4/lib/fstream.ml +++ /dev/null @@ -1,77 +0,0 @@ -(* camlp4r *) -(* $Id: fstream.ml,v 1.5 2003/07/10 12:28:24 michel Exp $ *) -(* Copyright 2001 INRIA *) - -type t 'a = { count : int; data : Lazy.t (data 'a) } -and data 'a = - [ Nil - | Cons of 'a and t 'a - | App of t 'a and t 'a ] -; - -value from f = - loop 0 where rec loop i = - {count = 0; - data = - lazy - (match f i with - [ Some x -> Cons x (loop (i + 1)) - | None -> Nil ])} -; - -value rec next s = - let count = s.count + 1 in - match Lazy.force s.data with - [ Nil -> None - | Cons a s -> Some (a, {count = count; data = s.data}) - | App s1 s2 -> - match next s1 with - [ Some (a, s1) -> Some (a, {count = count; data = lazy (App s1 s2)}) - | None -> - match next s2 with - [ Some (a, s2) -> Some (a, {count = count; data = s2.data}) - | None -> None ] ] ] -; - -value empty s = - match next s with - [ Some _ -> None - | None -> Some ((), s) ] -; - -value nil = {count = 0; data = lazy Nil}; -value cons a s = Cons a s; -value app s1 s2 = App s1 s2; -value flazy f = {count = 0; data = Lazy.lazy_from_fun f}; - -value of_list l = - List.fold_right (fun x s -> flazy (fun () -> cons x s)) l nil -; - -value of_string s = - from (fun c -> if c < String.length s then Some s.[c] else None) -; - -value of_channel ic = - from (fun _ -> try Some (input_char ic) with [ End_of_file -> None ]) -; - -value iter f = - do_rec where rec do_rec strm = - match next strm with - [ Some (a, strm) -> - let _ = f a in - do_rec strm - | None -> () ] -; - -value count s = s.count; - -value count_unfrozen s = - loop 0 s where rec loop cnt s = - if Lazy.lazy_is_val s.data then - match Lazy.force s.data with - [ Cons _ s -> loop (cnt + 1) s - | _ -> cnt ] - else cnt -; diff --git a/camlp4/lib/fstream.mli b/camlp4/lib/fstream.mli deleted file mode 100644 index 1ec3e57f..00000000 --- a/camlp4/lib/fstream.mli +++ /dev/null @@ -1,60 +0,0 @@ -(* camlp4r *) -(* $Id: fstream.mli,v 1.3 2002/07/19 14:53:48 mauny Exp $ *) - -(* Module [Fstream]: functional streams *) - -(* This module implement functional streams. - To be used with syntax [pa_fstream.cmo]. The syntax is: -- stream: [fstream [: ... :]] -- parser: [parser [ [: ... :] -> ... | ... ]] - - Functional parsers are of type: [Fstream.t 'a -> option ('a * Fstream.t 'a)] - - They have limited backtrack, i.e if a rule fails, the next rule is tested - with the initial stream; limited because when in case of a rule with two - consecutive symbols [a] and [b], if [b] fails, the rule fails: there is - no try with the next rule of [a]. -*) - -type t 'a = 'x; - (* The type of 'a functional streams *) -value from : (int -> option 'a) -> t 'a; - (* [Fstream.from f] returns a stream built from the function [f]. - To create a new stream element, the function [f] is called with - the current stream count. The user function [f] must return either - [Some ] for a value or [None] to specify the end of the - stream. *) - -value of_list : list 'a -> t 'a; - (* Return the stream holding the elements of the list in the same - order. *) -value of_string : string -> t char; - (* Return the stream of the characters of the string parameter. *) -value of_channel : in_channel -> t char; - (* Return the stream of the characters read from the input channel. *) - -value iter : ('a -> unit) -> t 'a -> unit; - (* [Fstream.iter f s] scans the whole stream s, applying function [f] - in turn to each stream element encountered. *) - -value next : t 'a -> option ('a * t 'a); - (* Return [Some (a, s)] where [a] is the first element of the stream - and [s] the remaining stream, or [None] if the stream is empty. *) -value empty : t 'a -> option (unit * t 'a); - (* Return [Some ((), s)] if the stream is empty where [s] is itself, - else [None] *) -value count : t 'a -> int; - (* Return the current count of the stream elements, i.e. the number - of the stream elements discarded. *) -value count_unfrozen : t 'a -> int; - (* Return the number of unfrozen elements in the beginning of the - stream; useful to determine the position of a parsing error (longuest - path). *) - -(*--*) - -value nil : t 'a; -type data 'a = 'x; -value cons : 'a -> t 'a -> data 'a; -value app : t 'a -> t 'a -> data 'a; -value flazy : (unit -> data 'a) -> t 'a; diff --git a/camlp4/lib/gramext.ml b/camlp4/lib/gramext.ml deleted file mode 100644 index a7af21db..00000000 --- a/camlp4/lib/gramext.ml +++ /dev/null @@ -1,565 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: gramext.ml,v 1.4 2002/07/19 14:53:48 mauny Exp $ *) - -open Printf; - -type grammar 'te = - { gtokens : Hashtbl.t Token.pattern (ref int); - glexer : mutable Token.glexer 'te } -; - -type g_entry 'te = - { egram : grammar 'te; - ename : string; - estart : mutable int -> Stream.t 'te -> Obj.t; - econtinue : mutable int -> int -> Obj.t -> Stream.t 'te -> Obj.t; - edesc : mutable g_desc 'te } -and g_desc 'te = - [ Dlevels of list (g_level 'te) - | Dparser of Stream.t 'te -> Obj.t ] -and g_level 'te = - { assoc : g_assoc; - lname : option string; - lsuffix : g_tree 'te; - lprefix : g_tree 'te } -and g_assoc = - [ NonA - | RightA - | LeftA ] -and g_symbol 'te = - [ Smeta of string and list (g_symbol 'te) and Obj.t - | Snterm of g_entry 'te - | Snterml of g_entry 'te and string - | Slist0 of g_symbol 'te - | Slist0sep of g_symbol 'te and g_symbol 'te - | Slist1 of g_symbol 'te - | Slist1sep of g_symbol 'te and g_symbol 'te - | Sopt of g_symbol 'te - | Sself - | Snext - | Stoken of Token.pattern - | Stree of g_tree 'te ] -and g_action = Obj.t -and g_tree 'te = - [ Node of g_node 'te - | LocAct of g_action and list g_action - | DeadEnd ] -and g_node 'te = - { node : g_symbol 'te; son : g_tree 'te; brother : g_tree 'te } -; - -type position = - [ First - | Last - | Before of string - | After of string - | Level of string ] -; - -value warning_verbose = ref True; - -value rec derive_eps = - fun - [ Slist0 _ -> True - | Slist0sep _ _ -> True - | Sopt _ -> True - | Stree t -> tree_derive_eps t - | Smeta _ _ _ | Slist1 _ | Slist1sep _ _ | Snterm _ | Snterml _ _ | Snext | - Sself | Stoken _ -> - 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 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) -> eq_symbol s1 s2 - | (Slist0sep s1 sep1, Slist0sep s2 sep2) -> - eq_symbol s1 s2 && eq_symbol sep1 sep2 - | (Slist1 s1, Slist1 s2) -> eq_symbol s1 s2 - | (Slist1sep s1 sep1, Slist1sep s2 sep2) -> - eq_symbol s1 s2 && eq_symbol sep1 sep2 - | (Sopt s1, Sopt s2) -> eq_symbol s1 s2 - | (Stree _, Stree _) -> False - | _ -> s1 = s2 ] -; - -value is_before s1 s2 = - match (s1, s2) with - [ (Stoken ("ANY", _), _) -> False - | (_, Stoken ("ANY", _)) -> True - | (Stoken (_, s), Stoken (_, "")) when s <> "" -> True - | (Stoken _, Stoken _) -> False - | (Stoken _, _) -> True - | _ -> False ] -; - -value insert_tree entry_name 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 -> - do { - if warning_verbose.val then do { - eprintf " Grammar extension: "; - if entry_name <> "" then eprintf "in [%s], " entry_name - else (); - eprintf "some rule has been masked\n"; - flush stderr - } - else (); - 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 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 ] - and insert_new = - fun - [ [s :: sl] -> Node {node = s; son = insert_new sl; brother = DeadEnd} - | [] -> LocAct action [] ] - in - insert gsymbols tree -; - -value srules rl = - let t = - List.fold_left - (fun tree (symbols, action) -> insert_tree "" symbols action tree) - DeadEnd rl - in - Stree t -; - -external action : 'a -> g_action = "%identity"; - -value is_level_labelled n lev = - match lev.lname with - [ Some n1 -> n = n1 - | None -> False ] -; - -value insert_level entry_name e1 symbols action slev = - match e1 with - [ True -> - {assoc = slev.assoc; lname = slev.lname; - lsuffix = insert_tree entry_name symbols action slev.lsuffix; - lprefix = slev.lprefix} - | False -> - {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix; - lprefix = insert_tree entry_name symbols action slev.lprefix} ] -; - -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 lev n lname assoc = - let a = - match assoc with - [ None -> lev.assoc - | Some a -> - do { - if a <> lev.assoc && warning_verbose.val then do { - eprintf " Changing associativity of level \"%s\"\n" n; - flush stderr - } - else (); - a - } ] - in - do { - match lname with - [ Some n -> - if lname <> lev.lname && warning_verbose.val then do { - eprintf " Level label \"%s\" ignored\n" n; flush stderr - } - else () - | None -> () ]; - {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; - lprefix = lev.lprefix} - } -; - -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 stderr; - failwith "Grammar.extend" - } - | [lev :: levs] -> - if is_level_labelled n lev then ([], change_lev 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 stderr; - failwith "Grammar.extend" - } - | [lev :: levs] -> - if 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 stderr; - failwith "Grammar.extend" - } - | [lev :: levs] -> - if 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 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 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 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 -> check_gram entry s - | Slist1 s -> check_gram entry s - | Sopt s -> check_gram entry s - | Stree t -> tree_check_gram entry t - | Snext | Sself | Stoken _ -> () ] -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 change_to_self entry = - fun - [ Snterm e when e == entry -> Sself - | x -> x ] -; - -value get_initial entry = - 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 -> insert s - | Slist1 s -> insert s - | Slist0sep s t -> do { insert s; insert t } - | Slist1sep s t -> do { insert s; insert t } - | Sopt s -> insert s - | Stree t -> tinsert t - | Stoken ("ANY", _) -> () - | Stoken tok -> - do { - gram.glexer.Token.tok_using tok; - let r = - try Hashtbl.find gram.gtokens tok with - [ Not_found -> - let r = ref 0 in - do { Hashtbl.add gram.gtokens tok r; r } ] - in - incr r - } - | Snterm _ | Snterml _ _ | Snext | Sself -> () ] - 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 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 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 entry symbols in - insert_tokens entry.egram symbols; - insert_level entry.ename e1 symbols action lev - }) - lev level - in - ([lev :: levs], empty_lev)) - ([], make_lev) rules - in - levs1 @ List.rev levs @ levs2 -; - -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) -> eq_symbols s1 s2 - | (Slist0sep s1 sep1, Slist0sep s2 sep2) -> - eq_symbols s1 s2 && eq_symbols sep1 sep2 - | (Slist1 s1, Slist1 s2) -> eq_symbols s1 s2 - | (Slist1sep s1 sep1, Slist1sep s2 sep2) -> - eq_symbols s1 s2 && eq_symbols sep1 sep2 - | (Sopt s1, Sopt s2) -> eq_symbols s1 s2 - | (Stree t1, Stree t2) -> eq_trees t1 t2 - | _ -> 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 -; - -(* [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 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 ] - | ([s :: sl], _) -> 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 - [ Stoken tok -> - let r = Hashtbl.find gram.gtokens tok in - do { - decr r; - if r.val == 0 then do { - Hashtbl.remove gram.gtokens tok; gram.glexer.Token.tok_removing tok - } - else () - } - | Smeta _ sl _ -> List.iter (decr_keyw_use gram) sl - | Slist0 s -> decr_keyw_use gram s - | Slist1 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 } - | Sopt s -> decr_keyw_use gram s - | Stree t -> decr_keyw_use_in_tree gram t - | Sself | Snext | Snterm _ | Snterml _ _ -> () ] -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 Not_found ] -; - -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 Not_found ] -; - -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 ] -; diff --git a/camlp4/lib/gramext.mli b/camlp4/lib/gramext.mli deleted file mode 100644 index f01ba636..00000000 --- a/camlp4/lib/gramext.mli +++ /dev/null @@ -1,81 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: gramext.mli,v 1.3 2002/07/19 14:53:48 mauny Exp $ *) - -type grammar 'te = - { gtokens : Hashtbl.t Token.pattern (ref int); - glexer : mutable Token.glexer 'te } -; - -type g_entry 'te = - { egram : grammar 'te; - ename : string; - estart : mutable int -> Stream.t 'te -> Obj.t; - econtinue : mutable int -> int -> Obj.t -> Stream.t 'te -> Obj.t; - edesc : mutable g_desc 'te } -and g_desc 'te = - [ Dlevels of list (g_level 'te) - | Dparser of Stream.t 'te -> Obj.t ] -and g_level 'te = - { assoc : g_assoc; - lname : option string; - lsuffix : g_tree 'te; - lprefix : g_tree 'te } -and g_assoc = - [ NonA - | RightA - | LeftA ] -and g_symbol 'te = - [ Smeta of string and list (g_symbol 'te) and Obj.t - | Snterm of g_entry 'te - | Snterml of g_entry 'te and string - | Slist0 of g_symbol 'te - | Slist0sep of g_symbol 'te and g_symbol 'te - | Slist1 of g_symbol 'te - | Slist1sep of g_symbol 'te and g_symbol 'te - | Sopt of g_symbol 'te - | Sself - | Snext - | Stoken of Token.pattern - | Stree of g_tree 'te ] -and g_action = Obj.t -and g_tree 'te = - [ Node of g_node 'te - | LocAct of g_action and list g_action - | DeadEnd ] -and g_node 'te = - { node : g_symbol 'te; son : g_tree 'te; brother : g_tree 'te } -; - -type position = - [ First - | Last - | Before of string - | After of string - | Level of string ] -; - -value levels_of_rules : - g_entry 'te -> option position -> - list - (option string * option g_assoc * - list (list (g_symbol 'te) * g_action)) -> - list (g_level 'te); -value srules : list (list (g_symbol 'te) * g_action) -> g_symbol 'te; -external action : 'a -> g_action = "%identity"; - -value delete_rule_in_level_list : - g_entry 'te -> list (g_symbol 'te) -> list (g_level 'te) -> - list (g_level 'te); - -value warning_verbose : ref bool; diff --git a/camlp4/lib/grammar.ml b/camlp4/lib/grammar.ml deleted file mode 100644 index b2ce254b..00000000 --- a/camlp4/lib/grammar.ml +++ /dev/null @@ -1,1084 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: grammar.ml,v 1.14 2005/03/24 17:20:53 doligez Exp $ *) - -open Stdpp; -open Gramext; -open Format; - -value rec flatten_tree = - fun - [ DeadEnd -> [] - | LocAct _ _ -> [[]] - | Node {node = n; brother = b; son = s} -> - List.map (fun l -> [n :: l]) (flatten_tree s) @ flatten_tree b ] -; - -value print_str ppf s = fprintf ppf "\"%s\"" (String.escaped s); - -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 - | Stoken (con, prm) when con <> "" && prm <> "" -> - fprintf ppf "%s@ %a" con print_str prm - | Snterml e l -> fprintf ppf "%s@ LEVEL@ %a" e.ename print_str l - | Snterm _ | Snext | Sself | Stoken _ | Stree _ 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 ("", s) -> print_str ppf s - | Stoken (con, "") -> pp_print_string ppf con - | Stree t -> print_level ppf pp_print_space (flatten_tree t) - | Smeta _ _ _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ | - Slist1sep _ _ | Sopt _ | Stoken _ 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 ppf -> ()) 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 ppf -> ()) rules - in - fprintf ppf " ]@]" - } -; - -value print_levels ppf elev = - let _ = - List.fold_left - (fun sep lev -> - let rules = - List.map (fun t -> [Sself :: t]) (flatten_tree lev.lsuffix) @ - flatten_tree lev.lprefix - in - do { - fprintf ppf "%t@[" sep; - match lev.lname with - [ Some n -> fprintf ppf "%a@;<1 2>" print_str 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 ppf -> ()) elev - in - () -; - -value print_entry ppf e = - do { - fprintf ppf "@[[ "; - match e.edesc with - [ Dlevels elev -> print_levels ppf elev - | Dparser _ -> fprintf ppf "" ]; - fprintf ppf " ]@]" - } -; - -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 -> do_symbol s - | Slist0sep s1 s2 | Slist1sep s1 s2 -> do { do_symbol s1; do_symbol s2 } - | Stree t -> do_tree t - | Sself | Snext | Stoken _ -> () ] - 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 -> 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 _ -> accu ] - in - do_entry init e -; - -type g = Gramext.grammar Token.t; - -external grammar_obj : g -> grammar Token.t = "%identity"; - -value floc = ref (fun _ -> failwith "internal error when computing location"); -value loc_of_token_interval bp ep = - if bp == ep then - if bp == 0 then (Token.nowhere, Token.succ_pos Token.nowhere) - else - let a = snd (floc.val (bp - 1)) in - (a, Token.succ_pos a) - else - let (bp1, bp2) = floc.val bp in - let (ep1, ep2) = floc.val (pred ep) in - (if Token.lt_pos bp1 ep1 then bp1 else ep1, if Token.lt_pos ep2 bp2 then bp2 else ep2) -; - -value rec name_of_symbol entry = - fun - [ Snterm e -> "[" ^ e.ename ^ "]" - | Snterml e l -> "[" ^ e.ename ^ " level " ^ l ^ "]" - | Sself | Snext -> "[" ^ entry.ename ^ "]" - | Stoken tok -> entry.egram.glexer.Token.tok_text tok - | _ -> "???" ] -; - -value rec get_token_list entry tokl last_tok tree = - match tree with - [ Node {node = Stoken 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 rec name_of_symbol_failed entry = - fun - [ Slist0 s -> name_of_symbol_failed entry s - | Slist0sep s _ -> name_of_symbol_failed entry s - | Slist1 s -> name_of_symbol_failed entry s - | Slist1sep s _ -> name_of_symbol_failed entry s - | Sopt 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 tok -> get_token_list entry [] tok 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, last_tok, son) -> - List.fold_left - (fun s tok -> - (if s = "" then "" else s ^ " ") ^ - entry.egram.glexer.Token.tok_text tok) - "" tokl ] - | DeadEnd | LocAct _ _ -> "???" ] -; - -value search_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 _ | Stoken _ | Stree _ - 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 ] - | Stree t -> - match search_tree t with - [ Some t -> Some (Stree t) - | None -> None ] - | _ -> None ] - in - search_levels levels - | Dparser _ -> tree ] -; - -value error_verbose = ref False; - -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 Obj.magic 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 Obj.magic 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" ] - | Sopt _ | Stree _ -> txt ^ " expected" - | _ -> txt ^ " expected after " ^ name_of_symbol entry prev_symb ] - in - do { - if error_verbose.val then do { - let tree = search_tree_in_entry prev_symb tree entry.edesc in - let ppf = err_formatter in - fprintf ppf "@[@,"; - fprintf ppf "----------------------------------@,"; - fprintf ppf "Parse error in entry [%s], rule:@;<0 2>" entry.ename; - fprintf ppf "@["; - print_level ppf pp_force_newline (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 -; - -external app : Obj.t -> 'a = "%identity"; - -value is_level_labelled n lev = - match lev.lname with - [ Some n1 -> n = n1 - | None -> False ] -; - -value level_number entry lab = - let rec lookup levn = - fun - [ [] -> failwith ("unknown level " ^ lab) - | [lev :: levs] -> - if 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 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 entry_of_symb entry = - fun - [ Sself | Snext -> entry - | Snterm e -> e - | Snterml e _ -> e - | _ -> 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 skip_if_empty bp p strm = - if Stream.count strm == bp then Gramext.action (fun a -> p strm) - else raise Stream.Failure -; - -value continue entry bp a s son p1 = - parser - [: a = (entry_of_symb entry s).econtinue 0 bp a; - act = p1 ? tree_failed entry a s son :] -> - Gramext.action (fun _ -> app act a) -; - -value do_recover parser_of_tree entry nlevn alevn bp a s son = - parser - [ [: a = parser_of_tree entry nlevn alevn (top_tree entry son) :] -> a - | [: a = skip_if_empty bp (parser []) :] -> a - | [: a = - continue entry bp a s son - (parser_of_tree entry nlevn alevn son) :] -> - a ] -; - -value strict_parsing = ref False; -value strict_parsing_warning = ref False; - -value recover parser_of_tree entry nlevn alevn bp a s son strm = - if strict_parsing.val then raise (Stream.Error (tree_failed entry a s son)) - else - let _ = - if strict_parsing_warning.val then - do { - let msg = tree_failed entry a s son in - try - let (_,bp2) = floc.val bp in - let c = bp2.Lexing.pos_cnum - bp2.Lexing.pos_bol in - match (bp2.Lexing.pos_fname <> "", c > 0) with [ - (True, True) -> - Printf.eprintf "File \"%s\", line %d, character %d:\n" - bp2.Lexing.pos_fname bp2.Lexing.pos_lnum c - | (False, True) -> Printf.eprintf "Character %d:\n" c - | _ -> () ] - with [ _ -> () ]; - Printf.eprintf "Warning: trying to recover from syntax error"; - if entry.ename <> "" then Printf.eprintf " in [%s]\n" entry.ename - else Printf.eprintf "\n"; - Printf.eprintf "%s\n%!" msg - } else () in - do_recover parser_of_tree entry nlevn alevn bp a s son strm -; - -value token_count = ref 0; - -value peek_nth n strm = - let list = Stream.npeek n strm in - do { - token_count.val := Stream.count strm + n; - let rec loop list n = - match (list, n) with - [ ([x :: _], 1) -> Some x - | ([_ :: l], n) -> loop l (n - 1) - | ([], _) -> None ] - in - loop list n - } -; - -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 :] -> app 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 :] -> app act a - | [: a = p2 :] -> a ] - | Node {node = s; son = son; brother = DeadEnd} -> - let tokl = - match s with - [ Stoken tok -> get_token_list entry [] tok 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 - parser bp [: a = ps; act = p1 bp a :] -> app 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 (Stoken last_tok) son in - parser_of_token_list entry.egram p1 tokl ] - | Node {node = s; son = son; brother = bro} -> - let tokl = - match s with - [ Stoken tok -> get_token_list entry [] tok 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 - parser bp - [ [: a = ps; act = p1 bp a :] -> app 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 (Stoken last_tok) son in - let p1 = parser_of_token_list entry.egram 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 bp a = - parser - [ [: a = p1 :] -> a - | [: a = recover parser_of_tree entry nlevn alevn bp a s son :] -> a - | [: :] -> raise (Stream.Error (tree_failed entry a s son)) ] -and parser_of_token_list gram p1 tokl = - loop 1 tokl where rec loop n = - fun - [ [tok :: tokl] -> - let tematch = gram.glexer.Token.tok_match tok in - match tokl with - [ [] -> - let ps strm = - match peek_nth n strm with - [ Some tok -> - let r = tematch tok in - do { for i = 1 to n do { Stream.junk strm }; Obj.repr r } - | None -> raise Stream.Failure ] - in - parser bp [: a = ps; act = p1 bp a :] -> app act a - | _ -> - let ps strm = - match peek_nth n strm with - [ Some tok -> tematch tok - | None -> raise Stream.Failure ] - in - let p1 = loop (n + 1) tokl in - parser - [: a = ps; s :] -> - let act = p1 s in - app act a ] - | [] -> invalid_arg "parser_of_token_list" ] -and parser_of_symbol entry nlevn = - fun - [ Smeta _ symbl act -> - let act = Obj.magic act entry symbl in - Obj.magic - (List.fold_left - (fun act symb -> Obj.magic act (parser_of_symbol entry nlevn symb)) - act symbl) - | 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 [] :] -> Obj.repr (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 ? symb_failed entry v sep symb; s :] -> - kont [a :: al] s - | [: :] -> al ] - in - parser - [ [: a = ps; s :] -> Obj.repr (List.rev (kont [a] s)) - | [: :] -> Obj.repr [] ] - | 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 :] -> Obj.repr (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 (symb_failed entry v sep symb)) ]; - s :] -> - kont [a :: al] s - | [: :] -> al ] - in - parser [: a = ps; s :] -> Obj.repr (List.rev (kont [a] s)) - | Sopt s -> - let ps = parser_of_symbol entry nlevn s in - parser - [ [: a = ps :] -> Obj.repr (Some a) - | [: :] -> Obj.repr None ] - | Stree t -> - let pt = parser_of_tree entry 1 0 t in - parser bp - [: a = pt :] ep -> - let loc = loc_of_token_interval bp ep in - app a 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 - | Stoken tok -> - let f = entry.egram.glexer.Token.tok_match tok in - fun strm -> - match Stream.peek strm with - [ Some tok -> - let r = f tok in - do { Stream.junk strm; Obj.repr r } - | None -> raise Stream.Failure ] ] -and parse_top_symb entry symb = - parser_of_symbol entry 0 (top_symb entry symb) -; - -value symb_failed_txt e s1 s2 = symb_failed e 0 s1 s2; - -value rec continue_parser_of_levels entry clevn = - fun - [ [] -> fun levn bp a -> 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 - [ [: a = p1 levn bp a :] -> a - | [: act = p2 :] ep -> - let a = app act a (loc_of_token_interval bp ep) in - entry.econtinue levn bp a strm ] ] ] -; - -value rec start_parser_of_levels entry clevn = - fun - [ [] -> fun levn -> 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 -> - match strm with parser bp - [ [: act = p2 :] ep -> - let a = app act (loc_of_token_interval bp ep) in - entry.econtinue levn bp a strm ] - | _ -> - fun levn strm -> - if levn > clevn then p1 levn strm - else - match strm with parser bp - [ [: act = p2 :] ep -> - let a = app act (loc_of_token_interval bp ep) in - entry.econtinue levn bp a strm - | [: a = p1 levn :] -> a ] ] ] ] -; - -value continue_parser_of_entry entry = - 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 p -> fun levn bp a -> parser [] ] -; - -value empty_entry ename levn strm = - raise (Stream.Error ("entry [" ^ ename ^ "] is empty")) -; - -value start_parser_of_entry entry = - match entry.edesc with - [ Dlevels [] -> empty_entry entry.ename - | Dlevels elev -> start_parser_of_levels entry 0 elev - | Dparser p -> fun levn strm -> p strm ] -; - -value parse_parsable entry efun (cs, (ts, fun_loc)) = - let restore = - let old_floc = floc.val in - let old_tc = token_count.val in - fun () -> do { floc.val := old_floc; token_count.val := old_tc } - in - let get_loc () = - try - let cnt = Stream.count ts in - let loc = fun_loc cnt in - if token_count.val - 1 <= cnt then loc - else (fst loc, snd (fun_loc (token_count.val - 1))) - with _ -> (Token.nowhere, Token.succ_pos Token.nowhere) - in - do { - floc.val := fun_loc; - token_count.val := 0; - try - let r = efun ts in - do { restore (); r } - with - [ Stream.Failure -> - let loc = get_loc () in - do { - restore (); - raise_with_loc loc - (Stream.Error ("illegal begin of " ^ entry.ename)) - } - | Stream.Error _ as exc -> - let loc = get_loc () in - do { restore (); raise_with_loc loc exc } - | exc -> - let loc = (Token.nowhere, Token.succ_pos Token.nowhere) in - do { restore (); raise_with_loc loc exc } ] - } -; - -value wrap_parse entry efun cs = - let parsable = (cs, entry.egram.glexer.Token.tok_func cs) in - parse_parsable entry efun parsable -; - -value create_toktab () = Hashtbl.create 301; -value gcreate glexer = {gtokens = create_toktab (); glexer = glexer}; - -value tematch tparse tok = - match tparse tok with - [ Some p -> fun x -> p [: `x :] - | None -> Token.default_match tok ] -; -value glexer_of_lexer lexer = - {Token.tok_func = lexer.Token.func; Token.tok_using = lexer.Token.using; - Token.tok_removing = lexer.Token.removing; - Token.tok_match = tematch lexer.Token.tparse; - Token.tok_text = lexer.Token.text; Token.tok_comm = None} -; -value create lexer = gcreate (glexer_of_lexer lexer); - -(* Extend syntax *) - -value extend_entry entry position rules = - try - let elev = Gramext.levels_of_rules entry position rules in - do { - entry.edesc := Dlevels elev; - entry.estart := - fun lev strm -> - let f = start_parser_of_entry entry in - do { entry.estart := f; f lev strm }; - entry.econtinue := - fun lev bp a strm -> - let f = continue_parser_of_entry entry in - do { entry.econtinue := f; f lev bp a strm } - } - with - [ Token.Error s -> - do { - Printf.eprintf "Lexer initialization error:\n- %s\n" s; - flush stderr; - failwith "Grammar.extend" - } ] -; - -value extend entry_rules_list = - let gram = ref None in - List.iter - (fun (entry, position, rules) -> - do { - match gram.val with - [ Some g -> - if g != entry.egram then do { - Printf.eprintf "Error: entries with different grammars\n"; - flush stderr; - failwith "Grammar.extend" - } - else () - | None -> gram.val := Some entry.egram ]; - extend_entry entry position rules - }) - entry_rules_list -; - -(* Deleting a rule *) - -value delete_rule entry sl = - match entry.edesc with - [ Dlevels levs -> - let levs = Gramext.delete_rule_in_level_list entry sl levs in - do { - entry.edesc := Dlevels levs; - entry.estart := - fun lev strm -> - let f = start_parser_of_entry entry in - do { entry.estart := f; f lev strm }; - entry.econtinue := - fun lev bp a strm -> - let f = continue_parser_of_entry entry in - do { entry.econtinue := f; f lev bp a strm } - } - | Dparser _ -> () ] -; - -(* Unsafe *) - -value clear_entry e = - do { - e.estart := fun _ -> parser []; - e.econtinue := fun _ _ _ -> parser []; - match e.edesc with - [ Dlevels _ -> e.edesc := Dlevels [] - | Dparser _ -> () ] - } -; - -value gram_reinit g glexer = - do { Hashtbl.clear g.gtokens; g.glexer := glexer } -; - -value reinit_gram g lexer = gram_reinit g (glexer_of_lexer lexer); - -module Unsafe = - struct - value gram_reinit = gram_reinit; - value clear_entry = clear_entry; - value reinit_gram = reinit_gram; - end -; - -value find_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 find_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 _ -> None ] - and find_symbol_list = - fun - [ [s :: sl] -> - match find_symbol s with - [ None -> find_symbol_list sl - | x -> x ] - | [] -> None ] - and find_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 ] -; - -value of_entry e = e.egram; - -module Entry = - struct - type te = Token.t; - type e 'a = g_entry te; - value create g n = - {egram = g; ename = n; estart = empty_entry n; - econtinue _ _ _ = parser []; edesc = Dlevels []} - ; - value parse (entry : e 'a) cs : 'a = - Obj.magic (wrap_parse entry (entry.estart 0) cs) - ; - value parse_token (entry : e 'a) ts : 'a = Obj.magic (entry.estart 0 ts); - value name e = e.ename; - value of_parser g n (p : Stream.t te -> 'a) : e 'a = - {egram = g; ename = n; estart _ = Obj.magic p; - econtinue _ _ _ = parser []; edesc = Dparser (Obj.magic p)} - ; - external obj : e 'a -> Gramext.g_entry te = "%identity"; - value print e = printf "%a@." print_entry (obj e); - value find e s = find_entry (obj e) s; - end -; - -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 - } -; - -value glexer g = g.glexer; - -value warning_verbose = Gramext.warning_verbose; - -(* Functorial interface *) - -module type GLexerType = sig type te = 'x; value lexer : Token.glexer te; end; - -module type S = - sig - type te = 'x; - type parsable = 'x; - value parsable : Stream.t char -> parsable; - value tokens : string -> list (string * int); - value glexer : Token.glexer te; - module Entry : - sig - type e 'a = 'x; - value create : string -> e 'a; - value parse : e 'a -> parsable -> 'a; - value parse_token : e 'a -> Stream.t te -> 'a; - value name : e 'a -> string; - value of_parser : string -> (Stream.t te -> 'a) -> e 'a; - value print : e 'a -> unit; - external obj : e 'a -> Gramext.g_entry te = "%identity"; - end - ; - module Unsafe : - sig - value gram_reinit : Token.glexer te -> unit; - value clear_entry : Entry.e 'a -> unit; - value reinit_gram : Token.lexer -> unit; - end - ; - value extend : - Entry.e 'a -> option Gramext.position -> - list - (option string * option Gramext.g_assoc * - list (list (Gramext.g_symbol te) * Gramext.g_action)) -> - unit; - value delete_rule : Entry.e 'a -> list (Gramext.g_symbol te) -> unit; - end -; - -module type ReinitType = sig value reinit_gram : g -> Token.lexer -> unit; end -; - -module GGMake (R : ReinitType) (L : GLexerType) = - struct - type te = L.te; - type parsable = (Stream.t char * (Stream.t te * Token.flocation_function)); - value gram = gcreate L.lexer; - value parsable cs = (cs, L.lexer.Token.tok_func cs); - value tokens = tokens gram; - value glexer = glexer gram; - module Entry = - struct - type e 'a = g_entry te; - value create n = - {egram = gram; ename = n; estart = empty_entry n; - econtinue _ _ _ = parser []; edesc = Dlevels []} - ; - external obj : e 'a -> Gramext.g_entry te = "%identity"; - value parse (e : e 'a) p : 'a = - Obj.magic (parse_parsable e (e.estart 0) p) - ; - value parse_token (e : e 'a) ts : 'a = Obj.magic (e.estart 0 ts); - value name e = e.ename; - value of_parser n (p : Stream.t te -> 'a) : e 'a = - {egram = gram; ename = n; estart _ = Obj.magic p; - econtinue _ _ _ = parser []; edesc = Dparser (Obj.magic p)} - ; - value print e = printf "%a@." print_entry (obj e); - end - ; - module Unsafe = - struct - value gram_reinit = gram_reinit gram; - value clear_entry = Unsafe.clear_entry; - value reinit_gram = R.reinit_gram (Obj.magic gram); - end - ; - value extend = extend_entry; - value delete_rule e r = delete_rule (Entry.obj e) r; - end -; - -module GMake (L : GLexerType) = - GGMake - (struct - value reinit_gram _ _ = - failwith "call of deprecated reinit_gram in grammar built by GMake" - ; - end) - L -; - -module type LexerType = sig value lexer : Token.lexer; end; - -module Make (L : LexerType) = - GGMake (struct value reinit_gram = reinit_gram; end) - (struct type te = Token.t; value lexer = glexer_of_lexer L.lexer; end) -; diff --git a/camlp4/lib/grammar.mli b/camlp4/lib/grammar.mli deleted file mode 100644 index 7e996a76..00000000 --- a/camlp4/lib/grammar.mli +++ /dev/null @@ -1,213 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: grammar.mli,v 1.7 2005/03/24 17:20:53 doligez Exp $ *) - -(** Extensible grammars. - - This module implements the Camlp4 extensible grammars system. - Grammars entries can be extended using the [EXTEND] statement, - added by loading the Camlp4 [pa_extend.cmo] file. *) - -type g = 'x; - (** The type for grammars, holding entries. *) -value gcreate : Token.glexer Token.t -> g; - (** Create a new grammar, without keywords, using the lexer given - as parameter. *) -value tokens : g -> string -> list (string * int); - (** Given a grammar and a token pattern constructor, returns the list of - the corresponding values currently used in all entries of this grammar. - The integer is the number of times this pattern value is used. - - Examples: -- If the associated lexer uses ("", xxx) to represent a keyword - (what is represented by then simple string xxx in an [EXTEND] - statement rule), the call [Grammar.token g ""] returns the keywords - list. -- The call [Grammar.token g "IDENT"] returns the list of all usages - of the pattern "IDENT" in the [EXTEND] statements. *) -value glexer : g -> Token.glexer Token.t; - (** Return the lexer used by the grammar *) - -module Entry : - sig - type e 'a = 'x; - value create : g -> string -> e 'a; - value parse : e 'a -> Stream.t char -> 'a; - value parse_token : e 'a -> Stream.t Token.t -> 'a; - value name : e 'a -> string; - value of_parser : g -> string -> (Stream.t Token.t -> 'a) -> e 'a; - value print : e 'a -> unit; - value find : e 'a -> string -> e Obj.t; - external obj : e 'a -> Gramext.g_entry Token.t = "%identity"; - end -; - (** Module to handle entries. -- [Entry.e] is the type for entries returning values of type ['a]. -- [Entry.create g n] creates a new entry named [n] in the grammar [g]. -- [Entry.parse e] returns the stream parser of the entry [e]. -- [Entry.parse_token e] returns the token parser of the entry [e]. -- [Entry.name e] returns the name of the entry [e]. -- [Entry.of_parser g n p] makes an entry from a token stream parser. -- [Entry.print e] displays the entry [e] using [Format]. -- [Entry.find e s] finds the entry named [s] in [e]'s rules. -- [Entry.obj e] converts an entry into a [Gramext.g_entry] allowing -- to see what it holds ([Gramext] is visible, but not documented). *) - -value of_entry : Entry.e 'a -> g; - (** Return the grammar associated with an entry. *) - -(** {6 Clearing grammars and entries} *) - -module Unsafe : - sig - value gram_reinit : g -> Token.glexer Token.t -> unit; - value clear_entry : Entry.e 'a -> unit; - (**/**) - (* deprecated since version 3.05; use rather function [gram_reinit] *) - value reinit_gram : g -> Token.lexer -> unit; - end -; - (** Module for clearing grammars and entries. To be manipulated with - care, because: 1) reinitializing a grammar destroys all tokens - and there may have problems with the associated lexer if it has - a notion of keywords; 2) clearing an entry does not destroy the - tokens used only by itself. -- [Unsafe.reinit_gram g lex] removes the tokens of the grammar -- and sets [lex] as a new lexer for [g]. Warning: the lexer -- itself is not reinitialized. -- [Unsafe.clear_entry e] removes all rules of the entry [e]. *) - -(** {6 Functorial interface} *) - - (** Alternative for grammars use. Grammars are no more Ocaml values: - there is no type for them. Modules generated preserve the - rule "an entry cannot call an entry of another grammar" by - normal OCaml typing. *) - -module type GLexerType = - sig - type te = 'x; - value lexer : Token.glexer te; - end; - (** The input signature for the functor [Grammar.GMake]: [te] is the - type of the tokens. *) - -module type S = - sig - type te = 'x; - type parsable = 'x; - value parsable : Stream.t char -> parsable; - value tokens : string -> list (string * int); - value glexer : Token.glexer te; - module Entry : - sig - type e 'a = 'y; - value create : string -> e 'a; - value parse : e 'a -> parsable -> 'a; - value parse_token : e 'a -> Stream.t te -> 'a; - value name : e 'a -> string; - value of_parser : string -> (Stream.t te -> 'a) -> e 'a; - value print : e 'a -> unit; - external obj : e 'a -> Gramext.g_entry te = "%identity"; - end - ; - module Unsafe : - sig - value gram_reinit : Token.glexer te -> unit; - value clear_entry : Entry.e 'a -> unit; - (**/**) - (* deprecated since version 3.05; use rather [gram_reinit] *) - (* warning: [reinit_gram] fails if used with GMake *) - value reinit_gram : Token.lexer -> unit; - end - ; - value extend : - Entry.e 'a -> option Gramext.position -> - list - (option string * option Gramext.g_assoc * - list (list (Gramext.g_symbol te) * Gramext.g_action)) -> - unit; - value delete_rule : Entry.e 'a -> list (Gramext.g_symbol te) -> unit; - end -; - (** Signature type of the functor [Grammar.GMake]. The types and - functions are almost the same than in generic interface, but: -- Grammars are not values. Functions holding a grammar as parameter - do not have this parameter yet. -- The type [parsable] is used in function [parse] instead of - the char stream, avoiding the possible loss of tokens. -- The type of tokens (expressions and patterns) can be any - type (instead of (string * string)); the module parameter - must specify a way to show them as (string * string) *) - -module GMake (L : GLexerType) : S with type te = L.te; - -(** {6 Miscellaneous} *) - -value error_verbose : ref bool; - (** Flag for displaying more information in case of parsing error; - default = [False] *) - -value warning_verbose : ref bool; - (** Flag for displaying warnings while extension; default = [True] *) - -value strict_parsing : ref bool; - (** Flag to apply strict parsing, without trying to recover errors; - default = [False] *) - -value strict_parsing_warning : ref bool; - (** Flag for displaying a warning when entering recovery mode; - default = [False] *) - -value print_entry : Format.formatter -> Gramext.g_entry 'te -> unit; - (** General printer for all kinds of entries (obj entries) *) - -value iter_entry : - (Gramext.g_entry 'te -> unit) -> Gramext.g_entry 'te -> unit; - (** [Grammar.iter_entry f e] applies [f] to the entry [e] and - transitively all entries called by [e]. The order in which - the entries are passed to [f] is the order they appear in - each entry. Each entry is passed only once. *) - -value fold_entry : - (Gramext.g_entry 'te -> 'a -> 'a) -> Gramext.g_entry 'te -> 'a -> 'a; - (** [Grammar.fold_entry f e init] computes [(f eN .. (f e2 (f e1 init)))], - where [e1 .. eN] are [e] and transitively all entries called by [e]. - The order in which the entries are passed to [f] is the order they - appear in each entry. Each entry is passed only once. *) - -(**/**) - -(*** deprecated since version 3.05; use rather the functor GMake *) -module type LexerType = sig value lexer : Token.lexer; end; -module Make (L : LexerType) : S with type te = Token.t; -(*** deprecated since version 3.05; use rather the function gcreate *) -value create : Token.lexer -> g; - -(*** For system use *) - -value loc_of_token_interval : int -> int -> Token.flocation; -value extend : - list - (Gramext.g_entry 'te * option Gramext.position * - list - (option string * option Gramext.g_assoc * - list (list (Gramext.g_symbol 'te) * Gramext.g_action))) -> - unit; -value delete_rule : Entry.e 'a -> list (Gramext.g_symbol Token.t) -> unit; - -value parse_top_symb : - Gramext.g_entry 'te -> Gramext.g_symbol 'te -> Stream.t 'te -> Obj.t; -value symb_failed_txt : - Gramext.g_entry 'te -> Gramext.g_symbol 'te -> Gramext.g_symbol 'te -> - string; diff --git a/camlp4/lib/plexer.ml b/camlp4/lib/plexer.ml deleted file mode 100644 index 477f8567..00000000 --- a/camlp4/lib/plexer.ml +++ /dev/null @@ -1,813 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: plexer.ml,v 1.26 2005/10/21 10:55:32 mauny Exp $ *) - -open Stdpp; -open Token; - -value no_quotations = ref False; - -(* The string buffering machinery *) - -value buff = ref (String.create 80); -value store len x = - do { - if len >= String.length buff.val then - buff.val := buff.val ^ String.create (String.length buff.val) - else (); - buff.val.[len] := x; - succ len - } -; -value mstore len s = - add_rec len 0 where rec add_rec len i = - if i == String.length s then len else add_rec (store len s.[i]) (succ i) -; -value get_buff len = String.sub buff.val 0 len; - -(* The lexer *) - -value stream_peek_nth n strm = - loop n (Stream.npeek n strm) where rec loop n = - fun - [ [] -> None - | [x] -> if n == 1 then Some x else None - | [_ :: l] -> loop (n - 1) l ] -; - -value rec ident len = - parser - [ [: `('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255' | '0'..'9' | '_' | ''' as - c) - ; - s :] -> - ident (store len c) s - | [: :] -> len ] -and ident2 len = - parser - [ [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' | '.' | ':' | '<' | '>' | '|' | '$' as - c) - ; - s :] -> - ident2 (store len c) s - | [: :] -> len ] -and ident3 len = - parser - [ [: `('0'..'9' | 'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255' | '_' | '!' | '%' | '&' | '*' | '+' | '-' | '.' | - '/' | ':' | '<' | '=' | '>' | '?' | '@' | '^' | '|' | '~' | ''' | - '$' as - c) - ; - s :] -> - ident3 (store len c) s - | [: :] -> len ] -and base_number len = - parser - [ [: `'o' | 'O'; s :] -> digits octal (store len 'o') s - | [: `'x' | 'X'; s :] -> digits hexa (store len 'x') s - | [: `'b' | 'B'; s :] -> digits binary (store len 'b') s - | [: a = number len :] -> a ] -and digits kind len = - parser - [ [: d = kind; s :] -> digits_under kind (store len d) s - | [: :] -> raise (Stream.Error "ill-formed integer constant") ] -and digits_under kind len = - parser - [ [: d = kind; s :] -> digits_under kind (store len d) s - | [: `'_'; s :] -> digits_under kind len s - | [: `'l' :] -> ("INT32", get_buff len) - | [: `'L' :] -> ("INT64", get_buff len) - | [: `'n' :] -> ("NATIVEINT", get_buff len) - | [: :] -> ("INT", get_buff len) ] -and octal = parser [ [: `('0'..'7' as d) :] -> d ] -and hexa = parser [ [: `('0'..'9' | 'a'..'f' | 'A'..'F' as d) :] -> d ] -and binary = parser [ [: `('0'..'1' as d) :] -> d ] -and number len = - parser - [ [: `('0'..'9' as c); s :] -> number (store len c) s - | [: `'_'; s :] -> number len s - | [: `'.'; s :] -> decimal_part (store len '.') s - | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s - | [: `'l' :] -> ("INT32", get_buff len) - | [: `'L' :] -> ("INT64", get_buff len) - | [: `'n' :] -> ("NATIVEINT", get_buff len) - | [: :] -> ("INT", get_buff len) ] -and decimal_part len = - parser - [ [: `('0'..'9' as c); s :] -> decimal_part (store len c) s - | [: `'_'; s :] -> decimal_part len s - | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s - | [: :] -> ("FLOAT", get_buff len) ] -and exponent_part len = - parser - [ [: `('+' | '-' as c); s :] -> end_exponent_part (store len c) s - | [: a = end_exponent_part len :] -> a ] -and end_exponent_part len = - parser - [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (store len c) s - | [: :] -> raise (Stream.Error "ill-formed floating-point constant") ] -and end_exponent_part_under len = - parser - [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (store len c) s - | [: `'_'; s :] -> end_exponent_part_under len s - | [: :] -> ("FLOAT", get_buff len) ] -; - -value error_on_unknown_keywords = ref False; -value err loc msg = raise_with_loc loc (Token.Error msg); - -(* Debugging positions and locations *) -value eprint_pos msg p = - Printf.eprintf "%s: fname=%s; lnum=%d; bol=%d; cnum=%d%!" - msg p.Lexing.pos_fname p.Lexing.pos_lnum p.Lexing.pos_bol p.Lexing.pos_cnum -; - -value eprint_loc (bp, ep) = - do { eprint_pos "P1=" bp; eprint_pos " --P2=" ep } -; - -value check_location msg ((bp, ep) as loc) = - let ok = - if (bp.Lexing.pos_lnum > ep.Lexing.pos_lnum || - bp.Lexing.pos_bol > ep.Lexing.pos_bol || - bp.Lexing.pos_cnum > ep.Lexing.pos_cnum || - bp.Lexing.pos_lnum < 0 || ep.Lexing.pos_lnum < 0 || - bp.Lexing.pos_bol < 0 || ep.Lexing.pos_bol < 0 || - bp.Lexing.pos_cnum < 0 || ep.Lexing.pos_cnum < 0) - (* Here, we don't check - bp.Lexing.pos_cnum < bp.Lexing.pos_bol || ep.Lexing.pos_cnum < bp.Lexing.pos_bol - since the lexer is called on antiquotations, with cnum=0, but lnum and bolpos - have "correct" values *) - then - do { - Printf.eprintf "*** Warning: (%s) strange positions ***\n" msg; - eprint_loc loc; - False - } - else - True in - (ok, loc) -; - -value debug_token ((kind, tok), loc) = do { - Printf.eprintf "%s(%s) at " kind tok; - eprint_loc loc; - Printf.eprintf "\n%!" -}; - -value next_token_fun dfa ssd find_kwd fname lnum bolpos glexr = - let make_pos p = - {Lexing.pos_fname = fname.val; Lexing.pos_lnum = lnum.val; - Lexing.pos_bol = bolpos.val; Lexing.pos_cnum = p} in - let mkloc (bp, ep) = (make_pos bp, make_pos ep) in - let keyword_or_error (bp,ep) s = - let loc = mkloc (bp, ep) in - try (("", find_kwd s), loc) with - [ Not_found -> - if error_on_unknown_keywords.val then err loc ("illegal token: " ^ s) - else (("", s), loc) ] in - let error_if_keyword ( ((_,id) as a), bep) = - let loc = mkloc bep in - try do { - ignore(find_kwd id); - err loc ("illegal use of a keyword as a label: " ^ id) } - with [ Not_found -> (a, loc) ] - in - let rec next_token after_space = - parser bp - [ [: `'\010'; s :] ep -> - do { bolpos.val := ep; incr lnum; next_token True s } - | [: `'\013'; s :] ep -> - let ep = - match Stream.peek s with - [ Some '\010' -> do { Stream.junk s; ep+1 } - | _ -> ep ] in - do { bolpos.val := ep; incr lnum; next_token True s } - | [: `' ' | '\t' | '\026' | '\012'; s :] -> next_token True s - | [: `'#' when bp = bolpos.val; s :] -> - if linedir 1 s then do { line_directive s; next_token True s } - else keyword_or_error (bp, bp + 1) "#" - | [: `'('; s :] -> left_paren bp s - | [: `('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c); s :] -> - let id = get_buff (ident (store 0 c) s) in - let loc = mkloc (bp, (Stream.count s)) in - (try ("", find_kwd id) with [ Not_found -> ("UIDENT", id) ], loc) - | [: `('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c); s :] -> - let id = get_buff (ident (store 0 c) s) in - let loc = mkloc (bp, (Stream.count s)) in - (try ("", find_kwd id) with [ Not_found -> ("LIDENT", id) ], loc) - | [: `('1'..'9' as c); s :] -> - let tok = number (store 0 c) s in - let loc = mkloc (bp, (Stream.count s)) in - (tok, loc) - | [: `'0'; s :] -> - let tok = base_number (store 0 '0') s in - let loc = mkloc (bp, (Stream.count s)) in - (tok, loc) - | [: `'''; s :] -> - match Stream.npeek 2 s with - [ [_; '''] | ['\\'; _] -> - let tok = ("CHAR", get_buff (char bp 0 s)) in - let loc = mkloc (bp, (Stream.count s)) in - (tok, loc) - | _ -> keyword_or_error (bp, Stream.count s) "'" ] - | [: `'"'; s :] -> - let bpos = make_pos bp in - let tok = ("STRING", get_buff (string bpos 0 s)) in - let loc = mkloc (bp, Stream.count s) in - (tok, loc) - | [: `'$'; s :] -> - let bpos = make_pos bp in - let tok = dollar bpos 0 s in - let loc = (bpos, make_pos (Stream.count s)) in - (tok, loc) - | [: `('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c); - s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id - | [: `('~' as c); - a = - parser - [ [: `('a'..'z' as c); len = ident (store 0 c); s :] ep -> - let id = get_buff len in - match s with parser - [ [: `':' :] ep -> error_if_keyword (("LABEL", id), (bp, ep)) - | [: :] -> error_if_keyword (("TILDEIDENT", id), (bp, ep)) ] - | [: s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id ] :] -> - a - - | [: `('?' as c); - a = - parser - [ [: `('a'..'z' as c); len = ident (store 0 c); s :] ep -> - let id = get_buff len in - match s with parser - [ [: `':' :] ep -> error_if_keyword (("OPTLABEL", id), (bp,ep)) - | [: :] -> error_if_keyword (("QUESTIONIDENT", id), (bp, ep)) ] - | [: s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id ] :] -> - a - | [: `'<'; s :] -> less bp s - | [: `(':' as c1); - len = - parser - [ [: `(']' | ':' | '=' | '>' as c2) :] -> store (store 0 c1) c2 - | [: :] -> store 0 c1 ] :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `('>' | '|' as c1); - len = - parser - [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2 - | [: a = ident2 (store 0 c1) :] -> a ] :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `('[' | '{' as c1); s :] -> - let len = - match Stream.npeek 2 s with - [ ['<'; '<' | ':'] -> store 0 c1 - | _ -> - match s with parser - [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2 - | [: :] -> store 0 c1 ] ] - in - let ep = Stream.count s in - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `'.'; - id = - parser - [ [: `'.' :] -> ".." - | [: :] -> if ssd && after_space then " ." else "." ] :] ep -> - keyword_or_error (bp, ep) id - | [: `';'; - id = - parser - [ [: `';' :] -> ";;" - | [: :] -> ";" ] :] ep -> - keyword_or_error (bp, ep) id - | [: `'\\'; s :] ep -> (("LIDENT", get_buff (ident3 0 s)), mkloc (bp, ep)) - | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c) - | [: _ = Stream.empty :] -> (("EOI", ""), mkloc (bp, succ bp)) ] - and less bp strm = - if no_quotations.val then - match strm with parser - [ [: len = ident2 (store 0 '<') :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id ] - else - let bpos = make_pos bp in - match strm with parser - [ [: `'<'; len = quotation bpos 0 :] ep -> - (("QUOTATION", ":" ^ get_buff len), (bpos, make_pos ep)) - | [: `':'; i = parser [: len = ident 0 :] -> get_buff len; - `'<' ? "character '<' expected"; len = quotation bpos 0 :] ep -> - (("QUOTATION", i ^ ":" ^ get_buff len), (bpos, make_pos ep)) - | [: len = ident2 (store 0 '<') :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id ] - and string bpos len = - parser - [ [: `'"' :] -> len - | [: `'\\'; `c; s :] ep -> - let len = store len '\\' in - match c with [ - '\010' -> do { bolpos.val := ep; incr lnum; string bpos (store len c) s } - | '\013' -> - let (len, ep) = - match Stream.peek s with [ - Some '\010' -> do { Stream.junk s; (store (store len '\013') '\010', ep+1) } - | _ -> (store len '\013', ep) ] in - do { bolpos.val := ep; incr lnum; string bpos len s } - | c -> string bpos (store len c) s - ] - | [: `'\010'; s :] ep -> do { bolpos.val := ep; incr lnum; string bpos (store len '\010') s } - | [: `'\013'; s :] ep -> - let (len, ep) = - match Stream.peek s with - [ Some '\010' -> do { Stream.junk s; (store (store len '\013') '\010', ep+1) } - | _ -> (store len '\013', ep) ] in - do { bolpos.val := ep; incr lnum; string bpos len s } - | [: `c; s :] -> string bpos (store len c) s - | [: :] ep -> err (bpos, make_pos ep) "string not terminated" ] - and char bp len = - parser - [ [: `'''; s :] -> if len = 0 then char bp (store len ''') s else len - | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s - | [: `'\010'; s :] -> do {bolpos.val := bp+1; incr lnum; char bp (store len '\010') s} - | [: `'\013'; s :] -> - let bol = - match Stream.peek s with - [ Some '\010' -> do { Stream.junk s; bp+2 } - | _ -> bp+1 ] in - do { bolpos.val := bol; incr lnum; char bp (store len '\013') s} - | [: `c; s :] -> char bp (store len c) s - | [: :] ep -> err (mkloc (bp, ep)) "char not terminated" ] - and dollar bpos len s = - if no_quotations.val then - ("", get_buff (ident2 (store 0 '$') s)) - else match s with parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bpos (store len c) s - | [: `('0'..'9' as c); s :] -> maybe_locate bpos (store len c) s - | [: `':'; s :] -> - let k = get_buff len in - ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bpos 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bpos (store len c) s) - | [: s :] -> - if dfa then - match s with parser - [ [: `c :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bpos (store len c) s) - | [: :] ep -> err (bpos, make_pos ep) "antiquotation not terminated" ] - else ("", get_buff (ident2 (store 0 '$') s)) ] - and maybe_locate bpos len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('0'..'9' as c); s :] -> maybe_locate bpos (store len c) s - | [: `':'; s :] -> - ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bpos 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bpos (store len c) s) - | [: `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bpos (store len c) s) - | [: :] ep -> err (bpos, make_pos ep) "antiquotation not terminated" ] - and antiquot bpos len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] -> - antiquot bpos (store len c) s - | [: `':'; s :] -> - let k = get_buff len in - ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bpos 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bpos (store len c) s) - | [: `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bpos (store len c) s) - | [: :] ep -> err (bpos, make_pos ep) "antiquotation not terminated" ] - and locate_or_antiquot_rest bpos len = - parser - [ [: `'$' :] -> get_buff len - | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bpos (store len c) s - | [: `c; s :] -> locate_or_antiquot_rest bpos (store len c) s - | [: :] ep -> err (bpos, make_pos ep) "antiquotation not terminated" ] - and quotation bpos len = - parser - [ [: `'>'; s :] -> maybe_end_quotation bpos len s - | [: `'<'; s :] -> - quotation bpos (maybe_nested_quotation bpos (store len '<') s) s - | [: `'\\'; - len = - parser - [ [: `('>' | '<' | '\\' as c) :] -> store len c - | [: :] -> store len '\\' ]; - s :] -> - quotation bpos len s - | [: `'\010'; s :] ep -> do {bolpos.val := ep; incr lnum; quotation bpos (store len '\010') s} - | [: `'\013'; s :] ep -> - let bol = - match Stream.peek s with - [ Some '\010' -> do { Stream.junk s; ep+1 } - | _ -> ep ] in - do { bolpos.val := bol; incr lnum; quotation bpos (store len '\013') s} - | [: `c; s :] -> quotation bpos (store len c) s - | [: :] ep -> err (bpos, make_pos ep) "quotation not terminated" ] - and maybe_nested_quotation bpos len = - parser - [ [: `'<'; s :] -> mstore (quotation bpos (store len '<') s) ">>" - | [: `':'; len = ident (store len ':'); - a = - parser - [ [: `'<'; s :] -> mstore (quotation bpos (store len '<') s) ">>" - | [: :] -> len ] :] -> - a - | [: :] -> len ] - and maybe_end_quotation bpos len = - parser - [ [: `'>' :] -> len - | [: a = quotation bpos (store len '>') :] -> a ] - and left_paren bp = - parser - [ [: `'*'; _ = comment (make_pos bp); a = next_token True :] -> a - | [: :] ep -> keyword_or_error (bp, ep) "(" ] - and comment bpos = - parser - [ [: `'('; s :] -> left_paren_in_comment bpos s - | [: `'*'; s :] -> star_in_comment bpos s - | [: `'"'; _ = string bpos 0; s :] -> comment bpos s - | [: `'''; s :] -> quote_in_comment bpos s - | [: `'\010'; s :] ep -> do { bolpos.val := ep; incr lnum; comment bpos s } - | [: `'\013'; s :] ep -> - let ep = - match Stream.peek s with - [ Some '\010' -> do { Stream.junk s; ep+1 } - | _ -> ep ] in - do { bolpos.val := ep; incr lnum; comment bpos s } - | [: `c; s :] -> comment bpos s - | [: :] ep -> err (bpos, make_pos ep) "comment not terminated" ] - and quote_in_comment bpos = - parser - [ [: `'''; s :] -> comment bpos s - | [: `'\\'; s :] -> quote_antislash_in_comment bpos 0 s - | [: s :] ep -> - do { - match Stream.npeek 2 s with - [ [ ( '\013' | '\010' ); '''] -> - do { bolpos.val := ep; incr lnum; - Stream.junk s; Stream.junk s } - | [ '\013'; '\010' ] -> - match Stream.npeek 3 s with - [ [_; _; '''] -> do { bolpos.val := ep + 1; incr lnum; - Stream.junk s; Stream.junk s; Stream.junk s } - | _ -> () ] - | [_; '''] -> do { Stream.junk s; Stream.junk s } - | _ -> () ]; - comment bpos s - } ] - and quote_any_in_comment bp = - parser - [ [: `'''; s :] -> comment bp s - | [: a = comment bp :] -> a ] - and quote_antislash_in_comment bp len = - parser - [ [: `'''; s :] -> comment bp s - | [: `'\\' | '"' | 'n' | 't' | 'b' | 'r'; s :] -> - quote_any_in_comment bp s - | [: `'0'..'9'; s :] -> quote_antislash_digit_in_comment bp s - | [: a = comment bp :] -> a ] - and quote_antislash_digit_in_comment bp = - parser - [ [: `'0'..'9'; s :] -> quote_antislash_digit2_in_comment bp s - | [: a = comment bp :] -> a ] - and quote_antislash_digit2_in_comment bp = - parser - [ [: `'0'..'9'; s :] -> quote_any_in_comment bp s - | [: a = comment bp :] -> a ] - and left_paren_in_comment bpos = - parser - [ [: `'*'; s :] -> do { comment bpos s; comment bpos s } - | [: a = comment bpos :] -> a ] - and star_in_comment bpos = - parser - [ [: `')' :] -> () - | [: a = comment bpos :] -> a ] - and linedir n s = - match stream_peek_nth n s with - [ Some (' ' | '\t') -> linedir (n + 1) s - | Some ('0'..'9') -> True - | _ -> False ] - and any_to_nl = - parser - [ [: `'\010'; _s :] ep -> - do { bolpos.val := ep; incr lnum } - | [: `'\013'; s :] ep -> - let ep = - match Stream.peek s with - [ Some '\010' -> do { Stream.junk s; ep+1 } - | _ -> ep ] in - do { bolpos.val := ep; incr lnum } - | [: `_; s :] -> any_to_nl s - | [: :] -> () ] - and line_directive = parser (* we are sure that there is a line directive here *) - [ [: _ = skip_spaces; n = line_directive_number 0; - _ = skip_spaces; _ = line_directive_string; - _ = any_to_nl :] ep - -> do { (* fname has been updated by by line_directive_string *) - bolpos.val := ep; lnum.val := n - } - ] - and skip_spaces = parser - [ [: `' ' | '\t'; s :] -> skip_spaces s - | [: :] -> () ] - and line_directive_number n = parser - [ [: `('0'..'9' as c) ; s :] - -> line_directive_number (10*n + (Char.code c - Char.code '0')) s - | [: :] -> n ] - and line_directive_string = parser - [ [: ` '"' ; _ = line_directive_string_contents 0 :] -> () - | [: :] -> () - ] - and line_directive_string_contents len = parser - [ [: ` '\010' | '\013' :] -> () - | [: ` '"' :] -> fname.val := get_buff len - | [: `c; s :] -> line_directive_string_contents (store len c) s - ] - in - fun cstrm -> - try - let glex = glexr.val in - let comm_bp = Stream.count cstrm in - let r = next_token False cstrm in - do { - match glex.tok_comm with - [ Some list -> - let next_bp = (fst (snd r)).Lexing.pos_cnum in - if next_bp > comm_bp then - let comm_loc = mkloc (comm_bp, next_bp) in - glex.tok_comm := Some [comm_loc :: list] - else () - | None -> () ]; - (* debug_token r; *) - r - } - with - [ Stream.Error str -> - err (mkloc (Stream.count cstrm, Stream.count cstrm + 1)) str ] -; - - -value dollar_for_antiquotation = ref True; -value specific_space_dot = ref False; - -value func kwd_table glexr = - let bolpos = ref 0 in - let lnum = ref 1 in - let fname = ref "" in - let find = Hashtbl.find kwd_table in - let dfa = dollar_for_antiquotation.val in - let ssd = specific_space_dot.val in - (Token.lexer_func_of_parser (next_token_fun dfa ssd find fname lnum bolpos glexr), - (bolpos, lnum, fname)) -; - -value rec check_keyword_stream = - parser [: _ = check; _ = Stream.empty :] -> True -and check = - parser - [ [: `'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | '\248'..'\255' - ; - s :] -> - check_ident s - | [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' | '.' - ; - s :] -> - check_ident2 s - | [: `'<'; s :] -> - match Stream.npeek 1 s with - [ [':' | '<'] -> () - | _ -> check_ident2 s ] - | [: `':'; - _ = - parser - [ [: `']' | ':' | '=' | '>' :] -> () - | [: :] -> () ] :] -> - () - | [: `'>' | '|'; - _ = - parser - [ [: `']' | '}' :] -> () - | [: a = check_ident2 :] -> a ] :] -> - () - | [: `'[' | '{'; s :] -> - match Stream.npeek 2 s with - [ ['<'; '<' | ':'] -> () - | _ -> - match s with parser - [ [: `'|' | '<' | ':' :] -> () - | [: :] -> () ] ] - | [: `';'; - _ = - parser - [ [: `';' :] -> () - | [: :] -> () ] :] -> - () - | [: `_ :] -> () ] -and check_ident = - parser - [ [: `'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255' | '0'..'9' | '_' | ''' - ; - s :] -> - check_ident s - | [: :] -> () ] -and check_ident2 = - parser - [ [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' | '.' | ':' | '<' | '>' | '|' - ; - s :] -> - check_ident2 s - | [: :] -> () ] -; - -value check_keyword s = - try check_keyword_stream (Stream.of_string s) with _ -> False -; - -value error_no_respect_rules p_con p_prm = - raise - (Token.Error - ("the token " ^ - (if p_con = "" then "\"" ^ p_prm ^ "\"" - else if p_prm = "" then p_con - else p_con ^ " \"" ^ p_prm ^ "\"") ^ - " does not respect Plexer rules")) -; - -value error_ident_and_keyword p_con p_prm = - raise - (Token.Error - ("the token \"" ^ p_prm ^ "\" is used as " ^ p_con ^ - " and as keyword")) -; - -value using_token kwd_table ident_table (p_con, p_prm) = - match p_con with - [ "" -> - if not (Hashtbl.mem kwd_table p_prm) then - if check_keyword p_prm then - if Hashtbl.mem ident_table p_prm then - error_ident_and_keyword (Hashtbl.find ident_table p_prm) p_prm - else Hashtbl.add kwd_table p_prm p_prm - else error_no_respect_rules p_con p_prm - else () - | "LIDENT" -> - if p_prm = "" then () - else - match p_prm.[0] with - [ 'A'..'Z' -> error_no_respect_rules p_con p_prm - | _ -> - if Hashtbl.mem kwd_table p_prm then - error_ident_and_keyword p_con p_prm - else Hashtbl.add ident_table p_prm p_con ] - | "UIDENT" -> - if p_prm = "" then () - else - match p_prm.[0] with - [ 'a'..'z' -> error_no_respect_rules p_con p_prm - | _ -> - if Hashtbl.mem kwd_table p_prm then - error_ident_and_keyword p_con p_prm - else Hashtbl.add ident_table p_prm p_con ] - | "INT" | "INT32" | "INT64" | "NATIVEINT" - | "FLOAT" | "CHAR" | "STRING" - | "TILDEIDENT" | "QUESTIONIDENT" | "LABEL" | "OPTLABEL" - | "QUOTATION" | "ANTIQUOT" | "LOCATE" | "EOI" -> - () - | _ -> - raise - (Token.Error - ("the constructor \"" ^ p_con ^ - "\" is not recognized by Plexer")) ] -; - -value removing_token kwd_table ident_table (p_con, p_prm) = - match p_con with - [ "" -> Hashtbl.remove kwd_table p_prm - | "LIDENT" | "UIDENT" -> - if p_prm <> "" then Hashtbl.remove ident_table p_prm else () - | _ -> () ] -; - -value text = - fun - [ ("", t) -> "'" ^ t ^ "'" - | ("LIDENT", "") -> "lowercase identifier" - | ("LIDENT", t) -> "'" ^ t ^ "'" - | ("UIDENT", "") -> "uppercase identifier" - | ("UIDENT", t) -> "'" ^ t ^ "'" - | ("INT", "") -> "integer" - | ("INT32", "") -> "32 bits integer" - | ("INT64", "") -> "64 bits integer" - | ("NATIVEINT", "") -> "native integer" - | (("INT" | "INT32" | "NATIVEINT"), s) -> "'" ^ s ^ "'" - | ("FLOAT", "") -> "float" - | ("STRING", "") -> "string" - | ("CHAR", "") -> "char" - | ("QUOTATION", "") -> "quotation" - | ("ANTIQUOT", k) -> "antiquot \"" ^ k ^ "\"" - | ("LOCATE", "") -> "locate" - | ("EOI", "") -> "end of input" - | (con, "") -> con - | (con, prm) -> con ^ " \"" ^ prm ^ "\"" ] -; - -value eq_before_colon p e = - loop 0 where rec loop i = - if i == String.length e then - failwith "Internal error in Plexer: incorrect ANTIQUOT" - else if i == String.length p then e.[i] == ':' - else if p.[i] == e.[i] then loop (i + 1) - else False -; - -value after_colon e = - try - let i = String.index e ':' in - String.sub e (i + 1) (String.length e - i - 1) - with - [ Not_found -> "" ] -; - -value tok_match = - fun - [ ("ANTIQUOT", p_prm) -> - fun - [ ("ANTIQUOT", prm) when eq_before_colon p_prm prm -> after_colon prm - | _ -> raise Stream.Failure ] - | tok -> Token.default_match tok ] -; - -value make_lexer () = - let kwd_table = Hashtbl.create 301 in - let id_table = Hashtbl.create 301 in - let glexr = - ref - {tok_func = fun []; tok_using = fun []; tok_removing = fun []; - tok_match = fun []; tok_text = fun []; tok_comm = None} - in - let (f,pos) = func kwd_table glexr in - let glex = - {tok_func = f; - tok_using = using_token kwd_table id_table; - tok_removing = removing_token kwd_table id_table; tok_match = tok_match; - tok_text = text; tok_comm = None} - in - do { glexr.val := glex; (glex, pos) } -; - -value gmake () = - let (p,_) = make_lexer () in p -; - -value tparse = - fun - [ ("ANTIQUOT", p_prm) -> - let p = - parser - [: `("ANTIQUOT", prm) when eq_before_colon p_prm prm :] -> - after_colon prm - in - Some p - | _ -> None ] -; - -value make () = - let kwd_table = Hashtbl.create 301 in - let id_table = Hashtbl.create 301 in - let glexr = - ref - {tok_func = fun []; tok_using = fun []; tok_removing = fun []; - tok_match = fun []; tok_text = fun []; tok_comm = None} - in - {func = fst(func kwd_table glexr); using = using_token kwd_table id_table; - removing = removing_token kwd_table id_table; tparse = tparse; text = text} -; diff --git a/camlp4/lib/plexer.mli b/camlp4/lib/plexer.mli deleted file mode 100644 index af9b8e83..00000000 --- a/camlp4/lib/plexer.mli +++ /dev/null @@ -1,80 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: plexer.mli,v 1.8 2005/03/24 17:20:53 doligez Exp $ *) - -(** A lexical analyzer. *) - -value gmake : unit -> Token.glexer Token.t; - (** Some lexer provided. See the module [Token]. The tokens returned - follow the Objective Caml and the Revised syntax lexing rules. - - The meaning of the tokens are: -- * [("", 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", s)] (resp. ["INT32"], ["INT64"] and ["NATIVEINT"]) - is an integer constant whose string source is [s]. -- * [("FLOAT", s)] is a float constant whose string source is [s]. -- * [("STRING", s)] is the string constant [s]. -- * [("CHAR", s)] is the character constant [s]. -- * [("QUOTATION", "t:s")] is a quotation [t] holding the string [s]. -- * [("ANTIQUOT", "t:s")] is an antiquotation [t] holding the string [s]. -- * [("LOCATE", "i:s")] is a location directive at pos [i] holding [s]. -- * [("EOI", "")] is the end of input. - - The associated token patterns in the EXTEND statement hold the - same names than the first string (constructor name) of the tokens - expressions above. - - Warning: the 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 function [Token.eval_string]. Same thing for - the constructor [CHAR]: to get the character, don't get the - first character of the string, but use the function - [Token.eval_char]. - - The lexer do not use global (mutable) variables: instantiations - of [Plexer.gmake ()] do not perturb each other. *) - -value make_lexer : - unit -> (Token.glexer Token.t * (ref int * ref int * ref string)); - (** [make_lexer] builds a lexer as [gmake does], but returns also - the triple [(bolpos, lnum, fname)] where -- [bolpos] contains the character number of the beginning of the current line, -- [lnum] contains the current line number and -- [fname] contains the name of the file being parsed. *) - -value dollar_for_antiquotation : ref bool; - (** When True (default), the next call to [Plexer.make ()] returns a - lexer where the dollar sign is used for antiquotations. If False, - the dollar sign can be used as token. *) - -value specific_space_dot : ref bool; - (** When False (default), the next call to [Plexer.make ()] returns a - lexer where the dots can be preceded by spaces. If True, dots - preceded by spaces return the keyword " ." (space dot), otherwise - return the keyword "." (dot). *) - -value no_quotations : ref bool; - (** When True, all lexers built by [Plexer.make ()] do not lex the - quotation syntax any more. Default is False (quotations are - lexed). *) - -(**/**) - -(* deprecated since version 3.05; use rather function gmake *) -value make : unit -> Token.lexer; diff --git a/camlp4/lib/stdpp.ml b/camlp4/lib/stdpp.ml deleted file mode 100644 index 796d2646..00000000 --- a/camlp4/lib/stdpp.ml +++ /dev/null @@ -1,88 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: stdpp.ml,v 1.6 2004/11/17 09:07:56 mauny Exp $ *) - -exception Exc_located of Token.flocation and exn; - -value raise_with_loc loc exc = - match exc with - [ Exc_located _ _ -> raise exc - | _ -> raise (Exc_located loc exc) ] -; - -value line_of_loc fname (bp, ep) = - (bp.Lexing.pos_fname, - bp.Lexing.pos_lnum, - bp.Lexing.pos_cnum - bp.Lexing.pos_bol, - ep.Lexing.pos_cnum - bp.Lexing.pos_bol) -; - -(* -value line_of_loc fname (bp, ep) = - try - let ic = open_in_bin fname in - let strm = Stream.of_channel ic in - let rec loop fname lin = - let rec not_a_line_dir col = - parser cnt - [: `c; s :] -> - if cnt < bp then - if c = '\n' then loop fname (lin + 1) - else not_a_line_dir (col + 1) s - else - let col = col - (cnt - bp) in - (fname, lin, col, col + ep - bp) - in - let rec a_line_dir str n col = - parser - [ [: `'\n' :] -> loop str n - | [: `_; s :] -> a_line_dir str n (col + 1) s ] - in - let rec spaces col = - parser - [ [: `' '; s :] -> spaces (col + 1) s - | [: :] -> col ] - in - let rec check_string str n col = - parser - [ [: `'"'; col = spaces (col + 1); s :] -> a_line_dir str n col s - | [: `c when c <> '\n'; s :] -> - check_string (str ^ String.make 1 c) n (col + 1) s - | [: a = not_a_line_dir col :] -> a ] - in - let check_quote n col = - parser - [ [: `'"'; s :] -> check_string "" n (col + 1) s - | [: a = not_a_line_dir col :] -> a ] - in - let rec check_num n col = - parser - [ [: `('0'..'9' as c); s :] -> - check_num (10 * n + Char.code c - Char.code '0') (col + 1) s - | [: col = spaces col; s :] -> check_quote n col s ] - in - let begin_line = - parser - [ [: `'#'; col = spaces 1; s :] -> check_num 0 col s - | [: a = not_a_line_dir 0 :] -> a ] - in - begin_line strm - in - let r = try loop fname 1 with [ Stream.Failure -> (fname, 1, bp, ep) ] in - do { close_in ic; r } - with - [ Sys_error _ -> (fname, 1, bp, ep) ] -; -*) - -value loc_name = ref "_loc"; diff --git a/camlp4/lib/stdpp.mli b/camlp4/lib/stdpp.mli deleted file mode 100644 index d053a6a6..00000000 --- a/camlp4/lib/stdpp.mli +++ /dev/null @@ -1,37 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: stdpp.mli,v 1.5 2004/05/12 15:22:42 mauny Exp $ *) - -(** Standard definitions. *) - -exception Exc_located of Token.flocation and exn; - (** [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 [raise_with_loc]. *) - -value raise_with_loc : Token.flocation -> exn -> 'a; - (** [raise_with_loc loc e], if [e] is already the exception [Exc_located], - re-raise it, else raise the exception [Exc_located loc e]. *) - -value line_of_loc : string -> Token.flocation -> (string * int * int * int); - (** [line_of_loc fname loc] reads the file [fname] up to the - location [loc] and returns the real input file, the line number - and the characters location in the line; the real input file - can be different from [fname] because of possibility of line - directives typically generated by /lib/cpp. *) - -value loc_name : ref string; - (** Name of the location variable used in grammars and in the predefined - quotations for OCaml syntax trees. Default: [loc] *) diff --git a/camlp4/lib/token.ml b/camlp4/lib/token.ml deleted file mode 100644 index f3c6d2af..00000000 --- a/camlp4/lib/token.ml +++ /dev/null @@ -1,258 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: token.ml,v 1.13 2004/11/06 20:13:41 doligez Exp $ *) - -type t = (string * string); -type pattern = (string * string); - -exception Error of string; - -value make_loc (bp, ep) = - ({ (Lexing.dummy_pos) with Lexing.pos_cnum = bp; Lexing.pos_lnum = 1 }, - { (Lexing.dummy_pos) with Lexing.pos_cnum = ep; Lexing.pos_lnum = 1 }) -; - -value nowhere = { (Lexing.dummy_pos) with Lexing.pos_cnum = 0 }; - -value dummy_loc = (Lexing.dummy_pos, Lexing.dummy_pos); - -value succ_pos p = - { ( p ) with Lexing.pos_cnum = p.Lexing.pos_cnum + 1}; -value lt_pos p1 p2 = p1.Lexing.pos_cnum < p2.Lexing.pos_cnum; - -type flocation = (Lexing.position * Lexing.position); - -type flocation_function = int -> flocation; -type lexer_func 'te = Stream.t char -> (Stream.t 'te * flocation_function); - -type glexer 'te = - { tok_func : lexer_func 'te; - tok_using : pattern -> unit; - tok_removing : pattern -> unit; - tok_match : pattern -> 'te -> string; - tok_text : pattern -> string; - tok_comm : mutable option (list flocation) } -; -type lexer = - { func : lexer_func t; - using : pattern -> unit; - removing : pattern -> unit; - tparse : pattern -> option (Stream.t t -> string); - text : pattern -> string } -; - -value lexer_text (con, prm) = - if con = "" then "'" ^ prm ^ "'" - else if prm = "" then con - else con ^ " '" ^ prm ^ "'" -; - -value locerr () = invalid_arg "Lexer: flocation function"; - -value tsz = 256; (* up to 2^29 entries on a 32-bit machine, 2^61 on 64-bit *) - -value loct_create () = (ref [| |], ref False); - -value loct_func (loct, ov) i = - match - if i < 0 || i/tsz >= Array.length loct.val then None - else if loct.val.(i/tsz) = [| |] then - if ov.val then Some (nowhere, nowhere) else None - else Array.unsafe_get (Array.unsafe_get loct.val (i/tsz)) (i mod tsz) - with - [ Some loc -> loc - | _ -> locerr () ] -; - -value loct_add (loct, ov) i loc = do { - while i/tsz >= Array.length loct.val && (not ov.val) do { - let new_tmax = Array.length loct.val * 2 + 1 in - if new_tmax < Sys.max_array_length then do { - let new_loct = Array.make new_tmax [| |] in - Array.blit loct.val 0 new_loct 0 (Array.length loct.val); - loct.val := new_loct - } else ov.val := True - }; - if not(ov.val) then do { - if loct.val.(i/tsz) = [| |] then - loct.val.(i/tsz) := Array.make tsz None - else (); - loct.val.(i/tsz).(i mod tsz) := Some loc - } else () -}; - -value make_stream_and_flocation next_token_loc = - let loct = loct_create () in - let ts = - Stream.from - (fun i -> - let (tok, loc) = next_token_loc () in - do { loct_add loct i loc; Some tok }) - in - (ts, loct_func loct) -; - -value lexer_func_of_parser next_token_loc cs = - make_stream_and_flocation (fun () -> next_token_loc cs) -; - -value lexer_func_of_ocamllex lexfun cs = - let lb = - Lexing.from_function - (fun s n -> - try do { s.[0] := Stream.next cs; 1 } with [ Stream.Failure -> 0 ]) - in - let next_token_loc _ = - let tok = lexfun lb in - let loc = (Lexing.lexeme_start_p lb, Lexing.lexeme_end_p lb) in - (tok, loc) - in - make_stream_and_flocation next_token_loc -; - -(* Char and string tokens to real chars and string *) - -value buff = ref (String.create 80); -value store len x = - do { - if len >= String.length buff.val then - buff.val := buff.val ^ String.create (String.length buff.val) - else (); - buff.val.[len] := x; - succ len - } -; -value mstore len s = - add_rec len 0 where rec add_rec len i = - if i == String.length s then len else add_rec (store len s.[i]) (succ i) -; -value get_buff len = String.sub buff.val 0 len; - -value valch x = Char.code x - Char.code '0'; -value valch_a x = Char.code x - Char.code 'a' + 10; -value valch_A x = Char.code x - Char.code 'A' + 10; - -value rec backslash s i = - if i = String.length s then raise Not_found - else - match s.[i] with - [ 'n' -> ('\n', i + 1) - | 'r' -> ('\r', i + 1) - | 't' -> ('\t', i + 1) - | 'b' -> ('\b', i + 1) - | '\\' -> ('\\', i + 1) - | '"' -> ('"', i + 1) - | ''' -> (''', i + 1) - | ' ' -> (' ', i + 1) - | '0'..'9' as c -> backslash1 (valch c) s (i + 1) - | 'x' -> backslash1h s (i + 1) - | _ -> raise Not_found ] -and backslash1 cod s i = - if i = String.length s then raise Not_found - else - match s.[i] with - [ '0'..'9' as c -> backslash2 (10 * cod + valch c) s (i + 1) - | _ -> raise Not_found ] -and backslash2 cod s i = - if i = String.length s then raise Not_found - else - match s.[i] with - [ '0'..'9' as c -> (Char.chr (10 * cod + valch c), i + 1) - | _ -> raise Not_found ] -and backslash1h s i = - if i = String.length s then raise Not_found - else - match s.[i] with - [ '0'..'9' as c -> backslash2h (valch c) s (i + 1) - | 'a'..'f' as c -> backslash2h (valch_a c) s (i + 1) - | 'A'..'F' as c -> backslash2h (valch_A c) s (i + 1) - | _ -> raise Not_found ] -and backslash2h cod s i = - if i = String.length s then ('\\', i - 2) - else - match s.[i] with - [ '0'..'9' as c -> (Char.chr (16 * cod + valch c), i + 1) - | 'a'..'f' as c -> (Char.chr (16 * cod + valch_a c), i + 1) - | 'A'..'F' as c -> (Char.chr (16 * cod + valch_A c), i + 1) - | _ -> raise Not_found ] -; - -value rec skip_indent s i = - if i = String.length s then i - else - match s.[i] with - [ ' ' | '\t' -> skip_indent s (i + 1) - | _ -> i ] -; - -value skip_opt_linefeed s i = - if i = String.length s then i else if s.[i] = '\010' then i + 1 else i -; - -value eval_char s = - if String.length s = 1 then s.[0] - else if String.length s = 0 then failwith "invalid char token" - else if s.[0] = '\\' then - if String.length s = 2 && s.[1] = ''' then ''' - else - try - let (c, i) = backslash s 1 in - if i = String.length s then c else raise Not_found - with - [ Not_found -> failwith "invalid char token" ] - else failwith "invalid char token" -; - -value eval_string (bp, ep) s = - loop 0 0 where rec loop len i = - if i = String.length s then get_buff len - else - let (len, i) = - if s.[i] = '\\' then - let i = i + 1 in - if i = String.length s then failwith "invalid string token" else - if s.[i] = '"' then (store len '"', i + 1) else - match s.[i] with - [ '\010' -> (len, skip_indent s (i + 1)) - | '\013' -> (len, skip_indent s (skip_opt_linefeed s (i + 1))) - | c -> - try - let (c, i) = backslash s i in - (store len c, i) - with - [ Not_found -> do { - let txt = "Invalid backslash escape in string" in - let pos = bp.Lexing.pos_cnum - bp.Lexing.pos_bol + i in - if bp.Lexing.pos_fname = "" then - Printf.eprintf "Warning: line %d, chars %d-%d: %s\n" - bp.Lexing.pos_lnum pos (pos + 1) txt - else - Printf.eprintf "Warning: File \"%s\", line %d, chars %d-%d: %s\n" - bp.Lexing.pos_fname bp.Lexing.pos_lnum pos (pos + 1) txt; - (store (store len '\\') c, i + 1) } ] ] - else (store len s.[i], i + 1) - in - loop len i -; - -value default_match = - fun - [ ("ANY", "") -> fun (con, prm) -> prm - | ("ANY", v) -> - fun (con, prm) -> if v = prm then v else raise Stream.Failure - | (p_con, "") -> - fun (con, prm) -> if con = p_con then prm else raise Stream.Failure - | (p_con, p_prm) -> - fun (con, prm) -> - if con = p_con && prm = p_prm then prm else raise Stream.Failure ] -; diff --git a/camlp4/lib/token.mli b/camlp4/lib/token.mli deleted file mode 100644 index 9244a86c..00000000 --- a/camlp4/lib/token.mli +++ /dev/null @@ -1,141 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: token.mli,v 1.6 2004/05/12 15:22:42 mauny Exp $ *) - -(** Lexers for Camlp4 grammars. - - This module defines the Camlp4 lexer type to be used in extensible - grammars (see module [Grammar]). It also provides some useful functions - to create lexers (this module should be renamed [Glexer] one day). *) - -type pattern = (string * string); - (** Token patterns come from the EXTEND statement. -- The first string is the constructor name (must start with - an uppercase character). When it is empty, the second string - is supposed to be a keyword. -- The second string is the constructor parameter. Empty if it - has no parameter. -- The way tokens patterns are interpreted to parse tokens is - done by the lexer, function [tok_match] below. *) - -exception Error of string; - (** An lexing error exception to be used by lexers. *) - -(** {6 Lexer type} *) - -type flocation = (Lexing.position * Lexing.position); - -value nowhere : Lexing.position; -value dummy_loc : flocation; - -value make_loc : (int * int) -> flocation; -value succ_pos : Lexing.position -> Lexing.position; -value lt_pos : Lexing.position -> Lexing.position -> bool; - -type flocation_function = int -> flocation; - (** The type for a function associating a number of a token in a stream - (starting from 0) to its source location. *) -type lexer_func 'te = Stream.t char -> (Stream.t 'te * flocation_function); - (** The type for a lexer function. The character stream is the input - stream to be lexed. The result is a pair of a token stream and - a location function for this tokens stream. *) - -type glexer 'te = - { tok_func : lexer_func 'te; - tok_using : pattern -> unit; - tok_removing : pattern -> unit; - tok_match : pattern -> 'te -> string; - tok_text : pattern -> string; - tok_comm : mutable option (list flocation) } -; - (** The type for a lexer used by Camlp4 grammars. -- The field [tok_func] is the main lexer function. See [lexer_func] - type above. This function may be created from a [char stream parser] - or for an [ocamllex] function using the functions below. -- The field [tok_using] is a function telling the lexer that the grammar - uses this token (pattern). The lexer can check that its constructor - is correct, and interpret some kind of tokens as keywords (to record - them in its tables). Called by [EXTEND] statements. -- The field [tok_removing] is a function telling the lexer that the - grammar does not uses the given token (pattern) any more. If the - lexer has a notion of "keywords", it can release it from its tables. - Called by [DELETE_RULE] statements. -- The field [tok_match] is a function taking a pattern and returning - a function matching a token against the pattern. Warning: for - efficency, write it as a function returning functions according - to the values of the pattern, not a function with two parameters. -- The field [tok_text] returns the name of some token pattern, - used in error messages. -- The field [tok_comm] if not None asks the lexer to record the - locations of the comments. *) - -value lexer_text : pattern -> string; - (** A simple [tok_text] function for lexers *) - -value default_match : pattern -> (string * string) -> string; - (** A simple [tok_match] function for lexers, appling to token type - [(string * string)] *) - -(** {6 Lexers from char stream parsers or ocamllex function} - - The functions below create lexer functions either from a [char stream] - parser or for an [ocamllex] function. With the returned function [f], - the simplest [Token.lexer] can be written: - {[ - { Token.tok_func = f; - Token.tok_using = (fun _ -> ()); - Token.tok_removing = (fun _ -> ()); - Token.tok_match = Token.default_match; - Token.tok_text = Token.lexer_text } - ]} - Note that a better [tok_using] function should check the used tokens - and raise [Token.Error] for incorrect ones. The other functions - [tok_removing], [tok_match] and [tok_text] may have other implementations - as well. *) - -value lexer_func_of_parser : - (Stream.t char -> ('te * flocation)) -> lexer_func 'te; - (** A lexer function from a lexer written as a char stream parser - returning the next token and its location. *) -value lexer_func_of_ocamllex : (Lexing.lexbuf -> 'te) -> lexer_func 'te; - (** A lexer function from a lexer created by [ocamllex] *) - -value make_stream_and_flocation : - (unit -> ('te * flocation)) -> (Stream.t 'te * flocation_function); - (** General function *) - -(** {6 Useful functions} *) - -value eval_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 eval_string : flocation -> string -> string; - (** Convert a string token, where the escape sequences (backslashes) - remain to be interpreted; issue a warning if an incorrect - backslash sequence is found; - [Token.eval_string loc (String.escaped s)] returns [s] *) - -(**/**) - -(* deprecated since version 3.05; use rather type glexer *) -type t = (string * string); -type lexer = - { func : lexer_func t; - using : pattern -> unit; - removing : pattern -> unit; - tparse : pattern -> option (Stream.t t -> string); - text : pattern -> string } -; diff --git a/camlp4/man/Makefile b/camlp4/man/Makefile index 7a49883a..b2df6374 100644 --- a/camlp4/man/Makefile +++ b/camlp4/man/Makefile @@ -1,20 +1,13 @@ -# $Id: Makefile,v 1.6 2003/07/03 16:14:49 xleroy Exp $ +# $Id: Makefile,v 1.7 2006/06/29 08:12:44 pouillar Exp $ -include ../config/Makefile +include ../config/Makefile.cnf TARGET=camlp4.1 ALIASES=camlp4o.1 camlp4r.1 mkcamlp4.1 ocpp.1 camlp4o.opt.1 camlp4r.opt.1 -all: $(TARGET) +include ../config/Makefile.base -clean:: - rm -f $(TARGET) - -depend: - -get_promote: - -install: +install-local: if test -n '$(MANDIR)'; then \ $(MKDIR) $(MANDIR)/man1 ; \ cp $(TARGET) $(MANDIR)/man1/. ; \ diff --git a/camlp4/meta/.cvsignore b/camlp4/meta/.cvsignore deleted file mode 100644 index 460c5a60..00000000 --- a/camlp4/meta/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -*.cm[oia] -camlp4r -camlp4r.opt diff --git a/camlp4/meta/.depend b/camlp4/meta/.depend deleted file mode 100644 index 83b86c27..00000000 --- a/camlp4/meta/.depend +++ /dev/null @@ -1,16 +0,0 @@ -pa_extend.cmo: ../camlp4/reloc.cmi ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pa_extend.cmx: ../camlp4/reloc.cmx ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -pa_extend_m.cmo: pa_extend.cmo -pa_extend_m.cmx: pa_extend.cmx -pa_macro.cmo: ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pa_macro.cmx: ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -pa_r.cmo: ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pa_r.cmx: ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -pa_rp.cmo: ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pa_rp.cmx: ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -pr_dump.cmo: ../camlp4/pcaml.cmi $(OTOP)/utils/config.cmi ../camlp4/ast2pt.cmi -pr_dump.cmx: ../camlp4/pcaml.cmx $(OTOP)/utils/config.cmx ../camlp4/ast2pt.cmx -q_MLast.cmo: ../camlp4/reloc.cmi ../camlp4/quotation.cmi ../camlp4/pcaml.cmi \ - ../camlp4/mLast.cmi -q_MLast.cmx: ../camlp4/reloc.cmx ../camlp4/quotation.cmx ../camlp4/pcaml.cmx \ - ../camlp4/mLast.cmi diff --git a/camlp4/meta/Makefile b/camlp4/meta/Makefile deleted file mode 100644 index 3a88058d..00000000 --- a/camlp4/meta/Makefile +++ /dev/null @@ -1,58 +0,0 @@ -# $Id: Makefile,v 1.18 2004/11/30 18:57:03 doligez Exp $ - -include ../config/Makefile - -INCLUDES=-I ../camlp4 -I ../boot -I $(OTOP)/utils -OCAMLCFLAGS=-warn-error A $(INCLUDES) -OBJS=q_MLast.cmo pa_r.cmo pa_rp.cmo pa_extend.cmo pa_extend_m.cmo pa_macro.cmo pr_dump.cmo -OBJSX=$(OBJS:.cmo=.cmx) -CAMLP4RM=pa_r.cmo pa_rp.cmo pr_dump.cmo -CAMLP4RMX=$(CAMLP4RM:.cmo=.cmx) -SHELL=/bin/sh -COUT=$(OBJS) camlp4r$(EXE) -COPT=$(OBJSX) camlp4r.opt - -all: $(COUT) -opt: $(COPT) - -camlp4r$(EXE): ../camlp4/camlp4$(EXE) $(CAMLP4RM) - rm -f camlp4r$(EXE) - cd ../camlp4; $(MAKE) OTOP=$(OTOP) CAMLP4=../meta/camlp4r$(EXE) CAMLP4M="-I ../meta $(CAMLP4RM)" - -camlp4r.opt: $(CAMLP4RMX) - rm -f camlp4r.opt - cd ../camlp4; $(MAKE) optp4 OTOP=$(OTOP) CAMLP4OPT=../meta/camlp4r.opt CAMLP4M="-I ../meta $(CAMLP4RMX)" - -clean:: - rm -f *.cm* *.pp[io] *.o *.bak .*.bak $(COUT) $(COPT) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -promote: - cp $(COUT) pa_extend.cmi ../boot/. - -compare: - @for j in $(COUT); do \ - if cmp $$j ../boot/$$j; then :; else exit 1; fi; \ - done - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" - cp $(OBJS) "$(LIBDIR)/camlp4/." - cp pa_macro.cmi pa_extend.cmi "$(LIBDIR)/camlp4/." - cp camlp4r$(EXE) "$(BINDIR)/." - if test -f camlp4r.opt; then \ - cp camlp4r.opt "$(BINDIR)/camlp4r.opt$(EXE)" ;\ - cp $(OBJSX) "$(LIBDIR)/camlp4/."; \ - for file in $(OBJSX); do \ - cp "`echo $$file | sed -e 's/\.cmx$$/.$(O)/'`" "$(LIBDIR)/camlp4/."; \ - done ; \ - fi - -include .depend diff --git a/camlp4/meta/pa_extend.ml b/camlp4/meta/pa_extend.ml deleted file mode 100644 index 7147f2b6..00000000 --- a/camlp4/meta/pa_extend.ml +++ /dev/null @@ -1,927 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: pa_extend.ml,v 1.34 2004/11/17 09:07:56 mauny Exp $ *) - -open Stdpp; - -value split_ext = ref False; - -Pcaml.add_option "-split_ext" (Arg.Set split_ext) - "Split EXTEND by functions to turn around a PowerPC problem."; - -Pcaml.add_option "-split_gext" (Arg.Set split_ext) - "Old name for the option -split_ext."; - -type loc = (Lexing.position * Lexing.position); - -type name 'e = { expr : 'e; tvar : string; loc : loc }; - -type styp = - [ STlid of loc and string - | STapp of loc and styp and styp - | STquo of loc and string - | STself of loc and string - | STtyp of MLast.ctyp ] -; - -type text 'e = - [ TXmeta of loc and string and list (text 'e) and 'e and styp - | TXlist of loc and bool and text 'e and option (text 'e) - | TXnext of loc - | TXnterm of loc and name 'e and option string - | TXopt of loc and text 'e - | TXrules of loc and list (list (text 'e) * 'e) - | TXself of loc - | TXtok of loc and string and 'e ] -; - -type entry 'e 'p = - { name : name 'e; pos : option 'e; levels : list (level 'e 'p) } -and level 'e 'p = - { label : option string; assoc : option 'e; rules : list (rule 'e 'p) } -and rule 'e 'p = { prod : list (psymbol 'e 'p); action : option 'e } -and psymbol 'e 'p = { pattern : option 'p; symbol : symbol 'e 'p } -and symbol 'e 'p = { used : list string; text : text 'e; styp : styp } -; - -type used = [ Unused | UsedScanned | UsedNotScanned ]; - -value mark_used modif ht n = - try - let rll = Hashtbl.find_all ht n in - List.iter - (fun (r, _) -> - if r.val == Unused then do { - r.val := UsedNotScanned; modif.val := True; - } - else ()) - rll - with - [ Not_found -> () ] -; - -value rec mark_symbol modif ht symb = - List.iter (fun e -> mark_used modif ht e) symb.used -; - -value check_use nl el = - let ht = Hashtbl.create 301 in - let modif = ref False in - do { - List.iter - (fun e -> - let u = - match e.name.expr with - [ <:expr< $lid:_$ >> -> Unused - | _ -> UsedNotScanned ] - in - Hashtbl.add ht e.name.tvar (ref u, e)) - el; - List.iter - (fun n -> - try - let rll = Hashtbl.find_all ht n.tvar in - List.iter (fun (r, _) -> r.val := UsedNotScanned) rll - with _ -> - ()) - nl; - modif.val := True; - while modif.val do { - modif.val := False; - Hashtbl.iter - (fun s (r, e) -> - if r.val = UsedNotScanned then do { - r.val := UsedScanned; - List.iter - (fun level -> - let rules = level.rules in - List.iter - (fun rule -> - List.iter (fun ps -> mark_symbol modif ht ps.symbol) - rule.prod) - rules) - e.levels - } - else ()) - ht - }; - Hashtbl.iter - (fun s (r, e) -> - if r.val = Unused then - Pcaml.warning.val e.name.loc ("Unused local entry \"" ^ s ^ "\"") - else ()) - ht; - } -; - -value locate n = let _loc = n.loc in <:expr< $n.expr$ >>; - -value new_type_var = - let i = ref 0 in fun () -> do { incr i; "e__" ^ string_of_int i.val } -; - -value used_of_rule_list rl = - List.fold_left - (fun nl r -> List.fold_left (fun nl s -> s.symbol.used @ nl) nl r.prod) [] - rl -; - -value retype_rule_list_without_patterns _loc rl = - try - List.map - (fun - [ {prod = [{pattern = None; symbol = s}]; action = None} -> - {prod = [{pattern = Some <:patt< x >>; symbol = s}]; - action = Some <:expr< x >>} - | {prod = []; action = Some _} as r -> r - | _ -> raise Exit ]) - rl - with - [ Exit -> rl ] -; - -value quotify = ref False; -value meta_action = ref False; - -module MetaAction = - struct - value not_impl f x = - let desc = - if Obj.is_block (Obj.repr x) then - "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) - else "int_val = " ^ string_of_int (Obj.magic x) - in - failwith (f ^ ", not impl: " ^ desc) - ; - value _loc = - let nowhere = - { (Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0 } in - (nowhere, nowhere); - value rec mlist mf = - fun - [ [] -> <:expr< [] >> - | [x :: l] -> <:expr< [ $mf x$ :: $mlist mf l$ ] >> ] - ; - value moption mf = - fun - [ None -> <:expr< None >> - | Some x -> <:expr< Some $mf x$ >> ] - ; - value mbool = - fun - [ False -> <:expr< False >> - | True -> <:expr< True >> ] - ; - value mloc = - <:expr< let nowhere = - { (Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0 } in - (nowhere, nowhere) >>; - value rec mexpr = - fun - [ MLast.ExAcc _loc e1 e2 -> - <:expr< MLast.ExAcc $mloc$ $mexpr e1$ $mexpr e2$ >> - | MLast.ExApp _loc e1 e2 -> - <:expr< MLast.ExApp $mloc$ $mexpr e1$ $mexpr e2$ >> - | MLast.ExChr _loc s -> <:expr< MLast.ExChr $mloc$ $str:s$ >> - | MLast.ExFun _loc pwel -> <:expr< MLast.ExFun $mloc$ $mlist mpwe pwel$ >> - | MLast.ExIfe _loc e1 e2 e3 -> - <:expr< MLast.ExIfe $mloc$ $mexpr e1$ $mexpr e2$ $mexpr e3$ >> - | MLast.ExInt _loc s -> <:expr< MLast.ExInt $mloc$ $str:s$ >> - | MLast.ExFlo _loc s -> <:expr< MLast.ExFlo $mloc$ $str:s$ >> - | MLast.ExLet _loc rf pel e -> - <:expr< MLast.ExLet $mloc$ $mbool rf$ $mlist mpe pel$ $mexpr e$ >> - | MLast.ExLid _loc s -> <:expr< MLast.ExLid $mloc$ $str:s$ >> - | MLast.ExMat _loc e pwel -> - <:expr< MLast.ExMat $mloc$ $mexpr e$ $mlist mpwe pwel$ >> - | MLast.ExRec _loc pel eo -> - <:expr< MLast.ExRec $mloc$ $mlist mpe pel$ $moption mexpr eo$ >> - | MLast.ExSeq _loc el -> <:expr< MLast.ExSeq $mloc$ $mlist mexpr el$ >> - | MLast.ExSte _loc e1 e2 -> - <:expr< MLast.ExSte $mloc$ $mexpr e1$ $mexpr e2$ >> - | MLast.ExStr _loc s -> - <:expr< MLast.ExStr $mloc$ $str:String.escaped s$ >> - | MLast.ExTry _loc e pwel -> - <:expr< MLast.ExTry $mloc$ $mexpr e$ $mlist mpwe pwel$ >> - | MLast.ExTup _loc el -> <:expr< MLast.ExTup $mloc$ $mlist mexpr el$ >> - | MLast.ExTyc _loc e t -> - <:expr< MLast.ExTyc $mloc$ $mexpr e$ $mctyp t$ >> - | MLast.ExUid _loc s -> <:expr< MLast.ExUid $mloc$ $str:s$ >> - | x -> not_impl "mexpr" x ] - and mpatt = - fun - [ MLast.PaAcc _loc p1 p2 -> - <:expr< MLast.PaAcc $mloc$ $mpatt p1$ $mpatt p2$ >> - | MLast.PaAny _loc -> <:expr< MLast.PaAny $mloc$ >> - | MLast.PaApp _loc p1 p2 -> - <:expr< MLast.PaApp $mloc$ $mpatt p1$ $mpatt p2$ >> - | MLast.PaInt _loc s -> <:expr< MLast.PaInt $mloc$ $str:s$ >> - | MLast.PaLid _loc s -> <:expr< MLast.PaLid $mloc$ $str:s$ >> - | MLast.PaOrp _loc p1 p2 -> - <:expr< MLast.PaOrp $mloc$ $mpatt p1$ $mpatt p2$ >> - | MLast.PaStr _loc s -> - <:expr< MLast.PaStr $mloc$ $str:String.escaped s$ >> - | MLast.PaTup _loc pl -> <:expr< MLast.PaTup $mloc$ $mlist mpatt pl$ >> - | MLast.PaTyc _loc p t -> - <:expr< MLast.PaTyc $mloc$ $mpatt p$ $mctyp t$ >> - | MLast.PaUid _loc s -> <:expr< MLast.PaUid $mloc$ $str:s$ >> - | x -> not_impl "mpatt" x ] - and mctyp = - fun - [ MLast.TyAcc _loc t1 t2 -> - <:expr< MLast.TyAcc $mloc$ $mctyp t1$ $mctyp t2$ >> - | MLast.TyApp loc t1 t2 -> - <:expr< MLast.TyApp $mloc$ $mctyp t1$ $mctyp t2$ >> - | MLast.TyLid _loc s -> <:expr< MLast.TyLid $mloc$ $str:s$ >> - | MLast.TyQuo _loc s -> <:expr< MLast.TyQuo $mloc$ $str:s$ >> - | MLast.TyTup _loc tl -> <:expr< MLast.TyTup $mloc$ $mlist mctyp tl$ >> - | MLast.TyUid _loc s -> <:expr< MLast.TyUid $mloc$ $str:s$ >> - | x -> not_impl "mctyp" x ] - and mpe (p, e) = <:expr< ($mpatt p$, $mexpr e$) >> - and mpwe (p, w, e) = <:expr< ($mpatt p$, $moption mexpr w$, $mexpr e$) >> - ; - end -; - -value mklistexp _loc = - loop True where rec loop top = - fun - [ [] -> <:expr< [] >> - | [e1 :: el] -> - let _loc = - if top then _loc else (fst (MLast.loc_of_expr e1), snd _loc) - in - <:expr< [$e1$ :: $loop False el$] >> ] -; - -value mklistpat _loc = - loop True where rec loop top = - fun - [ [] -> <:patt< [] >> - | [p1 :: pl] -> - let _loc = - if top then _loc else (fst (MLast.loc_of_patt p1), snd _loc) - in - <:patt< [$p1$ :: $loop False pl$] >> ] -; - -value rec expr_fa al = - fun - [ <:expr< $f$ $a$ >> -> expr_fa [a :: al] f - | f -> (f, al) ] -; - -value rec quot_expr e = - let _loc = MLast.loc_of_expr e in - match e with - [ <:expr< None >> -> <:expr< Qast.Option None >> - | <:expr< Some $e$ >> -> <:expr< Qast.Option (Some $quot_expr e$) >> - | <:expr< False >> -> <:expr< Qast.Bool False >> - | <:expr< True >> -> <:expr< Qast.Bool True >> - | <:expr< () >> -> e - | <:expr< Qast.List $_$ >> -> e - | <:expr< Qast.Option $_$ >> -> e - | <:expr< Qast.Str $_$ >> -> e - | <:expr< [] >> -> <:expr< Qast.List [] >> - | <:expr< [$e$] >> -> <:expr< Qast.List [$quot_expr e$] >> - | <:expr< [$e1$ :: $e2$] >> -> - <:expr< Qast.Cons $quot_expr e1$ $quot_expr e2$ >> - | <:expr< $_$ $_$ >> -> - let (f, al) = expr_fa [] e in - match f with - [ <:expr< $uid:c$ >> -> - let al = List.map quot_expr al in - <:expr< Qast.Node $str:c$ $mklistexp _loc al$ >> - | <:expr< MLast.$uid:c$ >> -> - let al = List.map quot_expr al in - <:expr< Qast.Node $str:c$ $mklistexp _loc al$ >> - | <:expr< $uid:m$.$uid:c$ >> -> - let al = List.map quot_expr al in - <:expr< Qast.Node $str:m ^ "." ^ c$ $mklistexp _loc al$ >> - | <:expr< $lid:f$ >> -> - let al = List.map quot_expr al in - List.fold_left (fun f e -> <:expr< $f$ $e$ >>) - <:expr< $lid:f$ >> al - | _ -> e ] - | <:expr< {$list:pel$} >> -> - try - let lel = - List.map - (fun (p, e) -> - let lab = - match p with - [ <:patt< $lid:c$ >> -> <:expr< $str:c$ >> - | <:patt< $_$.$lid:c$ >> -> <:expr< $str:c$ >> - | _ -> raise Not_found ] - in - <:expr< ($lab$, $quot_expr e$) >>) - pel - in - <:expr< Qast.Record $mklistexp _loc lel$>> - with - [ Not_found -> e ] - | <:expr< $lid:s$ >> -> - if s = Stdpp.loc_name.val then <:expr< Qast.Loc >> else e - | <:expr< MLast.$uid:s$ >> -> <:expr< Qast.Node $str:s$ [] >> - | <:expr< $uid:m$.$uid:s$ >> -> <:expr< Qast.Node $str:m ^ "." ^ s$ [] >> - | <:expr< $uid:s$ >> -> <:expr< Qast.Node $str:s$ [] >> - | <:expr< $str:s$ >> -> <:expr< Qast.Str $str:s$ >> - | <:expr< ($list:el$) >> -> - let el = List.map quot_expr el in - <:expr< Qast.Tuple $mklistexp _loc el$ >> - | <:expr< let $opt:r$ $list:pel$ in $e$ >> -> - let pel = List.map (fun (p, e) -> (p, quot_expr e)) pel in - <:expr< let $opt:r$ $list:pel$ in $quot_expr e$ >> - | _ -> e ] -; - -value symgen = "xx"; - -value pname_of_ptuple pl = - List.fold_left - (fun pname p -> - match p with - [ <:patt< $lid:s$ >> -> pname ^ s - | _ -> pname ]) - "" pl -; - -value quotify_action psl act = - let e = quot_expr act in - List.fold_left - (fun e ps -> - match ps.pattern with - [ Some <:patt< ($list:pl$) >> -> - let _loc = - let nowhere = - { (Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0 } in - (nowhere, nowhere) in - let pname = pname_of_ptuple pl in - let (pl1, el1) = - let (l, _) = - List.fold_left - (fun (l, cnt) _ -> - ([symgen ^ string_of_int cnt :: l], cnt + 1)) - ([], 1) pl - in - let l = List.rev l in - (List.map (fun s -> <:patt< $lid:s$ >>) l, - List.map (fun s -> <:expr< $lid:s$ >>) l) - in - <:expr< - let ($list:pl$) = - match $lid:pname$ with - [ Qast.Tuple $mklistpat _loc pl1$ -> ($list:el1$) - | _ -> match () with [] ] - in $e$ >> - | _ -> e ]) - e psl -; - -value rec make_ctyp styp tvar = - match styp with - [ STlid _loc s -> <:ctyp< $lid:s$ >> - | STapp _loc t1 t2 -> <:ctyp< $make_ctyp t1 tvar$ $make_ctyp t2 tvar$ >> - | STquo _loc s -> <:ctyp< '$s$ >> - | STself _loc x -> - if tvar = "" then - Stdpp.raise_with_loc _loc - (Stream.Error ("'" ^ x ^ "' illegal in anonymous entry level")) - else <:ctyp< '$tvar$ >> - | STtyp t -> t ] -; - -value rec make_expr gmod tvar = - fun - [ TXmeta _loc n tl e t -> - let el = - List.fold_right - (fun t el -> <:expr< [$make_expr gmod "" t$ :: $el$] >>) - tl <:expr< [] >> - in - <:expr< - Gramext.Smeta $str:n$ $el$ (Obj.repr ($e$ : $make_ctyp t tvar$)) >> - | TXlist _loc min t ts -> - let txt = make_expr gmod "" t in - match (min, ts) with - [ (False, None) -> <:expr< Gramext.Slist0 $txt$ >> - | (True, None) -> <:expr< Gramext.Slist1 $txt$ >> - | (False, Some s) -> - let x = make_expr gmod tvar s in - <:expr< Gramext.Slist0sep $txt$ $x$ >> - | (True, Some s) -> - let x = make_expr gmod tvar s in - <:expr< Gramext.Slist1sep $txt$ $x$ >> ] - | TXnext _loc -> <:expr< Gramext.Snext >> - | TXnterm _loc n lev -> - match lev with - [ Some lab -> - <:expr< - Gramext.Snterml - ($uid:gmod$.Entry.obj ($n.expr$ : $uid:gmod$.Entry.e '$n.tvar$)) - $str:lab$ >> - | None -> - if n.tvar = tvar then <:expr< Gramext.Sself >> - else - <:expr< - Gramext.Snterm - ($uid:gmod$.Entry.obj - ($n.expr$ : $uid:gmod$.Entry.e '$n.tvar$)) >> ] - | TXopt _loc t -> <:expr< Gramext.Sopt $make_expr gmod "" t$ >> - | TXrules _loc rl -> - <:expr< Gramext.srules $make_expr_rules _loc gmod rl ""$ >> - | TXself _loc -> <:expr< Gramext.Sself >> - | TXtok _loc s e -> <:expr< Gramext.Stoken ($str:s$, $e$) >> ] -and make_expr_rules _loc gmod rl tvar = - List.fold_left - (fun txt (sl, ac) -> - let sl = - List.fold_right - (fun t txt -> - let x = make_expr gmod tvar t in - <:expr< [$x$ :: $txt$] >>) - sl <:expr< [] >> - in - <:expr< [($sl$, $ac$) :: $txt$] >>) - <:expr< [] >> rl -; - -value text_of_action _loc psl rtvar act tvar = - let locid = <:patt< $lid:Stdpp.loc_name.val$ >> in - let act = - match act with - [ Some act -> if quotify.val then quotify_action psl act else act - | None -> <:expr< () >> ] - in - let e = <:expr< fun [ ($locid$ : (Lexing.position * Lexing.position)) -> ($act$ : '$rtvar$) ] >> in - let txt = - List.fold_left - (fun txt ps -> - match ps.pattern with - [ None -> <:expr< fun _ -> $txt$ >> - | Some p -> - let t = make_ctyp ps.symbol.styp tvar in - let p = - match p with - [ <:patt< ($list:pl$) >> when quotify.val -> - <:patt< $lid:pname_of_ptuple pl$ >> - | _ -> p ] - in - <:expr< fun ($p$ : $t$) -> $txt$ >> ]) - e psl - in - let txt = - if meta_action.val then - <:expr< Obj.magic $MetaAction.mexpr txt$ >> - else txt - in - <:expr< Gramext.action $txt$ >> -; - -value srules loc t rl tvar = - List.map - (fun r -> - let sl = List.map (fun ps -> ps.symbol.text) r.prod in - let ac = text_of_action loc r.prod t r.action tvar in - (sl, ac)) - rl -; - -value expr_of_delete_rule _loc gmod n sl = - let sl = - List.fold_right - (fun s e -> <:expr< [$make_expr gmod "" s.text$ :: $e$] >>) sl - <:expr< [] >> - in - (<:expr< $n.expr$ >>, sl) -; - -value rec ident_of_expr = - fun - [ <:expr< $lid:s$ >> -> s - | <:expr< $uid:s$ >> -> s - | <:expr< $e1$ . $e2$ >> -> ident_of_expr e1 ^ "__" ^ ident_of_expr e2 - | _ -> failwith "internal error in pa_extend" ] -; - -value mk_name loc e = {expr = e; tvar = ident_of_expr e; loc = loc}; - -value slist loc min sep symb = - let t = - match sep with - [ Some s -> Some s.text - | None -> None ] - in - TXlist loc min symb.text t -; - -value sstoken _loc s = - let n = mk_name _loc <:expr< $lid:"a_" ^ s$ >> in - TXnterm _loc n None -; - -value mk_psymbol p s t = - let symb = {used = []; text = s; styp = t} in - {pattern = Some p; symbol = symb} -; - -value sslist _loc min sep s = - let rl = - let r1 = - let prod = - let n = mk_name _loc <:expr< a_list >> in - [mk_psymbol <:patt< a >> (TXnterm _loc n None) (STquo _loc "a_list")] - in - let act = <:expr< a >> in - {prod = prod; action = Some act} - in - let r2 = - let prod = - [mk_psymbol <:patt< a >> (slist _loc min sep s) - (STapp _loc (STlid _loc "list") s.styp)] - in - let act = <:expr< Qast.List a >> in - {prod = prod; action = Some act} - in - [r1; r2] - in - let used = - match sep with - [ Some symb -> symb.used @ s.used - | None -> s.used ] - in - let used = ["a_list" :: used] in - let text = TXrules _loc (srules _loc "a_list" rl "") in - let styp = STquo _loc "a_list" in - {used = used; text = text; styp = styp} -; - -value ssopt _loc s = - let rl = - let r1 = - let prod = - let n = mk_name _loc <:expr< a_opt >> in - [mk_psymbol <:patt< a >> (TXnterm _loc n None) (STquo _loc "a_opt")] - in - let act = <:expr< a >> in - {prod = prod; action = Some act} - in - let r2 = - let s = - match s.text with - [ TXtok _loc "" <:expr< $str:_$ >> -> - let rl = - [{prod = [{pattern = Some <:patt< x >>; symbol = s}]; - action = Some <:expr< Qast.Str x >>}] - in - let t = new_type_var () in - {used = []; text = TXrules _loc (srules _loc t rl ""); - styp = STquo _loc t} - | _ -> s ] - in - let prod = - [mk_psymbol <:patt< a >> (TXopt _loc s.text) - (STapp _loc (STlid _loc "option") s.styp)] - in - let act = <:expr< Qast.Option a >> in - {prod = prod; action = Some act} - in - [r1; r2] - in - let used = ["a_opt" :: s.used] in - let text = TXrules _loc (srules _loc "a_opt" rl "") in - let styp = STquo _loc "a_opt" in - {used = used; text = text; styp = styp} -; - -value text_of_entry _loc gmod e = - let ent = - let x = e.name in - let _loc = e.name.loc in - <:expr< ($x.expr$ : $uid:gmod$.Entry.e '$x.tvar$) >> - in - let pos = - match e.pos with - [ Some pos -> <:expr< Some $pos$ >> - | None -> <:expr< None >> ] - in - let txt = - List.fold_right - (fun level txt -> - let lab = - match level.label with - [ Some lab -> <:expr< Some $str:lab$ >> - | None -> <:expr< None >> ] - in - let ass = - match level.assoc with - [ Some ass -> <:expr< Some $ass$ >> - | None -> <:expr< None >> ] - in - let txt = - let rl = srules _loc e.name.tvar level.rules e.name.tvar in - let e = make_expr_rules _loc gmod rl e.name.tvar in - <:expr< [($lab$, $ass$, $e$) :: $txt$] >> - in - txt) - e.levels <:expr< [] >> - in - (ent, pos, txt) -; - -value let_in_of_extend _loc gmod functor_version gl el args = - match gl with - [ Some ([n1 :: _] as nl) -> - do { - check_use nl el; - let ll = - let same_tvar e n = e.name.tvar = n.tvar in - List.fold_right - (fun e ll -> - match e.name.expr with - [ <:expr< $lid:_$ >> -> - if List.exists (same_tvar e) nl then ll - else if List.exists (same_tvar e) ll then ll - else [e.name :: ll] - | _ -> ll ]) - el [] - in - let globals = - List.map - (fun {expr = e; tvar = x; loc = _loc} -> - (<:patt< _ >>, <:expr< ($e$ : $uid:gmod$.Entry.e '$x$) >>)) - nl - in - let locals = - List.map - (fun {expr = e; tvar = x; loc = _loc} -> - let i = - match e with - [ <:expr< $lid:i$ >> -> i - | _ -> failwith "internal error in pa_extend" ] - in - (<:patt< $lid:i$ >>, <:expr< - (grammar_entry_create $str:i$ : $uid:gmod$.Entry.e '$x$) >>)) - ll - in - let e = - if ll = [] then args - else if functor_version then - <:expr< - let grammar_entry_create = $uid:gmod$.Entry.create in - let $list:locals$ in $args$ >> - else - <:expr< - let grammar_entry_create s = - $uid:gmod$.Entry.create ($uid:gmod$.of_entry $locate n1$) s - in - let $list:locals$ in $args$ >> - in - <:expr< let $list:globals$ in $e$ >> - } - | _ -> args ] -; - -value text_of_extend _loc gmod gl el f = - if split_ext.val then - let args = - List.map - (fun e -> - let (ent, pos, txt) = text_of_entry e.name.loc gmod e in - let ent = <:expr< $uid:gmod$.Entry.obj $ent$ >> in - let e = <:expr< ($ent$, $pos$, $txt$) >> in - <:expr< let aux () = $f$ [$e$] in aux () >>) - el - in - let args = <:expr< do { $list:args$ } >> in - let_in_of_extend _loc gmod False gl el args - else - let args = - List.fold_right - (fun e el -> - let (ent, pos, txt) = text_of_entry e.name.loc gmod e in - let ent = <:expr< $uid:gmod$.Entry.obj $ent$ >> in - let e = <:expr< ($ent$, $pos$, $txt$) >> in - <:expr< [$e$ :: $el$] >>) - el <:expr< [] >> - in - let args = let_in_of_extend _loc gmod False gl el args in - <:expr< $f$ $args$ >> -; - -value text_of_functorial_extend _loc gmod gl el = - let args = - let el = - List.map - (fun e -> - let (ent, pos, txt) = text_of_entry e.name.loc gmod e in - let e = <:expr< $uid:gmod$.extend $ent$ $pos$ $txt$ >> in - if split_ext.val then <:expr< let aux () = $e$ in aux () >> else e) - el - in - <:expr< do { $list:el$ } >> - in - let_in_of_extend _loc gmod True gl el args -; - -value zero_loc = {(Lexing.dummy_pos) with Lexing.pos_cnum = 0}; - -open Pcaml; -value symbol = Grammar.Entry.create gram "symbol"; -value semi_sep = - if syntax_name.val = "Scheme" then - Grammar.Entry.of_parser gram "'/'" (parser [: `("", "/") :] -> ()) - else - Grammar.Entry.of_parser gram "';'" (parser [: `("", ";") :] -> ()) -; - -EXTEND - GLOBAL: expr symbol; - expr: AFTER "top" - [ [ "EXTEND"; e = extend_body; "END" -> e - | "GEXTEND"; e = gextend_body; "END" -> e - | "DELETE_RULE"; e = delete_rule_body; "END" -> e - | "GDELETE_RULE"; e = gdelete_rule_body; "END" -> e ] ] - ; - extend_body: - [ [ f = efunction; sl = OPT global; - el = LIST1 [ e = entry; semi_sep -> e ] -> - text_of_extend _loc "Grammar" sl el f ] ] - ; - gextend_body: - [ [ g = UIDENT; sl = OPT global; el = LIST1 [ e = entry; semi_sep -> e ] -> - text_of_functorial_extend _loc g sl el ] ] - ; - delete_rule_body: - [ [ n = name; ":"; sl = LIST1 symbol SEP semi_sep -> - let (e, b) = expr_of_delete_rule _loc "Grammar" n sl in - <:expr< Grammar.delete_rule $e$ $b$ >> ] ] - ; - gdelete_rule_body: - [ [ g = UIDENT; n = name; ":"; sl = LIST1 symbol SEP semi_sep -> - let (e, b) = expr_of_delete_rule _loc g n sl in - <:expr< $uid:g$.delete_rule $e$ $b$ >> ] ] - ; - efunction: - [ [ UIDENT "FUNCTION"; ":"; f = qualid; semi_sep -> f - | -> <:expr< Grammar.extend >> ] ] - ; - global: - [ [ UIDENT "GLOBAL"; ":"; sl = LIST1 name; semi_sep -> sl ] ] - ; - entry: - [ [ n = name; ":"; pos = OPT position; ll = level_list -> - {name = n; pos = pos; levels = ll} ] ] - ; - position: - [ [ UIDENT "FIRST" -> <:expr< Gramext.First >> - | UIDENT "LAST" -> <:expr< Gramext.Last >> - | UIDENT "BEFORE"; n = string -> <:expr< Gramext.Before $n$ >> - | UIDENT "AFTER"; n = string -> <:expr< Gramext.After $n$ >> - | UIDENT "LEVEL"; n = string -> <:expr< Gramext.Level $n$ >> ] ] - ; - level_list: - [ [ "["; ll = LIST0 level SEP "|"; "]" -> ll ] ] - ; - level: - [ [ lab = OPT STRING; ass = OPT assoc; rules = rule_list -> - {label = lab; assoc = ass; rules = rules} ] ] - ; - assoc: - [ [ UIDENT "LEFTA" -> <:expr< Gramext.LeftA >> - | UIDENT "RIGHTA" -> <:expr< Gramext.RightA >> - | UIDENT "NONA" -> <:expr< Gramext.NonA >> ] ] - ; - rule_list: - [ [ "["; "]" -> [] - | "["; rules = LIST1 rule SEP "|"; "]" -> - retype_rule_list_without_patterns _loc rules ] ] - ; - rule: - [ [ psl = LIST0 psymbol SEP semi_sep; "->"; act = expr -> - {prod = psl; action = Some act} - | psl = LIST0 psymbol SEP semi_sep -> - {prod = psl; action = None} ] ] - ; - psymbol: - [ [ p = LIDENT; "="; s = symbol -> - {pattern = Some <:patt< $lid:p$ >>; symbol = s} - | i = LIDENT; lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] -> - let name = mk_name _loc <:expr< $lid:i$ >> in - let text = TXnterm _loc name lev in - let styp = STquo _loc i in - let symb = {used = [i]; text = text; styp = styp} in - {pattern = None; symbol = symb} - | p = pattern; "="; s = symbol -> {pattern = Some p; symbol = s} - | s = symbol -> {pattern = None; symbol = s} ] ] - ; - symbol: - [ "top" NONA - [ UIDENT "LIST0"; s = SELF; - sep = OPT [ UIDENT "SEP"; t = symbol -> t ] -> - if quotify.val then sslist _loc False sep s - else - let used = - match sep with - [ Some symb -> symb.used @ s.used - | None -> s.used ] - in - let styp = STapp _loc (STlid _loc "list") s.styp in - let text = slist _loc False sep s in - {used = used; text = text; styp = styp} - | UIDENT "LIST1"; s = SELF; - sep = OPT [ UIDENT "SEP"; t = symbol -> t ] -> - if quotify.val then sslist _loc True sep s - else - let used = - match sep with - [ Some symb -> symb.used @ s.used - | None -> s.used ] - in - let styp = STapp _loc (STlid _loc "list") s.styp in - let text = slist _loc True sep s in - {used = used; text = text; styp = styp} - | UIDENT "OPT"; s = SELF -> - if quotify.val then ssopt _loc s - else - let styp = STapp _loc (STlid _loc "option") s.styp in - let text = TXopt _loc s.text in - {used = s.used; text = text; styp = styp} ] - | [ UIDENT "SELF" -> - {used = []; text = TXself _loc; styp = STself _loc "SELF"} - | UIDENT "NEXT" -> - {used = []; text = TXnext _loc; styp = STself _loc "NEXT"} - | "["; rl = LIST0 rule SEP "|"; "]" -> - let rl = retype_rule_list_without_patterns _loc rl in - let t = new_type_var () in - {used = used_of_rule_list rl; - text = TXrules _loc (srules _loc t rl ""); - styp = STquo _loc t} - | x = UIDENT -> - let text = - if quotify.val then sstoken _loc x - else TXtok _loc x <:expr< "" >> - in - {used = []; text = text; styp = STlid _loc "string"} - | x = UIDENT; e = string -> - let text = TXtok _loc x e in - {used = []; text = text; styp = STlid _loc "string"} - | e = string -> - let text = TXtok _loc "" e in - {used = []; text = text; styp = STlid _loc "string"} - | i = UIDENT; "."; e = qualid; - lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] -> - let n = mk_name _loc <:expr< $uid:i$ . $e$ >> in - {used = [n.tvar]; text = TXnterm _loc n lev; - styp = STquo _loc n.tvar} - | n = name; lev = OPT [ UIDENT "LEVEL"; s = STRING -> s ] -> - {used = [n.tvar]; text = TXnterm _loc n lev; - styp = STquo _loc n.tvar} - | "("; s_t = SELF; ")" -> s_t ] ] - ; - pattern: - [ [ i = LIDENT -> <:patt< $lid:i$ >> - | "_" -> <:patt< _ >> - | "("; p = SELF; ")" -> <:patt< $p$ >> - | "("; p = SELF; ","; pl = patterns_comma; ")" -> - <:patt< ( $list:[p :: pl]$ ) >> ] ] - ; - patterns_comma: - [ [ pl = SELF; ","; p = pattern -> pl @ [p] ] - | [ p = pattern -> [p] ] ] - ; - name: - [ [ e = qualid -> mk_name _loc e ] ] - ; - qualid: - [ [ e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> ] - | [ i = UIDENT -> <:expr< $uid:i$ >> - | i = LIDENT -> <:expr< $lid:i$ >> ] ] - ; - string: - [ [ s = STRING -> <:expr< $str:s$ >> - | i = ANTIQUOT -> - let shift = Reloc.shift_pos (String.length "$") (fst _loc) in - let e = - try Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string i) with - [ Exc_located (bp, ep) exc -> - raise_with_loc (Reloc.adjust_loc shift (bp,ep)) exc ] - in - Pcaml.expr_reloc (fun (bp, ep) -> (Reloc.adjust_loc shift (bp,ep))) zero_loc e ] ] - ; -END; - -Pcaml.add_option "-quotify" (Arg.Set quotify) - "Generate code for quotations"; - -Pcaml.add_option "-meta_action" (Arg.Set meta_action) - "Undocumented"; diff --git a/camlp4/meta/pa_extend_m.ml b/camlp4/meta/pa_extend_m.ml deleted file mode 100644 index 0548431a..00000000 --- a/camlp4/meta/pa_extend_m.ml +++ /dev/null @@ -1,26 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: pa_extend_m.ml,v 1.9 2004/11/17 09:07:56 mauny Exp $ *) - -open Pa_extend; - -EXTEND - symbol: LEVEL "top" - [ NONA - [ min = [ UIDENT "SLIST0" -> False | UIDENT "SLIST1" -> True ]; - s = SELF; sep = OPT [ UIDENT "SEP"; t = symbol -> t ] -> - sslist _loc min sep s - | UIDENT "SOPT"; s = SELF -> - ssopt _loc s ] ] - ; -END; diff --git a/camlp4/meta/pa_macro.ml b/camlp4/meta/pa_macro.ml deleted file mode 100644 index cd2ddb7b..00000000 --- a/camlp4/meta/pa_macro.ml +++ /dev/null @@ -1,354 +0,0 @@ -(* camlp4r *) -(* $Id: pa_macro.ml,v 1.5 2005/10/21 10:55:32 mauny Exp $ *) - -(* -Added statements: - - At toplevel (structure item): - - DEFINE - DEFINE = - DEFINE () = - IFDEF THEN (END | ENDIF) - IFDEF THEN ELSE (END | ENDIF) - IFNDEF THEN (END | ENDIF) - IFNDEF THEN ELSE (END | ENDIF) - INCLUDE - - In expressions: - - IFDEF THEN ELSE (END | ENDIF) - IFNDEF THEN ELSE (END | ENDIF) - __FILE__ - __LOCATION__ - - In patterns: - - IFDEF THEN ELSE (END | ENDIF) - IFNDEF THEN ELSE (END | ENDIF) - - As Camlp4 options: - - -D define - -U undefine it - -I add to the search path for INCLUDE'd files - - After having used a DEFINE followed by "= ", you - can use it in expressions *and* in patterns. If the expression defining - the macro cannot be used as a pattern, there is an error message if - it is used in a pattern. - - - - The toplevel statement INCLUDE can be used to include a - file containing macro definitions; note that files included in such - a way can not have any non-macro toplevel items. The included files - are looked up in directories passed in via the -I option, falling - back to the current directory. - - The expression __FILE__ returns the current compiled file name. - The expression __LOCATION__ returns the current location of itself. - -*) - -#load "pa_extend.cmo"; -#load "q_MLast.cmo"; - -open Pcaml; - -type item_or_def 'a = - [ SdStr of 'a - | SdDef of string and option (list string * MLast.expr) - | SdUnd of string - | SdITE of string and list (item_or_def 'a) and list (item_or_def 'a) - | SdInc of string ] -; - -value rec list_remove x = - fun - [ [(y, _) :: l] when y = x -> l - | [d :: l] -> [d :: list_remove x l] - | [] -> [] ] -; - -value defined = ref []; - -value is_defined i = List.mem_assoc i defined.val; - -value _loc = - let nowhere = - { (Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0 } in - (nowhere, nowhere); - -value subst mloc env = - let rec loop = - fun - [ <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> - let pel = List.map (fun (p, e) -> (p, loop e)) pel in - <:expr< let $opt:rf$ $list:pel$ in $loop e$ >> - | <:expr< if $e1$ then $e2$ else $e3$ >> -> - <:expr< if $loop e1$ then $loop e2$ else $loop e3$ >> - | <:expr< $e1$ $e2$ >> -> <:expr< $loop e1$ $loop e2$ >> - | <:expr< fun $args$ -> $e$ >> -> <:expr< fun $args$ -> $loop e$ >> - | <:expr< fun [ $list: peoel$ ] >> -> <:expr< fun [ $list: (List.map loop_peoel peoel)$ ] >> - | <:expr< $lid:x$ >> | <:expr< $uid:x$ >> as e -> - try <:expr< $anti:List.assoc x env$ >> with - [ Not_found -> e ] - | <:expr< ($list:x$) >> -> <:expr< ($list:List.map loop x$) >> - | <:expr< do {$list:x$} >> -> <:expr< do {$list:List.map loop x$} >> - | <:expr< { $list:pel$ } >> -> - let pel = List.map (fun (p, e) -> (p, loop e)) pel in - <:expr< { $list:pel$ } >> - | <:expr< match $e$ with [ $list:peoel$ ] >> -> - <:expr< match $loop e$ with [ $list: (List.map loop_peoel peoel)$ ] >> - | <:expr< try $e$ with [ $list:pel$ ] >> -> - let loop' = fun - [ (p, Some e1, e2) -> (p, Some (loop e1), loop e2) - | (p, None, e2) -> (p, None, loop e2) ] in - <:expr< try $loop e$ with [ $list: (List.map loop' pel)$ ] >> - | e -> e ] - and loop_peoel = - fun - [ (p, Some e1, e2) -> (p, Some (loop e1), loop e2) - | (p, None, e2) -> (p, None, loop e2) ] - in loop -; - -value substp mloc env = - loop where rec loop = - fun - [ <:expr< $e1$ $e2$ >> -> <:patt< $loop e1$ $loop e2$ >> - | <:expr< $lid:x$ >> -> - try <:patt< $anti:List.assoc x env$ >> with - [ Not_found -> <:patt< $lid:x$ >> ] - | <:expr< $uid:x$ >> -> - try <:patt< $anti:List.assoc x env$ >> with - [ Not_found -> <:patt< $uid:x$ >> ] - | <:expr< $int:x$ >> -> <:patt< $int:x$ >> - | <:expr< $str:s$ >> -> <:patt< $str:s$ >> - | <:expr< ($list:x$) >> -> <:patt< ($list:List.map loop x$) >> - | <:expr< { $list:pel$ } >> -> - let ppl = List.map (fun (p, e) -> (p, loop e)) pel in - <:patt< { $list:ppl$ } >> - | x -> - Stdpp.raise_with_loc mloc - (Failure - "this macro cannot be used in a pattern (see its definition)") ] -; - -value incorrect_number loc l1 l2 = - Stdpp.raise_with_loc loc - (Failure - (Printf.sprintf "expected %d parameters; found %d" - (List.length l2) (List.length l1))) -; - -value define eo x = - do { - match eo with - [ Some ([], e) -> - EXTEND - expr: LEVEL "simple" - [ [ UIDENT $x$ -> Pcaml.expr_reloc (fun _ -> _loc) (fst _loc) e ] ] - ; - patt: LEVEL "simple" - [ [ UIDENT $x$ -> - let p = substp _loc [] e in - Pcaml.patt_reloc (fun _ -> _loc) (fst _loc) p ] ] - ; - END - | Some (sl, e) -> - EXTEND - expr: LEVEL "apply" - [ [ UIDENT $x$; param = SELF -> - let el = - match param with - [ <:expr< ($list:el$) >> -> el - | e -> [e] ] - in - if List.length el = List.length sl then - let env = List.combine sl el in - let e = subst _loc env e in - Pcaml.expr_reloc (fun _ -> _loc) (fst _loc) e - else - incorrect_number _loc el sl ] ] - ; - patt: LEVEL "simple" - [ [ UIDENT $x$; param = SELF -> - let pl = - match param with - [ <:patt< ($list:pl$) >> -> pl - | p -> [p] ] - in - if List.length pl = List.length sl then - let env = List.combine sl pl in - let p = substp _loc env e in - Pcaml.patt_reloc (fun _ -> _loc) (fst _loc) p - else - incorrect_number _loc pl sl ] ] - ; - END - | None -> () ]; - defined.val := [(x, eo) :: defined.val]; - } -; - -value undef x = - try - do { - let eo = List.assoc x defined.val in - match eo with - [ Some ([], _) -> - do { - DELETE_RULE expr: UIDENT $x$ END; - DELETE_RULE patt: UIDENT $x$ END; - } - | Some (_, _) -> - do { - DELETE_RULE expr: UIDENT $x$; SELF END; - DELETE_RULE patt: UIDENT $x$; SELF END; - } - | None -> () ]; - defined.val := list_remove x defined.val; - } - with - [ Not_found -> () ] -; - -(* This is a list of directories to search for INCLUDE statements. *) -value include_dirs = ref [] -; - -(* Add something to the above, make sure it ends with a slash. *) -value add_include_dir str = - if str <> "" then - let str = - if String.get str ((String.length str)-1) = '/' - then str else str ^ "/" - in include_dirs.val := include_dirs.val @ [str] - else () -; - -value smlist = Grammar.Entry.create Pcaml.gram "smlist" -; - -value parse_include_file = - let dir_ok file dir = Sys.file_exists (dir ^ file) in - fun file -> - let file = - try (List.find (dir_ok file) (include_dirs.val @ ["./"])) ^ file - with [ Not_found -> file ] - in - let ch = open_in file in - let st = Stream.of_channel ch in - let old_input = Pcaml.input_file.val in - let (bol_ref, lnum_ref, name_ref) = Pcaml.position.val in - let (old_bol, old_lnum, old_name) = (bol_ref.val, lnum_ref.val, name_ref.val) in - let restore () = - do { - close_in ch; - bol_ref.val := old_bol; - lnum_ref.val := old_lnum; - name_ref.val := old_name; - Pcaml.input_file.val := old_input; - } - in - do { - bol_ref.val := 0; - lnum_ref.val := 1; - name_ref.val := file; - Pcaml.input_file.val := file; - try - let items = Grammar.Entry.parse smlist st in - do { restore (); items } - with [ exn -> do { restore (); raise exn } ] } -; - -value rec execute_macro = fun -[ SdStr i -> [i] -| SdDef x eo -> do { define eo x; [] } -| SdUnd x -> do { undef x; [] } -| SdITE i l1 l2 -> - execute_macro_list (if is_defined i then l1 else l2) -| SdInc f -> execute_macro_list (parse_include_file f) ] - -and execute_macro_list = fun -[ [] -> [] -| [hd::tl] -> (* The evaluation order is important here *) - let il1 = execute_macro hd in - let il2 = execute_macro_list tl in - il1 @ il2 ] -; - -EXTEND - GLOBAL: expr patt str_item sig_item smlist; - str_item: FIRST - [ [ x = macro_def -> - match execute_macro x with - [ [si] -> si - | sil -> <:str_item< declare $list:sil$ end >> ] ] ] - ; - macro_def: - [ [ "DEFINE"; i = uident; def = opt_macro_value -> SdDef i def - | "UNDEF"; i = uident -> SdUnd i - | "IFDEF"; i = uident; "THEN"; dl = smlist; _ = endif -> - SdITE i dl [] - | "IFDEF"; i = uident; "THEN"; dl1 = smlist; "ELSE"; - dl2 = smlist; _ = endif -> - SdITE i dl1 dl2 - | "IFNDEF"; i = uident; "THEN"; dl = smlist; _ = endif -> - SdITE i [] dl - | "IFNDEF"; i = uident; "THEN"; dl1 = smlist; "ELSE"; - dl2 = smlist; _ = endif -> - SdITE i dl2 dl1 - | "INCLUDE"; fname = STRING -> SdInc fname ] ] - ; - smlist: - [ [ sml = LIST1 str_item_or_macro -> sml ] ] - ; - endif: - [ [ "END" -> () - | "ENDIF" -> () ] ] - ; - str_item_or_macro: - [ [ d = macro_def -> d - | si = str_item -> SdStr si ] ] - ; - opt_macro_value: - [ [ "("; pl = LIST1 LIDENT SEP ","; ")"; "="; e = expr -> Some (pl, e) - | "="; e = expr -> Some ([], e) - | -> None ] ] - ; - expr: LEVEL "top" - [ [ "IFDEF"; i = uident; "THEN"; e1 = expr; "ELSE"; e2 = expr; _ = endif -> - if is_defined i then e1 else e2 - | "IFNDEF"; i = uident; "THEN"; e1 = expr; "ELSE"; e2 = expr; _ = endif -> - if is_defined i then e2 else e1 ] ] - ; - expr: LEVEL "simple" - [ [ LIDENT "__FILE__" -> <:expr< $str:Pcaml.input_file.val$ >> - | LIDENT "__LOCATION__" -> - let bp = string_of_int ((fst _loc).Lexing.pos_cnum) in - let ep = string_of_int ((snd _loc).Lexing.pos_cnum) in - <:expr< ($int:bp$, $int:ep$) >> ] ] - ; - patt: - [ [ "IFDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; _ = endif -> - if is_defined i then p1 else p2 - | "IFNDEF"; i = uident; "THEN"; p1 = patt; "ELSE"; p2 = patt; _ = endif -> - if is_defined i then p2 else p1 ] ] - ; - uident: - [ [ i = UIDENT -> i ] ] - ; -END; - -Pcaml.add_option "-D" (Arg.String (define None)) - " Define for IFDEF instruction." -; -Pcaml.add_option "-U" (Arg.String undef) - " Undefine for IFDEF instruction." -; -Pcaml.add_option "-I" (Arg.String add_include_dir) - " Add a directory to INCLUDE search path." -; diff --git a/camlp4/meta/pa_r.ml b/camlp4/meta/pa_r.ml deleted file mode 100644 index 1489cf0b..00000000 --- a/camlp4/meta/pa_r.ml +++ /dev/null @@ -1,961 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: pa_r.ml,v 1.64 2005/06/29 04:11:26 garrigue Exp $ *) - -open Stdpp; -open Pcaml; - -Pcaml.no_constructors_arity.val := False; - -value help_sequences () = - do { - Printf.eprintf "\ -New syntax: - do {e1; e2; ... ; en} - while e do {e1; e2; ... ; en} - for v = v1 to/downto v2 do {e1; e2; ... ; en} -Old (discouraged) syntax: - do e1; e2; ... ; en-1; return en - while e do e1; e2; ... ; en; done - for v = v1 to/downto v2 do e1; e2; ... ; en; done -To avoid compilation warning use the new syntax. -"; - flush stderr; - exit 1 - } -; -Pcaml.add_option "-help_seq" (Arg.Unit help_sequences) - "Print explanations about new sequences and exit."; - -do { - let odfa = Plexer.dollar_for_antiquotation.val in - Plexer.dollar_for_antiquotation.val := False; - let (lexer, pos) = Plexer.make_lexer () in - Pcaml.position.val := pos; - Grammar.Unsafe.gram_reinit gram lexer; - Plexer.dollar_for_antiquotation.val := odfa; - Grammar.Unsafe.clear_entry interf; - Grammar.Unsafe.clear_entry implem; - Grammar.Unsafe.clear_entry top_phrase; - Grammar.Unsafe.clear_entry use_file; - Grammar.Unsafe.clear_entry module_type; - Grammar.Unsafe.clear_entry module_expr; - Grammar.Unsafe.clear_entry sig_item; - Grammar.Unsafe.clear_entry str_item; - Grammar.Unsafe.clear_entry expr; - Grammar.Unsafe.clear_entry patt; - Grammar.Unsafe.clear_entry ctyp; - Grammar.Unsafe.clear_entry let_binding; - Grammar.Unsafe.clear_entry type_declaration; - Grammar.Unsafe.clear_entry class_type; - Grammar.Unsafe.clear_entry class_expr; - Grammar.Unsafe.clear_entry class_sig_item; - Grammar.Unsafe.clear_entry class_str_item -}; - -Pcaml.parse_interf.val := Grammar.Entry.parse interf; -Pcaml.parse_implem.val := Grammar.Entry.parse implem; - -value o2b = - fun - [ Some _ -> True - | None -> False ] -; - -value mksequence _loc = - fun - [ [e] -> e - | el -> <:expr< do { $list:el$ } >> ] -; - -value mkmatchcase _loc p aso w e = - let p = - match aso with - [ Some p2 -> <:patt< ($p$ as $p2$) >> - | _ -> p ] - in - (p, w, e) -; - -value neg_string n = - let len = String.length n in - if len > 0 && n.[0] = '-' then String.sub n 1 (len - 1) - else "-" ^ n -; - -value mkumin _loc f arg = - match arg with - [ <:expr< $int:n$ >> -> <:expr< $int:neg_string n$ >> - | MLast.ExInt32 loc n -> MLast.ExInt32 loc (neg_string n) - | MLast.ExInt64 loc n -> MLast.ExInt64 loc (neg_string n) - | MLast.ExNativeInt loc n -> MLast.ExNativeInt loc (neg_string n) - | <:expr< $flo:n$ >> -> <:expr< $flo:neg_string n$ >> - | _ -> - let f = "~" ^ f in - <:expr< $lid:f$ $arg$ >> ] -; - -value mklistexp _loc last = - loop True where rec loop top = - fun - [ [] -> - match last with - [ Some e -> e - | None -> <:expr< [] >> ] - | [e1 :: el] -> - let _loc = - if top then _loc else (fst (MLast.loc_of_expr e1), snd _loc) - in - <:expr< [$e1$ :: $loop False el$] >> ] -; - -value mklistpat _loc last = - loop True where rec loop top = - fun - [ [] -> - match last with - [ Some p -> p - | None -> <:patt< [] >> ] - | [p1 :: pl] -> - let _loc = - if top then _loc else (fst (MLast.loc_of_patt p1), snd _loc) - in - <:patt< [$p1$ :: $loop False pl$] >> ] -; - -value mkexprident _loc ids = match ids with - [ [] -> Stdpp.raise_with_loc _loc (Stream.Error "illegal long identifier") - | [ id :: ids ] -> - let rec loop m = fun - [ [ id :: ids ] -> loop <:expr< $m$ . $id$ >> ids - | [] -> m ] - in - loop id ids ] -; - -value mkassert _loc e = - match e with - [ <:expr< False >> -> MLast.ExAsf _loc - | _ -> MLast.ExAsr _loc e ] -; - -value append_elem el e = el @ [e]; - -(* ...suppose to flush the input in case of syntax error to avoid multiple - errors in case of cut-and-paste in the xterm, but work bad: for example - the input "for x = 1;" waits for another line before displaying the - error... -value rec sync cs = - match cs with parser - [ [: `';' :] -> sync_semi cs - | [: `_ :] -> sync cs ] -and sync_semi cs = - match Stream.peek cs with - [ Some ('\010' | '\013') -> () - | _ -> sync cs ] -; -Pcaml.sync.val := sync; -*) - -value ipatt = Grammar.Entry.create gram "ipatt"; -value with_constr = Grammar.Entry.create gram "with_constr"; -value row_field = Grammar.Entry.create gram "row_field"; - -value not_yet_warned_variant = ref True; -value warn_variant loc = - if not_yet_warned_variant.val then do { - not_yet_warned_variant.val := False; - Pcaml.warning.val loc - (Printf.sprintf - "use of syntax of variants types deprecated since version 3.05"); - } - else () -; - -value not_yet_warned = ref True; -value warn_sequence loc = - if not_yet_warned.val then do { - not_yet_warned.val := False; - Pcaml.warning.val loc - ("use of syntax of sequences deprecated since version 3.01.1"); - } - else () -; -Pcaml.add_option "-no_warn_seq" (Arg.Clear not_yet_warned) - "No warning when using old syntax for sequences."; - -EXTEND - GLOBAL: sig_item str_item ctyp patt expr module_type module_expr class_type - class_expr class_sig_item class_str_item let_binding type_declaration - ipatt with_constr row_field; - module_expr: - [ [ "functor"; "("; i = UIDENT; ":"; t = module_type; ")"; "->"; - me = SELF -> - <:module_expr< functor ( $i$ : $t$ ) -> $me$ >> - | "struct"; st = LIST0 [ s = str_item; ";" -> s ]; "end" -> - <:module_expr< struct $list:st$ end >> ] - | [ me1 = SELF; me2 = SELF -> <:module_expr< $me1$ $me2$ >> ] - | [ me1 = SELF; "."; me2 = SELF -> <:module_expr< $me1$ . $me2$ >> ] - | "simple" - [ i = UIDENT -> <:module_expr< $uid:i$ >> - | "("; me = SELF; ":"; mt = module_type; ")" -> - <:module_expr< ( $me$ : $mt$ ) >> - | "("; me = SELF; ")" -> <:module_expr< $me$ >> ] ] - ; - str_item: - [ "top" - [ "declare"; st = LIST0 [ s = str_item; ";" -> s ]; "end" -> - <:str_item< declare $list:st$ end >> - | "exception"; (_, c, tl) = constructor_declaration; b = rebind_exn -> - <:str_item< exception $c$ of $list:tl$ = $b$ >> - | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING -> - <:str_item< external $i$ : $t$ = $list:pd$ >> - | "include"; me = module_expr -> <:str_item< include $me$ >> - | "module"; i = UIDENT; mb = module_binding -> - <:str_item< module $i$ = $mb$ >> - | "module"; "rec"; nmtmes = LIST1 module_rec_binding SEP "and" -> - MLast.StRecMod _loc nmtmes - | "module"; "type"; i = UIDENT; "="; mt = module_type -> - <:str_item< module type $i$ = $mt$ >> - | "open"; i = mod_ident -> <:str_item< open $i$ >> - | "type"; tdl = LIST1 type_declaration SEP "and" -> - <:str_item< type $list:tdl$ >> - | "value"; r = OPT "rec"; l = LIST1 let_binding SEP "and" -> - <:str_item< value $opt:o2b r$ $list:l$ >> - | e = expr -> <:str_item< $exp:e$ >> ] ] - ; - rebind_exn: - [ [ "="; sl = mod_ident -> sl - | -> [] ] ] - ; - module_binding: - [ RIGHTA - [ "("; m = UIDENT; ":"; mt = module_type; ")"; mb = SELF -> - <:module_expr< functor ( $m$ : $mt$ ) -> $mb$ >> - | ":"; mt = module_type; "="; me = module_expr -> - <:module_expr< ( $me$ : $mt$ ) >> - | "="; me = module_expr -> <:module_expr< $me$ >> ] ] - ; - module_rec_binding: - [ [ m = UIDENT; ":"; mt = module_type; "="; me = module_expr -> - (m, mt, me) ] ] - ; - module_type: - [ [ "functor"; "("; i = UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF -> - <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] - | [ mt = SELF; "with"; wcl = LIST1 with_constr SEP "and" -> - <:module_type< $mt$ with $list:wcl$ >> ] - | [ "sig"; sg = LIST0 [ s = sig_item; ";" -> s ]; "end" -> - <:module_type< sig $list:sg$ end >> ] - | [ m1 = SELF; m2 = SELF -> <:module_type< $m1$ $m2$ >> ] - | [ m1 = SELF; "."; m2 = SELF -> <:module_type< $m1$ . $m2$ >> ] - | "simple" - [ i = UIDENT -> <:module_type< $uid:i$ >> - | i = LIDENT -> <:module_type< $lid:i$ >> - | "'"; i = ident -> <:module_type< ' $i$ >> - | "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ] - ; - sig_item: - [ "top" - [ "declare"; st = LIST0 [ s = sig_item; ";" -> s ]; "end" -> - <:sig_item< declare $list:st$ end >> - | "exception"; (_, c, tl) = constructor_declaration -> - <:sig_item< exception $c$ of $list:tl$ >> - | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING -> - <:sig_item< external $i$ : $t$ = $list:pd$ >> - | "include"; mt = module_type -> <:sig_item< include $mt$ >> - | "module"; i = UIDENT; mt = module_declaration -> - <:sig_item< module $i$ : $mt$ >> - | "module"; "rec"; mds = LIST1 module_rec_declaration SEP "and" -> - MLast.SgRecMod _loc mds - | "module"; "type"; i = UIDENT; "="; mt = module_type -> - <:sig_item< module type $i$ = $mt$ >> - | "open"; i = mod_ident -> <:sig_item< open $i$ >> - | "type"; tdl = LIST1 type_declaration SEP "and" -> - <:sig_item< type $list:tdl$ >> - | "value"; i = LIDENT; ":"; t = ctyp -> - <:sig_item< value $i$ : $t$ >> ] ] - ; - module_declaration: - [ RIGHTA - [ ":"; mt = module_type -> <:module_type< $mt$ >> - | "("; i = UIDENT; ":"; t = module_type; ")"; mt = SELF -> - <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] ] - ; - module_rec_declaration: - [ [ m = UIDENT; ":"; mt = module_type -> (m, mt)] ] - ; - with_constr: - [ [ "type"; i = mod_ident; tpl = LIST0 type_parameter; "="; t = ctyp -> - <:with_constr< type $i$ $list:tpl$ = $t$ >> - | "module"; i = mod_ident; "="; me = module_expr -> - <:with_constr< module $i$ = $me$ >> ] ] - ; - expr: - [ "top" RIGHTA - [ "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; - x = SELF -> - <:expr< let $opt:o2b r$ $list:l$ in $x$ >> - | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = SELF -> - <:expr< let module $m$ = $mb$ in $e$ >> - | "fun"; "["; l = LIST0 match_case SEP "|"; "]" -> - <:expr< fun [ $list:l$ ] >> - | "fun"; p = ipatt; e = fun_def -> <:expr< fun $p$ -> $e$ >> - | "match"; e = SELF; "with"; "["; l = LIST0 match_case SEP "|"; "]" -> - <:expr< match $e$ with [ $list:l$ ] >> - | "match"; e = SELF; "with"; p1 = ipatt; "->"; e1 = SELF -> - <:expr< match $e$ with $p1$ -> $e1$ >> - | "try"; e = SELF; "with"; "["; l = LIST0 match_case SEP "|"; "]" -> - <:expr< try $e$ with [ $list:l$ ] >> - | "try"; e = SELF; "with"; p1 = ipatt; "->"; e1 = SELF -> - <:expr< try $e$ with $p1$ -> $e1$ >> - | "if"; e1 = SELF; "then"; e2 = SELF; "else"; e3 = SELF -> - <:expr< if $e1$ then $e2$ else $e3$ >> - | "do"; "{"; seq = sequence; "}" -> mksequence _loc seq - | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF; - "do"; "{"; seq = sequence; "}" -> - <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:seq$ } >> - | "while"; e = SELF; "do"; "{"; seq = sequence; "}" -> - <:expr< while $e$ do { $list:seq$ } >> - | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" -> - (* <:expr< object $opt:cspo$ $list:cf$ end >> *) - MLast.ExObj _loc cspo cf ] - | "where" - [ e = SELF; "where"; rf = OPT "rec"; lb = let_binding -> - <:expr< let $opt:o2b rf$ $list:[lb]$ in $e$ >> ] - | ":=" NONA - [ e1 = SELF; ":="; e2 = SELF; dummy -> <:expr< $e1$ := $e2$ >> ] - | "||" RIGHTA - [ e1 = SELF; "||"; e2 = SELF -> <:expr< $e1$ || $e2$ >> ] - | "&&" RIGHTA - [ e1 = SELF; "&&"; e2 = SELF -> <:expr< $e1$ && $e2$ >> ] - | "<" LEFTA - [ e1 = SELF; "<"; e2 = SELF -> <:expr< $e1$ < $e2$ >> - | e1 = SELF; ">"; e2 = SELF -> <:expr< $e1$ > $e2$ >> - | e1 = SELF; "<="; e2 = SELF -> <:expr< $e1$ <= $e2$ >> - | e1 = SELF; ">="; e2 = SELF -> <:expr< $e1$ >= $e2$ >> - | e1 = SELF; "="; e2 = SELF -> <:expr< $e1$ = $e2$ >> - | e1 = SELF; "<>"; e2 = SELF -> <:expr< $e1$ <> $e2$ >> - | e1 = SELF; "=="; e2 = SELF -> <:expr< $e1$ == $e2$ >> - | e1 = SELF; "!="; e2 = SELF -> <:expr< $e1$ != $e2$ >> ] - | "^" RIGHTA - [ e1 = SELF; "^"; e2 = SELF -> <:expr< $e1$ ^ $e2$ >> - | e1 = SELF; "@"; e2 = SELF -> <:expr< $e1$ @ $e2$ >> ] - | "+" LEFTA - [ e1 = SELF; "+"; e2 = SELF -> <:expr< $e1$ + $e2$ >> - | e1 = SELF; "-"; e2 = SELF -> <:expr< $e1$ - $e2$ >> - | e1 = SELF; "+."; e2 = SELF -> <:expr< $e1$ +. $e2$ >> - | e1 = SELF; "-."; e2 = SELF -> <:expr< $e1$ -. $e2$ >> ] - | "*" LEFTA - [ e1 = SELF; "*"; e2 = SELF -> <:expr< $e1$ * $e2$ >> - | e1 = SELF; "/"; e2 = SELF -> <:expr< $e1$ / $e2$ >> - | e1 = SELF; "*."; e2 = SELF -> <:expr< $e1$ *. $e2$ >> - | e1 = SELF; "/."; e2 = SELF -> <:expr< $e1$ /. $e2$ >> - | e1 = SELF; "land"; e2 = SELF -> <:expr< $e1$ land $e2$ >> - | e1 = SELF; "lor"; e2 = SELF -> <:expr< $e1$ lor $e2$ >> - | e1 = SELF; "lxor"; e2 = SELF -> <:expr< $e1$ lxor $e2$ >> - | e1 = SELF; "mod"; e2 = SELF -> <:expr< $e1$ mod $e2$ >> ] - | "**" RIGHTA - [ e1 = SELF; "**"; e2 = SELF -> <:expr< $e1$ ** $e2$ >> - | e1 = SELF; "asr"; e2 = SELF -> <:expr< $e1$ asr $e2$ >> - | e1 = SELF; "lsl"; e2 = SELF -> <:expr< $e1$ lsl $e2$ >> - | e1 = SELF; "lsr"; e2 = SELF -> <:expr< $e1$ lsr $e2$ >> ] - | "unary minus" NONA - [ "-"; e = SELF -> mkumin _loc "-" e - | "-."; e = SELF -> mkumin _loc "-." e ] - | "apply" LEFTA - [ e1 = SELF; e2 = SELF -> <:expr< $e1$ $e2$ >> - | "assert"; e = SELF -> mkassert _loc e - | "lazy"; e = SELF -> <:expr< lazy ($e$) >> ] - | "." LEFTA - [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >> - | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >> - | e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> ] - | "~-" NONA - [ "~-"; e = SELF -> <:expr< ~- $e$ >> - | "~-."; e = SELF -> <:expr< ~-. $e$ >> ] - | "simple" - [ s = INT -> <:expr< $int:s$ >> - | s = INT32 -> MLast.ExInt32 _loc s - | s = INT64 -> MLast.ExInt64 _loc s - | s = NATIVEINT -> MLast.ExNativeInt _loc s - | s = FLOAT -> <:expr< $flo:s$ >> - | s = STRING -> <:expr< $str:s$ >> - | s = CHAR -> <:expr< $chr:s$ >> - | ids = expr_ident -> mkexprident _loc ids - | "["; "]" -> <:expr< [] >> - | "["; el = LIST1 expr SEP ";"; last = cons_expr_opt; "]" -> - mklistexp _loc last el - | "[|"; el = LIST0 expr SEP ";"; "|]" -> <:expr< [| $list:el$ |] >> - | "{"; lel = LIST1 label_expr SEP ";"; "}" -> <:expr< { $list:lel$ } >> - | "{"; "("; e = SELF; ")"; "with"; lel = LIST1 label_expr SEP ";"; "}" - -> <:expr< { ($e$) with $list:lel$ } >> - | "("; ")" -> <:expr< () >> - | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >> - | "("; e = SELF; ","; el = LIST1 expr SEP ","; ")" -> - <:expr< ( $list:[e::el]$) >> - | "("; e = SELF; ")" -> <:expr< $e$ >> ] ] - ; - cons_expr_opt: - [ [ "::"; e = expr -> Some e - | -> None ] ] - ; - dummy: - [ [ -> () ] ] - ; - sequence: - [ [ "let"; rf = OPT "rec"; l = LIST1 let_binding SEP "and"; [ "in" | ";" ]; - el = SELF -> - [<:expr< let $opt:o2b rf$ $list:l$ in $mksequence _loc el$ >>] - | e = expr; ";"; el = SELF -> [e :: el] - | e = expr; ";" -> [e] - | e = expr -> [e] ] ] - ; - let_binding: - [ [ p = ipatt; e = fun_binding -> (p, e) ] ] - ; - fun_binding: - [ RIGHTA - [ p = ipatt; e = SELF -> <:expr< fun $p$ -> $e$ >> - | "="; e = expr -> <:expr< $e$ >> - | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> - | ":>"; t = ctyp; "="; e = expr -> <:expr< ($e$ :> $t$) >> ] ] - ; - match_case: - [ [ p = patt; aso = as_patt_opt; w = when_expr_opt; "->"; e = expr -> - mkmatchcase _loc p aso w e ] ] - ; - as_patt_opt: - [ [ "as"; p = patt -> Some p - | -> None ] ] - ; - when_expr_opt: - [ [ "when"; e = expr -> Some e - | -> None ] ] - ; - label_expr: - [ [ i = patt_label_ident; e = fun_binding -> (i, e) ] ] - ; - expr_ident: - [ RIGHTA - [ i = LIDENT -> [ <:expr< $lid:i$ >> ] - | i = UIDENT -> [ <:expr< $uid:i$ >> ] - | i = UIDENT; "."; j = SELF -> [ <:expr< $uid:i$ >> :: j ] ] ] - ; - fun_def: - [ RIGHTA - [ p = ipatt; e = SELF -> <:expr< fun $p$ -> $e$ >> - | "->"; e = expr -> e ] ] - ; - patt: - [ LEFTA - [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ] - | NONA - [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ] - | LEFTA - [ p1 = SELF; p2 = SELF -> <:patt< $p1$ $p2$ >> ] - | LEFTA - [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ] - | "simple" - [ s = LIDENT -> <:patt< $lid:s$ >> - | s = UIDENT -> <:patt< $uid:s$ >> - | s = INT -> <:patt< $int:s$ >> - | s = INT32 -> MLast.PaInt32 _loc s - | s = INT64 -> MLast.PaInt64 _loc s - | s = NATIVEINT -> MLast.PaNativeInt _loc s - | s = FLOAT -> <:patt< $flo:s$ >> - | s = STRING -> <:patt< $str:s$ >> - | s = CHAR -> <:patt< $chr:s$ >> - | "-"; s = INT -> MLast.PaInt _loc (neg_string s) - | "-"; s = INT32 -> MLast.PaInt32 _loc (neg_string s) - | "-"; s = INT64 -> MLast.PaInt64 _loc (neg_string s) - | "-"; s = NATIVEINT -> MLast.PaNativeInt _loc (neg_string s) - | "-"; s = FLOAT -> <:patt< $flo:neg_string s$ >> - | "["; "]" -> <:patt< [] >> - | "["; pl = LIST1 patt SEP ";"; last = cons_patt_opt; "]" -> - mklistpat _loc last pl - | "[|"; pl = LIST0 patt SEP ";"; "|]" -> <:patt< [| $list:pl$ |] >> - | "{"; lpl = LIST1 label_patt SEP ";"; "}" -> <:patt< { $list:lpl$ } >> - | "("; ")" -> <:patt< () >> - | "("; p = SELF; ")" -> <:patt< $p$ >> - | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> - | "("; p = SELF; "as"; p2 = SELF; ")" -> <:patt< ($p$ as $p2$) >> - | "("; p = SELF; ","; pl = LIST1 patt SEP ","; ")" -> - <:patt< ( $list:[p::pl]$) >> - | "_" -> <:patt< _ >> ] ] - ; - cons_patt_opt: - [ [ "::"; p = patt -> Some p - | -> None ] ] - ; - label_patt: - [ [ i = patt_label_ident; "="; p = patt -> (i, p) ] ] - ; - patt_label_ident: - [ LEFTA - [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ] - | "simple" RIGHTA - [ i = UIDENT -> <:patt< $uid:i$ >> - | i = LIDENT -> <:patt< $lid:i$ >> ] ] - ; - ipatt: - [ [ "{"; lpl = LIST1 label_ipatt SEP ";"; "}" -> <:patt< { $list:lpl$ } >> - | "("; ")" -> <:patt< () >> - | "("; p = SELF; ")" -> <:patt< $p$ >> - | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> - | "("; p = SELF; "as"; p2 = SELF; ")" -> <:patt< ($p$ as $p2$) >> - | "("; p = SELF; ","; pl = LIST1 ipatt SEP ","; ")" -> - <:patt< ( $list:[p::pl]$) >> - | s = LIDENT -> <:patt< $lid:s$ >> - | "_" -> <:patt< _ >> ] ] - ; - label_ipatt: - [ [ i = patt_label_ident; "="; p = ipatt -> (i, p) ] ] - ; - type_declaration: - [ [ n = type_patt; tpl = LIST0 type_parameter; "="; tk = ctyp; - cl = LIST0 constrain -> - (n, tpl, tk, cl) ] ] - ; - type_patt: - [ [ n = LIDENT -> (_loc, n) ] ] - ; - constrain: - [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ] - ; - type_parameter: - [ [ "'"; i = ident -> (i, (False, False)) - | "+"; "'"; i = ident -> (i, (True, False)) - | "-"; "'"; i = ident -> (i, (False, True)) ] ] - ; - ctyp: - [ LEFTA - [ t1 = SELF; "=="; t2 = SELF -> <:ctyp< $t1$ == $t2$ >> ] - | NONA - [ "private"; t = ctyp LEVEL "alias" -> <:ctyp< private $t$ >> ] - | "alias" LEFTA - [ t1 = SELF; "as"; t2 = SELF -> <:ctyp< $t1$ as $t2$ >> ] - | LEFTA - [ "!"; pl = LIST1 typevar; "."; t = ctyp -> - <:ctyp< ! $list:pl$ . $t$ >> ] - | "arrow" RIGHTA - [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ] - | "label" NONA - [ i = TILDEIDENT; ":"; t = SELF -> <:ctyp< ~ $i$ : $t$ >> - | i = LABEL; t = SELF -> <:ctyp< ~ $i$ : $t$ >> - | i = QUESTIONIDENT; ":"; t = SELF -> <:ctyp< ? $i$ : $t$ >> - | i = OPTLABEL; t = SELF -> <:ctyp< ? $i$ : $t$ >> ] - | LEFTA - [ t1 = SELF; t2 = SELF -> <:ctyp< $t1$ $t2$ >> ] - | LEFTA - [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >> ] - | "simple" - [ "'"; i = ident -> <:ctyp< '$i$ >> - | "_" -> <:ctyp< _ >> - | i = LIDENT -> <:ctyp< $lid:i$ >> - | i = UIDENT -> <:ctyp< $uid:i$ >> - | "("; t = SELF; "*"; tl = LIST1 ctyp SEP "*"; ")" -> - <:ctyp< ( $list:[t::tl]$ ) >> - | "("; t = SELF; ")" -> <:ctyp< $t$ >> - | "["; cdl = LIST0 constructor_declaration SEP "|"; "]" -> - <:ctyp< [ $list:cdl$ ] >> - (* MLast.TySum _loc cdl *) - | "{"; ldl = LIST1 label_declaration SEP ";"; "}" -> - <:ctyp< { $list:ldl$ } >> - (* MLast.TyRec _loc ldl *) ] ] - ; - constructor_declaration: - [ [ ci = UIDENT; "of"; cal = LIST1 ctyp SEP "and" -> (_loc, ci, cal) - | ci = UIDENT -> (_loc, ci, []) ] ] - ; - label_declaration: - [ [ i = LIDENT; ":"; mf = OPT "mutable"; t = ctyp -> - (_loc, i, o2b mf, t) ] ] - ; - ident: - [ [ i = LIDENT -> i - | i = UIDENT -> i ] ] - ; - mod_ident: - [ RIGHTA - [ i = UIDENT -> [i] - | i = LIDENT -> [i] - | i = UIDENT; "."; j = SELF -> [i :: j] ] ] - ; - (* Objects and Classes *) - str_item: - [ [ "class"; cd = LIST1 class_declaration SEP "and" -> - <:str_item< class $list:cd$ >> - | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" -> - <:str_item< class type $list:ctd$ >> ] ] - ; - sig_item: - [ [ "class"; cd = LIST1 class_description SEP "and" -> - <:sig_item< class $list:cd$ >> - | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" -> - <:sig_item< class type $list:ctd$ >> ] ] - ; - class_declaration: - [ [ vf = OPT "virtual"; i = LIDENT; ctp = class_type_parameters; - cfb = class_fun_binding -> - {MLast.ciLoc = _loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = i; MLast.ciExp = cfb} ] ] - ; - class_fun_binding: - [ [ "="; ce = class_expr -> ce - | ":"; ct = class_type; "="; ce = class_expr -> - <:class_expr< ($ce$ : $ct$) >> - | p = ipatt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ] - ; - class_type_parameters: - [ [ -> (_loc, []) - | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (_loc, tpl) ] ] - ; - class_fun_def: - [ [ p = ipatt; ce = SELF -> <:class_expr< fun $p$ -> $ce$ >> - | "->"; ce = class_expr -> ce ] ] - ; - class_expr: - [ "top" - [ "fun"; p = ipatt; ce = class_fun_def -> - <:class_expr< fun $p$ -> $ce$ >> - | "let"; rf = OPT "rec"; lb = LIST1 let_binding SEP "and"; "in"; - ce = SELF -> - <:class_expr< let $opt:o2b rf$ $list:lb$ in $ce$ >> ] - | "apply" NONA - [ ce = SELF; e = expr LEVEL "label" -> - <:class_expr< $ce$ $e$ >> ] - | "simple" - [ ci = class_longident; "["; ctcl = LIST0 ctyp SEP ","; "]" -> - <:class_expr< $list:ci$ [ $list:ctcl$ ] >> - | ci = class_longident -> <:class_expr< $list:ci$ >> - | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" -> - <:class_expr< object $opt:cspo$ $list:cf$ end >> - | "("; ce = SELF; ":"; ct = class_type; ")" -> - <:class_expr< ($ce$ : $ct$) >> - | "("; ce = SELF; ")" -> ce ] ] - ; - class_structure: - [ [ cf = LIST0 [ cf = class_str_item; ";" -> cf ] -> cf ] ] - ; - class_self_patt: - [ [ "("; p = patt; ")" -> p - | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ] ] - ; - class_str_item: - [ [ "declare"; st = LIST0 [ s= class_str_item; ";" -> s ]; "end" -> - <:class_str_item< declare $list:st$ end >> - | "inherit"; ce = class_expr; pb = OPT as_lident -> - <:class_str_item< inherit $ce$ $opt:pb$ >> - | "value"; mf = OPT "mutable"; lab = label; e = cvalue_binding -> - <:class_str_item< value $opt:o2b mf$ $lab$ = $e$ >> - | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp -> - <:class_str_item< method virtual $opt:o2b pf$ $l$ : $t$ >> - | "method"; pf = OPT "private"; l = label; topt = OPT polyt; - e = fun_binding -> - <:class_str_item< method $opt:o2b pf$ $l$ $opt:topt$ = $e$ >> - | "type"; t1 = ctyp; "="; t2 = ctyp -> - <:class_str_item< type $t1$ = $t2$ >> - | "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ] - ; - as_lident: - [ [ "as"; i = LIDENT -> i ] ] - ; - polyt: - [ [ ":"; t = ctyp -> t ] ] - ; - cvalue_binding: - [ [ "="; e = expr -> e - | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> - | ":"; t = ctyp; ":>"; t2 = ctyp; "="; e = expr -> - <:expr< ($e$ : $t$ :> $t2$) >> - | ":>"; t = ctyp; "="; e = expr -> <:expr< ($e$ :> $t$) >> ] ] - ; - label: - [ [ i = LIDENT -> i ] ] - ; - class_type: - [ [ "["; t = ctyp; "]"; "->"; ct = SELF -> - <:class_type< [ $t$ ] -> $ct$ >> - | id = clty_longident; "["; tl = LIST1 ctyp SEP ","; "]" -> - <:class_type< $list:id$ [ $list:tl$ ] >> - | id = clty_longident -> <:class_type< $list:id$ >> - | "object"; cst = OPT class_self_type; - csf = LIST0 [ csf = class_sig_item; ";" -> csf ]; "end" -> - <:class_type< object $opt:cst$ $list:csf$ end >> ] ] - ; - class_self_type: - [ [ "("; t = ctyp; ")" -> t ] ] - ; - class_sig_item: - [ [ "declare"; st = LIST0 [ s = class_sig_item; ";" -> s ]; "end" -> - <:class_sig_item< declare $list:st$ end >> - | "inherit"; cs = class_type -> <:class_sig_item< inherit $cs$ >> - | "value"; mf = OPT "mutable"; l = label; ":"; t = ctyp -> - <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >> - | "method"; "virtual"; pf = OPT "private"; l = label; ":"; t = ctyp -> - <:class_sig_item< method virtual $opt:o2b pf$ $l$ : $t$ >> - | "method"; pf = OPT "private"; l = label; ":"; t = ctyp -> - <:class_sig_item< method $opt:o2b pf$ $l$ : $t$ >> - | "type"; t1 = ctyp; "="; t2 = ctyp -> - <:class_sig_item< type $t1$ = $t2$ >> ] ] - ; - class_description: - [ [ vf = OPT "virtual"; n = LIDENT; ctp = class_type_parameters; ":"; - ct = class_type -> - {MLast.ciLoc = _loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = ct} ] ] - ; - class_type_declaration: - [ [ vf = OPT "virtual"; n = LIDENT; ctp = class_type_parameters; "="; - cs = class_type -> - {MLast.ciLoc = _loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = cs} ] ] - ; - expr: LEVEL "apply" - [ LEFTA - [ "new"; i = class_longident -> <:expr< new $list:i$ >> ] ] - ; - expr: LEVEL "." - [ [ e = SELF; "#"; lab = label -> <:expr< $e$ # $lab$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" -> - <:expr< ($e$ : $t$ :> $t2$ ) >> - | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >> - | "{<"; fel = LIST0 field_expr SEP ";"; ">}" -> - <:expr< {< $list:fel$ >} >> ] ] - ; - field_expr: - [ [ l = label; "="; e = expr -> (l, e) ] ] - ; - ctyp: LEVEL "simple" - [ [ "#"; id = class_longident -> <:ctyp< # $list:id$ >> - | "<"; (ml, v) = meth_list; ">" -> <:ctyp< < $list:ml$ $opt:v$ > >> - | "<"; ">" -> <:ctyp< < > >> ] ] - ; - meth_list: - [ [ f = field; ";"; (ml, v) = SELF -> ([f :: ml], v) - | f = field; ";" -> ([f], False) - | f = field -> ([f], False) - | ".." -> ([], True) ] ] - ; - field: - [ [ lab = LIDENT; ":"; t = ctyp -> (lab, t) ] ] - ; - typevar: - [ [ "'"; i = ident -> i ] ] - ; - clty_longident: - [ [ m = UIDENT; "."; l = SELF -> [m :: l] - | i = LIDENT -> [i] ] ] - ; - class_longident: - [ [ m = UIDENT; "."; l = SELF -> [m :: l] - | i = LIDENT -> [i] ] ] - ; - ctyp: LEVEL "simple" - [ [ "["; "="; rfl = row_field_list; "]" -> - <:ctyp< [ = $list:rfl$ ] >> - | "["; ">"; rfl = row_field_list; "]" -> - <:ctyp< [ > $list:rfl$ ] >> - | "["; "<"; rfl = row_field_list; "]" -> - <:ctyp< [ < $list:rfl$ ] >> - | "["; "<"; rfl = row_field_list; ">"; ntl = LIST1 name_tag; "]" -> - <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> - | "[<"; rfl = row_field_list; "]" -> - <:ctyp< [ < $list:rfl$ ] >> - | "[<"; rfl = row_field_list; ">"; ntl = LIST1 name_tag; "]" -> - <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ] - ; - row_field_list: - [ [ rfl = LIST0 row_field SEP "|" -> rfl ] ] - ; - row_field: - [ [ "`"; i = ident -> <:row_field< ` $i$ >> - | "`"; i = ident; "of"; ao = OPT "&"; l = LIST1 ctyp SEP "&" -> - <:row_field< ` $i$ of $opt:o2b ao$ $list:l$ >> - | t = ctyp -> <:row_field< $t$ >> ] ] - ; - name_tag: - [ [ "`"; i = ident -> i ] ] - ; - patt: LEVEL "simple" - [ [ "`"; s = ident -> <:patt< ` $s$ >> - | "#"; sl = mod_ident -> <:patt< # $list:sl$ >> - | i = TILDEIDENT; ":"; p = SELF -> <:patt< ~ $i$ : $p$ >> - | i = LABEL; p = SELF -> <:patt< ~ $i$ : $p$ >> - | i = TILDEIDENT -> <:patt< ~ $i$ >> - | i = QUESTIONIDENT; ":"; "("; p = patt_tcon; eo = OPT eq_expr; ")" -> - <:patt< ? $i$ : ($p$ $opt:eo$) >> - | i = OPTLABEL; "("; p = patt_tcon; eo = OPT eq_expr; ")" -> - <:patt< ? $i$ : ($p$ $opt:eo$) >> - | i = QUESTIONIDENT -> - <:patt< ? $i$ >> - | "?"; "("; p = patt_tcon; eo = OPT eq_expr; ")" -> - <:patt< ? ($p$ $opt:eo$) >> ] ] - ; - patt_tcon: - [ [ p = patt; ":"; t = ctyp -> <:patt< ($p$ : $t$) >> - | p = patt -> p ] ] - ; - ipatt: - [ [ i = TILDEIDENT; ":"; p = SELF -> <:patt< ~ $i$ : $p$ >> - | i = LABEL; p = SELF -> <:patt< ~ $i$ : $p$ >> - | i = TILDEIDENT -> <:patt< ~ $i$ >> - | i = QUESTIONIDENT; ":"; "("; p = ipatt_tcon; eo = OPT eq_expr; ")" -> - <:patt< ? $i$ : ($p$ $opt:eo$) >> - | i = OPTLABEL; "("; p = ipatt_tcon; eo = OPT eq_expr; ")" -> - <:patt< ? $i$ : ($p$ $opt:eo$) >> - | i = QUESTIONIDENT -> - <:patt< ? $i$ >> - | "?"; "("; p = ipatt_tcon; eo = OPT eq_expr; ")" -> - <:patt< ? ($p$ $opt:eo$) >> ] ] - ; - ipatt_tcon: - [ [ p = ipatt; ":"; t = ctyp -> <:patt< ($p$ : $t$) >> - | p = ipatt -> p ] ] - ; - eq_expr: - [ [ "="; e = expr -> e ] ] - ; - expr: AFTER "apply" - [ "label" NONA - [ i = TILDEIDENT; ":"; e = SELF -> <:expr< ~ $i$ : $e$ >> - | i = LABEL; e = SELF -> <:expr< ~ $i$ : $e$ >> - | i = TILDEIDENT -> <:expr< ~ $i$ >> - | i = QUESTIONIDENT; ":"; e = SELF -> <:expr< ? $i$ : $e$ >> - | i = OPTLABEL; e = SELF -> <:expr< ? $i$ : $e$ >> - | i = QUESTIONIDENT -> <:expr< ? $i$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "`"; s = ident -> <:expr< ` $s$ >> ] ] - ; - direction_flag: - [ [ "to" -> True - | "downto" -> False ] ] - ; - (* Compatibility old syntax of variant types definitions *) - ctyp: LEVEL "simple" - [ [ "[|"; warning_variant; rfl = row_field_list; "|]" -> - <:ctyp< [ = $list:rfl$ ] >> - | "[|"; warning_variant; ">"; rfl = row_field_list; "|]" -> - <:ctyp< [ > $list:rfl$ ] >> - | "[|"; warning_variant; "<"; rfl = row_field_list; "|]" -> - <:ctyp< [ < $list:rfl$ ] >> - | "[|"; warning_variant; "<"; rfl = row_field_list; ">"; - ntl = LIST1 name_tag; "|]" -> - <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ] - ; - warning_variant: - [ [ -> warn_variant _loc ] ] - ; - (* Compatibility old syntax of sequences *) - expr: LEVEL "top" - [ [ "do"; seq = LIST0 [ e = expr; ";" -> e ]; "return"; warning_sequence; - e = SELF -> - <:expr< do { $list:append_elem seq e$ } >> - | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF; - "do"; seq = LIST0 [ e = expr; ";" -> e ]; warning_sequence; "done" -> - <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:seq$ } >> - | "while"; e = SELF; "do"; seq = LIST0 [ e = expr; ";" -> e ]; - warning_sequence; "done" -> - <:expr< while $e$ do { $list:seq$ } >> ] ] - ; - warning_sequence: - [ [ -> warn_sequence _loc ] ] - ; -END; - -EXTEND - GLOBAL: interf implem use_file top_phrase expr patt; - interf: - [ [ "#"; n = LIDENT; dp = OPT expr; ";" -> - ([(<:sig_item< # $n$ $opt:dp$ >>, _loc)], True) - | si = sig_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped) - | EOI -> ([], False) ] ] - ; - sig_item_semi: - [ [ si = sig_item; ";" -> (si, _loc) ] ] - ; - implem: - [ [ "#"; n = LIDENT; dp = OPT expr; ";" -> - ([(<:str_item< # $n$ $opt:dp$ >>, _loc)], True) - | si = str_item_semi; (sil, stopped) = SELF -> ([si :: sil], stopped) - | EOI -> ([], False) ] ] - ; - str_item_semi: - [ [ si = str_item; ";" -> (si, _loc) ] ] - ; - top_phrase: - [ [ ph = phrase -> Some ph - | EOI -> None ] ] - ; - use_file: - [ [ "#"; n = LIDENT; dp = OPT expr; ";" -> - ([<:str_item< # $n$ $opt:dp$ >>], True) - | si = str_item; ";"; (sil, stopped) = SELF -> ([si :: sil], stopped) - | EOI -> ([], False) ] ] - ; - phrase: - [ [ "#"; n = LIDENT; dp = OPT expr; ";" -> - <:str_item< # $n$ $opt:dp$ >> - | sti = str_item; ";" -> sti ] ] - ; - expr: LEVEL "simple" - [ [ x = LOCATE -> - let x = - try - let i = String.index x ':' in - ({ (Lexing.dummy_pos) with Lexing.pos_cnum = int_of_string (String.sub x 0 i) } - , - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found | Failure _ -> ({(Lexing.dummy_pos) with Lexing.pos_cnum = 0}, x) ] - in - Pcaml.handle_expr_locate _loc x - | x = QUOTATION -> - let x = - try - let i = String.index x ':' in - (String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found -> ("", x) ] - in - Pcaml.handle_expr_quotation _loc x ] ] - ; - patt: LEVEL "simple" - [ [ x = LOCATE -> - let x = - try - let i = String.index x ':' in - ({(Lexing.dummy_pos) with Lexing.pos_cnum = int_of_string (String.sub x 0 i)} - , - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found | Failure _ -> ({(Lexing.dummy_pos) with Lexing.pos_cnum = 0}, x) ] - in - Pcaml.handle_patt_locate _loc x - | x = QUOTATION -> - let x = - try - let i = String.index x ':' in - (String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found -> ("", x) ] - in - Pcaml.handle_patt_quotation _loc x ] ] - ; -END; diff --git a/camlp4/meta/pa_rp.ml b/camlp4/meta/pa_rp.ml deleted file mode 100644 index b77847ed..00000000 --- a/camlp4/meta/pa_rp.ml +++ /dev/null @@ -1,318 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: pa_rp.ml,v 1.8 2004/11/17 09:07:56 mauny Exp $ *) - -open Pcaml; - -type spat_comp = - [ SpTrm of MLast.loc and MLast.patt and option MLast.expr - | SpNtr of MLast.loc and MLast.patt and MLast.expr - | SpStr of MLast.loc and MLast.patt ] -; -type sexp_comp = - [ SeTrm of MLast.loc and MLast.expr | SeNtr of MLast.loc and MLast.expr ] -; - -value strm_n = "strm__"; -value peek_fun _loc = <:expr< Stream.peek >>; -value junk_fun _loc = <:expr< Stream.junk >>; - -(* Parsers. *) -(* In syntax generated, many cases are optimisations. *) - -value rec pattern_eq_expression p e = - match (p, e) with - [ (<:patt< $lid:a$ >>, <:expr< $lid:b$ >>) -> a = b - | (<:patt< $uid:a$ >>, <:expr< $uid:b$ >>) -> a = b - | (<:patt< $p1$ $p2$ >>, <:expr< $e1$ $e2$ >>) -> - pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2 - | _ -> False ] -; - -value is_raise e = - match e with - [ <:expr< raise $_$ >> -> True - | _ -> False ] -; - -value is_raise_failure e = - match e with - [ <:expr< raise Stream.Failure >> -> True - | _ -> False ] -; - -value rec handle_failure e = - match e with - [ <:expr< try $te$ with [ Stream.Failure -> $e$] >> -> handle_failure e - | <:expr< match $me$ with [ $list:pel$ ] >> -> - handle_failure me && - List.for_all - (fun - [ (_, None, e) -> handle_failure e - | _ -> False ]) - pel - | <:expr< let $list:pel$ in $e$ >> -> - List.for_all (fun (p, e) -> handle_failure e) pel && handle_failure e - | <:expr< $lid:_$ >> | <:expr< $int:_$ >> | <:expr< $str:_$ >> | - <:expr< $chr:_$ >> | <:expr< fun [ $list:_$ ] >> | <:expr< $uid:_$ >> -> - True - | <:expr< raise $e$ >> -> - match e with - [ <:expr< Stream.Failure >> -> False - | _ -> True ] - | <:expr< $f$ $x$ >> -> - is_constr_apply f && handle_failure f && handle_failure x - | _ -> False ] -and is_constr_apply = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $lid:_$ >> -> False - | <:expr< $x$ $_$ >> -> is_constr_apply x - | _ -> False ] -; - -value rec subst v e = - let _loc = MLast.loc_of_expr e in - match e with - [ <:expr< $lid:x$ >> -> - let x = if x = v then strm_n else x in <:expr< $lid:x$ >> - | <:expr< $uid:_$ >> -> e - | <:expr< $int:_$ >> -> e - | <:expr< $chr:_$ >> -> e - | <:expr< $str:_$ >> -> e - | <:expr< $_$.$_$ >> -> e - | <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> - <:expr< let $opt:rf$ $list:List.map (subst_pe v) pel$ in $subst v e$ >> - | <:expr< $e1$ $e2$ >> -> <:expr< $subst v e1$ $subst v e2$ >> - | <:expr< ( $list:el$ ) >> -> <:expr< ( $list:List.map (subst v) el$ ) >> - | _ -> raise Not_found ] -and subst_pe v (p, e) = - match p with - [ <:patt< $lid:v'$ >> when v <> v' -> (p, subst v e) - | _ -> raise Not_found ] -; - -value stream_pattern_component skont ckont = - fun - [ SpTrm _loc p wo -> - <:expr< match $peek_fun _loc$ $lid:strm_n$ with - [ Some $p$ $when:wo$ -> - do { $junk_fun _loc$ $lid:strm_n$; $skont$ } - | _ -> $ckont$ ] >> - | SpNtr _loc p e -> - let e = - match e with - [ <:expr< fun [ ($lid:v$ : Stream.t _) -> $e$ ] >> when v = strm_n -> e - | _ -> <:expr< $e$ $lid:strm_n$ >> ] - in - if pattern_eq_expression p skont then - if is_raise_failure ckont then e - else if handle_failure e then e - else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> - else if is_raise_failure ckont then <:expr< let $p$ = $e$ in $skont$ >> - else if pattern_eq_expression <:patt< Some $p$ >> skont then - <:expr< try Some $e$ with [ Stream.Failure -> $ckont$ ] >> - else if is_raise ckont then - let tst = - if handle_failure e then e - else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> - in - <:expr< let $p$ = $tst$ in $skont$ >> - else - <:expr< match try Some $e$ with [ Stream.Failure -> None ] with - [ Some $p$ -> $skont$ - | _ -> $ckont$ ] >> - | SpStr _loc p -> - try - match p with - [ <:patt< $lid:v$ >> -> subst v skont - | _ -> raise Not_found ] - with - [ Not_found -> <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ] ] -; - -value rec stream_pattern _loc epo e ekont = - fun - [ [] -> - match epo with - [ Some ep -> <:expr< let $ep$ = Stream.count $lid:strm_n$ in $e$ >> - | _ -> e ] - | [(spc, err) :: spcl] -> - let skont = - let ekont err = - let str = - match err with - [ Some estr -> estr - | _ -> <:expr< "" >> ] - in - <:expr< raise (Stream.Error $str$) >> - in - stream_pattern _loc epo e ekont spcl - in - let ckont = ekont err in stream_pattern_component skont ckont spc ] -; - -value stream_patterns_term _loc ekont tspel = - let pel = - List.map - (fun (p, w, _loc, spcl, epo, e) -> - let p = <:patt< Some $p$ >> in - let e = - let ekont err = - let str = - match err with - [ Some estr -> estr - | _ -> <:expr< "" >> ] - in - <:expr< raise (Stream.Error $str$) >> - in - let skont = stream_pattern _loc epo e ekont spcl in - <:expr< do { $junk_fun _loc$ $lid:strm_n$; $skont$ } >> - in - (p, w, e)) - tspel - in - let pel = pel @ [(<:patt< _ >>, None, ekont ())] in - <:expr< match $peek_fun _loc$ $lid:strm_n$ with [ $list:pel$ ] >> -; - -value rec group_terms = - fun - [ [([(SpTrm _loc p w, None) :: spcl], epo, e) :: spel] -> - let (tspel, spel) = group_terms spel in - ([(p, w, _loc, spcl, epo, e) :: tspel], spel) - | spel -> ([], spel) ] -; - -value rec parser_cases _loc = - fun - [ [] -> <:expr< raise Stream.Failure >> - | spel -> - match group_terms spel with - [ ([], [(spcl, epo, e) :: spel]) -> - stream_pattern _loc epo e (fun _ -> parser_cases _loc spel) spcl - | (tspel, spel) -> - stream_patterns_term _loc (fun _ -> parser_cases _loc spel) tspel ] ] -; - -value cparser _loc bpo pc = - let e = parser_cases _loc pc in - let e = - match bpo with - [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >> - | None -> e ] - in - let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in <:expr< fun $p$ -> $e$ >> -; - -value cparser_match _loc me bpo pc = - let pc = parser_cases _loc pc in - let e = - match bpo with - [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >> - | None -> pc ] - in - match me with - [ <:expr< $lid:x$ >> when x = strm_n -> e - | _ -> <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >> ] -; - -(* streams *) - -value rec not_computing = - fun - [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $int:_$ >> | - <:expr< $flo:_$ >> | <:expr< $chr:_$ >> | <:expr< $str:_$ >> -> - True - | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y - | _ -> False ] -and is_cons_apply_not_computing = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $lid:_$ >> -> False - | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y - | _ -> False ] -; - -value slazy _loc e = - match e with - [ <:expr< $f$ () >> -> - match f with - [ <:expr< $lid:_$ >> -> f - | _ -> <:expr< fun _ -> $e$ >> ] - | _ -> <:expr< fun _ -> $e$ >> ] -; - -value rec cstream gloc = - fun - [ [] -> let _loc = gloc in <:expr< Stream.sempty >> - | [SeTrm _loc e] -> - if not_computing e then <:expr< Stream.ising $e$ >> - else <:expr< Stream.lsing $slazy _loc e$ >> - | [SeTrm _loc e :: secl] -> - if not_computing e then <:expr< Stream.icons $e$ $cstream gloc secl$ >> - else <:expr< Stream.lcons $slazy _loc e$ $cstream gloc secl$ >> - | [SeNtr _loc e] -> - if not_computing e then e else <:expr< Stream.slazy $slazy _loc e$ >> - | [SeNtr _loc e :: secl] -> - if not_computing e then <:expr< Stream.iapp $e$ $cstream gloc secl$ >> - else <:expr< Stream.lapp $slazy _loc e$ $cstream gloc secl$ >> ] -; - -(* Syntax extensions in Revised Syntax grammar *) - -EXTEND - GLOBAL: expr; - expr: LEVEL "top" - [ [ "parser"; po = OPT ipatt; "["; pcl = LIST0 parser_case SEP "|"; "]" -> - <:expr< $cparser _loc po pcl$ >> - | "parser"; po = OPT ipatt; pc = parser_case -> - <:expr< $cparser _loc po [pc]$ >> - | "match"; e = SELF; "with"; "parser"; po = OPT ipatt; "["; - pcl = LIST0 parser_case SEP "|"; "]" -> - <:expr< $cparser_match _loc e po pcl$ >> - | "match"; e = SELF; "with"; "parser"; po = OPT ipatt; - pc = parser_case -> - <:expr< $cparser_match _loc e po [pc]$ >> ] ] - ; - parser_case: - [ [ "[:"; sp = stream_patt; ":]"; po = OPT ipatt; "->"; e = expr -> - (sp, po, e) ] ] - ; - stream_patt: - [ [ spc = stream_patt_comp -> [(spc, None)] - | spc = stream_patt_comp; ";"; - sp = LIST1 stream_patt_comp_err SEP ";" -> - [(spc, None) :: sp] - | -> [] ] ] - ; - stream_patt_comp_err: - [ [ spc = stream_patt_comp; eo = OPT [ "?"; e = expr -> e ] -> - (spc, eo) ] ] - ; - stream_patt_comp: - [ [ "`"; p = patt; eo = OPT [ "when"; e = expr -> e ] -> SpTrm _loc p eo - | p = patt; "="; e = expr -> SpNtr _loc p e - | p = patt -> SpStr _loc p ] ] - ; - ipatt: - [ [ i = LIDENT -> <:patt< $lid:i$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "[:"; se = LIST0 stream_expr_comp SEP ";"; ":]" -> - <:expr< $cstream _loc se$ >> ] ] - ; - stream_expr_comp: - [ [ "`"; e = expr -> SeTrm _loc e | e = expr -> SeNtr _loc e ] ] - ; -END; diff --git a/camlp4/meta/pr_dump.ml b/camlp4/meta/pr_dump.ml deleted file mode 100644 index d9623260..00000000 --- a/camlp4/meta/pr_dump.ml +++ /dev/null @@ -1,52 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: pr_dump.ml,v 1.4 2003/07/10 12:28:27 michel Exp $ *) - -value open_out_file () = - match Pcaml.output_file.val with - [ Some f -> open_out_bin f - | None -> do { set_binary_mode_out stdout True; stdout } ] -; - -value interf ast = - let pt = Ast2pt.interf (List.map fst ast) in - let oc = open_out_file () in - let fname = Pcaml.input_file.val in - do { - output_string oc Config.ast_intf_magic_number; - output_value oc (if fname = "-" then "" else fname); - output_value oc pt; - flush oc; - match Pcaml.output_file.val with - [ Some _ -> close_out oc - | None -> () ] - } -; - -value implem ast = - let pt = Ast2pt.implem (List.map fst ast) in - let oc = open_out_file () in - let fname = Pcaml.input_file.val in - do { - output_string oc Config.ast_impl_magic_number; - output_value oc (if fname = "-" then "" else fname); - output_value oc pt; - flush oc; - match Pcaml.output_file.val with - [ Some _ -> close_out oc - | None -> () ] - } -; - -Pcaml.print_interf.val := interf; -Pcaml.print_implem.val := implem; diff --git a/camlp4/meta/q_MLast.ml b/camlp4/meta/q_MLast.ml deleted file mode 100644 index 1b023045..00000000 --- a/camlp4/meta/q_MLast.ml +++ /dev/null @@ -1,1572 +0,0 @@ -(* camlp4r pa_extend.cmo pa_extend_m.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: q_MLast.ml,v 1.60 2005/06/29 04:11:26 garrigue Exp $ *) - -value (gram, q_position) = - let (lexer,pos) = Plexer.make_lexer () in - (Grammar.gcreate lexer, pos) -; - -module Qast = - struct - type t = - [ Node of string and list t - | List of list t - | Tuple of list t - | Option of option t - | Int of string - | Str of string - | Bool of bool - | Cons of t and t - | Apply of string and list t - | Record of list (string * t) - | Loc - | Antiquot of MLast.loc and string ] - ; - value _loc = - let nowhere = - {(Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0 } in - (nowhere,nowhere); - value rec to_expr = - fun - [ Node n al -> - List.fold_left (fun e a -> <:expr< $e$ $to_expr a$ >>) - <:expr< MLast.$uid:n$ >> al - | List al -> - List.fold_right (fun a e -> <:expr< [$to_expr a$ :: $e$] >>) al - <:expr< [] >> - | Tuple al -> <:expr< ($list:List.map to_expr al$) >> - | Option None -> <:expr< None >> - | Option (Some a) -> <:expr< Some $to_expr a$ >> - | Int s -> <:expr< $int:s$ >> - | Str s -> <:expr< $str:s$ >> - | Bool True -> <:expr< True >> - | Bool False -> <:expr< False >> - | Cons a1 a2 -> <:expr< [$to_expr a1$ :: $to_expr a2$] >> - | Apply f al -> - List.fold_left (fun e a -> <:expr< $e$ $to_expr a$ >>) - <:expr< $lid:f$ >> al - | Record lal -> <:expr< {$list:List.map to_expr_label lal$} >> - | Loc -> <:expr< $lid:Stdpp.loc_name.val$ >> - | Antiquot loc s -> - let (bolpos,lnum, _) = Pcaml.position.val in - let (bolposv,lnumv) = (bolpos.val, lnum.val) in - let zero_pos () = do { bolpos.val := 0; lnum.val := 1 } in - let restore_pos () = do { bolpos.val := bolposv; lnum.val := lnumv } in - let e = - try - let _ = zero_pos() in - let result = Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string s) in - let _ = restore_pos() in - result - with - [ Stdpp.Exc_located (bp, ep) exc -> - do { restore_pos() ; raise (Stdpp.Exc_located (Reloc.adjust_loc (fst loc) (bp,ep)) exc) } - | exc -> do { restore_pos(); raise exc } ] - in - <:expr< $anti:e$ >> ] - and to_expr_label (l, a) = (<:patt< MLast.$lid:l$ >>, to_expr a); - value rec to_patt = - fun - [ Node n al -> - List.fold_left (fun e a -> <:patt< $e$ $to_patt a$ >>) - <:patt< MLast.$uid:n$ >> al - | List al -> - List.fold_right (fun a p -> <:patt< [$to_patt a$ :: $p$] >>) al - <:patt< [] >> - | Tuple al -> <:patt< ($list:List.map to_patt al$) >> - | Option None -> <:patt< None >> - | Option (Some a) -> <:patt< Some $to_patt a$ >> - | Int s -> <:patt< $int:s$ >> - | Str s -> <:patt< $str:s$ >> - | Bool True -> <:patt< True >> - | Bool False -> <:patt< False >> - | Cons a1 a2 -> <:patt< [$to_patt a1$ :: $to_patt a2$] >> - | Apply _ _ -> failwith "bad pattern" - | Record lal -> <:patt< {$list:List.map to_patt_label lal$} >> - | Loc -> <:patt< _ >> - | Antiquot loc s -> - let (bolpos,lnum, _) = Pcaml.position.val in - let (bolposv,lnumv) = (bolpos.val, lnum.val) in - let zero_pos () = do { bolpos.val := 0; lnum.val := 1 } in - let restore_pos () = do { bolpos.val := bolposv; lnum.val := lnumv } in - let p = - try - let _ = zero_pos() in - let result = Grammar.Entry.parse Pcaml.patt_eoi (Stream.of_string s) in - let _ = restore_pos() in - result - with - [ Stdpp.Exc_located (bp, ep) exc -> - do { restore_pos() ; raise (Stdpp.Exc_located (Reloc.adjust_loc (fst loc) (bp, ep)) exc) } - | exc -> do { restore_pos(); raise exc } ] - in - <:patt< $anti:p$ >> ] - and to_patt_label (l, a) = (<:patt< MLast.$lid:l$ >>, to_patt a); - end -; - -value antiquot k (bp, ep) x = - let shift = - if k = "" then String.length "$" - else String.length "$" + String.length k + String.length ":" - in - Qast.Antiquot (Reloc.shift_pos shift bp, Reloc.shift_pos (-1) ep) x -; - -value sig_item = Grammar.Entry.create gram "signature item"; -value str_item = Grammar.Entry.create gram "structure item"; -value ctyp = Grammar.Entry.create gram "type"; -value patt = Grammar.Entry.create gram "pattern"; -value expr = Grammar.Entry.create gram "expression"; - -value module_type = Grammar.Entry.create gram "module type"; -value module_expr = Grammar.Entry.create gram "module expression"; - -value class_type = Grammar.Entry.create gram "class type"; -value class_expr = Grammar.Entry.create gram "class expr"; -value class_sig_item = Grammar.Entry.create gram "class signature item"; -value class_str_item = Grammar.Entry.create gram "class structure item"; - -value ipatt = Grammar.Entry.create gram "ipatt"; -value let_binding = Grammar.Entry.create gram "let_binding"; -value type_declaration = Grammar.Entry.create gram "type_declaration"; -value with_constr = Grammar.Entry.create gram "with_constr"; -value row_field = Grammar.Entry.create gram "row_field"; - -value a_list = Grammar.Entry.create gram "a_list"; -value a_opt = Grammar.Entry.create gram "a_opt"; -value a_UIDENT = Grammar.Entry.create gram "a_UIDENT"; -value a_LIDENT = Grammar.Entry.create gram "a_LIDENT"; -value a_INT = Grammar.Entry.create gram "a_INT"; -value a_INT32 = Grammar.Entry.create gram "a_INT32"; -value a_INT64 = Grammar.Entry.create gram "a_INT64"; -value a_NATIVEINT = Grammar.Entry.create gram "a__NATIVEINT"; -value a_FLOAT = Grammar.Entry.create gram "a_FLOAT"; -value a_STRING = Grammar.Entry.create gram "a_STRING"; -value a_CHAR = Grammar.Entry.create gram "a_CHAR"; -value a_TILDEIDENT = Grammar.Entry.create gram "a_TILDEIDENT"; -value a_LABEL = Grammar.Entry.create gram "a_LABEL"; -value a_QUESTIONIDENT = Grammar.Entry.create gram "a_QUESTIONIDENT"; -value a_OPTLABEL = Grammar.Entry.create gram "a_OPTLABEL"; - -value o2b = - fun - [ Qast.Option (Some _) -> Qast.Bool True - | Qast.Option None -> Qast.Bool False - | x -> x ] -; - -value mksequence _ = - fun - [ Qast.List [e] -> e - | el -> Qast.Node "ExSeq" [Qast.Loc; el] ] -; - -value mkmatchcase _ p aso w e = - let p = - match aso with - [ Qast.Option (Some p2) -> Qast.Node "PaAli" [Qast.Loc; p; p2] - | Qast.Option None -> p - | _ -> Qast.Node "PaAli" [Qast.Loc; p; aso] ] - in - Qast.Tuple [p; w; e] -; - -value neg_string n = - let len = String.length n in - if len > 0 && n.[0] = '-' then String.sub n 1 (len - 1) - else "-" ^ n -; - -value mkumin _ f arg = - match arg with - [ Qast.Node (("ExInt" | "ExInt32" | "ExInt64" | "ExNativeInt") as exi) - [Qast.Loc; Qast.Str n] when int_of_string n > 0 -> - let n = neg_string n in - Qast.Node exi [Qast.Loc; Qast.Str n] - | Qast.Node "ExFlo" [Qast.Loc; Qast.Str n] when float_of_string n > 0.0 -> - let n = neg_string n in - Qast.Node "ExFlo" [Qast.Loc; Qast.Str n] - | _ -> - match f with - [ Qast.Str f -> - let f = "~" ^ f in - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str f]; arg] - | _ -> assert False ] ] -; - -value mkuminpat _ f is_int s = - let s = - match s with - [ Qast.Str s -> Qast.Str (neg_string s) - | s -> failwith "bad unary minus" ] - in - match is_int with - [ Qast.Bool True -> Qast.Node "PaInt" [Qast.Loc; s] - | Qast.Bool False -> Qast.Node "PaFlo" [Qast.Loc; s] - | _ -> assert False ] -; - -value mklistexp _ last = - loop True where rec loop top = - fun - [ Qast.List [] -> - match last with - [ Qast.Option (Some e) -> e - | Qast.Option None -> Qast.Node "ExUid" [Qast.Loc; Qast.Str "[]"] - | a -> a ] - | Qast.List [e1 :: el] -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExUid" [Qast.Loc; Qast.Str "::"]; e1]; - loop False (Qast.List el)] - | a -> a ] -; - -value mklistpat _ last = - loop True where rec loop top = - fun - [ Qast.List [] -> - match last with - [ Qast.Option (Some p) -> p - | Qast.Option None -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "[]"] - | a -> a ] - | Qast.List [p1 :: pl] -> - Qast.Node "PaApp" - [Qast.Loc; - Qast.Node "PaApp" - [Qast.Loc; Qast.Node "PaUid" [Qast.Loc; Qast.Str "::"]; p1]; - loop False (Qast.List pl)] - | a -> a ] -; - -value mkexprident loc i j = - loop (Qast.Node "ExUid" [Qast.Loc; i]) j where rec loop m = - fun - [ Qast.Node "ExAcc" [_; x; y] -> - loop (Qast.Node "ExAcc" [Qast.Loc; m; x]) y - | e -> Qast.Node "ExAcc" [Qast.Loc; m; e] ] -; - -value mkassert _ e = - match e with - [ Qast.Node "ExUid" [_; Qast.Str "False"] -> Qast.Node "ExAsf" [Qast.Loc] - | _ -> Qast.Node "ExAsr" [Qast.Loc; e] ] -; - -value append_elem el e = Qast.Apply "@" [el; Qast.List [e]]; - -value not_yet_warned_antiq = ref True; -value warn_antiq loc vers = - if not_yet_warned_antiq.val then do { - not_yet_warned_antiq.val := False; - Pcaml.warning.val loc - (Printf.sprintf - "use of antiquotation syntax deprecated since version %s" vers); - } - else () -; - -value not_yet_warned_variant = ref True; -value warn_variant _ = - if not_yet_warned_variant.val then do { - not_yet_warned_variant.val := False; - Pcaml.warning.val (Lexing.dummy_pos, Reloc.shift_pos 1 Lexing.dummy_pos) - (Printf.sprintf - "use of syntax of variants types deprecated since version 3.05"); - } - else () -; - -value not_yet_warned_seq = ref True; -value warn_sequence _ = - if not_yet_warned_seq.val then do { - not_yet_warned_seq.val := False; - Pcaml.warning.val (Lexing.dummy_pos, Reloc.shift_pos 1 Lexing.dummy_pos) - (Printf.sprintf - "use of syntax of sequences deprecated since version 3.01.1"); - } - else () -; - -EXTEND - GLOBAL: sig_item str_item ctyp patt expr module_type module_expr class_type - class_expr class_sig_item class_str_item let_binding type_declaration - ipatt with_constr row_field; - module_expr: - [ [ "functor"; "("; i = a_UIDENT; ":"; t = module_type; ")"; "->"; - me = SELF -> - Qast.Node "MeFun" [Qast.Loc; i; t; me] - | "struct"; st = SLIST0 [ s = str_item; ";" -> s ]; "end" -> - Qast.Node "MeStr" [Qast.Loc; st] ] - | [ me1 = SELF; me2 = SELF -> Qast.Node "MeApp" [Qast.Loc; me1; me2] ] - | [ me1 = SELF; "."; me2 = SELF -> - Qast.Node "MeAcc" [Qast.Loc; me1; me2] ] - | "simple" - [ i = a_UIDENT -> Qast.Node "MeUid" [Qast.Loc; i] - | "("; me = SELF; ":"; mt = module_type; ")" -> - Qast.Node "MeTyc" [Qast.Loc; me; mt] - | "("; me = SELF; ")" -> me ] ] - ; - str_item: - [ "top" - [ "declare"; st = SLIST0 [ s = str_item; ";" -> s ]; "end" -> - Qast.Node "StDcl" [Qast.Loc; st] - | "exception"; ctl = constructor_declaration; b = rebind_exn -> - let (_, c, tl) = - match ctl with - [ Qast.Tuple [xx1; xx2; xx3] -> (xx1, xx2, xx3) - | _ -> match () with [] ] - in - Qast.Node "StExc" [Qast.Loc; c; tl; b] - | "external"; i = a_LIDENT; ":"; t = ctyp; "="; pd = SLIST1 a_STRING -> - Qast.Node "StExt" [Qast.Loc; i; t; pd] - | "include"; me = module_expr -> Qast.Node "StInc" [Qast.Loc; me] - | "module"; i = a_UIDENT; mb = module_binding -> - Qast.Node "StMod" [Qast.Loc; i; mb] - | "module"; "rec"; nmtmes = SLIST1 module_rec_binding SEP "and" -> - Qast.Node "StRecMod" [Qast.Loc; nmtmes] - | "module"; "type"; i = a_UIDENT; "="; mt = module_type -> - Qast.Node "StMty" [Qast.Loc; i; mt] - | "open"; i = mod_ident -> Qast.Node "StOpn" [Qast.Loc; i] - | "type"; tdl = SLIST1 type_declaration SEP "and" -> - Qast.Node "StTyp" [Qast.Loc; tdl] - | "value"; r = SOPT "rec"; l = SLIST1 let_binding SEP "and" -> - Qast.Node "StVal" [Qast.Loc; o2b r; l] - | e = expr -> Qast.Node "StExp" [Qast.Loc; e] ] ] - ; - rebind_exn: - [ [ "="; sl = mod_ident -> sl - | -> Qast.List [] ] ] - ; - module_binding: - [ RIGHTA - [ "("; m = a_UIDENT; ":"; mt = module_type; ")"; mb = SELF -> - Qast.Node "MeFun" [Qast.Loc; m; mt; mb] - | ":"; mt = module_type; "="; me = module_expr -> - Qast.Node "MeTyc" [Qast.Loc; me; mt] - | "="; me = module_expr -> me ] ] - ; - module_rec_binding: - [ [ m = a_UIDENT; ":"; mt = module_type; "="; me = module_expr -> - Qast.Tuple [m; me; mt] ] ] - ; - module_type: - [ [ "functor"; "("; i = a_UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF -> - Qast.Node "MtFun" [Qast.Loc; i; t; mt] ] - | [ mt = SELF; "with"; wcl = SLIST1 with_constr SEP "and" -> - Qast.Node "MtWit" [Qast.Loc; mt; wcl] ] - | [ "sig"; sg = SLIST0 [ s = sig_item; ";" -> s ]; "end" -> - Qast.Node "MtSig" [Qast.Loc; sg] ] - | [ m1 = SELF; m2 = SELF -> Qast.Node "MtApp" [Qast.Loc; m1; m2] ] - | [ m1 = SELF; "."; m2 = SELF -> Qast.Node "MtAcc" [Qast.Loc; m1; m2] ] - | "simple" - [ i = a_UIDENT -> Qast.Node "MtUid" [Qast.Loc; i] - | i = a_LIDENT -> Qast.Node "MtLid" [Qast.Loc; i] - | "'"; i = ident -> Qast.Node "MtQuo" [Qast.Loc; i] - | "("; mt = SELF; ")" -> mt ] ] - ; - sig_item: - [ "top" - [ "declare"; st = SLIST0 [ s = sig_item; ";" -> s ]; "end" -> - Qast.Node "SgDcl" [Qast.Loc; st] - | "exception"; ctl = constructor_declaration -> - let (_, c, tl) = - match ctl with - [ Qast.Tuple [xx1; xx2; xx3] -> (xx1, xx2, xx3) - | _ -> match () with [] ] - in - Qast.Node "SgExc" [Qast.Loc; c; tl] - | "external"; i = a_LIDENT; ":"; t = ctyp; "="; pd = SLIST1 a_STRING -> - Qast.Node "SgExt" [Qast.Loc; i; t; pd] - | "include"; mt = module_type -> Qast.Node "SgInc" [Qast.Loc; mt] - | "module"; i = a_UIDENT; mt = module_declaration -> - Qast.Node "SgMod" [Qast.Loc; i; mt] - | "module"; "type"; i = a_UIDENT; "="; mt = module_type -> - Qast.Node "SgMty" [Qast.Loc; i; mt] - | "module"; "rec"; mds = SLIST1 module_rec_declaration SEP "and" -> - Qast.Node "SgRecMod" [Qast.Loc; mds] - | "open"; i = mod_ident -> Qast.Node "SgOpn" [Qast.Loc; i] - | "type"; tdl = SLIST1 type_declaration SEP "and" -> - Qast.Node "SgTyp" [Qast.Loc; tdl] - | "value"; i = a_LIDENT; ":"; t = ctyp -> - Qast.Node "SgVal" [Qast.Loc; i; t] ] ] - ; - module_declaration: - [ RIGHTA - [ ":"; mt = module_type -> mt - | "("; i = a_UIDENT; ":"; t = module_type; ")"; mt = SELF -> - Qast.Node "MtFun" [Qast.Loc; i; t; mt] ] ] - ; - module_rec_declaration: - [ [ m = a_UIDENT; ":"; mt = module_type -> Qast.Tuple [m; mt] ] ] - ; - with_constr: - [ [ "type"; i = mod_ident; tpl = SLIST0 type_parameter; "="; t = ctyp -> - Qast.Node "WcTyp" [Qast.Loc; i; tpl; t] - | "module"; i = mod_ident; "="; me = module_expr -> - Qast.Node "WcMod" [Qast.Loc; i; me] ] ] - ; - expr: - [ "top" RIGHTA - [ "let"; r = SOPT "rec"; l = SLIST1 let_binding SEP "and"; "in"; - x = SELF -> - Qast.Node "ExLet" [Qast.Loc; o2b r; l; x] - | "let"; "module"; m = a_UIDENT; mb = module_binding; "in"; e = SELF -> - Qast.Node "ExLmd" [Qast.Loc; m; mb; e] - | "fun"; "["; l = SLIST0 match_case SEP "|"; "]" -> - Qast.Node "ExFun" [Qast.Loc; l] - | "fun"; p = ipatt; e = fun_def -> - Qast.Node "ExFun" - [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]] - | "match"; e = SELF; "with"; "["; l = SLIST0 match_case SEP "|"; "]" -> - Qast.Node "ExMat" [Qast.Loc; e; l] - | "match"; e = SELF; "with"; p1 = ipatt; "->"; e1 = SELF -> - Qast.Node "ExMat" - [Qast.Loc; e; Qast.List [Qast.Tuple [p1; Qast.Option None; e1]]] - | "try"; e = SELF; "with"; "["; l = SLIST0 match_case SEP "|"; "]" -> - Qast.Node "ExTry" [Qast.Loc; e; l] - | "try"; e = SELF; "with"; p1 = ipatt; "->"; e1 = SELF -> - Qast.Node "ExTry" - [Qast.Loc; e; Qast.List [Qast.Tuple [p1; Qast.Option None; e1]]] - | "if"; e1 = SELF; "then"; e2 = SELF; "else"; e3 = SELF -> - Qast.Node "ExIfe" [Qast.Loc; e1; e2; e3] - | "do"; "{"; seq = sequence; "}" -> mksequence Qast.Loc seq - | "for"; i = a_LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF; - "do"; "{"; seq = sequence; "}" -> - Qast.Node "ExFor" [Qast.Loc; i; e1; e2; df; seq] - | "while"; e = SELF; "do"; "{"; seq = sequence; "}" -> - Qast.Node "ExWhi" [Qast.Loc; e; seq] ] - | "where" - [ e = SELF; "where"; rf = SOPT "rec"; lb = let_binding -> - Qast.Node "ExLet" [Qast.Loc; o2b rf; Qast.List [lb]; e] ] - | ":=" NONA - [ e1 = SELF; ":="; e2 = SELF; dummy -> - Qast.Node "ExAss" [Qast.Loc; e1; e2] ] - | "||" RIGHTA - [ e1 = SELF; "||"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "||"]; e1]; - e2] ] - | "&&" RIGHTA - [ e1 = SELF; "&&"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "&&"]; e1]; - e2] ] - | "<" LEFTA - [ e1 = SELF; "<"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "<"]; e1]; - e2] - | e1 = SELF; ">"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str ">"]; e1]; - e2] - | e1 = SELF; "<="; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "<="]; e1]; - e2] - | e1 = SELF; ">="; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str ">="]; e1]; - e2] - | e1 = SELF; "="; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "="]; e1]; - e2] - | e1 = SELF; "<>"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "<>"]; e1]; - e2] - | e1 = SELF; "=="; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "=="]; e1]; - e2] - | e1 = SELF; "!="; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "!="]; e1]; - e2] ] - | "^" RIGHTA - [ e1 = SELF; "^"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "^"]; e1]; - e2] - | e1 = SELF; "@"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "@"]; e1]; - e2] ] - | "+" LEFTA - [ e1 = SELF; "+"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "+"]; e1]; - e2] - | e1 = SELF; "-"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "-"]; e1]; - e2] - | e1 = SELF; "+."; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "+."]; e1]; - e2] - | e1 = SELF; "-."; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "-."]; e1]; - e2] ] - | "*" LEFTA - [ e1 = SELF; "*"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "*"]; e1]; - e2] - | e1 = SELF; "/"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "/"]; e1]; - e2] - | e1 = SELF; "*."; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "*."]; e1]; - e2] - | e1 = SELF; "/."; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "/."]; e1]; - e2] - | e1 = SELF; "land"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "land"]; e1]; - e2] - | e1 = SELF; "lor"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lor"]; e1]; - e2] - | e1 = SELF; "lxor"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lxor"]; e1]; - e2] - | e1 = SELF; "mod"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "mod"]; e1]; - e2] ] - | "**" RIGHTA - [ e1 = SELF; "**"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "**"]; e1]; - e2] - | e1 = SELF; "asr"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "asr"]; e1]; - e2] - | e1 = SELF; "lsl"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lsl"]; e1]; - e2] - | e1 = SELF; "lsr"; e2 = SELF -> - Qast.Node "ExApp" - [Qast.Loc; - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "lsr"]; e1]; - e2] ] - | "unary minus" NONA - [ "-"; e = SELF -> mkumin Qast.Loc (Qast.Str "-") e - | "-."; e = SELF -> mkumin Qast.Loc (Qast.Str "-.") e ] - | "apply" LEFTA - [ e1 = SELF; e2 = SELF -> Qast.Node "ExApp" [Qast.Loc; e1; e2] - | "assert"; e = SELF -> mkassert Qast.Loc e - | "lazy"; e = SELF -> Qast.Node "ExLaz" [Qast.Loc; e] ] - | "." LEFTA - [ e1 = SELF; "."; "("; e2 = SELF; ")" -> - Qast.Node "ExAre" [Qast.Loc; e1; e2] - | e1 = SELF; "."; "["; e2 = SELF; "]" -> - Qast.Node "ExSte" [Qast.Loc; e1; e2] - | e1 = SELF; "."; e2 = SELF -> Qast.Node "ExAcc" [Qast.Loc; e1; e2] ] - | "~-" NONA - [ "~-"; e = SELF -> - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "~-"]; e] - | "~-."; e = SELF -> - Qast.Node "ExApp" - [Qast.Loc; Qast.Node "ExLid" [Qast.Loc; Qast.Str "~-."]; e] ] - | "simple" - [ s = a_INT -> Qast.Node "ExInt" [Qast.Loc; s] - | s = a_INT32 -> Qast.Node "ExInt32" [Qast.Loc; s] - | s = a_INT64 -> Qast.Node "ExInt64" [Qast.Loc; s] - | s = a_NATIVEINT -> Qast.Node "ExNativeInt" [Qast.Loc; s] - | s = a_FLOAT -> Qast.Node "ExFlo" [Qast.Loc; s] - | s = a_STRING -> Qast.Node "ExStr" [Qast.Loc; s] - | s = a_CHAR -> Qast.Node "ExChr" [Qast.Loc; s] - | i = expr_ident -> i - | "["; "]" -> Qast.Node "ExUid" [Qast.Loc; Qast.Str "[]"] - | "["; el = SLIST1 expr SEP ";"; last = cons_expr_opt; "]" -> - mklistexp Qast.Loc last el - | "[|"; el = SLIST0 expr SEP ";"; "|]" -> - Qast.Node "ExArr" [Qast.Loc; el] - | "{"; lel = SLIST1 label_expr SEP ";"; "}" -> - Qast.Node "ExRec" [Qast.Loc; lel; Qast.Option None] - | "{"; "("; e = SELF; ")"; "with"; lel = SLIST1 label_expr SEP ";"; - "}" -> - Qast.Node "ExRec" [Qast.Loc; lel; Qast.Option (Some e)] - | "("; ")" -> Qast.Node "ExUid" [Qast.Loc; Qast.Str "()"] - | "("; e = SELF; ":"; t = ctyp; ")" -> - Qast.Node "ExTyc" [Qast.Loc; e; t] - | "("; e = SELF; ","; el = SLIST1 expr SEP ","; ")" -> - Qast.Node "ExTup" [Qast.Loc; Qast.Cons e el] - | "("; e = SELF; ")" -> e ] ] - ; - cons_expr_opt: - [ [ "::"; e = expr -> Qast.Option (Some e) - | -> Qast.Option None ] ] - ; - dummy: - [ [ -> () ] ] - ; - sequence: - [ [ "let"; rf = SOPT "rec"; l = SLIST1 let_binding SEP "and"; - [ "in" | ";" ]; el = SELF -> - Qast.List - [Qast.Node "ExLet" [Qast.Loc; o2b rf; l; mksequence Qast.Loc el]] - | e = expr; ";"; el = SELF -> Qast.Cons e el - | e = expr; ";" -> Qast.List [e] - | e = expr -> Qast.List [e] ] ] - ; - let_binding: - [ [ p = ipatt; e = fun_binding -> Qast.Tuple [p; e] ] ] - ; - fun_binding: - [ RIGHTA - [ p = ipatt; e = SELF -> - Qast.Node "ExFun" - [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]] - | "="; e = expr -> e - | ":"; t = ctyp; "="; e = expr -> Qast.Node "ExTyc" [Qast.Loc; e; t] ] ] - ; - match_case: - [ [ p = patt; aso = as_patt_opt; w = when_expr_opt; "->"; e = expr -> - mkmatchcase Qast.Loc p aso w e ] ] - ; - as_patt_opt: - [ [ "as"; p = patt -> Qast.Option (Some p) - | -> Qast.Option None ] ] - ; - when_expr_opt: - [ [ "when"; e = expr -> Qast.Option (Some e) - | -> Qast.Option None ] ] - ; - label_expr: - [ [ i = patt_label_ident; e = fun_binding -> Qast.Tuple [i; e] ] ] - ; - expr_ident: - [ RIGHTA - [ i = a_LIDENT -> Qast.Node "ExLid" [Qast.Loc; i] - | i = a_UIDENT -> Qast.Node "ExUid" [Qast.Loc; i] - | i = a_UIDENT; "."; j = SELF -> mkexprident Qast.Loc i j ] ] - ; - fun_def: - [ RIGHTA - [ p = ipatt; e = SELF -> - Qast.Node "ExFun" - [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]] - | "->"; e = expr -> e ] ] - ; - patt: - [ LEFTA - [ p1 = SELF; "|"; p2 = SELF -> Qast.Node "PaOrp" [Qast.Loc; p1; p2] ] - | NONA - [ p1 = SELF; ".."; p2 = SELF -> Qast.Node "PaRng" [Qast.Loc; p1; p2] ] - | LEFTA - [ p1 = SELF; p2 = SELF -> Qast.Node "PaApp" [Qast.Loc; p1; p2] ] - | LEFTA - [ p1 = SELF; "."; p2 = SELF -> Qast.Node "PaAcc" [Qast.Loc; p1; p2] ] - | "simple" - [ s = a_LIDENT -> Qast.Node "PaLid" [Qast.Loc; s] - | s = a_UIDENT -> Qast.Node "PaUid" [Qast.Loc; s] - | s = a_INT -> Qast.Node "PaInt" [Qast.Loc; s] - | s = a_INT32 -> Qast.Node "PaInt32" [Qast.Loc; s] - | s = a_INT64 -> Qast.Node "PaInt64" [Qast.Loc; s] - | s = a_NATIVEINT -> Qast.Node "PaNativeInt" [Qast.Loc; s] - | s = a_FLOAT -> Qast.Node "PaFlo" [Qast.Loc; s] - | s = a_STRING -> Qast.Node "PaStr" [Qast.Loc; s] - | s = a_CHAR -> Qast.Node "PaChr" [Qast.Loc; s] - | "-"; s = a_INT -> mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool True) s - | "-"; s = a_INT32 -> mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool True) s - | "-"; s = a_INT64 -> mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool True) s - | "-"; s = a_NATIVEINT -> mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool True) s - | "-"; s = a_FLOAT -> - mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool False) s - | "["; "]" -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "[]"] - | "["; pl = SLIST1 patt SEP ";"; last = cons_patt_opt; "]" -> - mklistpat Qast.Loc last pl - | "[|"; pl = SLIST0 patt SEP ";"; "|]" -> - Qast.Node "PaArr" [Qast.Loc; pl] - | "{"; lpl = SLIST1 label_patt SEP ";"; "}" -> - Qast.Node "PaRec" [Qast.Loc; lpl] - | "("; ")" -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "()"] - | "("; p = SELF; ")" -> p - | "("; p = SELF; ":"; t = ctyp; ")" -> - Qast.Node "PaTyc" [Qast.Loc; p; t] - | "("; p = SELF; "as"; p2 = SELF; ")" -> - Qast.Node "PaAli" [Qast.Loc; p; p2] - | "("; p = SELF; ","; pl = SLIST1 patt SEP ","; ")" -> - Qast.Node "PaTup" [Qast.Loc; Qast.Cons p pl] - | "_" -> Qast.Node "PaAny" [Qast.Loc] ] ] - ; - cons_patt_opt: - [ [ "::"; p = patt -> Qast.Option (Some p) - | -> Qast.Option None ] ] - ; - label_patt: - [ [ i = patt_label_ident; "="; p = patt -> Qast.Tuple [i; p] ] ] - ; - patt_label_ident: - [ LEFTA - [ p1 = SELF; "."; p2 = SELF -> Qast.Node "PaAcc" [Qast.Loc; p1; p2] ] - | "simple" RIGHTA - [ i = a_UIDENT -> Qast.Node "PaUid" [Qast.Loc; i] - | i = a_LIDENT -> Qast.Node "PaLid" [Qast.Loc; i] ] ] - ; - ipatt: - [ [ "{"; lpl = SLIST1 label_ipatt SEP ";"; "}" -> - Qast.Node "PaRec" [Qast.Loc; lpl] - | "("; ")" -> Qast.Node "PaUid" [Qast.Loc; Qast.Str "()"] - | "("; p = SELF; ")" -> p - | "("; p = SELF; ":"; t = ctyp; ")" -> - Qast.Node "PaTyc" [Qast.Loc; p; t] - | "("; p = SELF; "as"; p2 = SELF; ")" -> - Qast.Node "PaAli" [Qast.Loc; p; p2] - | "("; p = SELF; ","; pl = SLIST1 ipatt SEP ","; ")" -> - Qast.Node "PaTup" [Qast.Loc; Qast.Cons p pl] - | s = a_LIDENT -> Qast.Node "PaLid" [Qast.Loc; s] - | "_" -> Qast.Node "PaAny" [Qast.Loc] ] ] - ; - label_ipatt: - [ [ i = patt_label_ident; "="; p = ipatt -> Qast.Tuple [i; p] ] ] - ; - type_declaration: - [ [ n = type_patt; tpl = SLIST0 type_parameter; "="; tk = ctyp; - cl = SLIST0 constrain -> - Qast.Tuple [n; tpl; tk; cl] ] ] - ; - type_patt: - [ [ n = a_LIDENT -> Qast.Tuple [Qast.Loc; n] ] ] - ; - constrain: - [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> Qast.Tuple [t1; t2] ] ] - ; - type_parameter: - [ [ "'"; i = ident -> - Qast.Tuple [i; Qast.Tuple [Qast.Bool False; Qast.Bool False]] - | "+"; "'"; i = ident -> - Qast.Tuple [i; Qast.Tuple [Qast.Bool True; Qast.Bool False]] - | "-"; "'"; i = ident -> - Qast.Tuple [i; Qast.Tuple [Qast.Bool False; Qast.Bool True]] ] ] - ; - ctyp: - [ LEFTA - [ t1 = SELF; "=="; t2 = SELF -> Qast.Node "TyMan" [Qast.Loc; t1; t2] ] - | NONA - [ "private"; t = ctyp LEVEL "alias" -> Qast.Node "TyPrv" [Qast.Loc; t] ] - | "alias" LEFTA - [ t1 = SELF; "as"; t2 = SELF -> Qast.Node "TyAli" [Qast.Loc; t1; t2] ] - | LEFTA - [ "!"; pl = SLIST1 typevar; "."; t = SELF -> - Qast.Node "TyPol" [Qast.Loc; pl; t] ] - | "arrow" RIGHTA - [ t1 = SELF; "->"; t2 = SELF -> Qast.Node "TyArr" [Qast.Loc; t1; t2] ] - | "label" NONA - [ i = a_TILDEIDENT; ":"; t = SELF -> Qast.Node "TyLab" [Qast.Loc; i; t] - | i = a_LABEL; t = SELF -> Qast.Node "TyLab" [Qast.Loc; i; t] - | i = a_QUESTIONIDENT; ":"; t = SELF -> - Qast.Node "TyOlb" [Qast.Loc; i; t] - | i = a_OPTLABEL; t = SELF -> - Qast.Node "TyOlb" [Qast.Loc; i; t] ] - | LEFTA - [ t1 = SELF; t2 = SELF -> Qast.Node "TyApp" [Qast.Loc; t1; t2] ] - | LEFTA - [ t1 = SELF; "."; t2 = SELF -> Qast.Node "TyAcc" [Qast.Loc; t1; t2] ] - | "simple" - [ "'"; i = ident -> Qast.Node "TyQuo" [Qast.Loc; i] - | "_" -> Qast.Node "TyAny" [Qast.Loc] - | i = a_LIDENT -> Qast.Node "TyLid" [Qast.Loc; i] - | i = a_UIDENT -> Qast.Node "TyUid" [Qast.Loc; i] - | "("; t = SELF; "*"; tl = SLIST1 ctyp SEP "*"; ")" -> - Qast.Node "TyTup" [Qast.Loc; Qast.Cons t tl] - | "("; t = SELF; ")" -> t - | "["; cdl = SLIST0 constructor_declaration SEP "|"; "]" -> - Qast.Node "TySum" [Qast.Loc; cdl] - | "{"; ldl = SLIST1 label_declaration SEP ";"; "}" -> - Qast.Node "TyRec" [Qast.Loc; ldl] ] ] - ; - constructor_declaration: - [ [ ci = a_UIDENT; "of"; cal = SLIST1 ctyp SEP "and" -> - Qast.Tuple [Qast.Loc; ci; cal] - | ci = a_UIDENT -> Qast.Tuple [Qast.Loc; ci; Qast.List []] ] ] - ; - label_declaration: - [ [ i = a_LIDENT; ":"; mf = SOPT "mutable"; t = ctyp -> - Qast.Tuple [Qast.Loc; i; o2b mf; t] ] ] - ; - ident: - [ [ i = a_LIDENT -> i - | i = a_UIDENT -> i ] ] - ; - mod_ident: - [ RIGHTA - [ i = a_UIDENT -> Qast.List [i] - | i = a_LIDENT -> Qast.List [i] - | i = a_UIDENT; "."; j = SELF -> Qast.Cons i j ] ] - ; - (* Objects and Classes *) - str_item: - [ [ "class"; cd = SLIST1 class_declaration SEP "and" -> - Qast.Node "StCls" [Qast.Loc; cd] - | "class"; "type"; ctd = SLIST1 class_type_declaration SEP "and" -> - Qast.Node "StClt" [Qast.Loc; ctd] ] ] - ; - sig_item: - [ [ "class"; cd = SLIST1 class_description SEP "and" -> - Qast.Node "SgCls" [Qast.Loc; cd] - | "class"; "type"; ctd = SLIST1 class_type_declaration SEP "and" -> - Qast.Node "SgClt" [Qast.Loc; ctd] ] ] - ; - class_declaration: - [ [ vf = SOPT "virtual"; i = a_LIDENT; ctp = class_type_parameters; - cfb = class_fun_binding -> - Qast.Record - [("ciLoc", Qast.Loc); ("ciVir", o2b vf); ("ciPrm", ctp); - ("ciNam", i); ("ciExp", cfb)] ] ] - ; - class_fun_binding: - [ [ "="; ce = class_expr -> ce - | ":"; ct = class_type; "="; ce = class_expr -> - Qast.Node "CeTyc" [Qast.Loc; ce; ct] - | p = ipatt; cfb = SELF -> Qast.Node "CeFun" [Qast.Loc; p; cfb] ] ] - ; - class_type_parameters: - [ [ -> Qast.Tuple [Qast.Loc; Qast.List []] - | "["; tpl = SLIST1 type_parameter SEP ","; "]" -> - Qast.Tuple [Qast.Loc; tpl] ] ] - ; - class_fun_def: - [ [ p = ipatt; ce = SELF -> Qast.Node "CeFun" [Qast.Loc; p; ce] - | "->"; ce = class_expr -> ce ] ] - ; - class_expr: - [ "top" - [ "fun"; p = ipatt; ce = class_fun_def -> - Qast.Node "CeFun" [Qast.Loc; p; ce] - | "let"; rf = SOPT "rec"; lb = SLIST1 let_binding SEP "and"; "in"; - ce = SELF -> - Qast.Node "CeLet" [Qast.Loc; o2b rf; lb; ce] ] - | "apply" NONA - [ ce = SELF; e = expr LEVEL "label" -> - Qast.Node "CeApp" [Qast.Loc; ce; e] ] - | "simple" - [ ci = class_longident; "["; ctcl = SLIST0 ctyp SEP ","; "]" -> - Qast.Node "CeCon" [Qast.Loc; ci; ctcl] - | ci = class_longident -> Qast.Node "CeCon" [Qast.Loc; ci; Qast.List []] - | "object"; cspo = SOPT class_self_patt; cf = class_structure; "end" -> - Qast.Node "CeStr" [Qast.Loc; cspo; cf] - | "("; ce = SELF; ":"; ct = class_type; ")" -> - Qast.Node "CeTyc" [Qast.Loc; ce; ct] - | "("; ce = SELF; ")" -> ce ] ] - ; - class_structure: - [ [ cf = SLIST0 [ cf = class_str_item; ";" -> cf ] -> cf ] ] - ; - class_self_patt: - [ [ "("; p = patt; ")" -> p - | "("; p = patt; ":"; t = ctyp; ")" -> - Qast.Node "PaTyc" [Qast.Loc; p; t] ] ] - ; - class_str_item: - [ [ "declare"; st = SLIST0 [ s = class_str_item; ";" -> s ]; "end" -> - Qast.Node "CrDcl" [Qast.Loc; st] - | "inherit"; ce = class_expr; pb = SOPT as_lident -> - Qast.Node "CrInh" [Qast.Loc; ce; pb] - | "value"; mf = SOPT "mutable"; lab = label; e = cvalue_binding -> - Qast.Node "CrVal" [Qast.Loc; lab; o2b mf; e] - | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp -> - Qast.Node "CrVir" [Qast.Loc; l; o2b pf; t] - | "method"; pf = SOPT "private"; l = label; topt = SOPT polyt; - e = fun_binding -> - Qast.Node "CrMth" [Qast.Loc; l; o2b pf; e; topt] - | "type"; t1 = ctyp; "="; t2 = ctyp -> - Qast.Node "CrCtr" [Qast.Loc; t1; t2] - | "initializer"; se = expr -> Qast.Node "CrIni" [Qast.Loc; se] ] ] - ; - as_lident: - [ [ "as"; i = a_LIDENT -> i ] ] - ; - polyt: - [ [ ":"; t = ctyp -> t ] ] - ; - cvalue_binding: - [ [ "="; e = expr -> e - | ":"; t = ctyp; "="; e = expr -> Qast.Node "ExTyc" [Qast.Loc; e; t] - | ":"; t = ctyp; ":>"; t2 = ctyp; "="; e = expr -> - Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option (Some t); t2] - | ":>"; t = ctyp; "="; e = expr -> - Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option None; t] ] ] - ; - label: - [ [ i = a_LIDENT -> i ] ] - ; - class_type: - [ [ "["; t = ctyp; "]"; "->"; ct = SELF -> - Qast.Node "CtFun" [Qast.Loc; t; ct] - | id = clty_longident; "["; tl = SLIST1 ctyp SEP ","; "]" -> - Qast.Node "CtCon" [Qast.Loc; id; tl] - | id = clty_longident -> Qast.Node "CtCon" [Qast.Loc; id; Qast.List []] - | "object"; cst = SOPT class_self_type; - csf = SLIST0 [ csf = class_sig_item; ";" -> csf ]; "end" -> - Qast.Node "CtSig" [Qast.Loc; cst; csf] ] ] - ; - class_self_type: - [ [ "("; t = ctyp; ")" -> t ] ] - ; - class_sig_item: - [ [ "declare"; st = SLIST0 [ s = class_sig_item; ";" -> s ]; "end" -> - Qast.Node "CgDcl" [Qast.Loc; st] - | "inherit"; cs = class_type -> Qast.Node "CgInh" [Qast.Loc; cs] - | "value"; mf = SOPT "mutable"; l = label; ":"; t = ctyp -> - Qast.Node "CgVal" [Qast.Loc; l; o2b mf; t] - | "method"; "virtual"; pf = SOPT "private"; l = label; ":"; t = ctyp -> - Qast.Node "CgVir" [Qast.Loc; l; o2b pf; t] - | "method"; pf = SOPT "private"; l = label; ":"; t = ctyp -> - Qast.Node "CgMth" [Qast.Loc; l; o2b pf; t] - | "type"; t1 = ctyp; "="; t2 = ctyp -> - Qast.Node "CgCtr" [Qast.Loc; t1; t2] ] ] - ; - class_description: - [ [ vf = SOPT "virtual"; n = a_LIDENT; ctp = class_type_parameters; ":"; - ct = class_type -> - Qast.Record - [("ciLoc", Qast.Loc); ("ciVir", o2b vf); ("ciPrm", ctp); - ("ciNam", n); ("ciExp", ct)] ] ] - ; - class_type_declaration: - [ [ vf = SOPT "virtual"; n = a_LIDENT; ctp = class_type_parameters; "="; - cs = class_type -> - Qast.Record - [("ciLoc", Qast.Loc); ("ciVir", o2b vf); ("ciPrm", ctp); - ("ciNam", n); ("ciExp", cs)] ] ] - ; - expr: LEVEL "apply" - [ LEFTA - [ "new"; i = class_longident -> Qast.Node "ExNew" [Qast.Loc; i] ] ] - ; - expr: LEVEL "." - [ [ e = SELF; "#"; lab = label -> Qast.Node "ExSnd" [Qast.Loc; e; lab] ] ] - ; - expr: LEVEL "simple" - [ [ "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" -> - Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option (Some t); t2] - | "("; e = SELF; ":>"; t = ctyp; ")" -> - Qast.Node "ExCoe" [Qast.Loc; e; Qast.Option None; t] - | "{<"; fel = SLIST0 field_expr SEP ";"; ">}" -> - Qast.Node "ExOvr" [Qast.Loc; fel] ] ] - ; - field_expr: - [ [ l = label; "="; e = expr -> Qast.Tuple [l; e] ] ] - ; - ctyp: LEVEL "simple" - [ [ "#"; id = class_longident -> Qast.Node "TyCls" [Qast.Loc; id] - | "<"; ml = SLIST0 field SEP ";"; v = SOPT ".."; ">" -> - Qast.Node "TyObj" [Qast.Loc; ml; o2b v] ] ] - ; - field: - [ [ lab = a_LIDENT; ":"; t = ctyp -> Qast.Tuple [lab; t] ] ] - ; - typevar: - [ [ "'"; i = ident -> i ] ] - ; - clty_longident: - [ [ m = a_UIDENT; "."; l = SELF -> Qast.Cons m l - | i = a_LIDENT -> Qast.List [i] ] ] - ; - class_longident: - [ [ m = a_UIDENT; "."; l = SELF -> Qast.Cons m l - | i = a_LIDENT -> Qast.List [i] ] ] - ; - ctyp: LEVEL "simple" - [ [ "["; "="; rfl = row_field_list; "]" -> - Qast.Node "TyVrn" [Qast.Loc; rfl; Qast.Option None] - | "["; ">"; rfl = row_field_list; "]" -> - Qast.Node "TyVrn" - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option None))] - | "["; "<"; rfl = row_field_list; "]" -> - Qast.Node "TyVrn" - [Qast.Loc; rfl; - Qast.Option (Some (Qast.Option (Some (Qast.List []))))] - | "["; "<"; rfl = row_field_list; ">"; ntl = SLIST1 name_tag; "]" -> - Qast.Node "TyVrn" - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))] - | "[<"; rfl = row_field_list; "]" -> - Qast.Node "TyVrn" - [Qast.Loc; rfl; - Qast.Option (Some (Qast.Option (Some (Qast.List []))))] - | "[<"; rfl = row_field_list; ">"; ntl = SLIST1 name_tag; "]" -> - Qast.Node "TyVrn" - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))] ] ] - ; - row_field_list: - [ [ rfl = SLIST0 row_field SEP "|" -> rfl ] ] - ; - row_field: - [ [ "`"; i = ident -> Qast.Node "RfTag" [i; Qast.Bool True; Qast.List []] - | "`"; i = ident; "of"; ao = SOPT "&"; l = SLIST1 ctyp SEP "&" -> - Qast.Node "RfTag" [i; o2b ao; l] - | t = ctyp -> Qast.Node "RfInh" [t] ] ] - ; - name_tag: - [ [ "`"; i = ident -> i ] ] - ; - patt: LEVEL "simple" - [ [ "`"; s = ident -> Qast.Node "PaVrn" [Qast.Loc; s] - | "#"; sl = mod_ident -> Qast.Node "PaTyp" [Qast.Loc; sl] - | i = a_TILDEIDENT; ":"; p = SELF -> - Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)] - | i = a_LABEL; p = SELF -> - Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)] - | i = a_TILDEIDENT -> Qast.Node "PaLab" [Qast.Loc; i; Qast.Option None] - | i = a_QUESTIONIDENT; ":"; "("; p = patt_tcon; eo = SOPT eq_expr; - ")" -> - Qast.Node "PaOlb" - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))] - | i = a_OPTLABEL; "("; p = patt_tcon; eo = SOPT eq_expr; ")" -> - Qast.Node "PaOlb" - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))] - | i = a_QUESTIONIDENT -> - Qast.Node "PaOlb" [Qast.Loc; i; Qast.Option None] - | "?"; "("; p = patt_tcon; eo = SOPT eq_expr; ")" -> - Qast.Node "PaOlb" - [Qast.Loc; Qast.Str ""; - Qast.Option (Some (Qast.Tuple [p; eo]))] ] ] - ; - patt_tcon: - [ [ p = patt; ":"; t = ctyp -> Qast.Node "PaTyc" [Qast.Loc; p; t] - | p = patt -> p ] ] - ; - ipatt: - [ [ i = a_TILDEIDENT; ":"; p = SELF -> - Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)] - | i = a_LABEL; p = SELF -> - Qast.Node "PaLab" [Qast.Loc; i; Qast.Option (Some p)] - | i = a_TILDEIDENT -> Qast.Node "PaLab" [Qast.Loc; i; Qast.Option None] - | i = a_QUESTIONIDENT; ":"; "("; p = ipatt_tcon; eo = SOPT eq_expr; - ")" -> - Qast.Node "PaOlb" - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))] - | i = a_OPTLABEL; "("; p = ipatt_tcon; eo = SOPT eq_expr; ")" -> - Qast.Node "PaOlb" - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))] - | i = a_QUESTIONIDENT -> - Qast.Node "PaOlb" [Qast.Loc; i; Qast.Option None] - | "?"; "("; p = ipatt_tcon; eo = SOPT eq_expr; ")" -> - Qast.Node "PaOlb" - [Qast.Loc; Qast.Str ""; - Qast.Option (Some (Qast.Tuple [p; eo]))] ] ] - ; - ipatt_tcon: - [ [ p = ipatt; ":"; t = ctyp -> Qast.Node "PaTyc" [Qast.Loc; p; t] - | p = ipatt -> p ] ] - ; - eq_expr: - [ [ "="; e = expr -> e ] ] - ; - expr: AFTER "apply" - [ "label" NONA - [ i = a_TILDEIDENT; ":"; e = SELF -> - Qast.Node "ExLab" [Qast.Loc; i; Qast.Option (Some e)] - | i = a_LABEL; e = SELF -> - Qast.Node "ExLab" [Qast.Loc; i; Qast.Option (Some e)] - | i = a_TILDEIDENT -> Qast.Node "ExLab" [Qast.Loc; i; Qast.Option None] - | i = a_QUESTIONIDENT; ":"; e = SELF -> - Qast.Node "ExOlb" [Qast.Loc; i; Qast.Option (Some e)] - | i = a_OPTLABEL; e = SELF -> - Qast.Node "ExOlb" [Qast.Loc; i; Qast.Option (Some e)] - | i = a_QUESTIONIDENT -> - Qast.Node "ExOlb" [Qast.Loc; i; Qast.Option None] ] ] - ; - expr: LEVEL "simple" - [ [ "`"; s = ident -> Qast.Node "ExVrn" [Qast.Loc; s] ] ] - ; - direction_flag: - [ [ "to" -> Qast.Bool True - | "downto" -> Qast.Bool False ] ] - ; - (* Compatibility old syntax of variant types definitions *) - ctyp: LEVEL "simple" - [ [ "[|"; warning_variant; rfl = row_field_list; "|]" -> - Qast.Node "TyVrn" [Qast.Loc; rfl; Qast.Option None] - | "[|"; warning_variant; ">"; rfl = row_field_list; "|]" -> - Qast.Node "TyVrn" - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option None))] - | "[|"; warning_variant; "<"; rfl = row_field_list; "|]" -> - Qast.Node "TyVrn" - [Qast.Loc; rfl; - Qast.Option (Some (Qast.Option (Some (Qast.List []))))] - | "[|"; warning_variant; "<"; rfl = row_field_list; ">"; - ntl = SLIST1 name_tag; "|]" -> - Qast.Node "TyVrn" - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))] ] ] - ; - warning_variant: - [ [ -> warn_variant Qast.Loc ] ] - ; - (* Compatibility old syntax of sequences *) - expr: LEVEL "top" - [ [ "do"; seq = SLIST0 [ e = expr; ";" -> e ]; "return"; warning_sequence; - e = SELF -> - Qast.Node "ExSeq" [Qast.Loc; append_elem seq e] - | "for"; i = a_LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF; - "do"; seq = SLIST0 [ e = expr; ";" -> e ]; warning_sequence; "done" -> - Qast.Node "ExFor" [Qast.Loc; i; e1; e2; df; seq] - | "while"; e = SELF; "do"; seq = SLIST0 [ e = expr; ";" -> e ]; - warning_sequence; "done" -> - Qast.Node "ExWhi" [Qast.Loc; e; seq] ] ] - ; - warning_sequence: - [ [ -> warn_sequence Qast.Loc ] ] - ; - (* Antiquotations for local entries *) - sequence: - [ [ a = ANTIQUOT "list" -> antiquot "list" _loc a ] ] - ; - expr_ident: - [ [ a = ANTIQUOT -> antiquot "" _loc a ] ] - ; - patt_label_ident: LEVEL "simple" - [ [ a = ANTIQUOT -> antiquot "" _loc a ] ] - ; - when_expr_opt: - [ [ a = ANTIQUOT "when" -> antiquot "when" _loc a ] ] - ; - mod_ident: - [ [ a = ANTIQUOT -> antiquot "" _loc a ] ] - ; - clty_longident: - [ [ a = a_list -> a ] ] - ; - class_longident: - [ [ a = a_list -> a ] ] - ; - direction_flag: - [ [ a = ANTIQUOT "to" -> antiquot "to" _loc a ] ] - ; - (* deprecated since version 3.05; code for compatibility *) - class_expr: LEVEL "simple" - [ [ "object"; x = ANTIQUOT; cf = class_structure; "end" -> - let _ = warn_antiq _loc "3.05" in - Qast.Node "CeStr" [Qast.Loc; antiquot "" _loc x; cf] - | "object"; x = ANTIQUOT; ";"; - csl = SLIST0 [ cf = class_str_item; ";" -> cf ] ; "end" -> - let _ = warn_antiq _loc "3.05" in - Qast.Node "CeStr" - [Qast.Loc; Qast.Option None; - Qast.Cons (antiquot "" _loc x) csl] ] ] - ; - class_type: - [ [ "object"; x = ANTIQUOT; - csf = SLIST0 [ csf = class_sig_item; ";" -> csf ]; "end" -> - let _ = warn_antiq _loc "3.05" in - Qast.Node "CtSig" [Qast.Loc; antiquot "" _loc x; csf] - | "object"; x = ANTIQUOT; ";"; - csf = SLIST0 [ csf = class_sig_item; ";" -> csf ]; "end" -> - let _ = warn_antiq _loc "3.05" in - Qast.Node "CtSig" - [Qast.Loc; Qast.Option None; - Qast.Cons (antiquot "" _loc x) csf] ] ] - ; - (* deprecated since version 3.06+18; code for compatibility *) - expr: LEVEL "top" - [ [ "let"; r = ANTIQUOT "rec"; l = SLIST1 let_binding SEP "and"; "in"; - x = SELF -> - let _ = warn_antiq _loc "3.06+18" in - Qast.Node "ExLet" [Qast.Loc; antiquot "rec" _loc r; l; x] ] ] - ; - str_item: LEVEL "top" - [ [ "value"; r = ANTIQUOT "rec"; l = SLIST1 let_binding SEP "and" -> - let _ = warn_antiq _loc "3.06+18" in - Qast.Node "StVal" [Qast.Loc; antiquot "rec" _loc r; l] ] ] - ; - class_expr: LEVEL "top" - [ [ "let"; r = ANTIQUOT "rec"; lb = SLIST1 let_binding SEP "and"; "in"; - ce = SELF -> - let _ = warn_antiq _loc "3.06+18" in - Qast.Node "CeLet" [Qast.Loc; antiquot "rec" _loc r; lb; ce] ] ] - ; - class_str_item: - [ [ "inherit"; ce = class_expr; pb = ANTIQUOT "as" -> - let _ = warn_antiq _loc "3.06+18" in - Qast.Node "CrInh" [Qast.Loc; ce; antiquot "as" _loc pb] - | "value"; mf = ANTIQUOT "mut"; lab = label; e = cvalue_binding -> - let _ = warn_antiq _loc "3.06+18" in - Qast.Node "CrVal" [Qast.Loc; lab; antiquot "mut" _loc mf; e] ] ] - ; - class_sig_item: - [ [ "value"; mf = ANTIQUOT "mut"; l = label; ":"; t = ctyp -> - let _ = warn_antiq _loc "3.06+18" in - Qast.Node "CgVal" [Qast.Loc; l; antiquot "mut" _loc mf; t] ] ] - ; -END; - -EXTEND - GLOBAL: str_item sig_item; - str_item: - [ [ "#"; n = a_LIDENT; dp = dir_param -> - Qast.Node "StDir" [Qast.Loc; n; dp] ] ] - ; - sig_item: - [ [ "#"; n = a_LIDENT; dp = dir_param -> - Qast.Node "SgDir" [Qast.Loc; n; dp] ] ] - ; - dir_param: - [ [ a = ANTIQUOT "opt" -> antiquot "opt" _loc a - | e = expr -> Qast.Option (Some e) - | -> Qast.Option None ] ] - ; -END; - -(* Antiquotations *) - -EXTEND - module_expr: LEVEL "simple" - [ [ a = ANTIQUOT "mexp" -> antiquot "mexp" _loc a - | a = ANTIQUOT -> antiquot "" _loc a ] ] - ; - str_item: LEVEL "top" - [ [ a = ANTIQUOT "stri" -> antiquot "stri" _loc a - | a = ANTIQUOT -> antiquot "" _loc a ] ] - ; - module_type: LEVEL "simple" - [ [ a = ANTIQUOT "mtyp" -> antiquot "mtyp" _loc a - | a = ANTIQUOT -> antiquot "" _loc a ] ] - ; - sig_item: LEVEL "top" - [ [ a = ANTIQUOT "sigi" -> antiquot "sigi" _loc a - | a = ANTIQUOT -> antiquot "" _loc a ] ] - ; - expr: LEVEL "simple" - [ [ a = ANTIQUOT "exp" -> antiquot "exp" _loc a - | a = ANTIQUOT -> antiquot "" _loc a - | a = ANTIQUOT "anti" -> - Qast.Node "ExAnt" [Qast.Loc; antiquot "anti" _loc a] - | "("; el = a_list; ")" -> Qast.Node "ExTup" [Qast.Loc; el] ] ] - ; - patt: LEVEL "simple" - [ [ a = ANTIQUOT "pat" -> antiquot "pat" _loc a - | a = ANTIQUOT -> antiquot "" _loc a - | a = ANTIQUOT "anti" -> - Qast.Node "PaAnt" [Qast.Loc; antiquot "anti" _loc a] - | "("; pl = a_list; ")" -> Qast.Node "PaTup" [Qast.Loc; pl] ] ] - ; - ipatt: - [ [ a = ANTIQUOT "pat" -> antiquot "pat" _loc a - | a = ANTIQUOT -> antiquot "" _loc a - | a = ANTIQUOT "anti" -> - Qast.Node "PaAnt" [Qast.Loc; antiquot "anti" _loc a] - | "("; pl = a_list; ")" -> Qast.Node "PaTup" [Qast.Loc; pl] ] ] - ; - ctyp: LEVEL "simple" - [ [ a = ANTIQUOT "typ" -> antiquot "typ" _loc a - | a = ANTIQUOT -> antiquot "" _loc a - | "("; tl = a_list; ")" -> Qast.Node "TyTup" [Qast.Loc; tl] ] ] - ; - class_expr: LEVEL "simple" - [ [ a = ANTIQUOT -> antiquot "" _loc a ] ] - ; - class_str_item: - [ [ a = ANTIQUOT -> antiquot "" _loc a ] ] - ; - class_sig_item: - [ [ a = ANTIQUOT -> antiquot "" _loc a ] ] - ; - class_type: - [ [ a = ANTIQUOT -> antiquot "" _loc a ] ] - ; - expr: LEVEL "simple" - [ [ "{<"; fel = a_list; ">}" -> Qast.Node "ExOvr" [Qast.Loc; fel] ] ] - ; - patt: LEVEL "simple" - [ [ "#"; a = a_list -> Qast.Node "PaTyp" [Qast.Loc; a] ] ] - ; - a_list: - [ [ a = ANTIQUOT "list" -> antiquot "list" _loc a ] ] - ; - a_opt: - [ [ a = ANTIQUOT "opt" -> antiquot "opt" _loc a ] ] - ; - a_UIDENT: - [ [ a = ANTIQUOT "uid" -> antiquot "uid" _loc a - | a = ANTIQUOT -> antiquot "" _loc a - | i = UIDENT -> Qast.Str i ] ] - ; - a_LIDENT: - [ [ a = ANTIQUOT "lid" -> antiquot "lid" _loc a - | a = ANTIQUOT -> antiquot "" _loc a - | i = LIDENT -> Qast.Str i ] ] - ; - a_INT: - [ [ a = ANTIQUOT "int" -> antiquot "int" _loc a - | a = ANTIQUOT -> antiquot "" _loc a - | s = INT -> Qast.Str s ] ] - ; - a_INT32: - [ [ a = ANTIQUOT "int32" -> antiquot "int32" _loc a - | a = ANTIQUOT -> antiquot "" _loc a - | s = INT32 -> Qast.Str s ] ] - ; - a_INT64: - [ [ a = ANTIQUOT "int64" -> antiquot "int64" _loc a - | a = ANTIQUOT -> antiquot "" _loc a - | s = INT64 -> Qast.Str s ] ] - ; - a_NATIVEINT: - [ [ a = ANTIQUOT "nativeint" -> antiquot "nativeint" _loc a - | a = ANTIQUOT -> antiquot "" _loc a - | s = NATIVEINT -> Qast.Str s ] ] - ; - a_FLOAT: - [ [ a = ANTIQUOT "flo" -> antiquot "flo" _loc a - | a = ANTIQUOT -> antiquot "" _loc a - | s = FLOAT -> Qast.Str s ] ] - ; - a_STRING: - [ [ a = ANTIQUOT "str" -> antiquot "str" _loc a - | a = ANTIQUOT -> antiquot "" _loc a - | s = STRING -> Qast.Str s ] ] - ; - a_CHAR: - [ [ a = ANTIQUOT "chr" -> antiquot "chr" _loc a - | a = ANTIQUOT -> antiquot "" _loc a - | s = CHAR -> Qast.Str s ] ] - ; - a_TILDEIDENT: - [ [ "~"; a = ANTIQUOT -> antiquot "" _loc a - | s = TILDEIDENT -> Qast.Str s ] ] - ; - a_LABEL: - [ [ s = LABEL -> Qast.Str s ] ] - ; - a_QUESTIONIDENT: - [ [ "?"; a = ANTIQUOT -> antiquot "" _loc a - | s = QUESTIONIDENT -> Qast.Str s ] ] - ; - a_OPTLABEL: - [ [ s = OPTLABEL -> Qast.Str s ] ] - ; -END; - -value apply_entry e = - let f s = - let (bolpos,lnum,fname) = q_position in - let (bolp,ln,_) = (bolpos.val, lnum.val, fname.val) in - let zero_position() = do { bolpos.val := 0; lnum.val := 1 } in - let restore_position() = do { bolpos.val := bolp; lnum.val := ln } in - let _ = zero_position() in - try - let result = - Grammar.Entry.parse e (Stream.of_string s) in - let _ = restore_position() in - result - with exc -> do { restore_position(); raise exc } in - let expr s = Qast.to_expr (f s) in - let patt s = Qast.to_patt (f s) in - Quotation.ExAst (expr, patt) -; - - -let sig_item_eoi = Grammar.Entry.create gram "signature item" in -do { - EXTEND - sig_item_eoi: - [ [ x = sig_item; EOI -> x ] ] - ; - END; - Quotation.add "sig_item" (apply_entry sig_item_eoi) -}; - -let str_item_eoi = Grammar.Entry.create gram "structure item" in -do { - EXTEND - str_item_eoi: - [ [ x = str_item; EOI -> x ] ] - ; - END; - Quotation.add "str_item" (apply_entry str_item_eoi) -}; - -let ctyp_eoi = Grammar.Entry.create gram "type" in -do { - EXTEND - ctyp_eoi: - [ [ x = ctyp; EOI -> x ] ] - ; - END; - Quotation.add "ctyp" (apply_entry ctyp_eoi) -}; - -let patt_eoi = Grammar.Entry.create gram "pattern" in -do { - EXTEND - patt_eoi: - [ [ x = patt; EOI -> x ] ] - ; - END; - Quotation.add "patt" (apply_entry patt_eoi) -}; - -let expr_eoi = Grammar.Entry.create gram "expression" in -do { - EXTEND - expr_eoi: - [ [ x = expr; EOI -> x ] ] - ; - END; - Quotation.add "expr" (apply_entry expr_eoi) -}; - -let module_type_eoi = Grammar.Entry.create gram "module type" in -do { - EXTEND - module_type_eoi: - [ [ x = module_type; EOI -> x ] ] - ; - END; - Quotation.add "module_type" (apply_entry module_type_eoi) -}; - -let module_expr_eoi = Grammar.Entry.create gram "module expression" in -do { - EXTEND - module_expr_eoi: - [ [ x = module_expr; EOI -> x ] ] - ; - END; - Quotation.add "module_expr" (apply_entry module_expr_eoi) -}; - -let class_type_eoi = Grammar.Entry.create gram "class_type" in -do { - EXTEND - class_type_eoi: - [ [ x = class_type; EOI -> x ] ] - ; - END; - Quotation.add "class_type" (apply_entry class_type_eoi) -}; - -let class_expr_eoi = Grammar.Entry.create gram "class_expr" in -do { - EXTEND - class_expr_eoi: - [ [ x = class_expr; EOI -> x ] ] - ; - END; - Quotation.add "class_expr" (apply_entry class_expr_eoi) -}; - -let class_sig_item_eoi = Grammar.Entry.create gram "class_sig_item" in -do { - EXTEND - class_sig_item_eoi: - [ [ x = class_sig_item; EOI -> x ] ] - ; - END; - Quotation.add "class_sig_item" (apply_entry class_sig_item_eoi) -}; - -let class_str_item_eoi = Grammar.Entry.create gram "class_str_item" in -do { - EXTEND - class_str_item_eoi: - [ [ x = class_str_item; EOI -> x ] ] - ; - END; - Quotation.add "class_str_item" (apply_entry class_str_item_eoi) -}; - -let with_constr_eoi = Grammar.Entry.create gram "with constr" in -do { - EXTEND - with_constr_eoi: - [ [ x = with_constr; EOI -> x ] ] - ; - END; - Quotation.add "with_constr" (apply_entry with_constr_eoi) -}; - -let row_field_eoi = Grammar.Entry.create gram "row_field" in -do { - EXTEND - row_field_eoi: - [ [ x = row_field; EOI -> x ] ] - ; - END; - Quotation.add "row_field" (apply_entry row_field_eoi) -}; diff --git a/camlp4/mkcamlp4.ml b/camlp4/mkcamlp4.ml new file mode 100644 index 00000000..e231954c --- /dev/null +++ b/camlp4/mkcamlp4.ml @@ -0,0 +1,68 @@ +(****************************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed under *) +(* the terms of the GNU Library General Public License, with the special *) +(* exception on linking described in LICENSE at the top of the Objective *) +(* Caml source tree. *) +(* *) +(****************************************************************************) + +(* Authors: + * - Daniel de Rauglaudre: initial shell version + * - Nicolas Pouillard: rewriting in OCaml + *) + +(* $Id: mkcamlp4.ml,v 1.3 2007/02/07 10:09:21 ertai Exp $ *) + +open Camlp4; +open Camlp4_config; +open Filename; +open Format; + +value (interfaces, options, includes) = + let rec self (interf, opts, incl) = + fun + [ [] -> (List.rev interf, List.rev opts, List.rev incl) + | ["-I"; dir :: args] -> self (interf, opts, [dir; "-I" :: incl]) args + | ["-version" :: _] -> + do { printf "mkcamlp4, version %s@." version; exit 0 } + | [ arg :: args ] when check_suffix arg ".cmi" -> + let basename = String.capitalize (Filename.chop_suffix + (Filename.basename arg) ".cmi") in + self ([ basename :: interf ], opts, incl) args + | [ arg :: args ] -> + self (interf, [ arg :: opts ], incl) args ] + in self ([], [], ["."; "-I"]) (List.tl (Array.to_list Sys.argv)); + +value run l = + let cmd = String.concat " " l in + let () = Format.printf "%s@." cmd in + let st = + Sys.command cmd + (* 0 *) + in + if st <> 0 then failwith ("Exit: " ^ string_of_int st) else (); + +value crc_ml = Filename.temp_file "crc_" ".ml"; +value crc = Filename.chop_suffix crc_ml ".ml"; +value clean () = run ["rm"; "-f"; crc_ml; crc^".cmi"; crc^".cmo"]; + +try do { + run ([ocaml_standard_library^"/extract_crc"; "-I"; camlp4_standard_library] + @ includes @ interfaces @ [">"; crc_ml]); + + let cout = open_out_gen [Open_wronly; Open_append; Open_text] 0o666 crc_ml in do { + output_string cout "let _ = Dynlink.add_available_units crc_unit_list\n"; + close_out cout + }; + + run (["ocamlc"; "-I"; camlp4_standard_library; "Camlp4.cma"; crc_ml] + @ includes @ options @ ["Camlp4Bin.cmo"; "-linkall"]); + clean(); +} +with exc -> do { clean (); raise exc }; diff --git a/camlp4/ocaml_src/.cvsignore b/camlp4/ocaml_src/.cvsignore deleted file mode 100644 index 2551b024..00000000 --- a/camlp4/ocaml_src/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -SAVED diff --git a/camlp4/ocaml_src/camlp4/.cvsignore b/camlp4/ocaml_src/camlp4/.cvsignore deleted file mode 100644 index eb4bb86b..00000000 --- a/camlp4/ocaml_src/camlp4/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -camlp4 -crc.ml -extract_crc diff --git a/camlp4/ocaml_src/camlp4/.depend b/camlp4/ocaml_src/camlp4/.depend deleted file mode 100644 index 2f078d8d..00000000 --- a/camlp4/ocaml_src/camlp4/.depend +++ /dev/null @@ -1,21 +0,0 @@ -ast2pt.cmi: $(OTOP)/parsing/parsetree.cmi mLast.cmi $(OTOP)/parsing/longident.cmi \ - $(OTOP)/parsing/location.cmi -pcaml.cmi: spretty.cmi mLast.cmi -quotation.cmi: mLast.cmi -reloc.cmi: mLast.cmi -argl.cmo: pcaml.cmi ../odyl/odyl_main.cmi mLast.cmi ast2pt.cmi -argl.cmx: pcaml.cmx ../odyl/odyl_main.cmx mLast.cmi ast2pt.cmx -ast2pt.cmo: pcaml.cmi $(OTOP)/parsing/parsetree.cmi mLast.cmi \ - $(OTOP)/parsing/longident.cmi $(OTOP)/parsing/location.cmi \ - $(OTOP)/parsing/asttypes.cmi ast2pt.cmi -ast2pt.cmx: pcaml.cmx $(OTOP)/parsing/parsetree.cmi mLast.cmi \ - $(OTOP)/parsing/longident.cmx $(OTOP)/parsing/location.cmx \ - $(OTOP)/parsing/asttypes.cmi ast2pt.cmi -pcaml.cmo: spretty.cmi reloc.cmi quotation.cmi mLast.cmi pcaml.cmi -pcaml.cmx: spretty.cmx reloc.cmx quotation.cmx mLast.cmi pcaml.cmi -quotation.cmo: mLast.cmi quotation.cmi -quotation.cmx: mLast.cmi quotation.cmi -reloc.cmo: mLast.cmi reloc.cmi -reloc.cmx: mLast.cmi reloc.cmi -spretty.cmo: spretty.cmi -spretty.cmx: spretty.cmi diff --git a/camlp4/ocaml_src/camlp4/Makefile b/camlp4/ocaml_src/camlp4/Makefile deleted file mode 100644 index 81227d3b..00000000 --- a/camlp4/ocaml_src/camlp4/Makefile +++ /dev/null @@ -1,95 +0,0 @@ -# This file has been generated by program: do not edit! - -include ../../config/Makefile - -SHELL=/bin/sh - -INCLUDES=-I ../odyl -I ../../boot -I $(OTOP)/utils -I $(OTOP)/parsing -I $(OTOP)/otherlibs/dynlink -OCAMLCFLAGS= $(INCLUDES) -warn-error A $(INCLUDES) -LINKFLAGS=$(INCLUDES) -INTERFACES=-I $(OLIBDIR) Arg Array ArrayLabels Buffer Callback CamlinternalOO Char Complex Digest Filename Format Gc Genlex Hashtbl Int32 Int64 Lazy Lexing List ListLabels Map Marshal MoreLabels Nativeint Obj Oo Parsing Pervasives Printexc Printf Queue Random Scanf Set Sort Stack StdLabels Stream String StringLabels Sys Weak -I ../../boot Extfold Extfun Fstream Gramext Grammar Plexer Stdpp Token -I $(OTOP)/utils Config Warnings -I $(OTOP)/parsing Asttypes Location Longident Parsetree -I . Ast2pt MLast Pcaml Quotation Spretty -CAMLP4_INTF=$(OTOP)/utils/config.cmi $(OTOP)/utils/warnings.cmi $(OTOP)/parsing/asttypes.cmi $(OTOP)/parsing/location.cmi $(OTOP)/parsing/longident.cmi $(OTOP)/parsing/parsetree.cmi ast2pt.cmi mLast.cmi pcaml.cmi spretty.cmi quotation.cmi -CAMLP4_OBJS=../../boot/stdpp.cmo ../../boot/token.cmo ../../boot/plexer.cmo ../../boot/gramext.cmo ../../boot/grammar.cmo ../../boot/extfold.cmo ../../boot/extfun.cmo ../../boot/fstream.cmo $(OTOP)/utils/config.cmo quotation.cmo spretty.cmo reloc.cmo pcaml.cmo ast2pt.cmo argl.cmo -CAMLP4_XOBJS=../lib/stdpp.cmx ../lib/token.cmx ../lib/plexer.cmx ../lib/gramext.cmx ../lib/grammar.cmx ../lib/extfold.cmx ../lib/extfun.cmx ../lib/fstream.cmx $(OTOP)/utils/config.cmx quotation.cmx spretty.cmx reloc.cmx pcaml.cmx ast2pt.cmx argl.cmx -OBJS=../odyl/odyl.cma camlp4.cma -CAMLP4M= - -CAMLP4=camlp4$(EXE) -CAMLP4OPT=phony - -all: $(CAMLP4) - -opt: opt$(PROFILING) - -optnoprof: $(OBJS:.cma=.cmxa) - -optprof: optnoprof $(OBJS:.cma=.p.cmxa) - -optp4: $(CAMLP4OPT) - -$(CAMLP4): $(OBJS) ../odyl/odyl.cmo - $(OCAMLC) -linkall -o $@ $(OBJS) $(CAMLP4M) ../odyl/odyl.cmo - -$(CAMLP4OPT): $(OBJS:.cma=.cmxa) ../odyl/odyl.cmx - $(OCAMLOPT) -linkall -o $@ $(OBJS:.cma=.cmxa) $(CAMLP4M) ../odyl/odyl.cmx - -$(OTOP)/utils/config.cmx: $(OTOP)/utils/config.ml - $(OCAMLOPT) -I $(OTOP)/utils -c $(OTOP)/utils/config.ml - -$(OTOP)/utils/config.p.cmx: $(OTOP)/utils/config.ml - $(OCAMLOPT) -I $(OTOP)/utils -p -c -o $@ $(OTOP)/utils/config.ml - -camlp4.cma: $(CAMLP4_OBJS) - $(OCAMLC) $(LINKFLAGS) -a -o $@ $(CAMLP4_OBJS) - -camlp4.cmxa: $(CAMLP4_XOBJS) - $(OCAMLOPT) $(LINKFLAGS) -a -o $@ $(CAMLP4_XOBJS) - -camlp4.p.cmxa: $(CAMLP4_XOBJS:.cmx=.p.cmx) - $(OCAMLOPT) $(LINKFLAGS) -a -o $@ $(CAMLP4_XOBJS:.cmx=.p.cmx) - -clean:: - rm -f *.cm* *.pp[io] *.$(O) *.$(A) *.bak .*.bak *.out *.opt - rm -f $(CAMLP4) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -promote: - cp $(CAMLP4) ../../boot/. - -compare: - @for j in $(CAMLP4); do \ - if cmp $$j ../../boot/$$j; then :; else exit 1; fi; \ - done - -install: - -$(MKDIR) "$(BINDIR)" - -$(MKDIR) "$(LIBDIR)/camlp4" - cp $(CAMLP4) "$(BINDIR)/." - cp mLast.mli quotation.mli ast2pt.mli pcaml.mli spretty.mli "$(LIBDIR)/camlp4/." - cp mLast.cmi quotation.cmi ast2pt.cmi pcaml.cmi spretty.cmi "$(LIBDIR)/camlp4/." - cp argl.cmi argl.cmo "$(LIBDIR)/camlp4/." - for f in argl.o argl.cmx; do \ - if test -r $$f ; then \ - cp $$f "$(LIBDIR)/camlp4/." ; \ - fi ; \ - done - cp camlp4.cma $(LIBDIR)/camlp4/. - for f in camlp4.$(A) camlp4.p.$(A) ; do \ - if test -f $$f ; then \ - cp $$f "$(LIBDIR)/camlp4/." && ( cd "$(LIBDIR)/camlp4/." && $(RANLIB) $$f ) ; \ - fi ; \ - done - for f in camlp4.cmxa camlp4.p.cmxa ; do \ - if test -f $$f ; then \ - cp $$f "$(LIBDIR)/camlp4/." ; \ - fi ; \ - done - -include .depend diff --git a/camlp4/ocaml_src/camlp4/argl.ml b/camlp4/ocaml_src/camlp4/argl.ml deleted file mode 100644 index f32661e6..00000000 --- a/camlp4/ocaml_src/camlp4/argl.ml +++ /dev/null @@ -1,430 +0,0 @@ -(* camlp4r q_MLast.cmo *) -(* This file has been generated by program: do not edit! *) - -open Printf;; - -let rec action_arg s sl = - function - Arg.Unit f -> if s = "" then begin f (); Some sl end else None - | Arg.Bool f -> - if s = "" then - match sl with - s :: sl -> - begin try f (bool_of_string s); Some sl with - Invalid_argument "bool_of_string" -> None - end - | [] -> None - else - begin try f (bool_of_string s); Some sl with - Invalid_argument "bool_of_string" -> None - end - | Arg.Set r -> if s = "" then begin r := true; Some sl end else None - | Arg.Clear r -> if s = "" then begin r := false; Some sl end else None - | Arg.Rest f -> List.iter f (s :: sl); Some [] - | Arg.String f -> - if s = "" then - match sl with - s :: sl -> f s; Some sl - | [] -> None - else begin f s; Some sl end - | Arg.Set_string r -> - if s = "" then - match sl with - s :: sl -> r := s; Some sl - | [] -> None - else begin r := s; Some sl end - | Arg.Int f -> - if s = "" then - match sl with - s :: sl -> - begin try f (int_of_string s); Some sl with - Failure "int_of_string" -> None - end - | [] -> None - else - begin try f (int_of_string s); Some sl with - Failure "int_of_string" -> None - end - | Arg.Set_int r -> - if s = "" then - match sl with - s :: sl -> - begin try r := int_of_string s; Some sl with - Failure "int_of_string" -> None - end - | [] -> None - else - begin try r := int_of_string s; Some sl with - Failure "int_of_string" -> None - end - | Arg.Float f -> - if s = "" then - match sl with - s :: sl -> f (float_of_string s); Some sl - | [] -> None - else begin f (float_of_string s); Some sl end - | Arg.Set_float r -> - if s = "" then - match sl with - s :: sl -> r := float_of_string s; Some sl - | [] -> None - else begin r := float_of_string s; Some sl end - | Arg.Tuple specs -> - let rec action_args s sl = - function - [] -> 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 -> f s; Some sl - | _ -> None -;; - -let common_start s1 s2 = - let 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 - in - loop 0 -;; - -let rec parse_arg s sl = - function - (name, action, _) :: spec_list -> - 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 _ -> parse_arg s sl spec_list - else parse_arg s sl spec_list - | [] -> None -;; - -let rec parse_aux spec_list anon_fun = - function - [] -> [] - | s :: sl -> - if String.length s > 1 && s.[0] = '-' then - match parse_arg s sl spec_list with - Some sl -> parse_aux spec_list anon_fun sl - | None -> s :: parse_aux spec_list anon_fun sl - else begin (anon_fun s : unit); parse_aux spec_list anon_fun sl end -;; - -let loc_fmt = - match Sys.os_type with - "MacOS" -> - format_of_string "File \"%s\"; line %d; characters %d to %d\n### " - | _ -> format_of_string "File \"%s\", line %d, characters %d-%d:\n" -;; - -let print_location loc = - if !(Pcaml.input_file) <> "-" then - let (fname, line, bp, ep) = Stdpp.line_of_loc !(Pcaml.input_file) loc in - eprintf loc_fmt fname line bp ep - else - eprintf "At location %d-%d\n" (fst loc).Lexing.pos_cnum - (snd loc).Lexing.pos_cnum -;; - -let print_warning loc s = print_location loc; eprintf "%s\n" s;; - -let rec parse_file pa getdir useast = - let name = !(Pcaml.input_file) in - let (_, _, fname) = !(Pcaml.position) in - let () = fname := name in - Pcaml.warning := print_warning; - let ic = if name = "-" then stdin else open_in_bin name in - let cs = Stream.of_channel ic in - let clear () = if name = "-" then () else close_in ic in - let phr = - try - let rec loop () = - let (pl, stopped_at_directive) = pa cs in - if stopped_at_directive then - let pl = - let rpl = List.rev pl in - match getdir rpl with - Some x -> - begin match x with - loc, "load", Some (MLast.ExStr (_, s)) -> - Odyl_main.loadfile s; pl - | loc, "directory", Some (MLast.ExStr (_, s)) -> - Odyl_main.directory s; pl - | loc, "use", Some (MLast.ExStr (_, s)) -> - List.rev_append rpl - [useast loc s (use_file pa getdir useast s), loc] - | loc, _, _ -> - Stdpp.raise_with_loc loc (Stream.Error "bad directive") - end - | None -> pl - in - pl @ loop () - else pl - in - loop () - with - x -> clear (); raise x - in - clear (); phr -and use_file pa getdir useast s = - let (bolpos, lnum, fname) = !(Pcaml.position) in - let clear = - let v_input_file = !(Pcaml.input_file) in - let (bolp, ln, fn) = !bolpos, !lnum, !fname in - fun () -> - Pcaml.input_file := v_input_file; - bolpos := bolp; - lnum := ln; - fname := fn - in - Pcaml.input_file := s; - bolpos := 0; - lnum := 1; - fname := s; - try let r = parse_file pa getdir useast in clear (); r with - e -> clear (); raise e -;; - -let process pa pr getdir useast = pr (parse_file pa getdir useast);; - - -let gind = - function - (MLast.SgDir (loc, n, dp), _) :: _ -> Some (loc, n, dp) - | _ -> None -;; - -let gimd = - function - (MLast.StDir (loc, n, dp), _) :: _ -> Some (loc, n, dp) - | _ -> None -;; - -let usesig loc fname ast = MLast.SgUse (loc, fname, ast);; -let usestr loc fname ast = MLast.StUse (loc, fname, ast);; - -let process_intf () = - process !(Pcaml.parse_interf) !(Pcaml.print_interf) gind usesig -;; -let process_impl () = - process !(Pcaml.parse_implem) !(Pcaml.print_implem) gimd usestr -;; - -type file_kind = - Intf - | Impl -;; -let file_kind = ref Intf;; -let file_kind_of_name name = - if Filename.check_suffix name ".mli" then Intf - else if Filename.check_suffix name ".ml" then Impl - else raise (Arg.Bad ("don't know what to do with " ^ name)) -;; - -let print_version_string () = - print_string Pcaml.version; print_newline (); exit 0 -;; - -let print_version () = - eprintf "Camlp4 version %s\n" Pcaml.version; flush stderr; exit 0 -;; - -let align_doc key s = - let s = - let 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 - loop 0 - in - let (p, s) = - if String.length s > 0 then - if s.[0] = '<' then - let 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 - let 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) - in - loop (i + 1) - in - loop 0 - else "", s - else "", "" - in - let tab = - String.make (max 1 (13 - String.length key - String.length p)) ' ' - in - p ^ tab ^ s -;; - -let make_symlist l = - match l with - [] -> "" - | h :: t -> List.fold_left (fun x y -> x ^ "|" ^ y) ("{" ^ h) t ^ "}" -;; - -let 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 -;; - -let make_symlist l = - match l with - [] -> "" - | h :: t -> List.fold_left (fun x y -> x ^ "|" ^ y) ("{" ^ h) t ^ "}" -;; - -let 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 -;; - -let usage ini_sl ext_sl = - eprintf "\ -Usage: camlp4 [load-options] [--] [other-options] -Load options: - -I directory Add directory in search patch for object files. - -where Print camlp4 library directory and exit. - -nolib No automatic search for object files in library directory. - Load this file in Camlp4 core. -Other options: - Parse this file.\n"; - print_usage_list ini_sl; - begin - let rec loop = - function - (y, _, _) :: _ when y = "-help" -> () - | _ :: sl -> loop sl - | [] -> eprintf " -help Display this list of options.\n" - in - loop (ini_sl @ ext_sl) - end; - if ext_sl <> [] then - begin - eprintf "Options added by loaded object files:\n"; - print_usage_list ext_sl - end -;; - -let warn_noassert () = - eprintf "\ -camlp4 warning: option -noassert is obsolete -You should give the -noassert option to the ocaml compiler instead. -" -;; - -let initial_spec_list = - ["-intf", Arg.String (fun x -> file_kind := Intf; Pcaml.input_file := x), - " Parse as an interface, whatever its extension."; - "-impl", Arg.String (fun x -> file_kind := Impl; Pcaml.input_file := x), - " Parse as an implementation, whatever its extension."; - "-unsafe", Arg.Set Ast2pt.fast, - "Generate unsafe accesses to array and strings."; - "-noassert", Arg.Unit warn_noassert, "Obsolete, do not use this option."; - "-verbose", Arg.Set Grammar.error_verbose, - "More verbose in parsing errors."; - "-loc", Arg.String (fun x -> Stdpp.loc_name := x), - " Name of the location variable (default: " ^ !(Stdpp.loc_name) ^ - ")"; - "-QD", Arg.String (fun x -> Pcaml.quotation_dump_file := Some x), - " Dump quotation expander result in case of syntax error."; - "-o", Arg.String (fun x -> Pcaml.output_file := Some x), - " Output on instead of standard output."; - "-v", Arg.Unit print_version, "Print Camlp4 version and exit."; - "-version", Arg.Unit print_version_string, - "Print Camlp4 version number and exit."; - "-no_quot", Arg.Set Plexer.no_quotations, - " Don't parse quotations, allowing to use, e.g. \"<:>\" as token"] -;; - -let anon_fun x = Pcaml.input_file := x; file_kind := file_kind_of_name x;; - -let parse spec_list anon_fun remaining_args = - let spec_list = - Sort.list (fun (k1, _, _) (k2, _, _) -> k1 >= k2) spec_list - in - try parse_aux spec_list anon_fun remaining_args with - Arg.Bad s -> - eprintf "Error: %s\n" s; - eprintf "Use option -help for usage\n"; - flush stderr; - exit 2 -;; - -let remaining_args = - let rec loop l i = - if i == Array.length Sys.argv then l else loop (Sys.argv.(i) :: l) (i + 1) - in - List.rev (loop [] (!(Arg.current) + 1)) -;; - -let report_error = - function - Odyl_main.Error (fname, msg) -> - Format.print_string "Error while loading \""; - Format.print_string fname; - Format.print_string "\": "; - Format.print_string msg - | exc -> Pcaml.report_error exc -;; - -let go () = - let ext_spec_list = Pcaml.arg_spec_list () in - let arg_spec_list = initial_spec_list @ ext_spec_list in - begin match parse arg_spec_list anon_fun remaining_args with - [] -> () - | "-help" :: sl -> usage initial_spec_list ext_spec_list; exit 0 - | s :: sl -> - eprintf "%s: unknown or misused option\n" s; - eprintf "Use option -help for usage\n"; - exit 2 - end; - try - if !(Pcaml.input_file) <> "" then - match !file_kind with - Intf -> process_intf () - | Impl -> process_impl () - with - exc -> - Format.set_formatter_out_channel stderr; - Format.open_vbox 0; - let exc = - match exc with - Stdpp.Exc_located ((bp, ep), exc) -> print_location (bp, ep); exc - | _ -> exc - in - report_error exc; - Format.close_box (); - Format.print_newline (); - raise exc -;; - -Odyl_main.name := "camlp4";; -Odyl_main.go := go;; diff --git a/camlp4/ocaml_src/camlp4/ast2pt.ml b/camlp4/ocaml_src/camlp4/ast2pt.ml deleted file mode 100644 index b51e15b0..00000000 --- a/camlp4/ocaml_src/camlp4/ast2pt.ml +++ /dev/null @@ -1,957 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Stdpp;; -open MLast;; -open Parsetree;; -open Longident;; -open Asttypes;; - -let fast = ref false;; -let no_constructors_arity = Pcaml.no_constructors_arity;; - -let get_tag x = - if Obj.is_block (Obj.repr x) then Obj.tag (Obj.repr x) else Obj.magic x -;; - -let error loc str = raise_with_loc loc (Failure str);; - -let char_of_char_token loc s = - try Token.eval_char s with - Failure _ as exn -> raise_with_loc loc exn -;; - -let string_of_string_token loc s = - try Token.eval_string loc s with - Failure _ as exn -> raise_with_loc loc exn -;; - -let glob_fname = ref "";; - -let mkloc (bp, ep) = - let loc_at n = - {n with - Lexing.pos_fname = - if n.Lexing.pos_fname = "" then - if !glob_fname = "" then !(Pcaml.input_file) else !glob_fname - else n.Lexing.pos_fname} - in - {Location.loc_start = loc_at bp; Location.loc_end = loc_at ep; - Location.loc_ghost = bp.Lexing.pos_cnum = 0 && ep.Lexing.pos_cnum = 0} -;; - -let mkghloc (bp, ep) = - let loc_at n = - {n with - Lexing.pos_fname = - if n.Lexing.pos_fname = "" then - if !glob_fname = "" then !(Pcaml.input_file) else !glob_fname - else n.Lexing.pos_fname} - in - {Location.loc_start = loc_at bp; Location.loc_end = loc_at ep; - Location.loc_ghost = true} -;; - -let mktyp loc d = {ptyp_desc = d; ptyp_loc = mkloc loc};; -let mkpat loc d = {ppat_desc = d; ppat_loc = mkloc loc};; -let mkghpat loc d = {ppat_desc = d; ppat_loc = mkghloc loc};; -let mkexp loc d = {pexp_desc = d; pexp_loc = mkloc loc};; -let mkmty loc d = {pmty_desc = d; pmty_loc = mkloc loc};; -let mksig loc d = {psig_desc = d; psig_loc = mkloc loc};; -let mkmod loc d = {pmod_desc = d; pmod_loc = mkloc loc};; -let mkstr loc d = {pstr_desc = d; pstr_loc = mkloc loc};; -let mkfield loc d = {pfield_desc = d; pfield_loc = mkloc loc};; -let mkcty loc d = {pcty_desc = d; pcty_loc = mkloc loc};; -let mkpcl loc d = {pcl_desc = d; pcl_loc = mkloc loc};; -let mkpolytype t = - match t with - TyPol (_, _, _) -> t - | _ -> TyPol (MLast.loc_of_ctyp t, [], t) -;; - -let lident s = Lident s;; -let ldot l s = Ldot (l, s);; - -let conv_con = - let t = Hashtbl.create 73 in - 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 -;; - -let conv_lab = - let t = Hashtbl.create 73 in - List.iter (fun (s, s') -> Hashtbl.add t s s') ["val", "contents"]; - fun s -> - try Hashtbl.find t s with - Not_found -> s -;; - -let array_function str name = - ldot (lident str) (if !fast then "unsafe_" ^ name else name) -;; - -let mkrf = - function - true -> Recursive - | false -> Nonrecursive -;; - -let mkli s = - let rec loop f = - function - i :: il -> loop (fun s -> ldot (f i) s) il - | [] -> f s - in - loop (fun s -> lident s) -;; - -let long_id_of_string_list loc sl = - match List.rev sl with - [] -> error loc "bad ast in long ident" - | s :: sl -> mkli s (List.rev sl) -;; - -let rec ctyp_fa al = - function - TyApp (_, f, a) -> ctyp_fa (a :: al) f - | f -> f, al -;; - -let rec ctyp_long_id_prefix t = - match t with - TyAcc (_, m, TyLid (_, s)) -> - error (loc_of_ctyp t) "invalid module expression" - | TyAcc (_, m, TyUid (_, s)) -> - let (is_cls, li) = ctyp_long_id_prefix m in is_cls, ldot li s - | TyApp (_, m1, m2) -> - let (is_cls, li1) = ctyp_long_id_prefix m1 in - let (_, li2) = ctyp_long_id_prefix m2 in is_cls, Lapply (li1, li2) - | TyUid (_, s) -> false, lident s - | TyLid (_, s) -> error (loc_of_ctyp t) "invalid module expression" - | t -> error (loc_of_ctyp t) "invalid module expression" -;; - -let ctyp_long_id t = - match t with - TyAcc (_, m, TyLid (_, s)) -> - let (is_cls, li) = ctyp_long_id_prefix m in is_cls, ldot li s - | TyAcc (_, m, (TyUid (_, s) as t)) -> - error (loc_of_ctyp t) "invalid type name" - | TyApp (_, m1, m2) -> error (loc_of_ctyp t) "invalid type name" - | TyUid (_, s) -> error (loc_of_ctyp t) "invalid type name" - | TyLid (_, s) -> false, lident s - | TyCls (loc, sl) -> true, long_id_of_string_list loc sl - | t -> error (loc_of_ctyp t) "invalid type" -;; - -let rec ctyp = - function - TyAcc (loc, _, _) as f -> - let (is_cls, li) = ctyp_long_id f in - if is_cls then mktyp loc (Ptyp_class (li, [], [])) - else 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 (loc1, lab, t1), t2) -> - mktyp loc (Ptyp_arrow (lab, ctyp t1, ctyp t2)) - | TyArr (loc, TyOlb (loc1, lab, t1), t2) -> - let t1 = TyApp (loc1, TyLid (loc1, "option"), t1) in - mktyp loc (Ptyp_arrow (("?" ^ lab), ctyp t1, ctyp t2)) - | TyArr (loc, t1, t2) -> mktyp loc (Ptyp_arrow ("", ctyp t1, ctyp t2)) - | TyObj (loc, fl, v) -> mktyp loc (Ptyp_object (meth_list loc fl v)) - | TyCls (loc, id) -> - mktyp loc (Ptyp_class (long_id_of_string_list loc id, [], [])) - | TyLab (loc, _, _) -> error loc "labelled type not allowed here" - | TyLid (loc, s) -> mktyp loc (Ptyp_constr (lident s, [])) - | TyMan (loc, _, _) -> error loc "manifest type not allowed here" - | TyOlb (loc, lab, _) -> error loc "labelled type not allowed here" - | TyPol (loc, pl, t) -> mktyp loc (Ptyp_poly (pl, ctyp t)) - | 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" - | TyTup (loc, tl) -> mktyp loc (Ptyp_tuple (List.map ctyp tl)) - | TyUid (loc, s) as t -> error (loc_of_ctyp t) "invalid type" - | TyVrn (loc, catl, ool) -> - let catl = - List.map - (function - RfTag (c, a, t) -> Rtag (c, a, List.map ctyp t) - | RfInh t -> Rinherit (ctyp t)) - catl - in - let (clos, sl) = - match ool with - None -> true, None - | Some None -> false, None - | Some (Some sl) -> true, Some sl - in - mktyp loc (Ptyp_variant (catl, clos, sl)) -and meth_list loc fl v = - match fl with - [] -> if v then [mkfield loc Pfield_var] else [] - | (lab, t) :: fl -> - mkfield loc (Pfield (lab, ctyp (mkpolytype t))) :: meth_list loc fl v -;; - -let mktype loc tl cl tk tm = - let (params, variance) = List.split tl in - {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk; - ptype_manifest = tm; ptype_loc = mkloc loc; ptype_variance = variance} -;; -let mkmutable m = if m then Mutable else Immutable;; -let mkprivate m = if m then Private else Public;; -let mktrecord (loc, n, m, t) = - n, mkmutable m, ctyp (mkpolytype t), mkloc loc -;; -let mkvariant (loc, c, tl) = c, List.map ctyp tl, mkloc loc;; -let rec type_decl tl cl loc m pflag = - function - TyMan (_, t1, t2) -> type_decl tl cl loc (Some (ctyp t1)) pflag t2 - | TyPrv (_, t) -> type_decl tl cl loc m true t - | TyRec (_, ltl) -> - mktype loc tl cl - (Ptype_record (List.map mktrecord ltl, mkprivate pflag)) m - | TySum (_, ctl) -> - mktype loc tl cl - (Ptype_variant (List.map mkvariant ctl, mkprivate pflag)) m - | t -> - if m <> None then - error loc "only one manifest type allowed by definition" - else - let m = - match t with - TyQuo (_, s) -> - if List.mem_assoc s tl then Some (ctyp t) else None - | _ -> Some (ctyp t) - in - let k = if pflag then Ptype_private else Ptype_abstract in - mktype loc tl cl k m -;; - -let type_decl tl cl t = type_decl tl cl (loc_of_ctyp t) None false t;; - -let mkvalue_desc t p = {pval_type = ctyp t; pval_prim = p};; - -let option f = - function - Some x -> Some (f x) - | None -> None -;; - -let expr_of_lab loc lab = - function - Some e -> e - | None -> ExLid (loc, lab) -;; - -let patt_of_lab loc lab = - function - Some p -> p - | None -> PaLid (loc, lab) -;; - -let paolab loc lab peoo = - let lab = - match lab, peoo with - "", Some ((PaLid (_, i) | PaTyc (_, PaLid (_, i), _)), _) -> i - | "", _ -> error loc "bad ast in label" - | _ -> lab - in - let (p, eo) = - match peoo with - Some peo -> peo - | None -> PaLid (loc, lab), None - in - lab, p, eo -;; - -let rec same_type_expr ct ce = - match ct, ce with - TyLid (_, s1), ExLid (_, s2) -> s1 = s2 - | TyUid (_, s1), ExUid (_, s2) -> s1 = s2 - | TyAcc (_, t1, t2), ExAcc (_, e1, e2) -> - same_type_expr t1 e1 && same_type_expr t2 e2 - | _ -> false -;; - -let rec common_id loc t e = - match t, e with - TyLid (_, s1), ExLid (_, s2) when s1 = s2 -> lident s1 - | TyUid (_, s1), ExUid (_, s2) when s1 = s2 -> lident s1 - | TyAcc (_, t1, TyLid (_, s1)), ExAcc (_, e1, ExLid (_, s2)) when s1 = s2 -> - ldot (common_id loc t1 e1) s1 - | TyAcc (_, t1, TyUid (_, s1)), ExAcc (_, e1, ExUid (_, s2)) when s1 = s2 -> - ldot (common_id loc t1 e1) s1 - | _ -> error loc "this expression should repeat the class id inherited" -;; - -let rec type_id loc t = - match t with - TyLid (_, s1) -> lident s1 - | TyUid (_, s1) -> lident s1 - | TyAcc (_, t1, TyLid (_, s1)) -> ldot (type_id loc t1) s1 - | TyAcc (_, t1, TyUid (_, s1)) -> ldot (type_id loc t1) s1 - | _ -> error loc "type identifier expected" -;; - -let rec module_type_long_id = - function - MtAcc (_, m, MtUid (_, s)) -> ldot (module_type_long_id m) s - | MtAcc (_, m, MtLid (_, s)) -> ldot (module_type_long_id m) s - | MtApp (_, m1, m2) -> - Lapply (module_type_long_id m1, module_type_long_id m2) - | MtLid (_, s) -> lident s - | MtUid (_, s) -> lident s - | t -> error (loc_of_module_type t) "bad module type long ident" -;; - -let rec module_expr_long_id = - function - MeAcc (_, m, MeUid (_, s)) -> ldot (module_expr_long_id m) s - | MeUid (_, s) -> lident s - | t -> error (loc_of_module_expr t) "bad module expr long ident" -;; - -let mkwithc = - function - WcTyp (loc, id, tpl, ct) -> - let (params, variance) = List.split tpl in - long_id_of_string_list loc id, - Pwith_type - {ptype_params = params; ptype_cstrs = []; ptype_kind = Ptype_abstract; - ptype_manifest = Some (ctyp ct); ptype_loc = mkloc loc; - ptype_variance = variance} - | WcMod (loc, id, m) -> - long_id_of_string_list loc id, Pwith_module (module_expr_long_id m) -;; - -let rec patt_fa al = - function - PaApp (_, f, a) -> patt_fa (a :: al) f - | f -> f, al -;; - -let rec deep_mkrangepat loc c1 c2 = - if c1 = c2 then mkghpat loc (Ppat_constant (Const_char c1)) - else - mkghpat loc - (Ppat_or - (mkghpat loc (Ppat_constant (Const_char c1)), - deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2)) -;; - -let rec mkrangepat loc c1 c2 = - if c1 > c2 then mkrangepat loc c2 c1 - else if c1 = c2 then mkpat loc (Ppat_constant (Const_char c1)) - else - mkpat loc - (Ppat_or - (mkghpat loc (Ppat_constant (Const_char c1)), - deep_mkrangepat loc (Char.chr (Char.code c1 + 1)) c2)) -;; - -let rec patt_long_id il = - function - PaAcc (_, p, PaUid (_, i)) -> patt_long_id (i :: il) p - | p -> p, il -;; - -let rec patt_label_long_id = - function - PaAcc (_, m, PaLid (_, s)) -> ldot (patt_label_long_id m) (conv_lab s) - | PaAcc (_, m, PaUid (_, s)) -> ldot (patt_label_long_id m) s - | PaUid (_, s) -> lident s - | PaLid (_, s) -> lident (conv_lab s) - | p -> error (loc_of_patt p) "bad label" -;; - -let rec patt = - function - PaAcc (loc, p1, p2) -> - let p = - match patt_long_id [] p1 with - PaUid (_, i), il -> - begin match p2 with - PaUid (_, s) -> - Ppat_construct - (mkli (conv_con s) (i :: il), None, - not !no_constructors_arity) - | _ -> error (loc_of_patt p2) "uppercase identifier expected" - end - | _ -> error (loc_of_patt p2) "bad pattern" - in - mkpat loc p - | PaAli (loc, p1, p2) -> - let (p, i) = - match p1, p2 with - p, PaLid (_, s) -> p, s - | PaLid (_, s), p -> p, s - | _ -> error loc "invalid alias pattern" - in - mkpat loc (Ppat_alias (patt p, i)) - | PaAnt (_, p) -> patt p - | PaAny loc -> mkpat loc Ppat_any - | PaApp (loc, _, _) as f -> - let (f, al) = patt_fa [] f in - let al = List.map patt al in - begin match (patt f).ppat_desc with - Ppat_construct (li, None, _) -> - if !no_constructors_arity then - let a = - match al with - [a] -> a - | _ -> mkpat loc (Ppat_tuple al) - in - mkpat loc (Ppat_construct (li, Some a, false)) - else - let a = mkpat loc (Ppat_tuple al) in - mkpat loc (Ppat_construct (li, Some a, true)) - | 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" - end - | PaArr (loc, pl) -> mkpat loc (Ppat_array (List.map patt pl)) - | PaChr (loc, s) -> - mkpat loc (Ppat_constant (Const_char (char_of_char_token loc s))) - | PaInt (loc, s) -> - let i = - try int_of_string s with - Failure _ -> - error loc "Integer literal exceeds the range of representable integers of type int" - in - mkpat loc (Ppat_constant (Const_int i)) - | PaInt32 (loc, s) -> - let i32 = - try Int32.of_string s with - Failure _ -> - error loc "Integer literal exceeds the range of representable integers of type int32" - in - mkpat loc (Ppat_constant (Const_int32 i32)) - | PaInt64 (loc, s) -> - let i64 = - try Int64.of_string s with - Failure _ -> - error loc "Integer literal exceeds the range of representable integers of type int64" - in - mkpat loc (Ppat_constant (Const_int64 i64)) - | PaNativeInt (loc, s) -> - let nati = - try Nativeint.of_string s with - Failure _ -> - error loc "Integer literal exceeds the range of representable integers of type nativeint" - in - mkpat loc (Ppat_constant (Const_nativeint nati)) - | PaFlo (loc, s) -> mkpat loc (Ppat_constant (Const_float s)) - | PaLab (loc, _, _) -> error loc "labeled pattern not allowed here" - | PaLid (loc, s) -> mkpat loc (Ppat_var s) - | PaOlb (loc, _, _) -> error loc "labeled pattern not allowed here" - | PaOrp (loc, p1, p2) -> mkpat loc (Ppat_or (patt p1, patt p2)) - | PaRng (loc, p1, p2) -> - begin 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" - end - | PaRec (loc, lpl) -> mkpat loc (Ppat_record (List.map mklabpat lpl)) - | PaStr (loc, s) -> - mkpat loc (Ppat_constant (Const_string (string_of_string_token loc s))) - | PaTup (loc, []) -> error loc "empty tuple pattern" - | PaTup (loc, [_]) -> error loc "singleton tuple pattern" - | PaTup (loc, pl) -> mkpat loc (Ppat_tuple (List.map patt pl)) - | PaTyc (loc, p, t) -> mkpat loc (Ppat_constraint (patt p, ctyp t)) - | PaTyp (loc, sl) -> mkpat loc (Ppat_type (long_id_of_string_list loc sl)) - | PaUid (loc, s) -> - let ca = not !no_constructors_arity in - mkpat loc (Ppat_construct (lident (conv_con s), None, ca)) - | PaVrn (loc, s) -> mkpat loc (Ppat_variant (s, None)) -and mklabpat (lab, p) = patt_label_long_id lab, patt p;; - -let rec expr_fa al = - function - ExApp (_, f, a) -> expr_fa (a :: al) f - | f -> f, al -;; - -let rec class_expr_fa al = - function - CeApp (_, ce, a) -> class_expr_fa (a :: al) ce - | ce -> ce, al -;; - -let rec sep_expr_acc l = - function - ExAcc (_, e1, e2) -> sep_expr_acc (sep_expr_acc l e2) e1 - | ExUid ((bp, _ as loc), s) as e -> - begin match l with - [] -> [loc, [], e] - | ((_, ep), sl, e) :: l -> ((bp, ep), s :: sl, e) :: l - end - | e -> (loc_of_expr e, [], e) :: l -;; - -(* -value expr_label_long_id e = - match sep_expr_acc [] e with - [ [(_, ml, ExLid _ s)] -> mkli (conv_lab s) ml - | _ -> error (loc_of_expr e) "invalid label" ] -; -*) - -let class_info class_expr ci = - let (params, variance) = List.split (snd ci.ciPrm) in - {pci_virt = if ci.ciVir then Virtual else Concrete; - pci_params = params, mkloc (fst ci.ciPrm); pci_name = ci.ciNam; - pci_expr = class_expr ci.ciExp; pci_loc = mkloc ci.ciLoc; - pci_variance = variance} -;; - -let apply_with_var v x f = - let vx = !v in - try v := x; let r = f () in v := vx; r with - e -> v := vx; raise e -;; - -let rec expr = - function - ExAcc (loc, x, ExLid (_, "val")) -> - mkexp loc - (Pexp_apply (mkexp loc (Pexp_ident (Lident "!")), ["", expr x])) - | ExAcc (loc, _, _) as e -> - let (e, l) = - match sep_expr_acc [] e with - (loc, ml, ExUid (_, s)) :: l -> - let ca = not !no_constructors_arity in - mkexp loc (Pexp_construct (mkli s ml, None, ca)), l - | (loc, ml, ExLid (_, s)) :: l -> - mkexp loc (Pexp_ident (mkli s ml)), l - | (_, [], e) :: l -> expr e, l - | _ -> error loc "bad ast in expression" - in - let (_, e) = - List.fold_left - (fun ((bp, _), e1) ((_, ep), ml, e2) -> - match e2 with - ExLid (_, s) -> - let loc = bp, ep in - loc, mkexp loc (Pexp_field (e1, mkli (conv_lab s) ml)) - | _ -> error (loc_of_expr e2) "lowercase identifier expected") - (loc, e) l - in - e - | ExAnt (_, e) -> expr e - | ExApp (loc, _, _) as f -> - let (f, al) = expr_fa [] f in - let al = List.map label_expr al in - begin match (expr f).pexp_desc with - Pexp_construct (li, None, _) -> - let al = List.map snd al in - if !no_constructors_arity then - let a = - match al with - [a] -> a - | _ -> mkexp loc (Pexp_tuple al) - in - mkexp loc (Pexp_construct (li, Some a, false)) - else - let a = mkexp loc (Pexp_tuple al) in - mkexp loc (Pexp_construct (li, Some a, true)) - | 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)) - end - | ExAre (loc, e1, e2) -> - mkexp loc - (Pexp_apply - (mkexp loc (Pexp_ident (array_function "Array" "get")), - ["", expr e1; "", expr e2])) - | ExArr (loc, el) -> mkexp loc (Pexp_array (List.map expr el)) - | ExAsf loc -> mkexp loc Pexp_assertfalse - | ExAss (loc, e, v) -> - let e = - match e with - ExAcc (loc, x, ExLid (_, "val")) -> - Pexp_apply - (mkexp loc (Pexp_ident (Lident ":=")), ["", expr x; "", expr v]) - | ExAcc (loc, _, _) -> - begin match (expr e).pexp_desc with - Pexp_field (e, lab) -> Pexp_setfield (e, lab, expr v) - | _ -> error loc "bad record access" - end - | ExAre (_, e1, e2) -> - Pexp_apply - (mkexp loc (Pexp_ident (array_function "Array" "set")), - ["", expr e1; "", expr e2; "", expr v]) - | ExLid (_, lab) -> Pexp_setinstvar (lab, expr v) - | ExSte (_, e1, e2) -> - Pexp_apply - (mkexp loc (Pexp_ident (array_function "String" "set")), - ["", expr e1; "", expr e2; "", 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 (Const_char (char_of_char_token loc s))) - | ExCoe (loc, e, t1, t2) -> - mkexp loc (Pexp_constraint (expr e, option ctyp t1, Some (ctyp t2))) - | ExFlo (loc, s) -> mkexp loc (Pexp_constant (Const_float s)) - | ExFor (loc, i, e1, e2, df, el) -> - let e3 = ExSeq (loc, el) in - let df = if df then Upto else Downto in - mkexp loc (Pexp_for (i, expr e1, expr e2, df, expr e3)) - | ExFun (loc, [PaLab (_, lab, po), w, e]) -> - mkexp loc - (Pexp_function - (lab, None, [patt (patt_of_lab loc lab po), when_expr e w])) - | ExFun (loc, [PaOlb (_, lab, peoo), w, e]) -> - let (lab, p, eo) = paolab loc lab peoo in - mkexp loc - (Pexp_function (("?" ^ lab), option expr eo, [patt p, when_expr e w])) - | ExFun (loc, pel) -> - mkexp loc (Pexp_function ("", None, List.map mkpwe pel)) - | ExIfe (loc, e1, e2, e3) -> - mkexp loc (Pexp_ifthenelse (expr e1, expr e2, Some (expr e3))) - | ExInt (loc, s) -> - let i = - try int_of_string s with - Failure _ -> - error loc "Integer literal exceeds the range of representable integers of type int" - in - mkexp loc (Pexp_constant (Const_int i)) - | ExInt32 (loc, s) -> - let i32 = - try Int32.of_string s with - Failure _ -> - error loc "Integer literal exceeds the range of representable integers of type int32" - in - mkexp loc (Pexp_constant (Const_int32 i32)) - | ExInt64 (loc, s) -> - let i64 = - try Int64.of_string s with - Failure _ -> - error loc "Integer literal exceeds the range of representable integers of type int64" - in - mkexp loc (Pexp_constant (Const_int64 i64)) - | ExNativeInt (loc, s) -> - let nati = - try Nativeint.of_string s with - Failure _ -> - error loc "Integer literal exceeds the range of representable integers of type nativeint" - in - mkexp loc (Pexp_constant (Const_nativeint nati)) - | ExLab (loc, _, _) -> error loc "labeled expression not allowed here" - | ExLaz (loc, e) -> mkexp loc (Pexp_lazy (expr e)) - | ExLet (loc, rf, pel, e) -> - mkexp loc (Pexp_let (mkrf rf, List.map mkpe pel, expr e)) - | ExLid (loc, s) -> mkexp loc (Pexp_ident (lident s)) - | ExLmd (loc, i, me, e) -> - mkexp loc (Pexp_letmodule (i, module_expr me, expr e)) - | ExMat (loc, e, pel) -> mkexp loc (Pexp_match (expr e, List.map mkpwe pel)) - | ExNew (loc, id) -> mkexp loc (Pexp_new (long_id_of_string_list loc id)) - | ExObj (loc, po, cfl) -> - let p = - match po with - Some p -> p - | None -> PaAny loc - in - let cil = List.fold_right class_str_item cfl [] in - mkexp loc (Pexp_object (patt p, cil)) - | ExOlb (loc, _, _) -> error loc "labeled expression not allowed here" - | ExOvr (loc, iel) -> mkexp loc (Pexp_override (List.map mkideexp iel)) - | ExRec (loc, lel, eo) -> - if lel = [] then error loc "empty record" - else - let eo = - match eo with - Some e -> Some (expr e) - | None -> None - in - mkexp loc (Pexp_record (List.map mklabexp lel, eo)) - | ExSeq (loc, el) -> - let rec loop = - function - [] -> expr (ExUid (loc, "()")) - | [e] -> expr e - | e :: el -> - let loc = fst (loc_of_expr e), snd loc in - mkexp loc (Pexp_sequence (expr e, loop el)) - in - loop el - | ExSnd (loc, e, s) -> mkexp loc (Pexp_send (expr e, s)) - | ExSte (loc, e1, e2) -> - mkexp loc - (Pexp_apply - (mkexp loc (Pexp_ident (array_function "String" "get")), - ["", expr e1; "", expr e2])) - | ExStr (loc, s) -> - mkexp loc (Pexp_constant (Const_string (string_of_string_token loc s))) - | ExTry (loc, e, pel) -> mkexp loc (Pexp_try (expr e, List.map mkpwe pel)) - | ExTup (loc, []) -> error loc "empty tuple" - | ExTup (loc, [e]) -> error loc "singleton tuple" - | ExTup (loc, el) -> mkexp loc (Pexp_tuple (List.map expr el)) - | ExTyc (loc, e, t) -> - mkexp loc (Pexp_constraint (expr e, Some (ctyp t), None)) - | ExUid (loc, s) -> - let ca = not !no_constructors_arity in - mkexp loc (Pexp_construct (lident (conv_con s), None, ca)) - | ExVrn (loc, s) -> mkexp loc (Pexp_variant (s, None)) - | ExWhi (loc, e1, el) -> - let e2 = ExSeq (loc, el) in mkexp loc (Pexp_while (expr e1, expr e2)) -and label_expr = - function - ExLab (loc, lab, eo) -> lab, expr (expr_of_lab loc lab eo) - | ExOlb (loc, lab, eo) -> "?" ^ lab, expr (expr_of_lab loc lab eo) - | e -> "", expr e -and mkpe (p, e) = patt p, expr e -and mkpwe (p, w, e) = patt p, when_expr e w -and when_expr e = - function - Some w -> mkexp (loc_of_expr e) (Pexp_when (expr w, expr e)) - | None -> expr e -and mklabexp (lab, e) = patt_label_long_id lab, expr e -and mkideexp (ide, e) = ide, expr e -and mktype_decl ((loc, c), tl, td, cl) = - let cl = - List.map - (fun (t1, t2) -> - let loc = fst (loc_of_ctyp t1), snd (loc_of_ctyp t2) in - ctyp t1, ctyp t2, mkloc loc) - cl - in - c, type_decl tl cl td -and module_type = - function - MtAcc (loc, _, _) as f -> mkmty loc (Pmty_ident (module_type_long_id f)) - | MtApp (loc, _, _) as f -> mkmty loc (Pmty_ident (module_type_long_id f)) - | MtFun (loc, n, nt, mt) -> - mkmty loc (Pmty_functor (n, module_type nt, module_type mt)) - | MtLid (loc, s) -> mkmty loc (Pmty_ident (lident s)) - | MtQuo (loc, _) -> error loc "abstract module type not allowed here" - | MtSig (loc, sl) -> - mkmty loc (Pmty_signature (List.fold_right sig_item sl [])) - | MtUid (loc, s) -> mkmty loc (Pmty_ident (lident s)) - | MtWit (loc, mt, wcl) -> - mkmty loc (Pmty_with (module_type mt, List.map mkwithc wcl)) -and sig_item s l = - match s with - SgCls (loc, cd) -> - mksig loc (Psig_class (List.map (class_info class_type) cd)) :: l - | SgClt (loc, ctd) -> - mksig loc (Psig_class_type (List.map (class_info class_type) ctd)) :: l - | SgDcl (loc, sl) -> List.fold_right sig_item sl l - | SgDir (loc, _, _) -> l - | SgExc (loc, n, tl) -> - mksig loc (Psig_exception (n, List.map ctyp tl)) :: l - | SgExt (loc, n, t, p) -> mksig loc (Psig_value (n, mkvalue_desc t p)) :: l - | SgInc (loc, mt) -> mksig loc (Psig_include (module_type mt)) :: l - | SgMod (loc, n, mt) -> mksig loc (Psig_module (n, module_type mt)) :: l - | SgRecMod (loc, nmts) -> - mksig loc - (Psig_recmodule (List.map (fun (n, mt) -> n, module_type mt) nmts)) :: - l - | SgMty (loc, n, mt) -> - let si = - match mt with - MtQuo (_, _) -> Pmodtype_abstract - | _ -> Pmodtype_manifest (module_type mt) - in - mksig loc (Psig_modtype (n, si)) :: l - | SgOpn (loc, id) -> - mksig loc (Psig_open (long_id_of_string_list loc id)) :: l - | SgTyp (loc, tdl) -> mksig loc (Psig_type (List.map mktype_decl tdl)) :: l - | SgUse (loc, fn, sl) -> - apply_with_var glob_fname fn - (fun () -> List.fold_right (fun (si, _) -> sig_item si) sl l) - | SgVal (loc, n, t) -> mksig loc (Psig_value (n, mkvalue_desc t [])) :: l -and module_expr = - function - MeAcc (loc, _, _) as f -> mkmod loc (Pmod_ident (module_expr_long_id f)) - | MeApp (loc, me1, me2) -> - mkmod loc (Pmod_apply (module_expr me1, module_expr me2)) - | MeFun (loc, n, mt, me) -> - mkmod loc (Pmod_functor (n, module_type mt, module_expr me)) - | MeStr (loc, sl) -> - mkmod loc (Pmod_structure (List.fold_right str_item sl [])) - | MeTyc (loc, me, mt) -> - mkmod loc (Pmod_constraint (module_expr me, module_type mt)) - | MeUid (loc, s) -> mkmod loc (Pmod_ident (lident s)) -and str_item s l = - match s with - StCls (loc, cd) -> - mkstr loc (Pstr_class (List.map (class_info class_expr) cd)) :: l - | StClt (loc, ctd) -> - mkstr loc (Pstr_class_type (List.map (class_info class_type) ctd)) :: l - | StDcl (loc, sl) -> List.fold_right str_item sl l - | StDir (loc, _, _) -> l - | StExc (loc, n, tl, sl) -> - let si = - match tl, sl with - tl, [] -> Pstr_exception (n, List.map ctyp tl) - | [], sl -> Pstr_exn_rebind (n, long_id_of_string_list loc sl) - | _ -> error loc "bad exception declaration" - in - mkstr loc si :: l - | StExp (loc, e) -> mkstr loc (Pstr_eval (expr e)) :: l - | StExt (loc, n, t, p) -> - mkstr loc (Pstr_primitive (n, mkvalue_desc t p)) :: l - | StInc (loc, me) -> mkstr loc (Pstr_include (module_expr me)) :: l - | StMod (loc, n, me) -> mkstr loc (Pstr_module (n, module_expr me)) :: l - | StRecMod (loc, nmes) -> - mkstr loc - (Pstr_recmodule - (List.map (fun (n, mt, me) -> n, module_type mt, module_expr me) - nmes)) :: - l - | StMty (loc, n, mt) -> mkstr loc (Pstr_modtype (n, module_type mt)) :: l - | StOpn (loc, id) -> - mkstr loc (Pstr_open (long_id_of_string_list loc id)) :: l - | StTyp (loc, tdl) -> mkstr loc (Pstr_type (List.map mktype_decl tdl)) :: l - | StUse (loc, fn, sl) -> - apply_with_var glob_fname fn - (fun () -> List.fold_right (fun (si, _) -> str_item si) sl l) - | StVal (loc, rf, pel) -> - mkstr loc (Pstr_value (mkrf rf, List.map mkpe pel)) :: l -and class_type = - function - CtCon (loc, id, tl) -> - mkcty loc - (Pcty_constr (long_id_of_string_list loc id, List.map ctyp tl)) - | CtFun (loc, TyLab (_, lab, t), ct) -> - mkcty loc (Pcty_fun (lab, ctyp t, class_type ct)) - | CtFun (loc, TyOlb (loc1, lab, t), ct) -> - let t = TyApp (loc1, TyLid (loc1, "option"), t) in - mkcty loc (Pcty_fun (("?" ^ lab), ctyp t, class_type ct)) - | CtFun (loc, t, ct) -> mkcty loc (Pcty_fun ("", ctyp t, class_type ct)) - | CtSig (loc, t_o, ctfl) -> - let t = - match t_o with - Some t -> t - | None -> TyAny loc - in - let cil = List.fold_right class_sig_item ctfl [] in - mkcty loc (Pcty_signature (ctyp t, cil)) -and class_sig_item c l = - match c with - CgCtr (loc, t1, t2) -> Pctf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l - | CgDcl (loc, cl) -> List.fold_right class_sig_item cl l - | CgInh (loc, ct) -> Pctf_inher (class_type ct) :: l - | CgMth (loc, s, pf, t) -> - Pctf_meth (s, mkprivate pf, ctyp (mkpolytype t), mkloc loc) :: l - | CgVal (loc, s, b, t) -> - Pctf_val (s, mkmutable b, Some (ctyp t), mkloc loc) :: l - | CgVir (loc, s, b, t) -> - Pctf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l -and class_expr = - function - CeApp (loc, _, _) as c -> - let (ce, el) = class_expr_fa [] c in - let el = List.map label_expr el in - mkpcl loc (Pcl_apply (class_expr ce, el)) - | CeCon (loc, id, tl) -> - mkpcl loc (Pcl_constr (long_id_of_string_list loc id, List.map ctyp tl)) - | CeFun (loc, PaLab (_, lab, po), ce) -> - mkpcl loc - (Pcl_fun (lab, None, patt (patt_of_lab loc lab po), class_expr ce)) - | CeFun (loc, PaOlb (_, lab, peoo), ce) -> - let (lab, p, eo) = paolab loc lab peoo in - mkpcl loc (Pcl_fun (("?" ^ lab), option expr eo, patt p, class_expr ce)) - | CeFun (loc, p, ce) -> - mkpcl loc (Pcl_fun ("", None, patt p, class_expr ce)) - | CeLet (loc, rf, pel, ce) -> - mkpcl loc (Pcl_let (mkrf rf, List.map mkpe pel, class_expr ce)) - | CeStr (loc, po, cfl) -> - let p = - match po with - Some p -> p - | None -> PaAny loc - in - let cil = List.fold_right class_str_item cfl [] in - mkpcl loc (Pcl_structure (patt p, cil)) - | CeTyc (loc, ce, ct) -> - mkpcl loc (Pcl_constraint (class_expr ce, class_type ct)) -and class_str_item c l = - match c with - CrCtr (loc, t1, t2) -> Pcf_cstr (ctyp t1, ctyp t2, mkloc loc) :: l - | CrDcl (loc, cl) -> List.fold_right class_str_item cl l - | CrInh (loc, ce, pb) -> Pcf_inher (class_expr ce, pb) :: l - | CrIni (loc, e) -> Pcf_init (expr e) :: l - | CrMth (loc, s, b, e, t) -> - let t = option (fun t -> ctyp (mkpolytype t)) t in - let e = mkexp loc (Pexp_poly (expr e, t)) in - Pcf_meth (s, mkprivate b, e, mkloc loc) :: l - | CrVal (loc, s, b, e) -> Pcf_val (s, mkmutable b, expr e, mkloc loc) :: l - | CrVir (loc, s, b, t) -> - Pcf_virt (s, mkprivate b, ctyp (mkpolytype t), mkloc loc) :: l -;; - -let interf ast = List.fold_right sig_item ast [];; -let implem ast = List.fold_right str_item ast [];; - -let directive loc = - function - None -> Pdir_none - | Some (ExStr (_, s)) -> Pdir_string s - | Some (ExInt (_, i)) -> Pdir_int (int_of_string i) - | Some (ExUid (_, "True")) -> Pdir_bool true - | Some (ExUid (_, "False")) -> Pdir_bool false - | Some e -> - let sl = - let rec loop = - function - ExLid (_, i) | ExUid (_, i) -> [i] - | ExAcc (_, e, ExLid (_, i)) | ExAcc (_, e, ExUid (_, i)) -> - loop e @ [i] - | e -> - raise_with_loc (loc_of_expr e) (Failure "bad ast in directive") - in - loop e - in - Pdir_ident (long_id_of_string_list loc sl) -;; - -let phrase = - function - StDir (loc, d, dp) -> Ptop_dir (d, directive loc dp) - | si -> Ptop_def (str_item si []) -;; diff --git a/camlp4/ocaml_src/camlp4/ast2pt.mli b/camlp4/ocaml_src/camlp4/ast2pt.mli deleted file mode 100644 index c6aeab29..00000000 --- a/camlp4/ocaml_src/camlp4/ast2pt.mli +++ /dev/null @@ -1,23 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -val fast : bool ref;; -val no_constructors_arity : bool ref;; -val mkloc : MLast.loc -> Location.t;; -val long_id_of_string_list : MLast.loc -> string list -> Longident.t;; - -val str_item : MLast.str_item -> Parsetree.structure -> Parsetree.structure;; -val interf : MLast.sig_item list -> Parsetree.signature;; -val implem : MLast.str_item list -> Parsetree.structure;; -val phrase : MLast.str_item -> Parsetree.toplevel_phrase;; diff --git a/camlp4/ocaml_src/camlp4/mLast.mli b/camlp4/ocaml_src/camlp4/mLast.mli deleted file mode 100644 index 5d320122..00000000 --- a/camlp4/ocaml_src/camlp4/mLast.mli +++ /dev/null @@ -1,213 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(* Module [MLast]: abstract syntax tree - - This is undocumented because the AST is not supposed to be used - directly; the good usage is to use the quotations representing - these values in concrete syntax (see the Camlp4 documentation). - See also the file q_MLast.ml in Camlp4 sources. *) - -type loc = Lexing.position * Lexing.position;; - -type ctyp = - TyAcc of loc * ctyp * ctyp - | TyAli of loc * ctyp * ctyp - | TyAny of loc - | TyApp of loc * ctyp * ctyp - | TyArr of loc * ctyp * ctyp - | TyCls of loc * string list - | TyLab of loc * string * ctyp - | TyLid of loc * string - | TyMan of loc * ctyp * ctyp - | TyObj of loc * (string * ctyp) list * bool - | TyOlb of loc * string * ctyp - | TyPol of loc * string list * ctyp - | TyQuo of loc * string - | TyRec of loc * (loc * string * bool * ctyp) list - | TySum of loc * (loc * string * ctyp list) list - | TyPrv of loc * ctyp - | TyTup of loc * ctyp list - | TyUid of loc * string - | TyVrn of loc * row_field list * string list option option -and row_field = - RfTag of string * bool * ctyp list - | RfInh of ctyp -;; - -type 'a class_infos = - { ciLoc : loc; - ciVir : bool; - ciPrm : loc * (string * (bool * bool)) list; - ciNam : string; - ciExp : 'a } -;; - -type patt = - PaAcc of loc * patt * patt - | PaAli of loc * patt * patt - | PaAnt of loc * patt - | PaAny of loc - | PaApp of loc * patt * patt - | PaArr of loc * patt list - | PaChr of loc * string - | PaInt of loc * string - | PaInt32 of loc * string - | PaInt64 of loc * string - | PaNativeInt of loc * string - | PaFlo of loc * string - | PaLab of loc * string * patt option - | PaLid of loc * string - | PaOlb of loc * string * (patt * expr option) option - | PaOrp of loc * patt * patt - | PaRng of loc * patt * patt - | PaRec of loc * (patt * patt) list - | PaStr of loc * string - | PaTup of loc * patt list - | PaTyc of loc * patt * ctyp - | PaTyp of loc * string list - | PaUid of loc * string - | PaVrn of loc * string -and expr = - ExAcc of loc * expr * expr - | ExAnt of loc * expr - | ExApp of loc * expr * expr - | ExAre of loc * expr * expr - | ExArr of loc * expr list - | ExAsf of loc - | ExAsr of loc * expr - | ExAss of loc * expr * expr - | ExChr of loc * string - | ExCoe of loc * expr * ctyp option * ctyp - | ExFlo of loc * string - | ExFor of loc * string * expr * expr * bool * expr list - | ExFun of loc * (patt * expr option * expr) list - | ExIfe of loc * expr * expr * expr - | ExInt of loc * string - | ExInt32 of loc * string - | ExInt64 of loc * string - | ExNativeInt of loc * string - | ExLab of loc * string * expr option - | ExLaz of loc * expr - | ExLet of loc * bool * (patt * expr) list * expr - | ExLid of loc * string - | ExLmd of loc * string * module_expr * expr - | ExMat of loc * expr * (patt * expr option * expr) list - | ExNew of loc * string list - | ExObj of loc * patt option * class_str_item list - | ExOlb of loc * string * expr option - | ExOvr of loc * (string * expr) list - | ExRec of loc * (patt * expr) list * expr option - | ExSeq of loc * expr list - | ExSnd of loc * expr * string - | ExSte of loc * expr * expr - | ExStr of loc * string - | ExTry of loc * expr * (patt * expr option * expr) list - | ExTup of loc * expr list - | ExTyc of loc * expr * ctyp - | ExUid of loc * string - | ExVrn of loc * string - | ExWhi of loc * expr * expr list -and module_type = - MtAcc of loc * module_type * module_type - | MtApp of loc * module_type * module_type - | MtFun of loc * string * module_type * module_type - | MtLid of loc * string - | MtQuo of loc * string - | MtSig of loc * sig_item list - | MtUid of loc * string - | MtWit of loc * module_type * with_constr list -and sig_item = - SgCls of loc * class_type class_infos list - | SgClt of loc * class_type class_infos list - | SgDcl of loc * sig_item list - | SgDir of loc * string * expr option - | SgExc of loc * string * ctyp list - | SgExt of loc * string * ctyp * string list - | SgInc of loc * module_type - | SgMod of loc * string * module_type - | SgRecMod of loc * (string * module_type) list - | SgMty of loc * string * module_type - | SgOpn of loc * string list - | SgTyp of loc * type_decl list - | SgUse of loc * string * (sig_item * loc) list - | SgVal of loc * string * ctyp -and with_constr = - WcTyp of loc * string list * (string * (bool * bool)) list * ctyp - | WcMod of loc * string list * module_expr -and module_expr = - MeAcc of loc * module_expr * module_expr - | MeApp of loc * module_expr * module_expr - | MeFun of loc * string * module_type * module_expr - | MeStr of loc * str_item list - | MeTyc of loc * module_expr * module_type - | MeUid of loc * string -and str_item = - StCls of loc * class_expr class_infos list - | StClt of loc * class_type class_infos list - | StDcl of loc * str_item list - | StDir of loc * string * expr option - | StExc of loc * string * ctyp list * string list - | StExp of loc * expr - | StExt of loc * string * ctyp * string list - | StInc of loc * module_expr - | StMod of loc * string * module_expr - | StRecMod of loc * (string * module_type * module_expr) list - | StMty of loc * string * module_type - | StOpn of loc * string list - | StTyp of loc * type_decl list - | StUse of loc * string * (str_item * loc) list - | StVal of loc * bool * (patt * expr) list -and type_decl = - (loc * string) * (string * (bool * bool)) list * ctyp * (ctyp * ctyp) list -and class_type = - CtCon of loc * string list * ctyp list - | CtFun of loc * ctyp * class_type - | CtSig of loc * ctyp option * class_sig_item list -and class_sig_item = - CgCtr of loc * ctyp * ctyp - | CgDcl of loc * class_sig_item list - | CgInh of loc * class_type - | CgMth of loc * string * bool * ctyp - | CgVal of loc * string * bool * ctyp - | CgVir of loc * string * bool * ctyp -and class_expr = - CeApp of loc * class_expr * expr - | CeCon of loc * string list * ctyp list - | CeFun of loc * patt * class_expr - | CeLet of loc * bool * (patt * expr) list * class_expr - | CeStr of loc * patt option * class_str_item list - | CeTyc of loc * class_expr * class_type -and class_str_item = - CrCtr of loc * ctyp * ctyp - | CrDcl of loc * class_str_item list - | CrInh of loc * class_expr * string option - | CrIni of loc * expr - | CrMth of loc * string * bool * expr * ctyp option - | CrVal of loc * string * bool * expr - | CrVir of loc * string * bool * ctyp -;; - -external loc_of_ctyp : ctyp -> loc = "%field0";; -external loc_of_patt : patt -> loc = "%field0";; -external loc_of_expr : expr -> loc = "%field0";; -external loc_of_module_type : module_type -> loc = "%field0";; -external loc_of_module_expr : module_expr -> loc = "%field0";; -external loc_of_sig_item : sig_item -> loc = "%field0";; -external loc_of_str_item : str_item -> loc = "%field0";; - -external loc_of_class_type : class_type -> loc = "%field0";; -external loc_of_class_sig_item : class_sig_item -> loc = "%field0";; -external loc_of_class_expr : class_expr -> loc = "%field0";; -external loc_of_class_str_item : class_str_item -> loc = "%field0";; diff --git a/camlp4/ocaml_src/camlp4/pcaml.ml b/camlp4/ocaml_src/camlp4/pcaml.ml deleted file mode 100644 index 9e2e21e9..00000000 --- a/camlp4/ocaml_src/camlp4/pcaml.ml +++ /dev/null @@ -1,478 +0,0 @@ -(* camlp4r pa_extend.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -let version = Sys.ocaml_version;; - -let syntax_name = ref "";; - -let gram = - Grammar.gcreate - {Token.tok_func = (fun _ -> failwith "no loaded parsing module"); - Token.tok_using = (fun _ -> ()); Token.tok_removing = (fun _ -> ()); - Token.tok_match = (fun _ -> raise (Match_failure ("", 23, 23))); - Token.tok_text = (fun _ -> ""); Token.tok_comm = None} -;; - -let interf = Grammar.Entry.create gram "interf";; -let implem = Grammar.Entry.create gram "implem";; -let top_phrase = Grammar.Entry.create gram "top_phrase";; -let use_file = Grammar.Entry.create gram "use_file";; -let sig_item = Grammar.Entry.create gram "sig_item";; -let str_item = Grammar.Entry.create gram "str_item";; -let module_type = Grammar.Entry.create gram "module_type";; -let module_expr = Grammar.Entry.create gram "module_expr";; -let expr = Grammar.Entry.create gram "expr";; -let patt = Grammar.Entry.create gram "patt";; -let ctyp = Grammar.Entry.create gram "type";; -let let_binding = Grammar.Entry.create gram "let_binding";; -let type_declaration = Grammar.Entry.create gram "type_declaration";; - -let class_sig_item = Grammar.Entry.create gram "class_sig_item";; -let class_str_item = Grammar.Entry.create gram "class_str_item";; -let class_type = Grammar.Entry.create gram "class_type";; -let class_expr = Grammar.Entry.create gram "class_expr";; - -let parse_interf = ref (Grammar.Entry.parse interf);; -let parse_implem = ref (Grammar.Entry.parse implem);; - -let rec skip_to_eol cs = - match Stream.peek cs with - Some '\n' -> () - | Some c -> Stream.junk cs; skip_to_eol cs - | _ -> () -;; -let sync = ref skip_to_eol;; - -let input_file = ref "";; -let output_file = ref None;; - -let warning_default_function (bp, ep) txt = - let c1 = bp.Lexing.pos_cnum - bp.Lexing.pos_bol in - let c2 = ep.Lexing.pos_cnum - bp.Lexing.pos_bol in - Printf.eprintf " File \"%s\", line %d, chars %d-%d: %s\n" - bp.Lexing.pos_fname bp.Lexing.pos_lnum c1 c2 txt; - flush stderr -;; - -let warning = ref warning_default_function;; - -let apply_with_var v x f = - let vx = !v in - try v := x; let r = f () in v := vx; r with - e -> v := vx; raise e -;; - -List.iter (fun (n, f) -> Quotation.add n f) - ["id", Quotation.ExStr (fun _ s -> "$0:" ^ s ^ "$"); - "string", Quotation.ExStr (fun _ s -> "\"" ^ String.escaped s ^ "\"")];; - -let quotation_dump_file = ref (None : string option);; - -type err_ctx = - Finding - | Expanding - | ParsingResult of MLast.loc * string - | Locating -;; -exception Qerror of string * err_ctx * exn;; - -let expand_quotation loc expander shift name str = - let new_warning = - let warn = !warning in - fun (bp, ep) txt -> warn (Reloc.adjust_loc shift (bp, ep)) txt - in - apply_with_var warning new_warning - (fun () -> - try expander str with - Stdpp.Exc_located (loc, exc) -> - let exc1 = Qerror (name, Expanding, exc) in - raise (Stdpp.Exc_located (Reloc.adjust_loc shift loc, exc1)) - | exc -> - let exc1 = Qerror (name, Expanding, exc) in - raise (Stdpp.Exc_located (loc, exc1))) -;; - -let parse_quotation_result entry loc shift name str = - let cs = Stream.of_string str in - try Grammar.Entry.parse entry cs with - Stdpp.Exc_located (iloc, (Qerror (_, Locating, _) as exc)) -> - raise (Stdpp.Exc_located (Reloc.adjust_loc shift iloc, exc)) - | Stdpp.Exc_located (iloc, Qerror (_, Expanding, exc)) -> - let ctx = ParsingResult (iloc, str) in - let exc1 = Qerror (name, ctx, exc) in - raise (Stdpp.Exc_located (loc, exc1)) - | Stdpp.Exc_located (_, (Qerror (_, _, _) as exc)) -> - raise (Stdpp.Exc_located (loc, exc)) - | Stdpp.Exc_located (iloc, exc) -> - let ctx = ParsingResult (iloc, str) in - let exc1 = Qerror (name, ctx, exc) in - raise (Stdpp.Exc_located (loc, exc1)) -;; - -let ghostify (bp, ep) = - let ghost p = {p with Lexing.pos_cnum = 0} in ghost bp, ghost ep -;; - -let handle_quotation loc proj in_expr entry reloc (name, str) = - let shift = - match name with - "" -> String.length "<<" - | _ -> String.length "<:" + String.length name + String.length "<" - in - let shift = Reloc.shift_pos shift (fst loc) in - let expander = - try Quotation.find name with - exc -> - let exc1 = Qerror (name, Finding, exc) in - raise (Stdpp.Exc_located ((fst loc, shift), exc1)) - in - let ast = - match expander with - Quotation.ExStr f -> - let new_str = expand_quotation loc (f in_expr) shift name str in - parse_quotation_result entry loc shift name new_str - | Quotation.ExAst fe_fp -> - expand_quotation loc (proj fe_fp) shift name str - in - reloc - (let zero = ref None in - fun _ -> - match !zero with - None -> zero := Some (ghostify loc); loc - | Some x -> x) - shift ast -;; - -let parse_locate entry shift str = - let cs = Stream.of_string str in - try Grammar.Entry.parse entry cs with - Stdpp.Exc_located ((p1, p2), exc) -> - let ctx = Locating in - let exc1 = Qerror (Grammar.Entry.name entry, ctx, exc) in - raise (Stdpp.Exc_located (Reloc.adjust_loc shift (p1, p2), exc1)) -;; - -let handle_locate loc entry ast_f (pos, str) = - let s = str in - let loc = pos, Reloc.shift_pos (String.length s) pos in - let x = parse_locate entry (fst loc) s in ast_f loc x -;; - -let expr_anti loc e = MLast.ExAnt (loc, e);; -let patt_anti loc p = MLast.PaAnt (loc, p);; -let expr_eoi = Grammar.Entry.create gram "expression";; -let patt_eoi = Grammar.Entry.create gram "pattern";; -Grammar.extend - [Grammar.Entry.obj (expr_eoi : 'expr_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'expr) (_loc : Lexing.position * Lexing.position) -> - (x : 'expr_eoi))]]; - Grammar.Entry.obj (patt_eoi : 'patt_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'patt) (_loc : Lexing.position * Lexing.position) -> - (x : 'patt_eoi))]]];; - -let handle_expr_quotation loc x = - handle_quotation loc fst true expr_eoi Reloc.expr x -;; - -let handle_expr_locate loc x = handle_locate loc expr_eoi expr_anti x;; - -let handle_patt_quotation loc x = - handle_quotation loc snd false patt_eoi Reloc.patt x -;; - -let handle_patt_locate loc x = handle_locate loc patt_eoi patt_anti x;; - -let expr_reloc = Reloc.expr;; -let patt_reloc = Reloc.patt;; - -let ctyp_reloc = Reloc.ctyp;; -let row_field_reloc = Reloc.row_field;; -let class_infos_reloc = Reloc.class_infos;; -let module_type_reloc = Reloc.module_type;; -let sig_item_reloc = Reloc.sig_item;; -let with_constr_reloc = Reloc.with_constr;; -let module_expr_reloc = Reloc.module_expr;; -let str_item_reloc = Reloc.str_item;; -let class_type_reloc = Reloc.class_type;; -let class_sig_item_reloc = Reloc.class_sig_item;; -let class_expr_reloc = Reloc.class_expr;; -let class_str_item_reloc = Reloc.class_str_item;; - -let rename_id = ref (fun x -> x);; - -let find_line (bp, ep) str = - bp.Lexing.pos_lnum, bp.Lexing.pos_cnum - bp.Lexing.pos_bol, - ep.Lexing.pos_cnum - bp.Lexing.pos_bol -;; - -let loc_fmt = - match Sys.os_type with - "MacOS" -> - format_of_string "File \"%s\"; line %d; characters %d to %d\n### " - | _ -> format_of_string "File \"%s\", line %d, characters %d-%d:\n" -;; - -let report_quotation_error name ctx = - let name = if name = "" then !(Quotation.default) else name in - Format.print_flush (); - Format.open_hovbox 2; - Printf.eprintf "While %s \"%s\":" - (match ctx with - Finding -> "finding quotation" - | Expanding -> "expanding quotation" - | ParsingResult (_, _) -> "parsing result of quotation" - | Locating -> "parsing") - name; - match ctx with - ParsingResult ((bp, ep), str) -> - begin match !quotation_dump_file with - Some dump_file -> - Printf.eprintf " dumping result...\n"; - flush stderr; - begin try - let (line, c1, c2) = find_line (bp, ep) str in - let oc = open_out_bin dump_file in - output_string oc str; - output_string oc "\n"; - flush oc; - close_out oc; - Printf.eprintf loc_fmt dump_file line c1 c2; - flush stderr - with - _ -> - Printf.eprintf "Error while dumping result in file \"%s\"" - dump_file; - Printf.eprintf "; dump aborted.\n"; - flush stderr - end - | None -> - if !input_file = "" then - Printf.eprintf - "\n(consider setting variable Pcaml.quotation_dump_file)\n" - else Printf.eprintf " (consider using option -QD)\n"; - flush stderr - end - | _ -> Printf.eprintf "\n"; flush stderr -;; - -let print_format str = - let rec flush ini cnt = - if cnt > ini then Format.print_string (String.sub str ini (cnt - ini)) - in - let rec loop ini cnt = - if cnt == String.length str then flush ini cnt - else - match str.[cnt] with - '\n' -> - flush ini cnt; - Format.close_box (); - Format.force_newline (); - Format.open_box 2; - loop (cnt + 1) (cnt + 1) - | ' ' -> flush ini cnt; Format.print_space (); loop (cnt + 1) (cnt + 1) - | _ -> loop ini (cnt + 1) - in - Format.open_box 2; loop 0 0; Format.close_box () -;; - -let print_file_failed file line char = - Format.print_string ", file \""; - Format.print_string file; - Format.print_string "\", line "; - Format.print_int line; - Format.print_string ", char "; - Format.print_int char -;; - -let print_exn = - function - Out_of_memory -> Format.print_string "Out of memory\n" - | Assert_failure (file, line, char) -> - Format.print_string "Assertion failed"; print_file_failed file line char - | Match_failure (file, line, char) -> - Format.print_string "Pattern matching failed"; - print_file_failed file line char - | Stream.Error str -> print_format ("Parse error: " ^ str) - | Stream.Failure -> Format.print_string "Parse failure" - | Token.Error str -> - Format.print_string "Lexing error: "; Format.print_string str - | Failure str -> Format.print_string "Failure: "; Format.print_string str - | Invalid_argument str -> - Format.print_string "Invalid argument: "; Format.print_string str - | Sys_error msg -> - Format.print_string "I/O error: "; Format.print_string msg - | x -> - Format.print_string "Uncaught exception: "; - Format.print_string - (Obj.magic (Obj.field (Obj.field (Obj.repr x) 0) 0)); - if Obj.size (Obj.repr x) > 1 then - begin - Format.print_string " ("; - for i = 1 to Obj.size (Obj.repr x) - 1 do - if i > 1 then Format.print_string ", "; - let arg = Obj.field (Obj.repr x) i in - if not (Obj.is_block arg) then - Format.print_int (Obj.magic arg : int) - else if Obj.tag arg = Obj.tag (Obj.repr "a") then - begin - Format.print_char '\"'; - Format.print_string (Obj.magic arg : string); - Format.print_char '\"' - end - else Format.print_char '_' - done; - Format.print_char ')' - end -;; - -let report_error exn = - match exn with - Qerror (name, Finding, Not_found) -> - let name = if name = "" then !(Quotation.default) else name in - Format.print_flush (); - Format.open_hovbox 2; - Format.printf "Unbound quotation: \"%s\"" name; - Format.close_box () - | Qerror (name, ctx, exn) -> report_quotation_error name ctx; print_exn exn - | e -> print_exn exn -;; - -let no_constructors_arity = ref false;; - -let arg_spec_list_ref = ref [];; -let arg_spec_list () = !arg_spec_list_ref;; -let add_option name spec descr = - arg_spec_list_ref := !arg_spec_list_ref @ [name, spec, descr] -;; - -(* Printers *) - -open Spretty;; - -type 'a printer_t = - { mutable pr_fun : string -> 'a -> string -> kont -> pretty; - mutable pr_levels : 'a pr_level list } -and 'a pr_level = - { pr_label : string; - pr_box : 'a -> pretty Stream.t -> pretty; - mutable pr_rules : 'a pr_rule } -and 'a pr_rule = - ('a, ('a curr -> 'a next -> string -> kont -> pretty Stream.t)) Extfun.t -and 'a curr = 'a -> string -> kont -> pretty Stream.t -and 'a next = 'a -> string -> kont -> pretty -and kont = pretty Stream.t -;; - -let pr_str_item = - {pr_fun = (fun _ -> raise (Match_failure ("", 409, 30))); pr_levels = []} -;; -let pr_sig_item = - {pr_fun = (fun _ -> raise (Match_failure ("", 410, 30))); pr_levels = []} -;; -let pr_module_type = - {pr_fun = (fun _ -> raise (Match_failure ("", 411, 33))); pr_levels = []} -;; -let pr_module_expr = - {pr_fun = (fun _ -> raise (Match_failure ("", 412, 33))); pr_levels = []} -;; -let pr_expr = - {pr_fun = (fun _ -> raise (Match_failure ("", 413, 26))); pr_levels = []} -;; -let pr_patt = - {pr_fun = (fun _ -> raise (Match_failure ("", 414, 26))); pr_levels = []} -;; -let pr_ctyp = - {pr_fun = (fun _ -> raise (Match_failure ("", 415, 26))); pr_levels = []} -;; -let pr_class_sig_item = - {pr_fun = (fun _ -> raise (Match_failure ("", 416, 36))); pr_levels = []} -;; -let pr_class_str_item = - {pr_fun = (fun _ -> raise (Match_failure ("", 417, 36))); pr_levels = []} -;; -let pr_class_type = - {pr_fun = (fun _ -> raise (Match_failure ("", 418, 32))); pr_levels = []} -;; -let pr_class_expr = - {pr_fun = (fun _ -> raise (Match_failure ("", 419, 32))); pr_levels = []} -;; -let pr_expr_fun_args = ref Extfun.empty;; - -let pr_fun name pr lab = - let rec loop app = - function - [] -> (fun x dg k -> failwith ("unable to print " ^ name)) - | lev :: levl -> - if app || lev.pr_label = lab then - let next = loop true levl in - let rec curr x dg k = Extfun.apply lev.pr_rules x curr next dg k in - fun x dg k -> lev.pr_box x (curr x dg k) - else loop app levl - in - loop false pr.pr_levels -;; - -pr_str_item.pr_fun <- pr_fun "str_item" pr_str_item;; -pr_sig_item.pr_fun <- pr_fun "sig_item" pr_sig_item;; -pr_module_type.pr_fun <- pr_fun "module_type" pr_module_type;; -pr_module_expr.pr_fun <- pr_fun "module_expr" pr_module_expr;; -pr_expr.pr_fun <- pr_fun "expr" pr_expr;; -pr_patt.pr_fun <- pr_fun "patt" pr_patt;; -pr_ctyp.pr_fun <- pr_fun "ctyp" pr_ctyp;; -pr_class_sig_item.pr_fun <- pr_fun "class_sig_item" pr_class_sig_item;; -pr_class_str_item.pr_fun <- pr_fun "class_str_item" pr_class_str_item;; -pr_class_type.pr_fun <- pr_fun "class_type" pr_class_type;; -pr_class_expr.pr_fun <- pr_fun "class_expr" pr_class_expr;; - -let rec find_pr_level lab = - function - [] -> failwith ("level " ^ lab ^ " not found") - | lev :: levl -> if lev.pr_label = lab then lev else find_pr_level lab levl -;; - -let undef x = ref (fun _ -> failwith x);; -let print_interf = undef "no printer";; -let print_implem = undef "no printer";; - -let top_printer pr x = - Format.force_newline (); - Spretty.print_pretty Format.print_char Format.print_string - Format.print_newline "<< " " " 78 (fun _ _ -> "", 0, 0, 0) 0 - (pr.pr_fun "top" x "" Stream.sempty); - Format.print_string " >>" -;; - -let buff = Buffer.create 73;; -let buffer_char = Buffer.add_char buff;; -let buffer_string = Buffer.add_string buff;; -let buffer_newline () = Buffer.add_char buff '\n';; - -let string_of pr x = - Buffer.clear buff; - Spretty.print_pretty buffer_char buffer_string buffer_newline "" "" 78 - (fun _ _ -> "", 0, 0, 0) 0 (pr.pr_fun "top" x "" Stream.sempty); - Buffer.contents buff -;; - -let inter_phrases = ref None;; - -let position = ref (ref 0, ref 0, ref "");; diff --git a/camlp4/ocaml_src/camlp4/pcaml.mli b/camlp4/ocaml_src/camlp4/pcaml.mli deleted file mode 100644 index 460284d5..00000000 --- a/camlp4/ocaml_src/camlp4/pcaml.mli +++ /dev/null @@ -1,198 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(** Language grammar, entries and printers. - - Hold variables to be set by language syntax extensions. Some of them - are provided for quotations management. *) - -val syntax_name : string ref;; - -(** {6 Parsers} *) - -val parse_interf : - (char Stream.t -> (MLast.sig_item * MLast.loc) list * bool) ref;; -val parse_implem : - (char Stream.t -> (MLast.str_item * MLast.loc) list * bool) ref;; - (** Called when parsing an interface (mli file) or an implementation - (ml file) to build the syntax tree; the returned list contains the - phrases (signature items or structure items) and their locations; - the boolean tells that the parser has encountered a directive; in - this case, since the directive may change the syntax, the parsing - stops, the directive is evaluated, and this function is called - again. - These functions are references, because they can be changed to - use another technology than the Camlp4 extended grammars. By - default, they use the grammars entries [implem] and [interf] - defined below. *) - -val position : (int ref * int ref * string ref) ref;; - (** References holding respectively the character number of the beginning - of the current line, the current line number and the name of the file - being parsed. *) - -val gram : Grammar.g;; - (** Grammar variable of the OCaml language *) - -val interf : ((MLast.sig_item * MLast.loc) list * bool) Grammar.Entry.e;; -val implem : ((MLast.str_item * MLast.loc) list * bool) Grammar.Entry.e;; -val top_phrase : MLast.str_item option Grammar.Entry.e;; -val use_file : (MLast.str_item list * bool) Grammar.Entry.e;; -val module_type : MLast.module_type Grammar.Entry.e;; -val module_expr : MLast.module_expr Grammar.Entry.e;; -val sig_item : MLast.sig_item Grammar.Entry.e;; -val str_item : MLast.str_item Grammar.Entry.e;; -val expr : MLast.expr Grammar.Entry.e;; -val patt : MLast.patt Grammar.Entry.e;; -val ctyp : MLast.ctyp Grammar.Entry.e;; -val let_binding : (MLast.patt * MLast.expr) Grammar.Entry.e;; -val type_declaration : MLast.type_decl Grammar.Entry.e;; -val class_sig_item : MLast.class_sig_item Grammar.Entry.e;; -val class_str_item : MLast.class_str_item Grammar.Entry.e;; -val class_expr : MLast.class_expr Grammar.Entry.e;; -val class_type : MLast.class_type Grammar.Entry.e;; - (** Some entries of the language, set by [pa_o.cmo] and [pa_r.cmo]. *) - -val input_file : string ref;; - (** The file currently being parsed. *) -val output_file : string option ref;; - (** The output file, stdout if None (default) *) -val report_error : exn -> unit;; - (** Prints an error message, using the module [Format]. *) -val quotation_dump_file : string option ref;; - (** [quotation_dump_file] optionally tells the compiler 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]. *) -val version : string;; - (** The current version of Camlp4. *) -val add_option : string -> Arg.spec -> string -> unit;; - (** Add an option to the command line options. *) -val no_constructors_arity : bool ref;; - (** [True]: dont generate constructor arity. *) - -val sync : (char Stream.t -> unit) ref;; - -val handle_expr_quotation : MLast.loc -> string * string -> MLast.expr;; -val handle_expr_locate : MLast.loc -> Lexing.position * string -> MLast.expr;; - -val handle_patt_quotation : MLast.loc -> string * string -> MLast.patt;; -val handle_patt_locate : MLast.loc -> Lexing.position * string -> MLast.patt;; - -(** Relocation functions for abstract syntax trees *) -val expr_reloc : - (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.expr -> MLast.expr;; -val patt_reloc : - (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.patt -> MLast.patt;; - -val ctyp_reloc : (MLast.loc -> MLast.loc) -> 'a -> MLast.ctyp -> MLast.ctyp;; -val row_field_reloc : - (MLast.loc -> MLast.loc) -> 'a -> MLast.row_field -> MLast.row_field;; -val class_infos_reloc : - ((MLast.loc -> MLast.loc) -> 'a -> 'b -> 'c) -> (MLast.loc -> MLast.loc) -> - 'a -> 'b MLast.class_infos -> 'c MLast.class_infos;; -val module_type_reloc : - (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_type -> - MLast.module_type;; -val sig_item_reloc : - (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.sig_item -> - MLast.sig_item;; -val with_constr_reloc : - (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.with_constr -> - MLast.with_constr;; -val module_expr_reloc : - (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_expr -> - MLast.module_expr;; -val str_item_reloc : - (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.str_item -> - MLast.str_item;; -val class_type_reloc : - (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_type -> - MLast.class_type;; -val class_sig_item_reloc : - (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_sig_item -> - MLast.class_sig_item;; -val class_expr_reloc : - (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_expr -> - MLast.class_expr;; -val class_str_item_reloc : - (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_str_item -> - MLast.class_str_item;; - -(** To possibly rename identifiers; parsers may call this function - when generating their identifiers; default = identity *) -val rename_id : (string -> string) ref;; - -(** Allow user to catch exceptions in quotations *) -type err_ctx = - Finding - | Expanding - | ParsingResult of MLast.loc * string - | Locating -;; -exception Qerror of string * err_ctx * exn;; - -(** {6 Printers} *) - -open Spretty;; - -val print_interf : ((MLast.sig_item * MLast.loc) list -> unit) ref;; -val print_implem : ((MLast.str_item * MLast.loc) list -> unit) ref;; - (** Some printers, set by [pr_dump.cmo], [pr_o.cmo] and [pr_r.cmo]. *) - -type 'a printer_t = - { mutable pr_fun : string -> 'a -> string -> kont -> pretty; - mutable pr_levels : 'a pr_level list } -and 'a pr_level = - { pr_label : string; - pr_box : 'a -> pretty Stream.t -> pretty; - mutable pr_rules : 'a pr_rule } -and 'a pr_rule = - ('a, ('a curr -> 'a next -> string -> kont -> pretty Stream.t)) Extfun.t -and 'a curr = 'a -> string -> kont -> pretty Stream.t -and 'a next = 'a -> string -> kont -> pretty -and kont = pretty Stream.t -;; - -val pr_sig_item : MLast.sig_item printer_t;; -val pr_str_item : MLast.str_item printer_t;; -val pr_module_type : MLast.module_type printer_t;; -val pr_module_expr : MLast.module_expr printer_t;; -val pr_expr : MLast.expr printer_t;; -val pr_patt : MLast.patt printer_t;; -val pr_ctyp : MLast.ctyp printer_t;; -val pr_class_sig_item : MLast.class_sig_item printer_t;; -val pr_class_str_item : MLast.class_str_item printer_t;; -val pr_class_type : MLast.class_type printer_t;; -val pr_class_expr : MLast.class_expr printer_t;; - -val pr_expr_fun_args : - (MLast.expr, (MLast.patt list * MLast.expr)) Extfun.t ref;; - -val find_pr_level : string -> 'a pr_level list -> 'a pr_level;; - -val top_printer : 'a printer_t -> 'a -> unit;; -val string_of : 'a printer_t -> 'a -> string;; - -val inter_phrases : string option ref;; - -(**/**) - -(* for system use *) - -val warning : (MLast.loc -> string -> unit) ref;; -val expr_eoi : MLast.expr Grammar.Entry.e;; -val patt_eoi : MLast.patt Grammar.Entry.e;; -val arg_spec_list : unit -> (string * Arg.spec * string) list;; -val no_constructors_arity : bool ref;; diff --git a/camlp4/ocaml_src/camlp4/quotation.ml b/camlp4/ocaml_src/camlp4/quotation.ml deleted file mode 100644 index 07057c96..00000000 --- a/camlp4/ocaml_src/camlp4/quotation.ml +++ /dev/null @@ -1,33 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -type expander = - ExStr of (bool -> string -> string) - | ExAst of ((string -> MLast.expr) * (string -> MLast.patt)) -;; - -let expanders_table = ref [];; - -let default = ref "";; -let translate = ref (fun x -> x);; - -let expander_name name = - match !translate name with - "" -> !default - | name -> name -;; - -let find name = List.assoc (expander_name name) !expanders_table;; - -let add name f = expanders_table := (name, f) :: !expanders_table;; diff --git a/camlp4/ocaml_src/camlp4/quotation.mli b/camlp4/ocaml_src/camlp4/quotation.mli deleted file mode 100644 index aba963d7..00000000 --- a/camlp4/ocaml_src/camlp4/quotation.mli +++ /dev/null @@ -1,48 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(** Quotation operations. *) - -type expander = - ExStr of (bool -> string -> string) - | ExAst of ((string -> MLast.expr) * (string -> MLast.patt)) -;; - -(** The type for quotation expanders kind: -- [ExStr exp] for an expander [exp] returning a string which - can be parsed to create a syntax tree. Its boolean parameter - tells whether the quotation is in position of an expression - (True) or in position of a pattern (False). Quotations expanders - created with this way may work for some particular language syntax, - and not for another one (e.g. may work when used with Revised - syntax and not when used with Ocaml syntax, and conversely). -- [ExAst (expr_exp, patt_exp)] for expanders returning directly - syntax trees, therefore not necessiting to be parsed afterwards. - The function [expr_exp] is called when the quotation is in - position of an expression, and [patt_exp] when the quotation is - in position of a pattern. Quotation expanders created with this - way are independant from the language syntax. *) - -val add : string -> expander -> unit;; - (** [add name exp] adds the quotation [name] associated with the - expander [exp]. *) - -val find : string -> expander;; - (** [find name] returns the expander of the given quotation name. *) - -val default : string ref;; - (** [default] holds the default quotation name. *) - -val translate : (string -> string) ref;; - (** function translating quotation names; default = identity *) diff --git a/camlp4/ocaml_src/camlp4/reloc.ml b/camlp4/ocaml_src/camlp4/reloc.ml deleted file mode 100644 index 31d6b74d..00000000 --- a/camlp4/ocaml_src/camlp4/reloc.ml +++ /dev/null @@ -1,483 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open MLast;; - -let option_map f = - function - Some x -> Some (f x) - | None -> None -;; - -let rec ctyp floc sh = - let rec self = - function - TyAcc (loc, x1, x2) -> TyAcc (floc loc, self x1, self x2) - | TyAli (loc, x1, x2) -> TyAli (floc loc, self x1, self x2) - | TyAny loc -> TyAny (floc loc) - | TyApp (loc, x1, x2) -> TyApp (floc loc, self x1, self x2) - | TyArr (loc, x1, x2) -> TyArr (floc loc, self x1, self x2) - | TyCls (loc, x1) -> TyCls (floc loc, x1) - | TyLab (loc, x1, x2) -> TyLab (floc loc, x1, self x2) - | TyLid (loc, x1) -> TyLid (floc loc, x1) - | TyMan (loc, x1, x2) -> TyMan (floc loc, self x1, self x2) - | TyObj (loc, x1, x2) -> - TyObj (floc loc, List.map (fun (x1, x2) -> x1, self x2) x1, x2) - | TyOlb (loc, x1, x2) -> TyOlb (floc loc, x1, self x2) - | TyPol (loc, x1, x2) -> TyPol (floc loc, x1, self x2) - | TyQuo (loc, x1) -> TyQuo (floc loc, x1) - | TyRec (loc, x1) -> - TyRec - (floc loc, - List.map (fun (loc, x1, x2, x3) -> floc loc, x1, x2, self x3) x1) - | TySum (loc, x1) -> - TySum - (floc loc, - List.map (fun (loc, x1, x2) -> floc loc, x1, List.map self x2) x1) - | TyPrv (loc, x1) -> TyPrv (floc loc, self x1) - | TyTup (loc, x1) -> TyTup (floc loc, List.map self x1) - | TyUid (loc, x1) -> TyUid (floc loc, x1) - | TyVrn (loc, x1, x2) -> - TyVrn (floc loc, List.map (row_field floc sh) x1, x2) - in - self -and row_field floc sh = - function - RfTag (x1, x2, x3) -> RfTag (x1, x2, List.map (ctyp floc sh) x3) - | RfInh x1 -> RfInh (ctyp floc sh x1) -;; - -let class_infos a floc sh x = - {ciLoc = floc x.ciLoc; ciVir = x.ciVir; - ciPrm = begin let (x1, x2) = x.ciPrm in floc x1, x2 end; ciNam = x.ciNam; - ciExp = a floc sh x.ciExp} -;; - -(* Debugging positions and locations *) -let eprint_pos msg p = - Printf.eprintf "%s: fname=%s; lnum=%d; bol=%d; cnum=%d\n%!" msg - p.Lexing.pos_fname p.Lexing.pos_lnum p.Lexing.pos_bol p.Lexing.pos_cnum -;; - -let eprint_loc (bp, ep) = eprint_pos " P1" bp; eprint_pos " P2" ep;; - -let check_position msg p = - let ok = - if p.Lexing.pos_lnum < 0 || p.Lexing.pos_bol < 0 || - p.Lexing.pos_cnum < 0 || p.Lexing.pos_cnum < p.Lexing.pos_bol - then - begin - Printf.eprintf "*** Warning: (%s) strange position ***\n" msg; - eprint_pos msg p; - false - end - else true - in - ok, p -;; - -let check_location msg (bp, ep as loc) = - let ok = - let (ok1, _) = check_position " From: " bp in - let (ok2, _) = check_position " To: " ep in - if not ok1 || not ok2 || bp.Lexing.pos_lnum > ep.Lexing.pos_lnum || - bp.Lexing.pos_bol > ep.Lexing.pos_bol || - bp.Lexing.pos_cnum > ep.Lexing.pos_cnum - then - begin - Printf.eprintf "*** Warning: (%s) strange location ***\n" msg; - eprint_loc loc; - false - end - else true - in - ok, loc -;; - -let shift_pos n p = {p with Lexing.pos_cnum = p.Lexing.pos_cnum + n};; - -let zero_loc = - {(Lexing.dummy_pos) with Lexing.pos_cnum = 0; Lexing.pos_lnum = 0} -;; - -let adjust_pos globpos local_pos = - {Lexing.pos_fname = globpos.Lexing.pos_fname; - Lexing.pos_lnum = globpos.Lexing.pos_lnum + local_pos.Lexing.pos_lnum - 1; - Lexing.pos_bol = - if local_pos.Lexing.pos_lnum <= 1 then globpos.Lexing.pos_bol - else local_pos.Lexing.pos_bol + globpos.Lexing.pos_cnum; - Lexing.pos_cnum = local_pos.Lexing.pos_cnum + globpos.Lexing.pos_cnum} -;; - -let adjust_loc gpos (p1, p2) = adjust_pos gpos p1, adjust_pos gpos p2;; - -(* Note: in the following, the "let nloc = floc loc in" is necessary - in order to force evaluation order: the "floc" function has a side-effect - that changes all locations produced but the first one into ghost locations *) - -let rec patt floc sh = - let rec self = - function - PaAcc (loc, x1, x2) -> - let nloc = floc loc in PaAcc (nloc, self x1, self x2) - | PaAli (loc, x1, x2) -> - let nloc = floc loc in PaAli (nloc, self x1, self x2) - | PaAnt (loc, x1) -> - patt (fun lloc -> adjust_loc (adjust_pos sh (fst loc)) lloc) zero_loc - x1 - | PaAny loc -> let nloc = floc loc in PaAny nloc - | PaApp (loc, x1, x2) -> - let nloc = floc loc in PaApp (nloc, self x1, self x2) - | PaArr (loc, x1) -> let nloc = floc loc in PaArr (nloc, List.map self x1) - | PaChr (loc, x1) -> let nloc = floc loc in PaChr (nloc, x1) - | PaInt (loc, x1) -> let nloc = floc loc in PaInt (nloc, x1) - | PaInt32 (loc, x1) -> let nloc = floc loc in PaInt32 (nloc, x1) - | PaInt64 (loc, x1) -> let nloc = floc loc in PaInt64 (nloc, x1) - | PaNativeInt (loc, x1) -> let nloc = floc loc in PaNativeInt (nloc, x1) - | PaFlo (loc, x1) -> let nloc = floc loc in PaFlo (nloc, x1) - | PaLab (loc, x1, x2) -> - let nloc = floc loc in PaLab (nloc, x1, option_map self x2) - | PaLid (loc, x1) -> let nloc = floc loc in PaLid (nloc, x1) - | PaOlb (loc, x1, x2) -> - let nloc = floc loc in - PaOlb - (nloc, x1, - option_map (fun (x1, x2) -> self x1, option_map (expr floc sh) x2) - x2) - | PaOrp (loc, x1, x2) -> - let nloc = floc loc in PaOrp (nloc, self x1, self x2) - | PaRng (loc, x1, x2) -> - let nloc = floc loc in PaRng (nloc, self x1, self x2) - | PaRec (loc, x1) -> - let nloc = floc loc in - PaRec (nloc, List.map (fun (x1, x2) -> self x1, self x2) x1) - | PaStr (loc, x1) -> let nloc = floc loc in PaStr (nloc, x1) - | PaTup (loc, x1) -> let nloc = floc loc in PaTup (nloc, List.map self x1) - | PaTyc (loc, x1, x2) -> - let nloc = floc loc in PaTyc (nloc, self x1, ctyp floc sh x2) - | PaTyp (loc, x1) -> let nloc = floc loc in PaTyp (nloc, x1) - | PaUid (loc, x1) -> let nloc = floc loc in PaUid (nloc, x1) - | PaVrn (loc, x1) -> let nloc = floc loc in PaVrn (nloc, x1) - in - self -and expr floc sh = - let rec self = - function - ExAcc (loc, x1, x2) -> - let nloc = floc loc in ExAcc (nloc, self x1, self x2) - | ExAnt (loc, x1) -> - expr (fun lloc -> adjust_loc (adjust_pos sh (fst loc)) lloc) zero_loc - x1 - | ExApp (loc, x1, x2) -> - let nloc = floc loc in ExApp (nloc, self x1, self x2) - | ExAre (loc, x1, x2) -> - let nloc = floc loc in ExAre (nloc, self x1, self x2) - | ExArr (loc, x1) -> let nloc = floc loc in ExArr (nloc, List.map self x1) - | ExAsf loc -> let nloc = floc loc in ExAsf nloc - | ExAsr (loc, x1) -> let nloc = floc loc in ExAsr (nloc, self x1) - | ExAss (loc, x1, x2) -> - let nloc = floc loc in ExAss (nloc, self x1, self x2) - | ExChr (loc, x1) -> let nloc = floc loc in ExChr (nloc, x1) - | ExCoe (loc, x1, x2, x3) -> - let nloc = floc loc in - ExCoe (nloc, self x1, option_map (ctyp floc sh) x2, ctyp floc sh x3) - | ExFlo (loc, x1) -> let nloc = floc loc in ExFlo (nloc, x1) - | ExFor (loc, x1, x2, x3, x4, x5) -> - let nloc = floc loc in - ExFor (nloc, x1, self x2, self x3, x4, List.map self x5) - | ExFun (loc, x1) -> - let nloc = floc loc in - ExFun - (nloc, - List.map - (fun (x1, x2, x3) -> - patt floc sh x1, option_map self x2, self x3) - x1) - | ExIfe (loc, x1, x2, x3) -> - let nloc = floc loc in ExIfe (nloc, self x1, self x2, self x3) - | ExInt (loc, x1) -> let nloc = floc loc in ExInt (nloc, x1) - | ExInt32 (loc, x1) -> let nloc = floc loc in ExInt32 (nloc, x1) - | ExInt64 (loc, x1) -> let nloc = floc loc in ExInt64 (nloc, x1) - | ExNativeInt (loc, x1) -> let nloc = floc loc in ExNativeInt (nloc, x1) - | ExLab (loc, x1, x2) -> - let nloc = floc loc in ExLab (nloc, x1, option_map self x2) - | ExLaz (loc, x1) -> let nloc = floc loc in ExLaz (nloc, self x1) - | ExLet (loc, x1, x2, x3) -> - let nloc = floc loc in - ExLet - (nloc, x1, List.map (fun (x1, x2) -> patt floc sh x1, self x2) x2, - self x3) - | ExLid (loc, x1) -> let nloc = floc loc in ExLid (nloc, x1) - | ExLmd (loc, x1, x2, x3) -> - let nloc = floc loc in - ExLmd (nloc, x1, module_expr floc sh x2, self x3) - | ExMat (loc, x1, x2) -> - let nloc = floc loc in - ExMat - (nloc, self x1, - List.map - (fun (x1, x2, x3) -> - patt floc sh x1, option_map self x2, self x3) - x2) - | ExNew (loc, x1) -> let nloc = floc loc in ExNew (nloc, x1) - | ExObj (loc, x1, x2) -> - let nloc = floc loc in - ExObj - (nloc, option_map (patt floc sh) x1, - List.map (class_str_item floc sh) x2) - | ExOlb (loc, x1, x2) -> - let nloc = floc loc in ExOlb (nloc, x1, option_map self x2) - | ExOvr (loc, x1) -> - let nloc = floc loc in - ExOvr (nloc, List.map (fun (x1, x2) -> x1, self x2) x1) - | ExRec (loc, x1, x2) -> - let nloc = floc loc in - ExRec - (nloc, List.map (fun (x1, x2) -> patt floc sh x1, self x2) x1, - option_map self x2) - | ExSeq (loc, x1) -> let nloc = floc loc in ExSeq (nloc, List.map self x1) - | ExSnd (loc, x1, x2) -> let nloc = floc loc in ExSnd (nloc, self x1, x2) - | ExSte (loc, x1, x2) -> - let nloc = floc loc in ExSte (nloc, self x1, self x2) - | ExStr (loc, x1) -> let nloc = floc loc in ExStr (nloc, x1) - | ExTry (loc, x1, x2) -> - let nloc = floc loc in - ExTry - (nloc, self x1, - List.map - (fun (x1, x2, x3) -> - patt floc sh x1, option_map self x2, self x3) - x2) - | ExTup (loc, x1) -> let nloc = floc loc in ExTup (nloc, List.map self x1) - | ExTyc (loc, x1, x2) -> - let nloc = floc loc in ExTyc (nloc, self x1, ctyp floc sh x2) - | ExUid (loc, x1) -> let nloc = floc loc in ExUid (nloc, x1) - | ExVrn (loc, x1) -> let nloc = floc loc in ExVrn (nloc, x1) - | ExWhi (loc, x1, x2) -> - let nloc = floc loc in ExWhi (nloc, self x1, List.map self x2) - in - self -and module_type floc sh = - let rec self = - function - MtAcc (loc, x1, x2) -> - let nloc = floc loc in MtAcc (nloc, self x1, self x2) - | MtApp (loc, x1, x2) -> - let nloc = floc loc in MtApp (nloc, self x1, self x2) - | MtFun (loc, x1, x2, x3) -> - let nloc = floc loc in MtFun (nloc, x1, self x2, self x3) - | MtLid (loc, x1) -> let nloc = floc loc in MtLid (nloc, x1) - | MtQuo (loc, x1) -> let nloc = floc loc in MtQuo (nloc, x1) - | MtSig (loc, x1) -> - let nloc = floc loc in MtSig (nloc, List.map (sig_item floc sh) x1) - | MtUid (loc, x1) -> let nloc = floc loc in MtUid (nloc, x1) - | MtWit (loc, x1, x2) -> - let nloc = floc loc in - MtWit (nloc, self x1, List.map (with_constr floc sh) x2) - in - self -and sig_item floc sh = - let rec self = - function - SgCls (loc, x1) -> - let nloc = floc loc in - SgCls (nloc, List.map (class_infos class_type floc sh) x1) - | SgClt (loc, x1) -> - let nloc = floc loc in - SgClt (nloc, List.map (class_infos class_type floc sh) x1) - | SgDcl (loc, x1) -> let nloc = floc loc in SgDcl (nloc, List.map self x1) - | SgDir (loc, x1, x2) -> let nloc = floc loc in SgDir (nloc, x1, x2) - | SgExc (loc, x1, x2) -> - let nloc = floc loc in SgExc (nloc, x1, List.map (ctyp floc sh) x2) - | SgExt (loc, x1, x2, x3) -> - let nloc = floc loc in SgExt (nloc, x1, ctyp floc sh x2, x3) - | SgInc (loc, x1) -> - let nloc = floc loc in SgInc (nloc, module_type floc sh x1) - | SgMod (loc, x1, x2) -> - let nloc = floc loc in SgMod (nloc, x1, module_type floc sh x2) - | SgRecMod (loc, xxs) -> - let nloc = floc loc in - SgRecMod - (nloc, List.map (fun (x1, x2) -> x1, module_type floc sh x2) xxs) - | SgMty (loc, x1, x2) -> - let nloc = floc loc in SgMty (nloc, x1, module_type floc sh x2) - | SgOpn (loc, x1) -> let nloc = floc loc in SgOpn (nloc, x1) - | SgTyp (loc, x1) -> - let nloc = floc loc in - SgTyp - (nloc, - List.map - (fun ((loc, x1), x2, x3, x4) -> - (floc loc, x1), x2, ctyp floc sh x3, - List.map (fun (x1, x2) -> ctyp floc sh x1, ctyp floc sh x2) - x4) - x1) - | SgUse (loc, x1, x2) -> SgUse (loc, x1, x2) - | SgVal (loc, x1, x2) -> - let nloc = floc loc in SgVal (nloc, x1, ctyp floc sh x2) - in - self -and with_constr floc sh = - let rec self = - function - WcTyp (loc, x1, x2, x3) -> - let nloc = floc loc in WcTyp (nloc, x1, x2, ctyp floc sh x3) - | WcMod (loc, x1, x2) -> - let nloc = floc loc in WcMod (nloc, x1, module_expr floc sh x2) - in - self -and module_expr floc sh = - let rec self = - function - MeAcc (loc, x1, x2) -> - let nloc = floc loc in MeAcc (nloc, self x1, self x2) - | MeApp (loc, x1, x2) -> - let nloc = floc loc in MeApp (nloc, self x1, self x2) - | MeFun (loc, x1, x2, x3) -> - let nloc = floc loc in - MeFun (nloc, x1, module_type floc sh x2, self x3) - | MeStr (loc, x1) -> - let nloc = floc loc in MeStr (nloc, List.map (str_item floc sh) x1) - | MeTyc (loc, x1, x2) -> - let nloc = floc loc in MeTyc (nloc, self x1, module_type floc sh x2) - | MeUid (loc, x1) -> let nloc = floc loc in MeUid (nloc, x1) - in - self -and str_item floc sh = - let rec self = - function - StCls (loc, x1) -> - let nloc = floc loc in - StCls (nloc, List.map (class_infos class_expr floc sh) x1) - | StClt (loc, x1) -> - let nloc = floc loc in - StClt (nloc, List.map (class_infos class_type floc sh) x1) - | StDcl (loc, x1) -> let nloc = floc loc in StDcl (nloc, List.map self x1) - | StDir (loc, x1, x2) -> let nloc = floc loc in StDir (nloc, x1, x2) - | StExc (loc, x1, x2, x3) -> - let nloc = floc loc in - StExc (nloc, x1, List.map (ctyp floc sh) x2, x3) - | StExp (loc, x1) -> let nloc = floc loc in StExp (nloc, expr floc sh x1) - | StExt (loc, x1, x2, x3) -> - let nloc = floc loc in StExt (nloc, x1, ctyp floc sh x2, x3) - | StInc (loc, x1) -> - let nloc = floc loc in StInc (nloc, module_expr floc sh x1) - | StMod (loc, x1, x2) -> - let nloc = floc loc in StMod (nloc, x1, module_expr floc sh x2) - | StRecMod (loc, nmtmes) -> - let nloc = floc loc in - StRecMod - (nloc, - List.map - (fun (n, mt, me) -> - n, module_type floc sh mt, module_expr floc sh me) - nmtmes) - | StMty (loc, x1, x2) -> - let nloc = floc loc in StMty (nloc, x1, module_type floc sh x2) - | StOpn (loc, x1) -> let nloc = floc loc in StOpn (nloc, x1) - | StTyp (loc, x1) -> - let nloc = floc loc in - StTyp - (nloc, - List.map - (fun ((loc, x1), x2, x3, x4) -> - (floc loc, x1), x2, ctyp floc sh x3, - List.map (fun (x1, x2) -> ctyp floc sh x1, ctyp floc sh x2) - x4) - x1) - | StUse (loc, x1, x2) -> StUse (loc, x1, x2) - | StVal (loc, x1, x2) -> - let nloc = floc loc in - StVal - (nloc, x1, - List.map (fun (x1, x2) -> patt floc sh x1, expr floc sh x2) x2) - in - self -and class_type floc sh = - let rec self = - function - CtCon (loc, x1, x2) -> - let nloc = floc loc in CtCon (nloc, x1, List.map (ctyp floc sh) x2) - | CtFun (loc, x1, x2) -> - let nloc = floc loc in CtFun (nloc, ctyp floc sh x1, self x2) - | CtSig (loc, x1, x2) -> - let nloc = floc loc in - CtSig - (nloc, option_map (ctyp floc sh) x1, - List.map (class_sig_item floc sh) x2) - in - self -and class_sig_item floc sh = - let rec self = - function - CgCtr (loc, x1, x2) -> - let nloc = floc loc in CgCtr (nloc, ctyp floc sh x1, ctyp floc sh x2) - | CgDcl (loc, x1) -> - let nloc = floc loc in - CgDcl (nloc, List.map (class_sig_item floc sh) x1) - | CgInh (loc, x1) -> - let nloc = floc loc in CgInh (nloc, class_type floc sh x1) - | CgMth (loc, x1, x2, x3) -> - let nloc = floc loc in CgMth (nloc, x1, x2, ctyp floc sh x3) - | CgVal (loc, x1, x2, x3) -> - let nloc = floc loc in CgVal (nloc, x1, x2, ctyp floc sh x3) - | CgVir (loc, x1, x2, x3) -> - let nloc = floc loc in CgVir (nloc, x1, x2, ctyp floc sh x3) - in - self -and class_expr floc sh = - let rec self = - function - CeApp (loc, x1, x2) -> - let nloc = floc loc in CeApp (nloc, self x1, expr floc sh x2) - | CeCon (loc, x1, x2) -> - let nloc = floc loc in CeCon (nloc, x1, List.map (ctyp floc sh) x2) - | CeFun (loc, x1, x2) -> - let nloc = floc loc in CeFun (nloc, patt floc sh x1, self x2) - | CeLet (loc, x1, x2, x3) -> - let nloc = floc loc in - CeLet - (nloc, x1, - List.map (fun (x1, x2) -> patt floc sh x1, expr floc sh x2) x2, - self x3) - | CeStr (loc, x1, x2) -> - let nloc = floc loc in - CeStr - (nloc, option_map (patt floc sh) x1, - List.map (class_str_item floc sh) x2) - | CeTyc (loc, x1, x2) -> - let nloc = floc loc in CeTyc (nloc, self x1, class_type floc sh x2) - in - self -and class_str_item floc sh = - let rec self = - function - CrCtr (loc, x1, x2) -> - let nloc = floc loc in CrCtr (nloc, ctyp floc sh x1, ctyp floc sh x2) - | CrDcl (loc, x1) -> - let nloc = floc loc in - CrDcl (nloc, List.map (class_str_item floc sh) x1) - | CrInh (loc, x1, x2) -> - let nloc = floc loc in CrInh (nloc, class_expr floc sh x1, x2) - | CrIni (loc, x1) -> let nloc = floc loc in CrIni (nloc, expr floc sh x1) - | CrMth (loc, x1, x2, x3, x4) -> - let nloc = floc loc in - CrMth (nloc, x1, x2, expr floc sh x3, option_map (ctyp floc sh) x4) - | CrVal (loc, x1, x2, x3) -> - let nloc = floc loc in CrVal (nloc, x1, x2, expr floc sh x3) - | CrVir (loc, x1, x2, x3) -> - let nloc = floc loc in CrVir (nloc, x1, x2, ctyp floc sh x3) - in - self -;; diff --git a/camlp4/ocaml_src/camlp4/reloc.mli b/camlp4/ocaml_src/camlp4/reloc.mli deleted file mode 100644 index dae5bc1f..00000000 --- a/camlp4/ocaml_src/camlp4/reloc.mli +++ /dev/null @@ -1,55 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -val zero_loc : Lexing.position;; -val shift_pos : int -> Lexing.position -> Lexing.position;; -val adjust_loc : Lexing.position -> MLast.loc -> MLast.loc;; - -val ctyp : (MLast.loc -> MLast.loc) -> 'a -> MLast.ctyp -> MLast.ctyp;; -val row_field : - (MLast.loc -> MLast.loc) -> 'a -> MLast.row_field -> MLast.row_field;; -val class_infos : - ((MLast.loc -> MLast.loc) -> 'a -> 'b -> 'c) -> (MLast.loc -> MLast.loc) -> - 'a -> 'b MLast.class_infos -> 'c MLast.class_infos;; -val patt : - (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.patt -> MLast.patt;; -val expr : - (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.expr -> MLast.expr;; -val module_type : - (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_type -> - MLast.module_type;; -val sig_item : - (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.sig_item -> - MLast.sig_item;; -val with_constr : - (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.with_constr -> - MLast.with_constr;; -val module_expr : - (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.module_expr -> - MLast.module_expr;; -val str_item : - (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.str_item -> - MLast.str_item;; -val class_type : - (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_type -> - MLast.class_type;; -val class_sig_item : - (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_sig_item -> - MLast.class_sig_item;; -val class_expr : - (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_expr -> - MLast.class_expr;; -val class_str_item : - (MLast.loc -> MLast.loc) -> Lexing.position -> MLast.class_str_item -> - MLast.class_str_item;; diff --git a/camlp4/ocaml_src/camlp4/spretty.ml b/camlp4/ocaml_src/camlp4/spretty.ml deleted file mode 100644 index 9b6be4e5..00000000 --- a/camlp4/ocaml_src/camlp4/spretty.ml +++ /dev/null @@ -1,465 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -type glue = - LO - | RO - | LR - | NO -;; -type pretty = - S of glue * string - | Hbox of pretty Stream.t - | HVbox of pretty Stream.t - | HOVbox of pretty Stream.t - | HOVCbox of pretty Stream.t - | Vbox of pretty Stream.t - | BEbox of pretty Stream.t - | BEVbox of pretty Stream.t - | LocInfo of (int * int) * pretty -;; -type prettyL = - SL of int * glue * string - | HL of prettyL list - | BL of prettyL list - | PL of prettyL list - | QL of prettyL list - | VL of prettyL list - | BE of prettyL list - | BV of prettyL list - | LI of (string * int * int) * prettyL -;; -type getcomm = int -> int -> string * int * int * int;; - -let quiet = ref true;; -let maxl = ref 20;; -let dt = ref 2;; -let tol = ref 1;; -let sp = ref ' ';; -let last_ep = ref 0;; -let getcomm = ref (fun _ _ -> "", 0, 0, 0);; -let prompt = ref "";; -let print_char_fun = ref (output_char stdout);; -let print_string_fun = ref (output_string stdout);; -let print_newline_fun = ref (fun () -> output_char stdout '\n');; -let lazy_tab = ref (-1);; - -let flush_tab () = - if !lazy_tab >= 0 then - begin - !print_newline_fun (); - !print_string_fun !prompt; - for i = 1 to !lazy_tab do !print_char_fun !sp done; - lazy_tab := -1 - end -;; -let print_newline_and_tab tab = lazy_tab := tab;; -let print_char c = flush_tab (); !print_char_fun c;; -let print_string s = flush_tab (); !print_string_fun s;; - -let rec print_spaces nsp = for i = 1 to nsp do print_char !sp done;; - -let end_with_tab s = - let rec loop i = - if i >= 0 then if s.[i] = ' ' then loop (i - 1) else s.[i] = '\n' - else false - in - loop (String.length s - 1) -;; - -let print_comment tab s nl_bef tab_bef empty_stmt = - if s = "" then () - else - let (tab_aft, i_bef_tab) = - let rec loop tab_aft i = - if i >= 0 && s.[i] = ' ' then loop (tab_aft + 1) (i - 1) - else tab_aft, i - in - loop 0 (String.length s - 1) - in - let tab_bef = if nl_bef > 0 then tab_bef else tab in - let len = if empty_stmt then i_bef_tab else String.length s in - let rec loop i = - if i = len then () - else - begin - !print_char_fun s.[i]; - let i = - if s.[i] = '\n' && (i + 1 = len || s.[i + 1] <> '\n') then - let delta_ind = - if i = i_bef_tab then tab - tab_aft else tab - tab_bef - in - if delta_ind >= 0 then - begin - for i = 1 to delta_ind do !print_char_fun ' ' done; i + 1 - end - else - let rec loop cnt i = - if cnt = 0 then i - else if i = len then i - else if s.[i] = ' ' then loop (cnt + 1) (i + 1) - else i - in - loop delta_ind (i + 1) - else i + 1 - in - loop i - end - in - loop 0 -;; - -let string_np pos np = pos + np;; - -let trace_ov pos = - if not !quiet && pos > !maxl then - begin - prerr_string " prettych: overflow (length = "; - prerr_int pos; - prerr_endline ")" - end -;; - -let tolerate tab pos spc = pos + spc <= tab + !dt + !tol;; - -let h_print_string pos spc np x = - let npos = string_np (pos + spc) np in - print_spaces spc; print_string x; npos -;; - -let n_print_string pos spc np x = - print_spaces spc; print_string x; string_np (pos + spc) np -;; - -let rec hnps (pos, spc as ps) = - function - SL (np, RO, _) -> string_np pos np, 1 - | SL (np, LO, _) -> string_np (pos + spc) np, 0 - | SL (np, NO, _) -> string_np pos np, 0 - | SL (np, LR, _) -> string_np (pos + spc) np, 1 - | HL x -> hnps_list ps x - | BL x -> hnps_list ps x - | PL x -> hnps_list ps x - | QL x -> hnps_list ps x - | VL [x] -> hnps ps x - | VL [] -> ps - | VL x -> !maxl + 1, 0 - | BE x -> hnps_list ps x - | BV x -> !maxl + 1, 0 - | LI (_, x) -> hnps ps x -and hnps_list (pos, _ as ps) pl = - if pos > !maxl then !maxl + 1, 0 - else - match pl with - p :: pl -> hnps_list (hnps ps p) pl - | [] -> ps -;; - -let rec first = - function - SL (_, _, s) -> Some s - | HL x -> first_in_list x - | BL x -> first_in_list x - | PL x -> first_in_list x - | QL x -> first_in_list x - | VL x -> first_in_list x - | BE x -> first_in_list x - | BV x -> first_in_list x - | LI (_, x) -> first x -and first_in_list = - function - p :: pl -> - begin match first p with - Some p -> Some p - | None -> first_in_list pl - end - | [] -> None -;; - -let first_is_too_big tab p = - match first p with - Some s -> tab + String.length s >= !maxl - | None -> false -;; - -let too_long tab x p = - if first_is_too_big tab p then false - else let (pos, spc) = hnps x p in pos > !maxl -;; - -let rec has_comment = - function - LI ((comm, nl_bef, tab_bef), x) :: pl -> - comm <> "" || has_comment (x :: pl) - | (HL x | BL x | PL x | QL x | VL x | BE x | BV x) :: pl -> - has_comment x || has_comment pl - | SL (_, _, _) :: pl -> has_comment pl - | [] -> false -;; - -let rec hprint_pretty tab pos spc = - function - SL (np, RO, x) -> h_print_string pos 0 np x, 1 - | SL (np, LO, x) -> h_print_string pos spc np x, 0 - | SL (np, NO, x) -> h_print_string pos 0 np x, 0 - | SL (np, LR, x) -> h_print_string pos spc np x, 1 - | HL x -> hprint_box tab pos spc x - | BL x -> hprint_box tab pos spc x - | PL x -> hprint_box tab pos spc x - | QL x -> hprint_box tab pos spc x - | VL [x] -> hprint_pretty tab pos spc x - | VL [] -> pos, spc - | VL x -> hprint_box tab pos spc x - | BE x -> hprint_box tab pos spc x - | BV x -> hprint_box tab pos spc x - | LI ((comm, nl_bef, tab_bef), x) -> - if !lazy_tab >= 0 then - begin - for i = 2 to nl_bef do !print_char_fun '\n' done; flush_tab () - end; - print_comment tab comm nl_bef tab_bef false; - hprint_pretty tab pos spc x -and hprint_box tab pos spc = - function - p :: pl -> - let (pos, spc) = hprint_pretty tab pos spc p in - hprint_box tab pos spc pl - | [] -> pos, spc -;; - -let rec print_pretty tab pos spc = - function - SL (np, RO, x) -> n_print_string pos 0 np x, 1 - | SL (np, LO, x) -> n_print_string pos spc np x, 0 - | SL (np, NO, x) -> n_print_string pos 0 np x, 0 - | SL (np, LR, x) -> n_print_string pos spc np x, 1 - | HL x -> print_horiz tab pos spc x - | BL x as p -> print_horiz_vertic tab pos spc (too_long tab (pos, spc) p) x - | PL x as p -> print_paragraph tab pos spc (too_long tab (pos, spc) p) x - | QL x as p -> print_sparagraph tab pos spc (too_long tab (pos, spc) p) x - | VL x -> print_vertic tab pos spc x - | BE x as p -> print_begin_end tab pos spc (too_long tab (pos, spc) p) x - | BV x -> print_beg_end tab pos spc x - | LI ((comm, nl_bef, tab_bef), x) -> - if !lazy_tab >= 0 then - begin - for i = 2 to nl_bef do !print_char_fun '\n' done; - if comm <> "" && nl_bef = 0 then - for i = 1 to tab_bef do !print_char_fun ' ' done - else if comm = "" && x = BL [] then lazy_tab := -1 - else flush_tab () - end; - print_comment tab comm nl_bef tab_bef (x = BL []); - if comm <> "" && nl_bef = 0 then - if end_with_tab comm then lazy_tab := -1 else flush_tab (); - print_pretty tab pos spc x -and print_horiz tab pos spc = - function - p :: pl -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [] -> true - | _ -> false - then - npos, nspc - else print_horiz tab npos nspc pl - | [] -> pos, spc -and print_horiz_vertic tab pos spc ov pl = - if ov || has_comment pl then print_vertic tab pos spc pl - else hprint_box tab pos spc pl -and print_vertic tab pos spc = - function - p :: pl -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [] -> true - | _ -> false - then - npos, nspc - else if tolerate tab npos nspc then - begin print_spaces nspc; print_vertic_rest (npos + nspc) pl end - else - begin - print_newline_and_tab (tab + !dt); print_vertic_rest (tab + !dt) pl - end - | [] -> pos, spc -and print_vertic_rest tab = - function - p :: pl -> - let (pos, spc) = print_pretty tab tab 0 p in - if match pl with - [] -> true - | _ -> false - then - pos, spc - else begin print_newline_and_tab tab; print_vertic_rest tab pl end - | [] -> tab, 0 -and print_paragraph tab pos spc ov pl = - if has_comment pl then print_vertic tab pos spc pl - else if ov then print_parag tab pos spc pl - else hprint_box tab pos spc pl -and print_parag tab pos spc = - function - p :: pl -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [] -> true - | _ -> false - then - npos, nspc - else if npos == tab then print_parag_rest tab tab 0 pl - else if too_long tab (pos, spc) p then - begin - print_newline_and_tab (tab + !dt); - print_parag_rest (tab + !dt) (tab + !dt) 0 pl - end - else if tolerate tab npos nspc then - begin - print_spaces nspc; print_parag_rest (npos + nspc) (npos + nspc) 0 pl - end - else print_parag_rest (tab + !dt) npos nspc pl - | [] -> pos, spc -and print_parag_rest tab pos spc = - function - p :: pl -> - let (pos, spc) = - if pos > tab && too_long tab (pos, spc) p then - begin print_newline_and_tab tab; tab, 0 end - else pos, spc - in - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [] -> true - | _ -> false - then - npos, nspc - else - let (pos, spc) = - if npos > tab && too_long tab (pos, spc) p then - begin print_newline_and_tab tab; tab, 0 end - else npos, nspc - in - print_parag_rest tab pos spc pl - | [] -> pos, spc -and print_sparagraph tab pos spc ov pl = - if has_comment pl then print_vertic tab pos spc pl - else if ov then print_sparag tab pos spc pl - else hprint_box tab pos spc pl -and print_sparag tab pos spc = - function - p :: pl -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [] -> true - | _ -> false - then - npos, nspc - else if tolerate tab npos nspc then - begin - print_spaces nspc; - print_sparag_rest (npos + nspc) (npos + nspc) 0 pl - end - else print_sparag_rest (tab + !dt) npos nspc pl - | [] -> pos, spc -and print_sparag_rest tab pos spc = - function - p :: pl -> - let (pos, spc) = - if pos > tab && too_long tab (pos, spc) p then - begin print_newline_and_tab tab; tab, 0 end - else pos, spc - in - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [] -> true - | _ -> false - then - npos, nspc - else print_sparag_rest tab npos nspc pl - | [] -> pos, spc -and print_begin_end tab pos spc ov pl = - if ov || has_comment pl then print_beg_end tab pos spc pl - else hprint_box tab pos spc pl -and print_beg_end tab pos spc = - function - p :: pl -> - let (npos, nspc) = print_pretty tab pos spc p in - if match pl with - [] -> true - | _ -> false - then - npos, nspc - else if tolerate tab npos nspc then - let nspc = if npos == tab then nspc + !dt else nspc in - print_spaces nspc; print_beg_end_rest tab (npos + nspc) pl - else - begin - print_newline_and_tab (tab + !dt); - print_beg_end_rest tab (tab + !dt) pl - end - | [] -> pos, spc -and print_beg_end_rest tab pos = - function - p :: pl -> - let (pos, spc) = print_pretty (tab + !dt) pos 0 p in - if match pl with - [] -> true - | _ -> false - then - pos, spc - else begin print_newline_and_tab tab; print_beg_end_rest tab tab pl end - | [] -> pos, 0 -;; - -let string_npos s = String.length s;; - -let rec conv = - function - S (g, s) -> SL (string_npos s, g, s) - | Hbox x -> HL (conv_stream x) - | HVbox x -> BL (conv_stream x) - | HOVbox x -> - begin match conv_stream x with - [PL _ as x] -> x - | x -> PL x - end - | HOVCbox x -> QL (conv_stream x) - | Vbox x -> VL (conv_stream x) - | BEbox x -> BE (conv_stream x) - | BEVbox x -> BV (conv_stream x) - | LocInfo ((bp, ep), x) -> - let (comm, nl_bef, tab_bef, cnt) = - let len = bp - !last_ep in - if len > 0 then !getcomm !last_ep len else "", 0, 0, 0 - in - last_ep := !last_ep + cnt; - let v = conv x in - last_ep := max ep !last_ep; LI ((comm, nl_bef, tab_bef), v) -and conv_stream (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some p -> Stream.junk strm__; let x = conv p in x :: conv_stream strm__ - | _ -> [] -;; - -let print_pretty pr_ch pr_str pr_nl pr pr2 m lf bp p = - maxl := m; - print_char_fun := pr_ch; - print_string_fun := pr_str; - print_newline_fun := pr_nl; - prompt := pr2; - getcomm := lf; - last_ep := bp; - print_string pr; - let _ = print_pretty 0 0 0 (conv p) in () -;; diff --git a/camlp4/ocaml_src/camlp4/spretty.mli b/camlp4/ocaml_src/camlp4/spretty.mli deleted file mode 100644 index 5c62d3f6..00000000 --- a/camlp4/ocaml_src/camlp4/spretty.mli +++ /dev/null @@ -1,59 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(* Hbox: horizontal box - HVbox: horizontal-vertical box - HOVbox and HOVCbox: fill maximum of elements horizontally, line by line; - in HOVbox, if an element has to be displayed vertically (need several - lines), the next element is displayed next line; in HOVCbox, this next - element may be displayed same line if it holds. - Vbox: vertical box - BEbox: begin-end box: horizontal or 2nd element indented, 3rd element not - BEVbox: begin-end box always vertical - LocInfo: call back with location to allow inserting comments *) - -(* In case of box displayed vertically, 2nd line and following are indented - by dt.val spaces, except if first element of the box is empty: to not - indent, put HVbox [: :] as first element *) - -type glue = - LO - | RO - | LR - | NO -;; -type pretty = - S of glue * string - | Hbox of pretty Stream.t - | HVbox of pretty Stream.t - | HOVbox of pretty Stream.t - | HOVCbox of pretty Stream.t - | Vbox of pretty Stream.t - | BEbox of pretty Stream.t - | BEVbox of pretty Stream.t - | LocInfo of (int * int) * pretty -;; -type getcomm = int -> int -> string * int * int * int;; - -val print_pretty : - (char -> unit) -> (string -> unit) -> (unit -> unit) -> string -> string -> - int -> getcomm -> int -> pretty -> unit;; -val quiet : bool ref;; - -val dt : int ref;; - -(*--*) - -val tol : int ref;; -val sp : char ref;; diff --git a/camlp4/ocaml_src/lib/.depend b/camlp4/ocaml_src/lib/.depend deleted file mode 100644 index 286b4c5b..00000000 --- a/camlp4/ocaml_src/lib/.depend +++ /dev/null @@ -1,21 +0,0 @@ -extfold.cmi: gramext.cmi -gramext.cmi: token.cmi -grammar.cmi: token.cmi gramext.cmi -plexer.cmi: token.cmi -stdpp.cmi: token.cmi -extfold.cmo: grammar.cmi gramext.cmi extfold.cmi -extfold.cmx: grammar.cmx gramext.cmx extfold.cmi -extfun.cmo: extfun.cmi -extfun.cmx: extfun.cmi -fstream.cmo: fstream.cmi -fstream.cmx: fstream.cmi -gramext.cmo: token.cmi gramext.cmi -gramext.cmx: token.cmx gramext.cmi -grammar.cmo: token.cmi stdpp.cmi gramext.cmi grammar.cmi -grammar.cmx: token.cmx stdpp.cmx gramext.cmx grammar.cmi -plexer.cmo: token.cmi stdpp.cmi plexer.cmi -plexer.cmx: token.cmx stdpp.cmx plexer.cmi -stdpp.cmo: token.cmi stdpp.cmi -stdpp.cmx: token.cmx stdpp.cmi -token.cmo: token.cmi -token.cmx: token.cmi diff --git a/camlp4/ocaml_src/lib/Makefile b/camlp4/ocaml_src/lib/Makefile deleted file mode 100644 index 3ff16508..00000000 --- a/camlp4/ocaml_src/lib/Makefile +++ /dev/null @@ -1,62 +0,0 @@ -# This file has been generated by program: do not edit! - -include ../../config/Makefile - -INCLUDES= -OCAMLCFLAGS=-warn-error A $(INCLUDES) -OBJS=stdpp.cmo token.cmo plexer.cmo gramext.cmo grammar.cmo extfold.cmo extfun.cmo fstream.cmo -SHELL=/bin/sh -TARGET=gramlib.cma - -.PHONY: opt all clean depend promote compare install installopt - -all: $(TARGET) -opt: opt$(PROFILING) - -optnoprof: $(TARGET:.cma=.cmxa) -optprof: optnoprof $(TARGET:.cma=.p.cmxa) - -$(TARGET): $(OBJS) - $(OCAMLC) $(OBJS) -a -o $(TARGET) - -$(TARGET:.cma=.cmxa): $(OBJS:.cmo=.cmx) - $(OCAMLOPT) $(OBJS:.cmo=.cmx) -a -o $(TARGET:.cma=.cmxa) - -$(TARGET:.cma=.p.cmxa): $(OBJS:.cmo=.p.cmx) - $(OCAMLOPT) $(OBJS:.cmo=.p.cmx) -a -o $(TARGET:.cma=.p.cmxa) - -clean:: - rm -f *.cm[ioax] *.cmxa *.pp[io] *.$(O) *.$(A) *.bak .*.bak $(TARGET) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i >> .depend; \ - done - -promote: - cp $(OBJS) $(OBJS:.cmo=.cmi) ../../boot/. - -compare: - @for j in $(OBJS) $(OBJS:.cmo=.cmi); do \ - if cmp $$j ../../boot/$$j; then :; else exit 1; fi; \ - done - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" - cp $(TARGET) *.mli "$(LIBDIR)/camlp4/." - cp *.cmi "$(LIBDIR)/camlp4/." - test -f $(TARGET:.cma=.cmxa) && $(MAKE) installopt LIBDIR="$(LIBDIR)" || true - -installopt: - for f in $(TARGET:.cma=.cmxa) $(TARGET:.cma=.p.cmxa) *.cmx ; do \ - test -f $$f && cp $$f "$(LIBDIR)/camlp4/." || true ; \ - done - # Special treatment for this one: some versions of make don't like $(A) in $(TARGET:.cma=.$(A)) - target="`echo $(TARGET) | sed -e 's/\.cma$$/.$(A)/'`" ; \ - if test -f $$target ; then \ - cp $$target "$(LIBDIR)/camlp4/." && ( cd "$(LIBDIR)/camlp4/." && $(RANLIB) $$target ) \ - fi - -include .depend diff --git a/camlp4/ocaml_src/lib/extfold.ml b/camlp4/ocaml_src/lib/extfold.ml deleted file mode 100644 index 0411497f..00000000 --- a/camlp4/ocaml_src/lib/extfold.ml +++ /dev/null @@ -1,124 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) - -type ('te, 'a, 'b) t = - 'te Gramext.g_entry -> 'te Gramext.g_symbol list -> ('te Stream.t -> 'a) -> - 'te Stream.t -> 'b -;; - -type ('te, 'a, 'b) tsep = - 'te Gramext.g_entry -> 'te Gramext.g_symbol list -> ('te Stream.t -> 'a) -> - ('te Stream.t -> unit) -> 'te Stream.t -> 'b -;; - -let gen_fold0 final f e entry symbl psymb = - let rec fold accu (strm__ : _ Stream.t) = - match - try Some (psymb strm__) with - Stream.Failure -> None - with - Some a -> fold (f a accu) strm__ - | _ -> accu - in - fun (strm__ : _ Stream.t) -> let a = fold e strm__ in final a -;; - -let gen_fold1 final f e entry symbl psymb = - let rec fold accu (strm__ : _ Stream.t) = - match - try Some (psymb strm__) with - Stream.Failure -> None - with - Some a -> fold (f a accu) strm__ - | _ -> accu - in - fun (strm__ : _ Stream.t) -> - let a = psymb strm__ in - let a = - try fold (f a e) strm__ with - Stream.Failure -> raise (Stream.Error "") - in - final a -;; - -let gen_fold0sep final f e entry symbl psymb psep = - let failed = - function - [symb; sep] -> Grammar.symb_failed_txt entry sep symb - | _ -> "failed" - in - let rec kont accu (strm__ : _ Stream.t) = - match - try Some (psep strm__) with - Stream.Failure -> None - with - Some v -> - let a = - try psymb strm__ with - Stream.Failure -> raise (Stream.Error (failed symbl)) - in - kont (f a accu) strm__ - | _ -> accu - in - fun (strm__ : _ Stream.t) -> - match - try Some (psymb strm__) with - Stream.Failure -> None - with - Some a -> final (kont (f a e) strm__) - | _ -> e -;; - -let gen_fold1sep final f e entry symbl psymb psep = - let failed = - function - [symb; sep] -> Grammar.symb_failed_txt entry sep symb - | _ -> "failed" - in - let parse_top = - function - [symb; _] -> Grammar.parse_top_symb entry symb - | _ -> raise Stream.Failure - in - let rec kont accu (strm__ : _ Stream.t) = - match - try Some (psep strm__) with - Stream.Failure -> None - with - Some v -> - let a = - try - try psymb strm__ with - Stream.Failure -> - let a = - try parse_top symbl strm__ with - Stream.Failure -> raise (Stream.Error (failed symbl)) - in - Obj.magic a - with - Stream.Failure -> raise (Stream.Error "") - in - kont (f a accu) strm__ - | _ -> accu - in - fun (strm__ : _ Stream.t) -> - let a = psymb strm__ in final (kont (f a e) strm__) -;; - -let sfold0 f e = gen_fold0 (fun x -> x) f e;; -let sfold1 f e = gen_fold1 (fun x -> x) f e;; -let sfold0sep f e = gen_fold0sep (fun x -> x) f e;; -let sfold1sep f e = gen_fold1sep (fun x -> x) f e;; - -let cons x y = x :: y;; -let nil = [];; - -let slist0 entry = gen_fold0 List.rev cons nil entry;; -let slist1 entry = gen_fold1 List.rev cons nil entry;; -let slist0sep entry = gen_fold0sep List.rev cons nil entry;; -let slist1sep entry = gen_fold1sep List.rev cons nil entry;; - -let sopt entry symbl psymb (strm__ : _ Stream.t) = - try Some (psymb strm__) with - Stream.Failure -> None -;; diff --git a/camlp4/ocaml_src/lib/extfold.mli b/camlp4/ocaml_src/lib/extfold.mli deleted file mode 100644 index cb2824fb..00000000 --- a/camlp4/ocaml_src/lib/extfold.mli +++ /dev/null @@ -1,24 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) - -type ('te, 'a, 'b) t = - 'te Gramext.g_entry -> 'te Gramext.g_symbol list -> ('te Stream.t -> 'a) -> - 'te Stream.t -> 'b -;; - -type ('te, 'a, 'b) tsep = - 'te Gramext.g_entry -> 'te Gramext.g_symbol list -> ('te Stream.t -> 'a) -> - ('te Stream.t -> unit) -> 'te Stream.t -> 'b -;; - -val sfold0 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) t;; -val sfold1 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) t;; -val sfold0sep : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) tsep;; -val sfold1sep : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) tsep;; - -val slist0 : (_, 'a, 'a list) t;; -val slist1 : (_, 'a, 'a list) t;; -val slist0sep : (_, 'a, 'a list) tsep;; -val slist1sep : (_, 'a, 'a list) tsep;; - -val sopt : (_, 'a, 'a option) t;; diff --git a/camlp4/ocaml_src/lib/extfun.ml b/camlp4/ocaml_src/lib/extfun.ml deleted file mode 100644 index 249fadb8..00000000 --- a/camlp4/ocaml_src/lib/extfun.ml +++ /dev/null @@ -1,102 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) -(* Copyright 2001 INRIA *) - -(* Extensible Functions *) - -type ('a, 'b) t = ('a, 'b) matching list -and ('a, 'b) matching = { patt : patt; has_when : bool; expr : ('a, 'b) expr } -and patt = - Eapp of patt list - | Eacc of patt list - | Econ of string - | Estr of string - | Eint of string - | Etup of patt list - | Evar of unit -and ('a, 'b) expr = 'a -> 'b option -;; - -exception Failure;; - -let empty = [];; - -(*** Apply ***) - -let rec apply_matchings a = - function - m :: ml -> - begin match m.expr a with - None -> apply_matchings a ml - | x -> x - end - | [] -> None -;; - -let apply ef a = - match apply_matchings a ef with - Some x -> x - | None -> raise Failure -;; - -(*** Trace ***) - -let rec list_iter_sep f s = - function - [] -> () - | [x] -> f x - | x :: l -> f x; s (); list_iter_sep f s l -;; - -let rec print_patt = - function - Eapp pl -> list_iter_sep print_patt2 (fun () -> print_string " ") pl - | p -> print_patt2 p -and print_patt2 = - function - Eacc pl -> list_iter_sep print_patt1 (fun () -> print_string ".") pl - | p -> print_patt1 p -and print_patt1 = - function - Econ s -> print_string s - | Estr s -> print_string "\""; print_string s; print_string "\"" - | Eint s -> print_string s - | Evar () -> print_string "_" - | Etup pl -> - print_string "("; - list_iter_sep print_patt (fun () -> print_string ", ") pl; - print_string ")" - | Eapp _ | Eacc _ as p -> print_string "("; print_patt p; print_string ")" -;; - -let print ef = - List.iter - (fun m -> - print_patt m.patt; - if m.has_when then print_string " when ..."; - print_newline ()) - ef -;; - -(*** Extension ***) - -let insert_matching matchings (patt, has_when, expr) = - let m1 = {patt = patt; has_when = has_when; expr = expr} in - let rec loop = - function - m :: ml as gml -> - if m1.has_when && not m.has_when then m1 :: gml - else if not m1.has_when && m.has_when then m :: loop ml - else if compare m1.patt m.patt = 0 then - if not m1.has_when then m1 :: ml else m1 :: gml - else m :: loop ml - | [] -> [m1] - in - loop matchings -;; - -(* available extension function *) - -let extend ef matchings_def = - List.fold_left insert_matching ef matchings_def -;; diff --git a/camlp4/ocaml_src/lib/extfun.mli b/camlp4/ocaml_src/lib/extfun.mli deleted file mode 100644 index 2d42fe2e..00000000 --- a/camlp4/ocaml_src/lib/extfun.mli +++ /dev/null @@ -1,37 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) - -(** Extensible functions. - - This module implements pattern matching extensible functions. - To extend, use syntax [pa_extfun.cmo]: - - [extfun e with [ pattern_matching ]] *) - -type ('a, 'b) t;; - (** The type of the extensible functions of type ['a -> 'b] *) -val empty : ('a, 'b) t;; - (** Empty extensible function *) -val apply : ('a, 'b) t -> 'a -> 'b;; - (** Apply an extensible function *) -exception Failure;; - (** Match failure while applying an extensible function *) -val print : ('a, 'b) t -> unit;; - (** Print patterns in the order they are recorded *) - -(**/**) - -type ('a, 'b) matching = - { patt : patt; has_when : bool; expr : ('a, 'b) expr } -and patt = - Eapp of patt list - | Eacc of patt list - | Econ of string - | Estr of string - | Eint of string - | Etup of patt list - | Evar of unit -and ('a, 'b) expr = 'a -> 'b option -;; - -val extend : ('a, 'b) t -> (patt * bool * ('a, 'b) expr) list -> ('a, 'b) t;; diff --git a/camlp4/ocaml_src/lib/fstream.ml b/camlp4/ocaml_src/lib/fstream.ml deleted file mode 100644 index 9ffdb710..00000000 --- a/camlp4/ocaml_src/lib/fstream.ml +++ /dev/null @@ -1,84 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) -(* Copyright 2001 INRIA *) - -type 'a t = { count : int; data : 'a data Lazy.t } -and 'a data = - Nil - | Cons of 'a * 'a t - | App of 'a t * 'a t -;; - -let from f = - let rec loop i = - {count = 0; - data = - lazy - (match f i with - Some x -> Cons (x, loop (i + 1)) - | None -> Nil)} - in - loop 0 -;; - -let rec next s = - let count = s.count + 1 in - match Lazy.force s.data with - Nil -> None - | Cons (a, s) -> Some (a, {count = count; data = s.data}) - | App (s1, s2) -> - match next s1 with - Some (a, s1) -> Some (a, {count = count; data = lazy (App (s1, s2))}) - | None -> - match next s2 with - Some (a, s2) -> Some (a, {count = count; data = s2.data}) - | None -> None -;; - -let empty s = - match next s with - Some _ -> None - | None -> Some ((), s) -;; - -let nil = {count = 0; data = lazy Nil};; -let cons a s = Cons (a, s);; -let app s1 s2 = App (s1, s2);; -let flazy f = {count = 0; data = Lazy.lazy_from_fun f};; - -let of_list l = - List.fold_right (fun x s -> flazy (fun () -> cons x s)) l nil -;; - -let of_string s = - from (fun c -> if c < String.length s then Some s.[c] else None) -;; - -let of_channel ic = - from - (fun _ -> - try Some (input_char ic) with - End_of_file -> None) -;; - -let iter f = - let rec do_rec strm = - match next strm with - Some (a, strm) -> let _ = f a in do_rec strm - | None -> () - in - do_rec -;; - -let count s = s.count;; - -let count_unfrozen s = - let rec loop cnt s = - if Lazy.lazy_is_val s.data then - match Lazy.force s.data with - Cons (_, s) -> loop (cnt + 1) s - | _ -> cnt - else cnt - in - loop 0 s -;; diff --git a/camlp4/ocaml_src/lib/fstream.mli b/camlp4/ocaml_src/lib/fstream.mli deleted file mode 100644 index d0e8f8b4..00000000 --- a/camlp4/ocaml_src/lib/fstream.mli +++ /dev/null @@ -1,60 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) - -(* Module [Fstream]: functional streams *) - -(* This module implement functional streams. - To be used with syntax [pa_fstream.cmo]. The syntax is: -- stream: [fstream [: ... :]] -- parser: [parser [ [: ... :] -> ... | ... ]] - - Functional parsers are of type: [Fstream.t 'a -> option ('a * Fstream.t 'a)] - - They have limited backtrack, i.e if a rule fails, the next rule is tested - with the initial stream; limited because when in case of a rule with two - consecutive symbols [a] and [b], if [b] fails, the rule fails: there is - no try with the next rule of [a]. -*) - -type 'a t;; - (* The type of 'a functional streams *) -val from : (int -> 'a option) -> 'a t;; - (* [Fstream.from f] returns a stream built from the function [f]. - To create a new stream element, the function [f] is called with - the current stream count. The user function [f] must return either - [Some ] for a value or [None] to specify the end of the - stream. *) - -val of_list : 'a list -> 'a t;; - (* Return the stream holding the elements of the list in the same - order. *) -val of_string : string -> char t;; - (* Return the stream of the characters of the string parameter. *) -val of_channel : in_channel -> char t;; - (* Return the stream of the characters read from the input channel. *) - -val iter : ('a -> unit) -> 'a t -> unit;; - (* [Fstream.iter f s] scans the whole stream s, applying function [f] - in turn to each stream element encountered. *) - -val next : 'a t -> ('a * 'a t) option;; - (* Return [Some (a, s)] where [a] is the first element of the stream - and [s] the remaining stream, or [None] if the stream is empty. *) -val empty : 'a t -> (unit * 'a t) option;; - (* Return [Some ((), s)] if the stream is empty where [s] is itself, - else [None] *) -val count : 'a t -> int;; - (* Return the current count of the stream elements, i.e. the number - of the stream elements discarded. *) -val count_unfrozen : 'a t -> int;; - (* Return the number of unfrozen elements in the beginning of the - stream; useful to determine the position of a parsing error (longuest - path). *) - -(*--*) - -val nil : 'a t;; -type 'a data;; -val cons : 'a -> 'a t -> 'a data;; -val app : 'a t -> 'a t -> 'a data;; -val flazy : (unit -> 'a data) -> 'a t;; diff --git a/camlp4/ocaml_src/lib/gramext.ml b/camlp4/ocaml_src/lib/gramext.ml deleted file mode 100644 index 41fdd76c..00000000 --- a/camlp4/ocaml_src/lib/gramext.ml +++ /dev/null @@ -1,531 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Printf;; - -type 'te grammar = - { gtokens : (Token.pattern, int ref) Hashtbl.t; - mutable glexer : 'te Token.glexer } -;; - -type 'te g_entry = - { egram : 'te grammar; - ename : string; - mutable estart : int -> 'te Stream.t -> Obj.t; - mutable econtinue : int -> int -> Obj.t -> 'te Stream.t -> Obj.t; - mutable edesc : 'te g_desc } -and 'te g_desc = - Dlevels of 'te g_level list - | Dparser of ('te Stream.t -> Obj.t) -and 'te g_level = - { assoc : g_assoc; - lname : string option; - lsuffix : 'te g_tree; - lprefix : 'te g_tree } -and g_assoc = - NonA - | RightA - | LeftA -and 'te g_symbol = - Smeta of string * 'te g_symbol list * Obj.t - | Snterm of 'te g_entry - | Snterml of 'te g_entry * string - | Slist0 of 'te g_symbol - | Slist0sep of 'te g_symbol * 'te g_symbol - | Slist1 of 'te g_symbol - | Slist1sep of 'te g_symbol * 'te g_symbol - | Sopt of 'te g_symbol - | Sself - | Snext - | Stoken of Token.pattern - | Stree of 'te g_tree -and g_action = Obj.t -and 'te g_tree = - Node of 'te g_node - | LocAct of g_action * g_action list - | DeadEnd -and 'te g_node = - { node : 'te g_symbol; son : 'te g_tree; brother : 'te g_tree } -;; - -type position = - First - | Last - | Before of string - | After of string - | Level of string -;; - -let warning_verbose = ref true;; - -let rec derive_eps = - function - Slist0 _ -> true - | Slist0sep (_, _) -> true - | Sopt _ -> true - | Stree t -> tree_derive_eps t - | Smeta (_, _, _) | Slist1 _ | Slist1sep (_, _) | Snterm _ | - Snterml (_, _) | Snext | Sself | Stoken _ -> - false -and tree_derive_eps = - function - LocAct (_, _) -> true - | Node {node = s; brother = bro; son = son} -> - derive_eps s && tree_derive_eps son || tree_derive_eps bro - | DeadEnd -> false -;; - -let 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 -> eq_symbol s1 s2 - | Slist0sep (s1, sep1), Slist0sep (s2, sep2) -> - eq_symbol s1 s2 && eq_symbol sep1 sep2 - | Slist1 s1, Slist1 s2 -> eq_symbol s1 s2 - | Slist1sep (s1, sep1), Slist1sep (s2, sep2) -> - eq_symbol s1 s2 && eq_symbol sep1 sep2 - | Sopt s1, Sopt s2 -> eq_symbol s1 s2 - | Stree _, Stree _ -> false - | _ -> s1 = s2 -;; - -let is_before s1 s2 = - match s1, s2 with - Stoken ("ANY", _), _ -> false - | _, Stoken ("ANY", _) -> true - | Stoken (_, s), Stoken (_, "") when s <> "" -> true - | Stoken _, Stoken _ -> false - | Stoken _, _ -> true - | _ -> false -;; - -let insert_tree entry_name 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) -> - if !warning_verbose then - begin - eprintf " Grammar extension: "; - if entry_name <> "" then eprintf "in [%s], " entry_name; - eprintf "some rule has been masked\n"; - flush stderr - end; - 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 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 - begin match try_insert s sl bro with - Some bro -> - let t = Node {node = s1; son = son; brother = bro} in Some t - | None -> None - end - | LocAct (_, _) | DeadEnd -> None - and insert_new = - function - s :: sl -> Node {node = s; son = insert_new sl; brother = DeadEnd} - | [] -> LocAct (action, []) - in - insert gsymbols tree -;; - -let srules rl = - let t = - List.fold_left - (fun tree (symbols, action) -> insert_tree "" symbols action tree) - DeadEnd rl - in - Stree t -;; - -external action : 'a -> g_action = "%identity";; - -let is_level_labelled n lev = - match lev.lname with - Some n1 -> n = n1 - | None -> false -;; - -let insert_level entry_name e1 symbols action slev = - match e1 with - true -> - {assoc = slev.assoc; lname = slev.lname; - lsuffix = insert_tree entry_name symbols action slev.lsuffix; - lprefix = slev.lprefix} - | false -> - {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix; - lprefix = insert_tree entry_name symbols action slev.lprefix} -;; - -let empty_lev lname assoc = - let assoc = - match assoc with - Some a -> a - | None -> LeftA - in - {assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd} -;; - -let change_lev lev n lname assoc = - let a = - match assoc with - None -> lev.assoc - | Some a -> - if a <> lev.assoc && !warning_verbose then - begin - eprintf " Changing associativity of level \"%s\"\n" n; - flush stderr - end; - a - in - begin match lname with - Some n -> - if lname <> lev.lname && !warning_verbose then - begin eprintf " Level label \"%s\" ignored\n" n; flush stderr end - | None -> () - end; - {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; lprefix = lev.lprefix} -;; - -let get_level entry position levs = - match position with - Some First -> [], empty_lev, levs - | Some Last -> levs, empty_lev, [] - | Some (Level n) -> - let rec get = - function - [] -> - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush stderr; - failwith "Grammar.extend" - | lev :: levs -> - if is_level_labelled n lev then [], change_lev lev n, levs - else - let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2 - in - get levs - | Some (Before n) -> - let rec get = - function - [] -> - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush stderr; - failwith "Grammar.extend" - | lev :: levs -> - if 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 = - function - [] -> - eprintf "No level labelled \"%s\" in entry \"%s\"\n" n - entry.ename; - flush stderr; - failwith "Grammar.extend" - | lev :: levs -> - if 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 lev "", levs - | [] -> [], empty_lev, [] -;; - -let rec check_gram entry = - function - Snterm e -> - if e.egram != entry.egram then - begin - eprintf "\ -Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" - entry.ename e.ename; - flush stderr; - failwith "Grammar.extend error" - end - | Snterml (e, _) -> - if e.egram != entry.egram then - begin - eprintf "\ -Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n" - entry.ename e.ename; - flush stderr; - failwith "Grammar.extend error" - end - | Smeta (_, sl, _) -> List.iter (check_gram entry) sl - | Slist0sep (s, t) -> check_gram entry t; check_gram entry s - | Slist1sep (s, t) -> check_gram entry t; check_gram entry s - | Slist0 s -> check_gram entry s - | Slist1 s -> check_gram entry s - | Sopt s -> check_gram entry s - | Stree t -> tree_check_gram entry t - | Snext | Sself | Stoken _ -> () -and tree_check_gram entry = - function - Node {node = n; brother = bro; son = son} -> - check_gram entry n; tree_check_gram entry bro; tree_check_gram entry son - | LocAct (_, _) | DeadEnd -> () -;; - -let change_to_self entry = - function - Snterm e when e == entry -> Sself - | x -> x -;; - -let get_initial entry = - function - Sself :: symbols -> true, symbols - | symbols -> false, symbols -;; - -let insert_tokens gram symbols = - let rec insert = - function - Smeta (_, sl, _) -> List.iter insert sl - | Slist0 s -> insert s - | Slist1 s -> insert s - | Slist0sep (s, t) -> insert s; insert t - | Slist1sep (s, t) -> insert s; insert t - | Sopt s -> insert s - | Stree t -> tinsert t - | Stoken ("ANY", _) -> () - | Stoken tok -> - gram.glexer.Token.tok_using tok; - let r = - try Hashtbl.find gram.gtokens tok with - Not_found -> let r = ref 0 in Hashtbl.add gram.gtokens tok r; r - in - incr r - | Snterm _ | Snterml (_, _) | Snext | Sself -> () - and tinsert = - function - Node {node = s; brother = bro; son = son} -> - insert s; tinsert bro; tinsert son - | LocAct (_, _) | DeadEnd -> () - in - List.iter insert symbols -;; - -let levels_of_rules entry position rules = - let elev = - match entry.edesc with - Dlevels elev -> elev - | Dparser _ -> - eprintf "Error: entry not extensible: \"%s\"\n" entry.ename; - flush 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 - List.iter (check_gram entry) symbols; - let (e1, symbols) = get_initial entry symbols in - insert_tokens entry.egram symbols; - insert_level entry.ename e1 symbols action lev) - lev level - in - lev :: levs, empty_lev) - ([], make_lev) rules - in - levs1 @ List.rev levs @ levs2 -;; - -let 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 -> eq_symbols s1 s2 - | Slist0sep (s1, sep1), Slist0sep (s2, sep2) -> - eq_symbols s1 s2 && eq_symbols sep1 sep2 - | Slist1 s1, Slist1 s2 -> eq_symbols s1 s2 - | Slist1sep (s1, sep1), Slist1sep (s2, sep2) -> - eq_symbols s1 s2 && eq_symbols sep1 sep2 - | Sopt s1, Sopt s2 -> eq_symbols s1 s2 - | Stree t1, Stree t2 -> eq_trees t1 t2 - | _ -> 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 -;; - -(* [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 *) - -let delete_rule_in_tree entry = - let rec delete_in_tree symbols tree = - match symbols, tree with - s :: sl, Node n -> - if logically_eq_symbols entry s n.node then delete_son sl n - else - begin match delete_in_tree symbols n.brother with - Some (dsl, t) -> - Some (dsl, Node {node = n.node; son = n.son; brother = t}) - | None -> None - end - | s :: sl, _ -> None - | [], Node n -> - begin match delete_in_tree [] n.brother with - Some (dsl, t) -> - Some (dsl, Node {node = n.node; son = n.son; brother = t}) - | None -> None - end - | [], 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 -;; - -let rec decr_keyw_use gram = - function - Stoken tok -> - let r = Hashtbl.find gram.gtokens tok in - decr r; - if !r == 0 then - begin - Hashtbl.remove gram.gtokens tok; gram.glexer.Token.tok_removing tok - end - | Smeta (_, sl, _) -> List.iter (decr_keyw_use gram) sl - | Slist0 s -> decr_keyw_use gram s - | Slist1 s -> decr_keyw_use gram s - | Slist0sep (s1, s2) -> decr_keyw_use gram s1; decr_keyw_use gram s2 - | Slist1sep (s1, s2) -> decr_keyw_use gram s1; decr_keyw_use gram s2 - | Sopt s -> decr_keyw_use gram s - | Stree t -> decr_keyw_use_in_tree gram t - | Sself | Snext | Snterm _ | Snterml (_, _) -> () -and decr_keyw_use_in_tree gram = - function - DeadEnd | LocAct (_, _) -> () - | Node n -> - decr_keyw_use gram n.node; - decr_keyw_use_in_tree gram n.son; - decr_keyw_use_in_tree gram n.brother -;; - -let rec delete_rule_in_suffix entry symbols = - function - lev :: levs -> - begin match delete_rule_in_tree entry symbols lev.lsuffix with - Some (dsl, t) -> - begin match dsl with - Some dsl -> List.iter (decr_keyw_use entry.egram) dsl - | None -> () - end; - begin 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 - end - | None -> - let levs = delete_rule_in_suffix entry symbols levs in lev :: levs - end - | [] -> raise Not_found -;; - -let rec delete_rule_in_prefix entry symbols = - function - lev :: levs -> - begin match delete_rule_in_tree entry symbols lev.lprefix with - Some (dsl, t) -> - begin match dsl with - Some dsl -> List.iter (decr_keyw_use entry.egram) dsl - | None -> () - end; - begin 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 - end - | None -> - let levs = delete_rule_in_prefix entry symbols levs in lev :: levs - end - | [] -> raise Not_found -;; - -let 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 -;; diff --git a/camlp4/ocaml_src/lib/gramext.mli b/camlp4/ocaml_src/lib/gramext.mli deleted file mode 100644 index bd275ae8..00000000 --- a/camlp4/ocaml_src/lib/gramext.mli +++ /dev/null @@ -1,79 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -type 'te grammar = - { gtokens : (Token.pattern, int ref) Hashtbl.t; - mutable glexer : 'te Token.glexer } -;; - -type 'te g_entry = - { egram : 'te grammar; - ename : string; - mutable estart : int -> 'te Stream.t -> Obj.t; - mutable econtinue : int -> int -> Obj.t -> 'te Stream.t -> Obj.t; - mutable edesc : 'te g_desc } -and 'te g_desc = - Dlevels of 'te g_level list - | Dparser of ('te Stream.t -> Obj.t) -and 'te g_level = - { assoc : g_assoc; - lname : string option; - lsuffix : 'te g_tree; - lprefix : 'te g_tree } -and g_assoc = - NonA - | RightA - | LeftA -and 'te g_symbol = - Smeta of string * 'te g_symbol list * Obj.t - | Snterm of 'te g_entry - | Snterml of 'te g_entry * string - | Slist0 of 'te g_symbol - | Slist0sep of 'te g_symbol * 'te g_symbol - | Slist1 of 'te g_symbol - | Slist1sep of 'te g_symbol * 'te g_symbol - | Sopt of 'te g_symbol - | Sself - | Snext - | Stoken of Token.pattern - | Stree of 'te g_tree -and g_action = Obj.t -and 'te g_tree = - Node of 'te g_node - | LocAct of g_action * g_action list - | DeadEnd -and 'te g_node = - { node : 'te g_symbol; son : 'te g_tree; brother : 'te g_tree } -;; - -type position = - First - | Last - | Before of string - | After of string - | Level of string -;; - -val levels_of_rules : - 'te g_entry -> position option -> - (string option * g_assoc option * ('te g_symbol list * g_action) list) - list -> - 'te g_level list;; -val srules : ('te g_symbol list * g_action) list -> 'te g_symbol;; -external action : 'a -> g_action = "%identity";; - -val delete_rule_in_level_list : - 'te g_entry -> 'te g_symbol list -> 'te g_level list -> 'te g_level list;; - -val warning_verbose : bool ref;; diff --git a/camlp4/ocaml_src/lib/grammar.ml b/camlp4/ocaml_src/lib/grammar.ml deleted file mode 100644 index ce03d404..00000000 --- a/camlp4/ocaml_src/lib/grammar.ml +++ /dev/null @@ -1,1143 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Stdpp;; -open Gramext;; -open Format;; - -let rec flatten_tree = - function - DeadEnd -> [] - | LocAct (_, _) -> [[]] - | Node {node = n; brother = b; son = s} -> - List.map (fun l -> n :: l) (flatten_tree s) @ flatten_tree b -;; - -let print_str ppf s = fprintf ppf "\"%s\"" (String.escaped s);; - -let rec print_symbol ppf = - function - 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 - | Stoken (con, prm) when con <> "" && prm <> "" -> - fprintf ppf "%s@ %a" con print_str prm - | Snterml (e, l) -> fprintf ppf "%s@ LEVEL@ %a" e.ename print_str l - | Snterm _ | Snext | Sself | Stoken _ | Stree _ as s -> print_symbol1 ppf s -and print_meta ppf n sl = - let rec loop i = - function - [] -> () - | s :: sl -> - let j = - try String.index_from n i ' ' with - Not_found -> String.length n - in - fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s; - if sl = [] then () - else - begin fprintf ppf " "; loop (min (j + 1) (String.length n)) sl end - in - loop 0 sl -and print_symbol1 ppf = - function - Snterm e -> pp_print_string ppf e.ename - | Sself -> pp_print_string ppf "SELF" - | Snext -> pp_print_string ppf "NEXT" - | Stoken ("", s) -> print_str ppf s - | Stoken (con, "") -> pp_print_string ppf con - | Stree t -> print_level ppf pp_print_space (flatten_tree t) - | Smeta (_, _, _) | Snterml (_, _) | Slist0 _ | Slist0sep (_, _) | - Slist1 _ | Slist1sep (_, _) | Sopt _ | Stoken _ as s -> - fprintf ppf "(%a)" print_symbol s -and print_rule ppf symbols = - fprintf ppf "@["; - let _ = - List.fold_left - (fun sep symbol -> - fprintf ppf "%t%a" sep print_symbol symbol; - fun ppf -> fprintf ppf ";@ ") - (fun ppf -> ()) symbols - in - fprintf ppf "@]" -and print_level ppf pp_print_space rules = - fprintf ppf "@[[ "; - let _ = - List.fold_left - (fun sep rule -> - fprintf ppf "%t%a" sep print_rule rule; - fun ppf -> fprintf ppf "%a| " pp_print_space ()) - (fun ppf -> ()) rules - in - fprintf ppf " ]@]" -;; - -let print_levels ppf elev = - let _ = - List.fold_left - (fun sep lev -> - let rules = - List.map (fun t -> Sself :: t) (flatten_tree lev.lsuffix) @ - flatten_tree lev.lprefix - in - fprintf ppf "%t@[" sep; - begin match lev.lname with - Some n -> fprintf ppf "%a@;<1 2>" print_str n - | None -> () - end; - begin match lev.assoc with - LeftA -> fprintf ppf "LEFTA" - | RightA -> fprintf ppf "RIGHTA" - | NonA -> fprintf ppf "NONA" - end; - fprintf ppf "@]@;<1 2>"; - print_level ppf pp_force_newline rules; - fun ppf -> fprintf ppf "@,| ") - (fun ppf -> ()) elev - in - () -;; - -let print_entry ppf e = - fprintf ppf "@[[ "; - begin match e.edesc with - Dlevels elev -> print_levels ppf elev - | Dparser _ -> fprintf ppf "" - end; - fprintf ppf " ]@]" -;; - -let iter_entry f e = - let treated = ref [] in - let rec do_entry e = - if List.memq e !treated then () - else - begin - treated := e :: !treated; - f e; - match e.edesc with - Dlevels ll -> List.iter do_level ll - | Dparser _ -> () - end - and do_level lev = do_tree lev.lsuffix; do_tree lev.lprefix - and do_tree = - function - Node n -> do_node n - | LocAct (_, _) | DeadEnd -> () - and do_node n = do_symbol n.node; do_tree n.son; do_tree n.brother - and do_symbol = - function - Smeta (_, sl, _) -> List.iter do_symbol sl - | Snterm e | Snterml (e, _) -> do_entry e - | Slist0 s | Slist1 s | Sopt s -> do_symbol s - | Slist0sep (s1, s2) | Slist1sep (s1, s2) -> do_symbol s1; do_symbol s2 - | Stree t -> do_tree t - | Sself | Snext | Stoken _ -> () - in - do_entry e -;; - -let fold_entry f e init = - let treated = ref [] in - let rec do_entry accu e = - if List.memq e !treated then accu - else - begin - treated := e :: !treated; - let accu = f e accu in - match e.edesc with - Dlevels ll -> List.fold_left do_level accu ll - | Dparser _ -> accu - end - and do_level accu lev = - let accu = do_tree accu lev.lsuffix in do_tree accu lev.lprefix - and do_tree accu = - function - 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 = - function - Smeta (_, sl, _) -> List.fold_left do_symbol accu sl - | Snterm e | Snterml (e, _) -> do_entry accu e - | Slist0 s | Slist1 s | Sopt 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 _ -> accu - in - do_entry init e -;; - -type g = Token.t Gramext.grammar;; - -external grammar_obj : g -> Token.t grammar = "%identity";; - -let floc = ref (fun _ -> failwith "internal error when computing location");; -let loc_of_token_interval bp ep = - if bp == ep then - if bp == 0 then Token.nowhere, Token.succ_pos Token.nowhere - else let a = snd (!floc (bp - 1)) in a, Token.succ_pos a - else - let (bp1, bp2) = !floc bp in - let (ep1, ep2) = !floc (pred ep) in - (if Token.lt_pos bp1 ep1 then bp1 else ep1), - (if Token.lt_pos ep2 bp2 then bp2 else ep2) -;; - -let rec name_of_symbol entry = - function - Snterm e -> "[" ^ e.ename ^ "]" - | Snterml (e, l) -> "[" ^ e.ename ^ " level " ^ l ^ "]" - | Sself | Snext -> "[" ^ entry.ename ^ "]" - | Stoken tok -> entry.egram.glexer.Token.tok_text tok - | _ -> "???" -;; - -let rec get_token_list entry tokl last_tok tree = - match tree with - Node {node = Stoken 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) -;; - -let rec name_of_symbol_failed entry = - function - Slist0 s -> name_of_symbol_failed entry s - | Slist0sep (s, _) -> name_of_symbol_failed entry s - | Slist1 s -> name_of_symbol_failed entry s - | Slist1sep (s, _) -> name_of_symbol_failed entry s - | Sopt 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 = - function - Node {node = s; brother = bro; son = son} -> - let tokl = - match s with - Stoken tok -> get_token_list entry [] tok son - | _ -> None - in - begin 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, last_tok, son) -> - List.fold_left - (fun s tok -> - (if s = "" then "" else s ^ " ") ^ - entry.egram.glexer.Token.tok_text tok) - "" tokl - end - | DeadEnd | LocAct (_, _) -> "???" -;; - -let search_tree_in_entry prev_symb tree = - function - Dlevels levels -> - let rec search_levels = - function - [] -> 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 -> - begin 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 - end - | LocAct (_, _) | DeadEnd -> None - and search_symbol symb = - match symb with - Snterm _ | Snterml (_, _) | Slist0 _ | Slist0sep (_, _) | Slist1 _ | - Slist1sep (_, _) | Sopt _ | Stoken _ | Stree _ - when symb == prev_symb -> - Some symb - | Slist0 symb -> - begin match search_symbol symb with - Some symb -> Some (Slist0 symb) - | None -> None - end - | Slist0sep (symb, sep) -> - begin 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 - end - | Slist1 symb -> - begin match search_symbol symb with - Some symb -> Some (Slist1 symb) - | None -> None - end - | Slist1sep (symb, sep) -> - begin 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 - end - | Sopt symb -> - begin match search_symbol symb with - Some symb -> Some (Sopt symb) - | None -> None - end - | Stree t -> - begin match search_tree t with - Some t -> Some (Stree t) - | None -> None - end - | _ -> None - in - search_levels levels - | Dparser _ -> tree -;; - -let error_verbose = ref false;; - -let 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) -> - begin match Obj.magic 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" - end - | Slist1sep (s, sep) -> - begin match Obj.magic 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" - end - | Sopt _ | Stree _ -> txt ^ " expected" - | _ -> txt ^ " expected after " ^ name_of_symbol entry prev_symb - in - if !error_verbose then - begin - let tree = search_tree_in_entry prev_symb tree entry.edesc in - let ppf = err_formatter in - fprintf ppf "@[@,"; - fprintf ppf "----------------------------------@,"; - fprintf ppf "Parse error in entry [%s], rule:@;<0 2>" entry.ename; - fprintf ppf "@["; - print_level ppf pp_force_newline (flatten_tree tree); - fprintf ppf "@]@,"; - fprintf ppf "----------------------------------@,"; - fprintf ppf "@]@." - end; - txt ^ " (in [" ^ entry.ename ^ "])" -;; - -let 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 -;; - -external app : Obj.t -> 'a = "%identity";; - -let is_level_labelled n lev = - match lev.lname with - Some n1 -> n = n1 - | None -> false -;; - -let level_number entry lab = - let rec lookup levn = - function - [] -> failwith ("unknown level " ^ lab) - | lev :: levs -> - if 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 -;; - -let rec top_symb entry = - function - Sself | Snext -> Snterm entry - | Snterml (e, _) -> Snterm e - | Slist1sep (s, sep) -> Slist1sep (top_symb entry s, sep) - | _ -> raise Stream.Failure -;; - -let entry_of_symb entry = - function - Sself | Snext -> entry - | Snterm e -> e - | Snterml (e, _) -> e - | _ -> raise Stream.Failure -;; - -let top_tree entry = - function - Node {node = s; brother = bro; son = son} -> - Node {node = top_symb entry s; brother = bro; son = son} - | LocAct (_, _) | DeadEnd -> raise Stream.Failure -;; - -let skip_if_empty bp p strm = - if Stream.count strm == bp then Gramext.action (fun a -> p strm) - else raise Stream.Failure -;; - -let continue entry bp a s son p1 (strm__ : _ Stream.t) = - let a = (entry_of_symb entry s).econtinue 0 bp a strm__ in - let act = - try p1 strm__ with - Stream.Failure -> raise (Stream.Error (tree_failed entry a s son)) - in - Gramext.action (fun _ -> app act a) -;; - -let do_recover - parser_of_tree entry nlevn alevn bp a s son (strm__ : _ Stream.t) = - try parser_of_tree entry nlevn alevn (top_tree entry son) strm__ with - Stream.Failure -> - try - skip_if_empty bp (fun (strm__ : _ Stream.t) -> raise Stream.Failure) - strm__ - with - Stream.Failure -> - continue entry bp a s son (parser_of_tree entry nlevn alevn son) - strm__ -;; - -let strict_parsing = ref false;; -let strict_parsing_warning = ref false;; - -let recover parser_of_tree entry nlevn alevn bp a s son strm = - if !strict_parsing then raise (Stream.Error (tree_failed entry a s son)) - else - let _ = - if !strict_parsing_warning then - let msg = tree_failed entry a s son in - begin try - let (_, bp2) = !floc bp in - let c = bp2.Lexing.pos_cnum - bp2.Lexing.pos_bol in - match bp2.Lexing.pos_fname <> "", c > 0 with - true, true -> - Printf.eprintf "File \"%s\", line %d, character %d:\n" - bp2.Lexing.pos_fname bp2.Lexing.pos_lnum c - | false, true -> Printf.eprintf "Character %d:\n" c - | _ -> () - with - _ -> () - end; - Printf.eprintf "Warning: trying to recover from syntax error"; - if entry.ename <> "" then Printf.eprintf " in [%s]\n" entry.ename - else Printf.eprintf "\n"; - Printf.eprintf "%s\n%!" msg - in - do_recover parser_of_tree entry nlevn alevn bp a s son strm -;; - -let token_count = ref 0;; - -let peek_nth n strm = - let list = Stream.npeek n strm in - token_count := Stream.count strm + n; - let rec loop list n = - match list, n with - x :: _, 1 -> Some x - | _ :: l, n -> loop l (n - 1) - | [], _ -> None - in - loop list n -;; - -let rec parser_of_tree entry nlevn alevn = - function - DeadEnd -> (fun (strm__ : _ Stream.t) -> raise Stream.Failure) - | LocAct (act, _) -> (fun (strm__ : _ Stream.t) -> act) - | Node {node = Sself; son = LocAct (act, _); brother = DeadEnd} -> - (fun (strm__ : _ Stream.t) -> - let a = entry.estart alevn strm__ in app act a) - | Node {node = Sself; son = LocAct (act, _); brother = bro} -> - let p2 = parser_of_tree entry nlevn alevn bro in - (fun (strm__ : _ Stream.t) -> - match - try Some (entry.estart alevn strm__) with - Stream.Failure -> None - with - Some a -> app act a - | _ -> p2 strm__) - | Node {node = s; son = son; brother = DeadEnd} -> - let tokl = - match s with - Stoken tok -> get_token_list entry [] tok son - | _ -> None - in - begin 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__ : _ Stream.t) -> - let bp = Stream.count strm__ in - let a = ps strm__ in - let act = - try p1 bp a strm__ with - Stream.Failure -> raise (Stream.Error "") - in - app 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 (Stoken last_tok) son in - parser_of_token_list entry.egram p1 tokl - end - | Node {node = s; son = son; brother = bro} -> - let tokl = - match s with - Stoken tok -> get_token_list entry [] tok 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__ : _ Stream.t) -> - let bp = Stream.count strm__ in - match - try Some (ps strm__) with - Stream.Failure -> None - with - Some a -> - let act = - try p1 bp a strm__ with - Stream.Failure -> raise (Stream.Error "") - in - app act a - | _ -> p2 strm__) - | Some (tokl, last_tok, son) -> - let p1 = parser_of_tree entry nlevn alevn son in - let p1 = parser_cont p1 entry nlevn alevn (Stoken last_tok) son in - let p1 = parser_of_token_list entry.egram p1 tokl in - let p2 = parser_of_tree entry nlevn alevn bro in - fun (strm__ : _ Stream.t) -> - try p1 strm__ with - Stream.Failure -> p2 strm__ -and parser_cont p1 entry nlevn alevn s son bp a (strm__ : _ Stream.t) = - try p1 strm__ with - Stream.Failure -> - try recover parser_of_tree entry nlevn alevn bp a s son strm__ with - Stream.Failure -> raise (Stream.Error (tree_failed entry a s son)) -and parser_of_token_list gram p1 tokl = - let rec loop n = - function - tok :: tokl -> - let tematch = gram.glexer.Token.tok_match tok in - begin match tokl with - [] -> - let ps strm = - match peek_nth n strm with - Some tok -> - let r = tematch tok in - for i = 1 to n do Stream.junk strm done; Obj.repr r - | None -> raise Stream.Failure - in - (fun (strm__ : _ Stream.t) -> - let bp = Stream.count strm__ in - let a = ps strm__ in - let act = - try p1 bp a strm__ with - Stream.Failure -> raise (Stream.Error "") - in - app act a) - | _ -> - let ps strm = - match peek_nth n strm with - Some tok -> tematch tok - | None -> raise Stream.Failure - in - let p1 = loop (n + 1) tokl in - fun (strm__ : _ Stream.t) -> - let a = ps strm__ in let act = p1 strm__ in app act a - end - | [] -> invalid_arg "parser_of_token_list" - in - loop 1 tokl -and parser_of_symbol entry nlevn = - function - Smeta (_, symbl, act) -> - let act = Obj.magic act entry symbl in - Obj.magic - (List.fold_left - (fun act symb -> Obj.magic act (parser_of_symbol entry nlevn symb)) - act symbl) - | Slist0 s -> - let ps = parser_of_symbol entry nlevn s in - let rec loop al (strm__ : _ Stream.t) = - match - try Some (ps strm__) with - Stream.Failure -> None - with - Some a -> loop (a :: al) strm__ - | _ -> al - in - (fun (strm__ : _ Stream.t) -> - let a = loop [] strm__ in Obj.repr (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 (strm__ : _ Stream.t) = - match - try Some (pt strm__) with - Stream.Failure -> None - with - Some v -> - let a = - try ps strm__ with - Stream.Failure -> - raise (Stream.Error (symb_failed entry v sep symb)) - in - kont (a :: al) strm__ - | _ -> al - in - (fun (strm__ : _ Stream.t) -> - match - try Some (ps strm__) with - Stream.Failure -> None - with - Some a -> Obj.repr (List.rev (kont [a] strm__)) - | _ -> Obj.repr []) - | Slist1 s -> - let ps = parser_of_symbol entry nlevn s in - let rec loop al (strm__ : _ Stream.t) = - match - try Some (ps strm__) with - Stream.Failure -> None - with - Some a -> loop (a :: al) strm__ - | _ -> al - in - (fun (strm__ : _ Stream.t) -> - let a = ps strm__ in Obj.repr (List.rev (loop [a] strm__))) - | 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 (strm__ : _ Stream.t) = - match - try Some (pt strm__) with - Stream.Failure -> None - with - Some v -> - let a = - try ps strm__ with - Stream.Failure -> - try parse_top_symb entry symb strm__ with - Stream.Failure -> - raise (Stream.Error (symb_failed entry v sep symb)) - in - kont (a :: al) strm__ - | _ -> al - in - (fun (strm__ : _ Stream.t) -> - let a = ps strm__ in Obj.repr (List.rev (kont [a] strm__))) - | Sopt s -> - let ps = parser_of_symbol entry nlevn s in - (fun (strm__ : _ Stream.t) -> - match - try Some (ps strm__) with - Stream.Failure -> None - with - Some a -> Obj.repr (Some a) - | _ -> Obj.repr None) - | Stree t -> - let pt = parser_of_tree entry 1 0 t in - (fun (strm__ : _ Stream.t) -> - let bp = Stream.count strm__ in - let a = pt strm__ in - let ep = Stream.count strm__ in - let loc = loc_of_token_interval bp ep in app a loc) - | Snterm e -> (fun (strm__ : _ Stream.t) -> e.estart 0 strm__) - | Snterml (e, l) -> - (fun (strm__ : _ Stream.t) -> e.estart (level_number e l) strm__) - | Sself -> (fun (strm__ : _ Stream.t) -> entry.estart 0 strm__) - | Snext -> (fun (strm__ : _ Stream.t) -> entry.estart nlevn strm__) - | Stoken tok -> - let f = entry.egram.glexer.Token.tok_match tok in - fun strm -> - match Stream.peek strm with - Some tok -> let r = f tok in Stream.junk strm; Obj.repr r - | None -> raise Stream.Failure -and parse_top_symb entry symb = - parser_of_symbol entry 0 (top_symb entry symb) -;; - -let symb_failed_txt e s1 s2 = symb_failed e 0 s1 s2;; - -let rec continue_parser_of_levels entry clevn = - function - [] -> (fun levn bp a (strm__ : _ Stream.t) -> raise Stream.Failure) - | 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 - let (strm__ : _ Stream.t) = strm in - try p1 levn bp a strm__ with - Stream.Failure -> - let act = p2 strm__ in - let ep = Stream.count strm__ in - let a = app act a (loc_of_token_interval bp ep) in - entry.econtinue levn bp a strm -;; - -let rec start_parser_of_levels entry clevn = - function - [] -> (fun levn (strm__ : _ Stream.t) -> raise Stream.Failure) - | 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 (strm__ : _ Stream.t) = strm in - let bp = Stream.count strm__ in - let act = p2 strm__ in - let ep = Stream.count strm__ in - let a = app act (loc_of_token_interval bp ep) in - entry.econtinue levn bp a strm) - | _ -> - fun levn strm -> - if levn > clevn then p1 levn strm - else - let (strm__ : _ Stream.t) = strm in - let bp = Stream.count strm__ in - match - try Some (p2 strm__) with - Stream.Failure -> None - with - Some act -> - let ep = Stream.count strm__ in - let a = app act (loc_of_token_interval bp ep) in - entry.econtinue levn bp a strm - | _ -> p1 levn strm__ -;; - -let continue_parser_of_entry entry = - match entry.edesc with - Dlevels elev -> - let p = continue_parser_of_levels entry 0 elev in - (fun levn bp a (strm__ : _ Stream.t) -> - try p levn bp a strm__ with - Stream.Failure -> a) - | Dparser p -> fun levn bp a (strm__ : _ Stream.t) -> raise Stream.Failure -;; - -let empty_entry ename levn strm = - raise (Stream.Error ("entry [" ^ ename ^ "] is empty")) -;; - -let start_parser_of_entry entry = - match entry.edesc with - Dlevels [] -> empty_entry entry.ename - | Dlevels elev -> start_parser_of_levels entry 0 elev - | Dparser p -> fun levn strm -> p strm -;; - -let parse_parsable entry efun (cs, (ts, fun_loc)) = - let restore = - let old_floc = !floc in - let old_tc = !token_count in - fun () -> floc := old_floc; token_count := old_tc - in - let get_loc () = - try - let cnt = Stream.count ts in - let loc = fun_loc cnt in - if !token_count - 1 <= cnt then loc - else fst loc, snd (fun_loc (!token_count - 1)) - with - _ -> Token.nowhere, Token.succ_pos Token.nowhere - in - floc := fun_loc; - token_count := 0; - try let r = efun ts in restore (); r with - Stream.Failure -> - let loc = get_loc () in - restore (); - raise_with_loc loc (Stream.Error ("illegal begin of " ^ entry.ename)) - | Stream.Error _ as exc -> - let loc = get_loc () in restore (); raise_with_loc loc exc - | exc -> - let loc = Token.nowhere, Token.succ_pos Token.nowhere in - restore (); raise_with_loc loc exc -;; - -let wrap_parse entry efun cs = - let parsable = cs, entry.egram.glexer.Token.tok_func cs in - parse_parsable entry efun parsable -;; - -let create_toktab () = Hashtbl.create 301;; -let gcreate glexer = {gtokens = create_toktab (); glexer = glexer};; - -let tematch tparse tok = - match tparse tok with - Some p -> (fun x -> p (Stream.ising x)) - | None -> Token.default_match tok -;; -let glexer_of_lexer lexer = - {Token.tok_func = lexer.Token.func; Token.tok_using = lexer.Token.using; - Token.tok_removing = lexer.Token.removing; - Token.tok_match = tematch lexer.Token.tparse; - Token.tok_text = lexer.Token.text; Token.tok_comm = None} -;; -let create lexer = gcreate (glexer_of_lexer lexer);; - -(* Extend syntax *) - -let extend_entry entry position rules = - try - let elev = Gramext.levels_of_rules entry position rules in - entry.edesc <- Dlevels elev; - entry.estart <- - (fun lev strm -> - let f = start_parser_of_entry entry in - entry.estart <- f; f lev strm); - entry.econtinue <- - fun lev bp a strm -> - let f = continue_parser_of_entry entry in - entry.econtinue <- f; f lev bp a strm - with - Token.Error s -> - Printf.eprintf "Lexer initialization error:\n- %s\n" s; - flush stderr; - failwith "Grammar.extend" -;; - -let extend entry_rules_list = - let gram = ref None in - List.iter - (fun (entry, position, rules) -> - begin match !gram with - Some g -> - if g != entry.egram then - begin - Printf.eprintf "Error: entries with different grammars\n"; - flush stderr; - failwith "Grammar.extend" - end - | None -> gram := Some entry.egram - end; - extend_entry entry position rules) - entry_rules_list -;; - -(* Deleting a rule *) - -let delete_rule entry sl = - match entry.edesc with - Dlevels levs -> - let levs = Gramext.delete_rule_in_level_list entry sl levs in - entry.edesc <- Dlevels levs; - entry.estart <- - (fun lev strm -> - let f = start_parser_of_entry entry in - entry.estart <- f; f lev strm); - entry.econtinue <- - (fun lev bp a strm -> - let f = continue_parser_of_entry entry in - entry.econtinue <- f; f lev bp a strm) - | Dparser _ -> () -;; - -(* Unsafe *) - -let clear_entry e = - e.estart <- (fun _ (strm__ : _ Stream.t) -> raise Stream.Failure); - e.econtinue <- (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); - match e.edesc with - Dlevels _ -> e.edesc <- Dlevels [] - | Dparser _ -> () -;; - -let gram_reinit g glexer = Hashtbl.clear g.gtokens; g.glexer <- glexer;; - -let reinit_gram g lexer = gram_reinit g (glexer_of_lexer lexer);; - -module Unsafe = - struct - let gram_reinit = gram_reinit;; - let clear_entry = clear_entry;; - let reinit_gram = reinit_gram;; - end -;; - -let find_entry e s = - let rec find_levels = - function - [] -> None - | lev :: levs -> - match find_tree lev.lsuffix with - None -> - begin match find_tree lev.lprefix with - None -> find_levels levs - | x -> x - end - | x -> x - and find_symbol = - function - 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 _ -> None - and find_symbol_list = - function - s :: sl -> - begin match find_symbol s with - None -> find_symbol_list sl - | x -> x - end - | [] -> None - and find_tree = - function - Node {node = s; brother = bro; son = son} -> - begin match find_symbol s with - None -> - begin match find_tree bro with - None -> find_tree son - | x -> x - end - | x -> x - end - | LocAct (_, _) | DeadEnd -> None - in - match e.edesc with - Dlevels levs -> - begin match find_levels levs with - Some e -> e - | None -> raise Not_found - end - | Dparser _ -> raise Not_found -;; - -let of_entry e = e.egram;; - -module Entry = - struct - type te = Token.t;; - type 'a e = te g_entry;; - let create g n = - {egram = g; ename = n; estart = empty_entry n; - econtinue = (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); - edesc = Dlevels []} - ;; - let parse (entry : 'a e) cs : 'a = - Obj.magic (wrap_parse entry (entry.estart 0) cs) - ;; - let parse_token (entry : 'a e) ts : 'a = Obj.magic (entry.estart 0 ts);; - let name e = e.ename;; - let of_parser g n (p : te Stream.t -> 'a) : 'a e = - {egram = g; ename = n; estart = (fun _ -> Obj.magic p); - econtinue = (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); - edesc = Dparser (Obj.magic p)} - ;; - external obj : 'a e -> te Gramext.g_entry = "%identity";; - let print e = printf "%a@." print_entry (obj e);; - let find e s = find_entry (obj e) s;; - end -;; - -let tokens g con = - let list = ref [] in - Hashtbl.iter - (fun (p_con, p_prm) c -> if p_con = con then list := (p_prm, !c) :: !list) - g.gtokens; - !list -;; - -let glexer g = g.glexer;; - -let warning_verbose = Gramext.warning_verbose;; - -(* Functorial interface *) - -module type GLexerType = sig type te;; val lexer : te Token.glexer;; end;; - -module type S = - sig - type te;; - type parsable;; - val parsable : char Stream.t -> parsable;; - val tokens : string -> (string * int) list;; - val glexer : te Token.glexer;; - module Entry : - sig - type 'a e;; - val create : string -> 'a e;; - val parse : 'a e -> parsable -> 'a;; - val parse_token : 'a e -> te Stream.t -> 'a;; - val name : 'a e -> string;; - val of_parser : string -> (te Stream.t -> 'a) -> 'a e;; - val print : 'a e -> unit;; - external obj : 'a e -> te Gramext.g_entry = "%identity";; - end - ;; - module Unsafe : - sig - val gram_reinit : te Token.glexer -> unit;; - val clear_entry : 'a Entry.e -> unit;; - val reinit_gram : Token.lexer -> unit;; - end - ;; - val extend : - 'a Entry.e -> Gramext.position option -> - (string option * Gramext.g_assoc option * - (te Gramext.g_symbol list * Gramext.g_action) list) - list -> - unit;; - val delete_rule : 'a Entry.e -> te Gramext.g_symbol list -> unit;; - end -;; - -module type ReinitType = sig val reinit_gram : g -> Token.lexer -> unit;; end -;; - -module GGMake (R : ReinitType) (L : GLexerType) = - struct - type te = L.te;; - type parsable = char Stream.t * (te Stream.t * Token.flocation_function);; - let gram = gcreate L.lexer;; - let parsable cs = cs, L.lexer.Token.tok_func cs;; - let tokens = tokens gram;; - let glexer = glexer gram;; - module Entry = - struct - type 'a e = te g_entry;; - let create n = - {egram = gram; ename = n; estart = empty_entry n; - econtinue = - (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); - edesc = Dlevels []} - ;; - external obj : 'a e -> te Gramext.g_entry = "%identity";; - let parse (e : 'a e) p : 'a = - Obj.magic (parse_parsable e (e.estart 0) p) - ;; - let parse_token (e : 'a e) ts : 'a = Obj.magic (e.estart 0 ts);; - let name e = e.ename;; - let of_parser n (p : te Stream.t -> 'a) : 'a e = - {egram = gram; ename = n; estart = (fun _ -> Obj.magic p); - econtinue = - (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); - edesc = Dparser (Obj.magic p)} - ;; - let print e = printf "%a@." print_entry (obj e);; - end - ;; - module Unsafe = - struct - let gram_reinit = gram_reinit gram;; - let clear_entry = Unsafe.clear_entry;; - let reinit_gram = R.reinit_gram (Obj.magic gram);; - end - ;; - let extend = extend_entry;; - let delete_rule e r = delete_rule (Entry.obj e) r;; - end -;; - -module GMake (L : GLexerType) = - GGMake - (struct - let reinit_gram _ _ = - failwith "call of deprecated reinit_gram in grammar built by GMake" - ;; - end) - (L) -;; - -module type LexerType = sig val lexer : Token.lexer;; end;; - -module Make (L : LexerType) = - GGMake (struct let reinit_gram = reinit_gram;; end) - (struct type te = Token.t;; let lexer = glexer_of_lexer L.lexer;; end) -;; diff --git a/camlp4/ocaml_src/lib/grammar.mli b/camlp4/ocaml_src/lib/grammar.mli deleted file mode 100644 index becf81a0..00000000 --- a/camlp4/ocaml_src/lib/grammar.mli +++ /dev/null @@ -1,204 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(** Extensible grammars. - - This module implements the Camlp4 extensible grammars system. - Grammars entries can be extended using the [EXTEND] statement, - added by loading the Camlp4 [pa_extend.cmo] file. *) - -type g;; - (** The type for grammars, holding entries. *) -val gcreate : Token.t Token.glexer -> g;; - (** Create a new grammar, without keywords, using the lexer given - as parameter. *) -val tokens : g -> string -> (string * int) list;; - (** Given a grammar and a token pattern constructor, returns the list of - the corresponding values currently used in all entries of this grammar. - The integer is the number of times this pattern value is used. - - Examples: -- If the associated lexer uses ("", xxx) to represent a keyword - (what is represented by then simple string xxx in an [EXTEND] - statement rule), the call [Grammar.token g ""] returns the keywords - list. -- The call [Grammar.token g "IDENT"] returns the list of all usages - of the pattern "IDENT" in the [EXTEND] statements. *) -val glexer : g -> Token.t Token.glexer;; - (** Return the lexer used by the grammar *) - -module Entry : - sig - type 'a e;; - val create : g -> string -> 'a e;; - val parse : 'a e -> char Stream.t -> 'a;; - val parse_token : 'a e -> Token.t Stream.t -> 'a;; - val name : 'a e -> string;; - val of_parser : g -> string -> (Token.t Stream.t -> 'a) -> 'a e;; - val print : 'a e -> unit;; - val find : 'a e -> string -> Obj.t e;; - external obj : 'a e -> Token.t Gramext.g_entry = "%identity";; - end -;; - (** Module to handle entries. -- [Entry.e] is the type for entries returning values of type ['a]. -- [Entry.create g n] creates a new entry named [n] in the grammar [g]. -- [Entry.parse e] returns the stream parser of the entry [e]. -- [Entry.parse_token e] returns the token parser of the entry [e]. -- [Entry.name e] returns the name of the entry [e]. -- [Entry.of_parser g n p] makes an entry from a token stream parser. -- [Entry.print e] displays the entry [e] using [Format]. -- [Entry.find e s] finds the entry named [s] in [e]'s rules. -- [Entry.obj e] converts an entry into a [Gramext.g_entry] allowing -- to see what it holds ([Gramext] is visible, but not documented). *) - -val of_entry : 'a Entry.e -> g;; - (** Return the grammar associated with an entry. *) - -(** {6 Clearing grammars and entries} *) - -module Unsafe : - sig - val gram_reinit : g -> Token.t Token.glexer -> unit;; - val clear_entry : 'a Entry.e -> unit;; - val reinit_gram : g -> Token.lexer -> unit;; - end -;; - (** Module for clearing grammars and entries. To be manipulated with - care, because: 1) reinitializing a grammar destroys all tokens - and there may have problems with the associated lexer if it has - a notion of keywords; 2) clearing an entry does not destroy the - tokens used only by itself. -- [Unsafe.reinit_gram g lex] removes the tokens of the grammar -- and sets [lex] as a new lexer for [g]. Warning: the lexer -- itself is not reinitialized. -- [Unsafe.clear_entry e] removes all rules of the entry [e]. *) - -(** {6 Functorial interface} *) - - (** Alternative for grammars use. Grammars are no more Ocaml values: - there is no type for them. Modules generated preserve the - rule "an entry cannot call an entry of another grammar" by - normal OCaml typing. *) - -module type GLexerType = sig type te;; val lexer : te Token.glexer;; end;; - (** The input signature for the functor [Grammar.GMake]: [te] is the - type of the tokens. *) - -module type S = - sig - type te;; - type parsable;; - val parsable : char Stream.t -> parsable;; - val tokens : string -> (string * int) list;; - val glexer : te Token.glexer;; - module Entry : - sig - type 'a e;; - val create : string -> 'a e;; - val parse : 'a e -> parsable -> 'a;; - val parse_token : 'a e -> te Stream.t -> 'a;; - val name : 'a e -> string;; - val of_parser : string -> (te Stream.t -> 'a) -> 'a e;; - val print : 'a e -> unit;; - external obj : 'a e -> te Gramext.g_entry = "%identity";; - end - ;; - module Unsafe : - sig - val gram_reinit : te Token.glexer -> unit;; - val clear_entry : 'a Entry.e -> unit;; - val reinit_gram : Token.lexer -> unit;; - end - ;; - val extend : - 'a Entry.e -> Gramext.position option -> - (string option * Gramext.g_assoc option * - (te Gramext.g_symbol list * Gramext.g_action) list) - list -> - unit;; - val delete_rule : 'a Entry.e -> te Gramext.g_symbol list -> unit;; - end -;; - (** Signature type of the functor [Grammar.GMake]. The types and - functions are almost the same than in generic interface, but: -- Grammars are not values. Functions holding a grammar as parameter - do not have this parameter yet. -- The type [parsable] is used in function [parse] instead of - the char stream, avoiding the possible loss of tokens. -- The type of tokens (expressions and patterns) can be any - type (instead of (string * string)); the module parameter - must specify a way to show them as (string * string) *) - -module GMake (L : GLexerType) : S with type te = L.te;; - -(** {6 Miscellaneous} *) - -val error_verbose : bool ref;; - (** Flag for displaying more information in case of parsing error; - default = [False] *) - -val warning_verbose : bool ref;; - (** Flag for displaying warnings while extension; default = [True] *) - -val strict_parsing : bool ref;; - (** Flag to apply strict parsing, without trying to recover errors; - default = [False] *) - -val strict_parsing_warning : bool ref;; - (** Flag for displaying a warning when entering recovery mode; - default = [False] *) - -val print_entry : Format.formatter -> 'te Gramext.g_entry -> unit;; - (** General printer for all kinds of entries (obj entries) *) - -val iter_entry : - ('te Gramext.g_entry -> unit) -> 'te Gramext.g_entry -> unit;; - (** [Grammar.iter_entry f e] applies [f] to the entry [e] and - transitively all entries called by [e]. The order in which - the entries are passed to [f] is the order they appear in - each entry. Each entry is passed only once. *) - -val fold_entry : - ('te Gramext.g_entry -> 'a -> 'a) -> 'te Gramext.g_entry -> 'a -> 'a;; - (** [Grammar.fold_entry f e init] computes [(f eN .. (f e2 (f e1 init)))], - where [e1 .. eN] are [e] and transitively all entries called by [e]. - The order in which the entries are passed to [f] is the order they - appear in each entry. Each entry is passed only once. *) - -(**/**) - -(*** deprecated since version 3.05; use rather the functor GMake *) -module type LexerType = sig val lexer : Token.lexer;; end;; -module Make (L : LexerType) : S with type te = Token.t;; -(*** deprecated since version 3.05; use rather the function gcreate *) -val create : Token.lexer -> g;; - -(*** For system use *) - -val loc_of_token_interval : int -> int -> Token.flocation;; -val extend : - ('te Gramext.g_entry * Gramext.position option * - (string option * Gramext.g_assoc option * - ('te Gramext.g_symbol list * Gramext.g_action) list) - list) - list -> - unit;; -val delete_rule : 'a Entry.e -> Token.t Gramext.g_symbol list -> unit;; - -val parse_top_symb : - 'te Gramext.g_entry -> 'te Gramext.g_symbol -> 'te Stream.t -> Obj.t;; -val symb_failed_txt : - 'te Gramext.g_entry -> 'te Gramext.g_symbol -> 'te Gramext.g_symbol -> - string;; diff --git a/camlp4/ocaml_src/lib/plexer.ml b/camlp4/ocaml_src/lib/plexer.ml deleted file mode 100644 index 81018704..00000000 --- a/camlp4/ocaml_src/lib/plexer.ml +++ /dev/null @@ -1,1137 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Stdpp;; -open Token;; - -let no_quotations = ref false;; - -(* The string buffering machinery *) - -let buff = ref (String.create 80);; -let store len x = - if len >= String.length !buff then - buff := !buff ^ String.create (String.length !buff); - !buff.[len] <- x; - succ len -;; -let mstore len s = - let rec add_rec len i = - if i == String.length s then len else add_rec (store len s.[i]) (succ i) - in - add_rec len 0 -;; -let get_buff len = String.sub !buff 0 len;; - -(* The lexer *) - -let stream_peek_nth n strm = - let rec loop n = - function - [] -> None - | [x] -> if n == 1 then Some x else None - | _ :: l -> loop (n - 1) l - in - loop n (Stream.npeek n strm) -;; - -let rec ident len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some - ('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255' | '0'..'9' | '_' | '\'' as c) -> - Stream.junk strm__; ident (store len c) strm__ - | _ -> len -and ident2 len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some - ('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' | - '.' | ':' | '<' | '>' | '|' | '$' as c) -> - Stream.junk strm__; ident2 (store len c) strm__ - | _ -> len -and ident3 len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some - ('0'..'9' | 'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255' | '_' | '!' | '%' | '&' | '*' | '+' | '-' | '.' | '/' | - ':' | '<' | '=' | '>' | '?' | '@' | '^' | '|' | '~' | '\'' | '$' as c - ) -> - Stream.junk strm__; ident3 (store len c) strm__ - | _ -> len -and base_number len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('o' | 'O') -> - Stream.junk strm__; digits octal (store len 'o') strm__ - | Some ('x' | 'X') -> Stream.junk strm__; digits hexa (store len 'x') strm__ - | Some ('b' | 'B') -> - Stream.junk strm__; digits binary (store len 'b') strm__ - | _ -> number len strm__ -and digits kind len (strm__ : _ Stream.t) = - let d = - try kind strm__ with - Stream.Failure -> raise (Stream.Error "ill-formed integer constant") - in - digits_under kind (store len d) strm__ -and digits_under kind len (strm__ : _ Stream.t) = - match - try Some (kind strm__) with - Stream.Failure -> None - with - Some d -> digits_under kind (store len d) strm__ - | _ -> - match Stream.peek strm__ with - Some '_' -> Stream.junk strm__; digits_under kind len strm__ - | Some 'l' -> Stream.junk strm__; "INT32", get_buff len - | Some 'L' -> Stream.junk strm__; "INT64", get_buff len - | Some 'n' -> Stream.junk strm__; "NATIVEINT", get_buff len - | _ -> "INT", get_buff len -and octal (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'7' as d) -> Stream.junk strm__; d - | _ -> raise Stream.Failure -and hexa (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9' | 'a'..'f' | 'A'..'F' as d) -> Stream.junk strm__; d - | _ -> raise Stream.Failure -and binary (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'1' as d) -> Stream.junk strm__; d - | _ -> raise Stream.Failure -and number len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9' as c) -> Stream.junk strm__; number (store len c) strm__ - | Some '_' -> Stream.junk strm__; number len strm__ - | Some '.' -> Stream.junk strm__; decimal_part (store len '.') strm__ - | Some ('e' | 'E') -> - Stream.junk strm__; exponent_part (store len 'E') strm__ - | Some 'l' -> Stream.junk strm__; "INT32", get_buff len - | Some 'L' -> Stream.junk strm__; "INT64", get_buff len - | Some 'n' -> Stream.junk strm__; "NATIVEINT", get_buff len - | _ -> "INT", get_buff len -and decimal_part len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9' as c) -> - Stream.junk strm__; decimal_part (store len c) strm__ - | Some '_' -> Stream.junk strm__; decimal_part len strm__ - | Some ('e' | 'E') -> - Stream.junk strm__; exponent_part (store len 'E') strm__ - | _ -> "FLOAT", get_buff len -and exponent_part len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('+' | '-' as c) -> - Stream.junk strm__; end_exponent_part (store len c) strm__ - | _ -> end_exponent_part len strm__ -and end_exponent_part len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9' as c) -> - Stream.junk strm__; end_exponent_part_under (store len c) strm__ - | _ -> raise (Stream.Error "ill-formed floating-point constant") -and end_exponent_part_under len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9' as c) -> - Stream.junk strm__; end_exponent_part_under (store len c) strm__ - | Some '_' -> Stream.junk strm__; end_exponent_part_under len strm__ - | _ -> "FLOAT", get_buff len -;; - -let error_on_unknown_keywords = ref false;; -let err loc msg = raise_with_loc loc (Token.Error msg);; - -(* Debugging positions and locations *) -let eprint_pos msg p = - Printf.eprintf "%s: fname=%s; lnum=%d; bol=%d; cnum=%d%!" msg - p.Lexing.pos_fname p.Lexing.pos_lnum p.Lexing.pos_bol p.Lexing.pos_cnum -;; - -let eprint_loc (bp, ep) = eprint_pos "P1=" bp; eprint_pos " --P2=" ep;; - -let check_location msg (bp, ep as loc) = - let ok = - if bp.Lexing.pos_lnum > ep.Lexing.pos_lnum || - bp.Lexing.pos_bol > ep.Lexing.pos_bol || - bp.Lexing.pos_cnum > ep.Lexing.pos_cnum || bp.Lexing.pos_lnum < 0 || - ep.Lexing.pos_lnum < 0 || bp.Lexing.pos_bol < 0 || - ep.Lexing.pos_bol < 0 || bp.Lexing.pos_cnum < 0 || - ep.Lexing.pos_cnum < 0 - then - begin - Printf.eprintf "*** Warning: (%s) strange positions ***\n" msg; - eprint_loc loc; - false - end - else true - in - ok, loc -;; - -let debug_token ((kind, tok), loc) = - Printf.eprintf "%s(%s) at " kind tok; eprint_loc loc; Printf.eprintf "\n%!" -;; - -let next_token_fun dfa ssd find_kwd fname lnum bolpos glexr = - let make_pos p = - {Lexing.pos_fname = !fname; Lexing.pos_lnum = !lnum; - Lexing.pos_bol = !bolpos; Lexing.pos_cnum = p} - in - let mkloc (bp, ep) = make_pos bp, make_pos ep in - let keyword_or_error (bp, ep) s = - let loc = mkloc (bp, ep) in - try ("", find_kwd s), loc with - Not_found -> - if !error_on_unknown_keywords then err loc ("illegal token: " ^ s) - else ("", s), loc - in - let error_if_keyword ((_, id as a), bep) = - let loc = mkloc bep in - try - ignore (find_kwd id); - err loc ("illegal use of a keyword as a label: " ^ id) - with - Not_found -> a, loc - in - let rec next_token after_space (strm__ : _ Stream.t) = - let bp = Stream.count strm__ in - match Stream.peek strm__ with - Some '\010' -> - Stream.junk strm__; - let s = strm__ in - let ep = Stream.count strm__ in - bolpos := ep; incr lnum; next_token true s - | Some '\013' -> - Stream.junk strm__; - let s = strm__ in - let ep = Stream.count strm__ in - let ep = - match Stream.peek s with - Some '\010' -> Stream.junk s; ep + 1 - | _ -> ep - in - bolpos := ep; incr lnum; next_token true s - | Some (' ' | '\t' | '\026' | '\012') -> - Stream.junk strm__; next_token true strm__ - | Some '#' when bp = !bolpos -> - Stream.junk strm__; - let s = strm__ in - if linedir 1 s then begin line_directive s; next_token true s end - else keyword_or_error (bp, bp + 1) "#" - | Some '(' -> Stream.junk strm__; left_paren bp strm__ - | Some ('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c) -> - Stream.junk strm__; - let s = strm__ in - let id = get_buff (ident (store 0 c) s) in - let loc = mkloc (bp, Stream.count s) in - (try "", find_kwd id with - Not_found -> "UIDENT", id), - loc - | Some ('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c) -> - Stream.junk strm__; - let s = strm__ in - let id = get_buff (ident (store 0 c) s) in - let loc = mkloc (bp, Stream.count s) in - (try "", find_kwd id with - Not_found -> "LIDENT", id), - loc - | Some ('1'..'9' as c) -> - Stream.junk strm__; - let tok = number (store 0 c) strm__ in - let loc = mkloc (bp, Stream.count strm__) in tok, loc - | Some '0' -> - Stream.junk strm__; - let tok = base_number (store 0 '0') strm__ in - let loc = mkloc (bp, Stream.count strm__) in tok, loc - | Some '\'' -> - Stream.junk strm__; - let s = strm__ in - begin match Stream.npeek 2 s with - [_; '\''] | ['\\'; _] -> - let tok = "CHAR", get_buff (char bp 0 s) in - let loc = mkloc (bp, Stream.count s) in tok, loc - | _ -> keyword_or_error (bp, Stream.count s) "'" - end - | Some '\"' -> - Stream.junk strm__; - let bpos = make_pos bp in - let tok = "STRING", get_buff (string bpos 0 strm__) in - let loc = mkloc (bp, Stream.count strm__) in tok, loc - | Some '$' -> - Stream.junk strm__; - let bpos = make_pos bp in - let tok = dollar bpos 0 strm__ in - let loc = bpos, make_pos (Stream.count strm__) in tok, loc - | Some ('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c) -> - Stream.junk strm__; - let id = get_buff (ident2 (store 0 c) strm__) in - keyword_or_error (bp, Stream.count strm__) id - | Some ('~' as c) -> - Stream.junk strm__; - begin try - match Stream.peek strm__ with - Some ('a'..'z' as c) -> - Stream.junk strm__; - let len = - try ident (store 0 c) strm__ with - Stream.Failure -> raise (Stream.Error "") - in - let s = strm__ in - let ep = Stream.count strm__ in - let id = get_buff len in - let (strm__ : _ Stream.t) = s in - begin match Stream.peek strm__ with - Some ':' -> - Stream.junk strm__; - let ep = Stream.count strm__ in - error_if_keyword (("LABEL", id), (bp, ep)) - | _ -> error_if_keyword (("TILDEIDENT", id), (bp, ep)) - end - | _ -> - let id = get_buff (ident2 (store 0 c) strm__) in - keyword_or_error (bp, Stream.count strm__) id - with - Stream.Failure -> raise (Stream.Error "") - end - | Some ('?' as c) -> - Stream.junk strm__; - begin try - match Stream.peek strm__ with - Some ('a'..'z' as c) -> - Stream.junk strm__; - let len = - try ident (store 0 c) strm__ with - Stream.Failure -> raise (Stream.Error "") - in - let s = strm__ in - let ep = Stream.count strm__ in - let id = get_buff len in - let (strm__ : _ Stream.t) = s in - begin match Stream.peek strm__ with - Some ':' -> - Stream.junk strm__; - let ep = Stream.count strm__ in - error_if_keyword (("OPTLABEL", id), (bp, ep)) - | _ -> error_if_keyword (("QUESTIONIDENT", id), (bp, ep)) - end - | _ -> - let id = get_buff (ident2 (store 0 c) strm__) in - keyword_or_error (bp, Stream.count strm__) id - with - Stream.Failure -> raise (Stream.Error "") - end - | Some '<' -> Stream.junk strm__; less bp strm__ - | Some (':' as c1) -> - Stream.junk strm__; - let len = - try - match Stream.peek strm__ with - Some (']' | ':' | '=' | '>' as c2) -> - Stream.junk strm__; store (store 0 c1) c2 - | _ -> store 0 c1 - with - Stream.Failure -> raise (Stream.Error "") - in - let ep = Stream.count strm__ in - let id = get_buff len in keyword_or_error (bp, ep) id - | Some ('>' | '|' as c1) -> - Stream.junk strm__; - let len = - try - match Stream.peek strm__ with - Some (']' | '}' as c2) -> - Stream.junk strm__; store (store 0 c1) c2 - | _ -> ident2 (store 0 c1) strm__ - with - Stream.Failure -> raise (Stream.Error "") - in - let ep = Stream.count strm__ in - let id = get_buff len in keyword_or_error (bp, ep) id - | Some ('[' | '{' as c1) -> - Stream.junk strm__; - let s = strm__ in - let len = - match Stream.npeek 2 s with - ['<'; '<' | ':'] -> store 0 c1 - | _ -> - let (strm__ : _ Stream.t) = s in - match Stream.peek strm__ with - Some ('|' | '<' | ':' as c2) -> - Stream.junk strm__; store (store 0 c1) c2 - | _ -> store 0 c1 - in - let ep = Stream.count s in - let id = get_buff len in keyword_or_error (bp, ep) id - | Some '.' -> - Stream.junk strm__; - let id = - try - match Stream.peek strm__ with - Some '.' -> Stream.junk strm__; ".." - | _ -> if ssd && after_space then " ." else "." - with - Stream.Failure -> raise (Stream.Error "") - in - let ep = Stream.count strm__ in keyword_or_error (bp, ep) id - | Some ';' -> - Stream.junk strm__; - let id = - try - match Stream.peek strm__ with - Some ';' -> Stream.junk strm__; ";;" - | _ -> ";" - with - Stream.Failure -> raise (Stream.Error "") - in - let ep = Stream.count strm__ in keyword_or_error (bp, ep) id - | Some '\\' -> - Stream.junk strm__; - let ep = Stream.count strm__ in - ("LIDENT", get_buff (ident3 0 strm__)), mkloc (bp, ep) - | Some c -> - Stream.junk strm__; - let ep = Stream.count strm__ in - keyword_or_error (bp, ep) (String.make 1 c) - | _ -> let _ = Stream.empty strm__ in ("EOI", ""), mkloc (bp, succ bp) - and less bp strm = - if !no_quotations then - let (strm__ : _ Stream.t) = strm in - let len = ident2 (store 0 '<') strm__ in - let ep = Stream.count strm__ in - let id = get_buff len in keyword_or_error (bp, ep) id - else - let bpos = make_pos bp in - let (strm__ : _ Stream.t) = strm in - match Stream.peek strm__ with - Some '<' -> - Stream.junk strm__; - let len = - try quotation bpos 0 strm__ with - Stream.Failure -> raise (Stream.Error "") - in - let ep = Stream.count strm__ in - ("QUOTATION", ":" ^ get_buff len), (bpos, make_pos ep) - | Some ':' -> - Stream.junk strm__; - let i = - try let len = ident 0 strm__ in get_buff len with - Stream.Failure -> raise (Stream.Error "") - in - begin match Stream.peek strm__ with - Some '<' -> - Stream.junk strm__; - let len = - try quotation bpos 0 strm__ with - Stream.Failure -> raise (Stream.Error "") - in - let ep = Stream.count strm__ in - ("QUOTATION", i ^ ":" ^ get_buff len), (bpos, make_pos ep) - | _ -> raise (Stream.Error "character '<' expected") - end - | _ -> - let len = ident2 (store 0 '<') strm__ in - let ep = Stream.count strm__ in - let id = get_buff len in keyword_or_error (bp, ep) id - and string bpos len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\"' -> Stream.junk strm__; len - | Some '\\' -> - Stream.junk strm__; - begin match Stream.peek strm__ with - Some c -> - Stream.junk strm__; - let s = strm__ in - let ep = Stream.count strm__ in - let len = store len '\\' in - begin match c with - '\010' -> bolpos := ep; incr lnum; string bpos (store len c) s - | '\013' -> - let (len, ep) = - match Stream.peek s with - Some '\010' -> - Stream.junk s; store (store len '\013') '\010', ep + 1 - | _ -> store len '\013', ep - in - bolpos := ep; incr lnum; string bpos len s - | c -> string bpos (store len c) s - end - | _ -> raise (Stream.Error "") - end - | Some '\010' -> - Stream.junk strm__; - let s = strm__ in - let ep = Stream.count strm__ in - bolpos := ep; incr lnum; string bpos (store len '\010') s - | Some '\013' -> - Stream.junk strm__; - let s = strm__ in - let ep = Stream.count strm__ in - let (len, ep) = - match Stream.peek s with - Some '\010' -> - Stream.junk s; store (store len '\013') '\010', ep + 1 - | _ -> store len '\013', ep - in - bolpos := ep; incr lnum; string bpos len s - | Some c -> Stream.junk strm__; string bpos (store len c) strm__ - | _ -> - let ep = Stream.count strm__ in - err (bpos, make_pos ep) "string not terminated" - and char bp len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\'' -> - Stream.junk strm__; - let s = strm__ in if len = 0 then char bp (store len '\'') s else len - | Some '\\' -> - Stream.junk strm__; - begin match Stream.peek strm__ with - Some c -> - Stream.junk strm__; char bp (store (store len '\\') c) strm__ - | _ -> raise (Stream.Error "") - end - | Some '\010' -> - Stream.junk strm__; - let s = strm__ in - bolpos := bp + 1; incr lnum; char bp (store len '\010') s - | Some '\013' -> - Stream.junk strm__; - let s = strm__ in - let bol = - match Stream.peek s with - Some '\010' -> Stream.junk s; bp + 2 - | _ -> bp + 1 - in - bolpos := bol; incr lnum; char bp (store len '\013') s - | Some c -> Stream.junk strm__; char bp (store len c) strm__ - | _ -> - let ep = Stream.count strm__ in - err (mkloc (bp, ep)) "char not terminated" - and dollar bpos len s = - if !no_quotations then "", get_buff (ident2 (store 0 '$') s) - else - let (strm__ : _ Stream.t) = s in - match Stream.peek strm__ with - Some '$' -> Stream.junk strm__; "ANTIQUOT", ":" ^ get_buff len - | Some ('a'..'z' | 'A'..'Z' as c) -> - Stream.junk strm__; antiquot bpos (store len c) strm__ - | Some ('0'..'9' as c) -> - Stream.junk strm__; maybe_locate bpos (store len c) strm__ - | Some ':' -> - Stream.junk strm__; - let k = get_buff len in - "ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bpos 0 strm__ - | Some '\\' -> - Stream.junk strm__; - begin match Stream.peek strm__ with - Some c -> - Stream.junk strm__; - "ANTIQUOT", - ":" ^ locate_or_antiquot_rest bpos (store len c) strm__ - | _ -> raise (Stream.Error "") - end - | _ -> - let s = strm__ in - if dfa then - let (strm__ : _ Stream.t) = s in - match Stream.peek strm__ with - Some c -> - Stream.junk strm__; - "ANTIQUOT", ":" ^ locate_or_antiquot_rest bpos (store len c) s - | _ -> - let ep = Stream.count strm__ in - err (bpos, make_pos ep) "antiquotation not terminated" - else "", get_buff (ident2 (store 0 '$') s) - and maybe_locate bpos len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '$' -> Stream.junk strm__; "ANTIQUOT", ":" ^ get_buff len - | Some ('0'..'9' as c) -> - Stream.junk strm__; maybe_locate bpos (store len c) strm__ - | Some ':' -> - Stream.junk strm__; - "LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bpos 0 strm__ - | Some '\\' -> - Stream.junk strm__; - begin match Stream.peek strm__ with - Some c -> - Stream.junk strm__; - "ANTIQUOT", - ":" ^ locate_or_antiquot_rest bpos (store len c) strm__ - | _ -> raise (Stream.Error "") - end - | Some c -> - Stream.junk strm__; - "ANTIQUOT", ":" ^ locate_or_antiquot_rest bpos (store len c) strm__ - | _ -> - let ep = Stream.count strm__ in - err (bpos, make_pos ep) "antiquotation not terminated" - and antiquot bpos len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '$' -> Stream.junk strm__; "ANTIQUOT", ":" ^ get_buff len - | Some ('a'..'z' | 'A'..'Z' | '0'..'9' as c) -> - Stream.junk strm__; antiquot bpos (store len c) strm__ - | Some ':' -> - Stream.junk strm__; - let k = get_buff len in - "ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bpos 0 strm__ - | Some '\\' -> - Stream.junk strm__; - begin match Stream.peek strm__ with - Some c -> - Stream.junk strm__; - "ANTIQUOT", - ":" ^ locate_or_antiquot_rest bpos (store len c) strm__ - | _ -> raise (Stream.Error "") - end - | Some c -> - Stream.junk strm__; - "ANTIQUOT", ":" ^ locate_or_antiquot_rest bpos (store len c) strm__ - | _ -> - let ep = Stream.count strm__ in - err (bpos, make_pos ep) "antiquotation not terminated" - and locate_or_antiquot_rest bpos len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '$' -> Stream.junk strm__; get_buff len - | Some '\\' -> - Stream.junk strm__; - begin match Stream.peek strm__ with - Some c -> - Stream.junk strm__; - locate_or_antiquot_rest bpos (store len c) strm__ - | _ -> raise (Stream.Error "") - end - | Some c -> - Stream.junk strm__; locate_or_antiquot_rest bpos (store len c) strm__ - | _ -> - let ep = Stream.count strm__ in - err (bpos, make_pos ep) "antiquotation not terminated" - and quotation bpos len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '>' -> Stream.junk strm__; maybe_end_quotation bpos len strm__ - | Some '<' -> - Stream.junk strm__; - quotation bpos (maybe_nested_quotation bpos (store len '<') strm__) - strm__ - | Some '\\' -> - Stream.junk strm__; - let len = - try - match Stream.peek strm__ with - Some ('>' | '<' | '\\' as c) -> Stream.junk strm__; store len c - | _ -> store len '\\' - with - Stream.Failure -> raise (Stream.Error "") - in - quotation bpos len strm__ - | Some '\010' -> - Stream.junk strm__; - let s = strm__ in - let ep = Stream.count strm__ in - bolpos := ep; incr lnum; quotation bpos (store len '\010') s - | Some '\013' -> - Stream.junk strm__; - let s = strm__ in - let ep = Stream.count strm__ in - let bol = - match Stream.peek s with - Some '\010' -> Stream.junk s; ep + 1 - | _ -> ep - in - bolpos := bol; incr lnum; quotation bpos (store len '\013') s - | Some c -> Stream.junk strm__; quotation bpos (store len c) strm__ - | _ -> - let ep = Stream.count strm__ in - err (bpos, make_pos ep) "quotation not terminated" - and maybe_nested_quotation bpos len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '<' -> - Stream.junk strm__; - mstore (quotation bpos (store len '<') strm__) ">>" - | Some ':' -> - Stream.junk strm__; - let len = - try ident (store len ':') strm__ with - Stream.Failure -> raise (Stream.Error "") - in - begin try - match Stream.peek strm__ with - Some '<' -> - Stream.junk strm__; - mstore (quotation bpos (store len '<') strm__) ">>" - | _ -> len - with - Stream.Failure -> raise (Stream.Error "") - end - | _ -> len - and maybe_end_quotation bpos len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '>' -> Stream.junk strm__; len - | _ -> quotation bpos (store len '>') strm__ - and left_paren bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '*' -> - Stream.junk strm__; - let _ = - try comment (make_pos bp) strm__ with - Stream.Failure -> raise (Stream.Error "") - in - begin try next_token true strm__ with - Stream.Failure -> raise (Stream.Error "") - end - | _ -> let ep = Stream.count strm__ in keyword_or_error (bp, ep) "(" - and comment bpos (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '(' -> Stream.junk strm__; left_paren_in_comment bpos strm__ - | Some '*' -> Stream.junk strm__; star_in_comment bpos strm__ - | Some '\"' -> - Stream.junk strm__; - let _ = - try string bpos 0 strm__ with - Stream.Failure -> raise (Stream.Error "") - in - comment bpos strm__ - | Some '\'' -> Stream.junk strm__; quote_in_comment bpos strm__ - | Some '\010' -> - Stream.junk strm__; - let s = strm__ in - let ep = Stream.count strm__ in - bolpos := ep; incr lnum; comment bpos s - | Some '\013' -> - Stream.junk strm__; - let s = strm__ in - let ep = Stream.count strm__ in - let ep = - match Stream.peek s with - Some '\010' -> Stream.junk s; ep + 1 - | _ -> ep - in - bolpos := ep; incr lnum; comment bpos s - | Some c -> Stream.junk strm__; comment bpos strm__ - | _ -> - let ep = Stream.count strm__ in - err (bpos, make_pos ep) "comment not terminated" - and quote_in_comment bpos (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\'' -> Stream.junk strm__; comment bpos strm__ - | Some '\\' -> - Stream.junk strm__; quote_antislash_in_comment bpos 0 strm__ - | _ -> - let s = strm__ in - let ep = Stream.count strm__ in - begin match Stream.npeek 2 s with - ['\013' | '\010'; '\''] -> - bolpos := ep; incr lnum; Stream.junk s; Stream.junk s - | ['\013'; '\010'] -> - begin match Stream.npeek 3 s with - [_; _; '\''] -> - bolpos := ep + 1; - incr lnum; - Stream.junk s; - Stream.junk s; - Stream.junk s - | _ -> () - end - | [_; '\''] -> Stream.junk s; Stream.junk s - | _ -> () - end; - comment bpos s - and quote_any_in_comment bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\'' -> Stream.junk strm__; comment bp strm__ - | _ -> comment bp strm__ - and quote_antislash_in_comment bp len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\'' -> Stream.junk strm__; comment bp strm__ - | Some ('\\' | '\"' | 'n' | 't' | 'b' | 'r') -> - Stream.junk strm__; quote_any_in_comment bp strm__ - | Some ('0'..'9') -> - Stream.junk strm__; quote_antislash_digit_in_comment bp strm__ - | _ -> comment bp strm__ - and quote_antislash_digit_in_comment bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9') -> - Stream.junk strm__; quote_antislash_digit2_in_comment bp strm__ - | _ -> comment bp strm__ - and quote_antislash_digit2_in_comment bp (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9') -> Stream.junk strm__; quote_any_in_comment bp strm__ - | _ -> comment bp strm__ - and left_paren_in_comment bpos (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '*' -> - Stream.junk strm__; let s = strm__ in comment bpos s; comment bpos s - | _ -> comment bpos strm__ - and star_in_comment bpos (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ')' -> Stream.junk strm__; () - | _ -> comment bpos strm__ - and linedir n s = - match stream_peek_nth n s with - Some (' ' | '\t') -> linedir (n + 1) s - | Some ('0'..'9') -> true - | _ -> false - and any_to_nl (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\010' -> - Stream.junk strm__; - let _s = strm__ in - let ep = Stream.count strm__ in bolpos := ep; incr lnum - | Some '\013' -> - Stream.junk strm__; - let s = strm__ in - let ep = Stream.count strm__ in - let ep = - match Stream.peek s with - Some '\010' -> Stream.junk s; ep + 1 - | _ -> ep - in - bolpos := ep; incr lnum - | Some _ -> Stream.junk strm__; any_to_nl strm__ - | _ -> () - and line_directive (strm__ : _ Stream.t) = - let _ = skip_spaces strm__ in - let n = - try line_directive_number 0 strm__ with - Stream.Failure -> raise (Stream.Error "") - in - let _ = - try skip_spaces strm__ with - Stream.Failure -> raise (Stream.Error "") - in - let _ = - try line_directive_string strm__ with - Stream.Failure -> raise (Stream.Error "") - in - let _ = - try any_to_nl strm__ with - Stream.Failure -> raise (Stream.Error "") - in - let ep = Stream.count strm__ in bolpos := ep; lnum := n - and skip_spaces (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some (' ' | '\t') -> Stream.junk strm__; skip_spaces strm__ - | _ -> () - and line_directive_number n (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('0'..'9' as c) -> - Stream.junk strm__; - line_directive_number (10 * n + (Char.code c - Char.code '0')) strm__ - | _ -> n - and line_directive_string (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some '\"' -> - Stream.junk strm__; - let _ = - try line_directive_string_contents 0 strm__ with - Stream.Failure -> raise (Stream.Error "") - in - () - | _ -> () - and line_directive_string_contents len (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ('\010' | '\013') -> Stream.junk strm__; () - | Some '\"' -> Stream.junk strm__; fname := get_buff len - | Some c -> - Stream.junk strm__; - line_directive_string_contents (store len c) strm__ - | _ -> raise Stream.Failure - in - fun cstrm -> - try - let glex = !glexr in - let comm_bp = Stream.count cstrm in - let r = next_token false cstrm in - begin match glex.tok_comm with - Some list -> - let next_bp = (fst (snd r)).Lexing.pos_cnum in - if next_bp > comm_bp then - let comm_loc = mkloc (comm_bp, next_bp) in - glex.tok_comm <- Some (comm_loc :: list) - | None -> () - end; - r - with - Stream.Error str -> - err (mkloc (Stream.count cstrm, Stream.count cstrm + 1)) str -;; - - -let dollar_for_antiquotation = ref true;; -let specific_space_dot = ref false;; - -let func kwd_table glexr = - let bolpos = ref 0 in - let lnum = ref 1 in - let fname = ref "" in - let find = Hashtbl.find kwd_table in - let dfa = !dollar_for_antiquotation in - let ssd = !specific_space_dot in - Token.lexer_func_of_parser - (next_token_fun dfa ssd find fname lnum bolpos glexr), - (bolpos, lnum, fname) -;; - -let rec check_keyword_stream (strm__ : _ Stream.t) = - let _ = check strm__ in - let _ = - try Stream.empty strm__ with - Stream.Failure -> raise (Stream.Error "") - in - true -and check (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some - ('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255') -> - Stream.junk strm__; check_ident strm__ - | Some - ('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' | - '.') -> - Stream.junk strm__; check_ident2 strm__ - | Some '<' -> - Stream.junk strm__; - let s = strm__ in - begin match Stream.npeek 1 s with - [':' | '<'] -> () - | _ -> check_ident2 s - end - | Some ':' -> - Stream.junk strm__; - let _ = - try - match Stream.peek strm__ with - Some (']' | ':' | '=' | '>') -> Stream.junk strm__; () - | _ -> () - with - Stream.Failure -> raise (Stream.Error "") - in - () - | Some ('>' | '|') -> - Stream.junk strm__; - let _ = - try - match Stream.peek strm__ with - Some (']' | '}') -> Stream.junk strm__; () - | _ -> check_ident2 strm__ - with - Stream.Failure -> raise (Stream.Error "") - in - () - | Some ('[' | '{') -> - Stream.junk strm__; - let s = strm__ in - begin match Stream.npeek 2 s with - ['<'; '<' | ':'] -> () - | _ -> - let (strm__ : _ Stream.t) = s in - match Stream.peek strm__ with - Some ('|' | '<' | ':') -> Stream.junk strm__; () - | _ -> () - end - | Some ';' -> - Stream.junk strm__; - let _ = - try - match Stream.peek strm__ with - Some ';' -> Stream.junk strm__; () - | _ -> () - with - Stream.Failure -> raise (Stream.Error "") - in - () - | Some _ -> Stream.junk strm__; () - | _ -> raise Stream.Failure -and check_ident (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some - ('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255' | '0'..'9' | '_' | '\'') -> - Stream.junk strm__; check_ident strm__ - | _ -> () -and check_ident2 (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some - ('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' | - '.' | ':' | '<' | '>' | '|') -> - Stream.junk strm__; check_ident2 strm__ - | _ -> () -;; - -let check_keyword s = - try check_keyword_stream (Stream.of_string s) with - _ -> false -;; - -let error_no_respect_rules p_con p_prm = - raise - (Token.Error - ("the token " ^ - (if p_con = "" then "\"" ^ p_prm ^ "\"" - else if p_prm = "" then p_con - else p_con ^ " \"" ^ p_prm ^ "\"") ^ - " does not respect Plexer rules")) -;; - -let error_ident_and_keyword p_con p_prm = - raise - (Token.Error - ("the token \"" ^ p_prm ^ "\" is used as " ^ p_con ^ - " and as keyword")) -;; - -let using_token kwd_table ident_table (p_con, p_prm) = - match p_con with - "" -> - if not (Hashtbl.mem kwd_table p_prm) then - if check_keyword p_prm then - if Hashtbl.mem ident_table p_prm then - error_ident_and_keyword (Hashtbl.find ident_table p_prm) p_prm - else Hashtbl.add kwd_table p_prm p_prm - else error_no_respect_rules p_con p_prm - | "LIDENT" -> - if p_prm = "" then () - else - begin match p_prm.[0] with - 'A'..'Z' -> error_no_respect_rules p_con p_prm - | _ -> - if Hashtbl.mem kwd_table p_prm then - error_ident_and_keyword p_con p_prm - else Hashtbl.add ident_table p_prm p_con - end - | "UIDENT" -> - if p_prm = "" then () - else - begin match p_prm.[0] with - 'a'..'z' -> error_no_respect_rules p_con p_prm - | _ -> - if Hashtbl.mem kwd_table p_prm then - error_ident_and_keyword p_con p_prm - else Hashtbl.add ident_table p_prm p_con - end - | "INT" | "INT32" | "INT64" | "NATIVEINT" | "FLOAT" | "CHAR" | "STRING" | - "TILDEIDENT" | "QUESTIONIDENT" | "LABEL" | "OPTLABEL" | "QUOTATION" | - "ANTIQUOT" | "LOCATE" | "EOI" -> - () - | _ -> - raise - (Token.Error - ("the constructor \"" ^ p_con ^ "\" is not recognized by Plexer")) -;; - -let removing_token kwd_table ident_table (p_con, p_prm) = - match p_con with - "" -> Hashtbl.remove kwd_table p_prm - | "LIDENT" | "UIDENT" -> - if p_prm <> "" then Hashtbl.remove ident_table p_prm - | _ -> () -;; - -let text = - function - "", t -> "'" ^ t ^ "'" - | "LIDENT", "" -> "lowercase identifier" - | "LIDENT", t -> "'" ^ t ^ "'" - | "UIDENT", "" -> "uppercase identifier" - | "UIDENT", t -> "'" ^ t ^ "'" - | "INT", "" -> "integer" - | "INT32", "" -> "32 bits integer" - | "INT64", "" -> "64 bits integer" - | "NATIVEINT", "" -> "native integer" - | ("INT" | "INT32" | "NATIVEINT"), s -> "'" ^ s ^ "'" - | "FLOAT", "" -> "float" - | "STRING", "" -> "string" - | "CHAR", "" -> "char" - | "QUOTATION", "" -> "quotation" - | "ANTIQUOT", k -> "antiquot \"" ^ k ^ "\"" - | "LOCATE", "" -> "locate" - | "EOI", "" -> "end of input" - | con, "" -> con - | con, prm -> con ^ " \"" ^ prm ^ "\"" -;; - -let eq_before_colon p e = - let rec loop i = - if i == String.length e then - failwith "Internal error in Plexer: incorrect ANTIQUOT" - else if i == String.length p then e.[i] == ':' - else if p.[i] == e.[i] then loop (i + 1) - else false - in - loop 0 -;; - -let after_colon e = - try - let i = String.index e ':' in - String.sub e (i + 1) (String.length e - i - 1) - with - Not_found -> "" -;; - -let tok_match = - function - "ANTIQUOT", p_prm -> - begin function - "ANTIQUOT", prm when eq_before_colon p_prm prm -> after_colon prm - | _ -> raise Stream.Failure - end - | tok -> Token.default_match tok -;; - -let make_lexer () = - let kwd_table = Hashtbl.create 301 in - let id_table = Hashtbl.create 301 in - let glexr = - ref - {tok_func = (fun _ -> raise (Match_failure ("", 774, 17))); - tok_using = (fun _ -> raise (Match_failure ("", 774, 37))); - tok_removing = (fun _ -> raise (Match_failure ("", 774, 60))); - tok_match = (fun _ -> raise (Match_failure ("", 775, 18))); - tok_text = (fun _ -> raise (Match_failure ("", 775, 37))); - tok_comm = None} - in - let (f, pos) = func kwd_table glexr in - let glex = - {tok_func = f; tok_using = using_token kwd_table id_table; - tok_removing = removing_token kwd_table id_table; tok_match = tok_match; - tok_text = text; tok_comm = None} - in - glexr := glex; glex, pos -;; - -let gmake () = let (p, _) = make_lexer () in p;; - -let tparse = - function - "ANTIQUOT", p_prm -> - let p (strm__ : _ Stream.t) = - match Stream.peek strm__ with - Some ("ANTIQUOT", prm) when eq_before_colon p_prm prm -> - Stream.junk strm__; after_colon prm - | _ -> raise Stream.Failure - in - Some p - | _ -> None -;; - -let make () = - let kwd_table = Hashtbl.create 301 in - let id_table = Hashtbl.create 301 in - let glexr = - ref - {tok_func = (fun _ -> raise (Match_failure ("", 808, 17))); - tok_using = (fun _ -> raise (Match_failure ("", 808, 37))); - tok_removing = (fun _ -> raise (Match_failure ("", 808, 60))); - tok_match = (fun _ -> raise (Match_failure ("", 809, 18))); - tok_text = (fun _ -> raise (Match_failure ("", 809, 37))); - tok_comm = None} - in - {func = fst (func kwd_table glexr); using = using_token kwd_table id_table; - removing = removing_token kwd_table id_table; tparse = tparse; text = text} -;; diff --git a/camlp4/ocaml_src/lib/plexer.mli b/camlp4/ocaml_src/lib/plexer.mli deleted file mode 100644 index b32a5806..00000000 --- a/camlp4/ocaml_src/lib/plexer.mli +++ /dev/null @@ -1,80 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(** A lexical analyzer. *) - -val gmake : unit -> Token.t Token.glexer;; - (** Some lexer provided. See the module [Token]. The tokens returned - follow the Objective Caml and the Revised syntax lexing rules. - - The meaning of the tokens are: -- * [("", 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", s)] (resp. ["INT32"], ["INT64"] and ["NATIVEINT"]) - is an integer constant whose string source is [s]. -- * [("FLOAT", s)] is a float constant whose string source is [s]. -- * [("STRING", s)] is the string constant [s]. -- * [("CHAR", s)] is the character constant [s]. -- * [("QUOTATION", "t:s")] is a quotation [t] holding the string [s]. -- * [("ANTIQUOT", "t:s")] is an antiquotation [t] holding the string [s]. -- * [("LOCATE", "i:s")] is a location directive at pos [i] holding [s]. -- * [("EOI", "")] is the end of input. - - The associated token patterns in the EXTEND statement hold the - same names than the first string (constructor name) of the tokens - expressions above. - - Warning: the 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 function [Token.eval_string]. Same thing for - the constructor [CHAR]: to get the character, don't get the - first character of the string, but use the function - [Token.eval_char]. - - The lexer do not use global (mutable) variables: instantiations - of [Plexer.gmake ()] do not perturb each other. *) - -val make_lexer : - unit -> Token.t Token.glexer * (int ref * int ref * string ref);; - (** [make_lexer] builds a lexer as [gmake does], but returns also - the triple [(bolpos, lnum, fname)] where -- [bolpos] contains the character number of the beginning of the current line, -- [lnum] contains the current line number and -- [fname] contains the name of the file being parsed. *) - -val dollar_for_antiquotation : bool ref;; - (** When True (default), the next call to [Plexer.make ()] returns a - lexer where the dollar sign is used for antiquotations. If False, - the dollar sign can be used as token. *) - -val specific_space_dot : bool ref;; - (** When False (default), the next call to [Plexer.make ()] returns a - lexer where the dots can be preceded by spaces. If True, dots - preceded by spaces return the keyword " ." (space dot), otherwise - return the keyword "." (dot). *) - -val no_quotations : bool ref;; - (** When True, all lexers built by [Plexer.make ()] do not lex the - quotation syntax any more. Default is False (quotations are - lexed). *) - -(**/**) - -(* deprecated since version 3.05; use rather function gmake *) -val make : unit -> Token.lexer;; diff --git a/camlp4/ocaml_src/lib/stdpp.ml b/camlp4/ocaml_src/lib/stdpp.ml deleted file mode 100644 index e3d63d90..00000000 --- a/camlp4/ocaml_src/lib/stdpp.ml +++ /dev/null @@ -1,87 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -exception Exc_located of Token.flocation * exn;; - -let raise_with_loc loc exc = - match exc with - Exc_located (_, _) -> raise exc - | _ -> raise (Exc_located (loc, exc)) -;; - -let line_of_loc fname (bp, ep) = - bp.Lexing.pos_fname, bp.Lexing.pos_lnum, - bp.Lexing.pos_cnum - bp.Lexing.pos_bol, - ep.Lexing.pos_cnum - bp.Lexing.pos_bol -;; - -(* -value line_of_loc fname (bp, ep) = - try - let ic = open_in_bin fname in - let strm = Stream.of_channel ic in - let rec loop fname lin = - let rec not_a_line_dir col = - parser cnt - [: `c; s :] -> - if cnt < bp then - if c = '\n' then loop fname (lin + 1) - else not_a_line_dir (col + 1) s - else - let col = col - (cnt - bp) in - (fname, lin, col, col + ep - bp) - in - let rec a_line_dir str n col = - parser - [ [: `'\n' :] -> loop str n - | [: `_; s :] -> a_line_dir str n (col + 1) s ] - in - let rec spaces col = - parser - [ [: `' '; s :] -> spaces (col + 1) s - | [: :] -> col ] - in - let rec check_string str n col = - parser - [ [: `'"'; col = spaces (col + 1); s :] -> a_line_dir str n col s - | [: `c when c <> '\n'; s :] -> - check_string (str ^ String.make 1 c) n (col + 1) s - | [: a = not_a_line_dir col :] -> a ] - in - let check_quote n col = - parser - [ [: `'"'; s :] -> check_string "" n (col + 1) s - | [: a = not_a_line_dir col :] -> a ] - in - let rec check_num n col = - parser - [ [: `('0'..'9' as c); s :] -> - check_num (10 * n + Char.code c - Char.code '0') (col + 1) s - | [: col = spaces col; s :] -> check_quote n col s ] - in - let begin_line = - parser - [ [: `'#'; col = spaces 1; s :] -> check_num 0 col s - | [: a = not_a_line_dir 0 :] -> a ] - in - begin_line strm - in - let r = try loop fname 1 with [ Stream.Failure -> (fname, 1, bp, ep) ] in - do { close_in ic; r } - with - [ Sys_error _ -> (fname, 1, bp, ep) ] -; -*) - -let loc_name = ref "_loc";; diff --git a/camlp4/ocaml_src/lib/stdpp.mli b/camlp4/ocaml_src/lib/stdpp.mli deleted file mode 100644 index e966ee9a..00000000 --- a/camlp4/ocaml_src/lib/stdpp.mli +++ /dev/null @@ -1,37 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(** Standard definitions. *) - -exception Exc_located of Token.flocation * exn;; - (** [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 [raise_with_loc]. *) - -val raise_with_loc : Token.flocation -> exn -> 'a;; - (** [raise_with_loc loc e], if [e] is already the exception [Exc_located], - re-raise it, else raise the exception [Exc_located loc e]. *) - -val line_of_loc : string -> Token.flocation -> string * int * int * int;; - (** [line_of_loc fname loc] reads the file [fname] up to the - location [loc] and returns the real input file, the line number - and the characters location in the line; the real input file - can be different from [fname] because of possibility of line - directives typically generated by /lib/cpp. *) - -val loc_name : string ref;; - (** Name of the location variable used in grammars and in the predefined - quotations for OCaml syntax trees. Default: [loc] *) diff --git a/camlp4/ocaml_src/lib/token.ml b/camlp4/ocaml_src/lib/token.ml deleted file mode 100644 index 013186c8..00000000 --- a/camlp4/ocaml_src/lib/token.ml +++ /dev/null @@ -1,255 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -type t = string * string;; -type pattern = string * string;; - -exception Error of string;; - -let make_loc (bp, ep) = - {(Lexing.dummy_pos) with Lexing.pos_cnum = bp; Lexing.pos_lnum = 1}, - {(Lexing.dummy_pos) with Lexing.pos_cnum = ep; Lexing.pos_lnum = 1} -;; - -let nowhere = {(Lexing.dummy_pos) with Lexing.pos_cnum = 0};; - -let dummy_loc = Lexing.dummy_pos, Lexing.dummy_pos;; - -let succ_pos p = {p with Lexing.pos_cnum = p.Lexing.pos_cnum + 1};; -let lt_pos p1 p2 = p1.Lexing.pos_cnum < p2.Lexing.pos_cnum;; - -type flocation = Lexing.position * Lexing.position;; - -type flocation_function = int -> flocation;; -type 'te lexer_func = char Stream.t -> 'te Stream.t * flocation_function;; - -type 'te glexer = - { tok_func : 'te lexer_func; - tok_using : pattern -> unit; - tok_removing : pattern -> unit; - tok_match : pattern -> 'te -> string; - tok_text : pattern -> string; - mutable tok_comm : flocation list option } -;; -type lexer = - { func : t lexer_func; - using : pattern -> unit; - removing : pattern -> unit; - tparse : pattern -> (t Stream.t -> string) option; - text : pattern -> string } -;; - -let lexer_text (con, prm) = - if con = "" then "'" ^ prm ^ "'" - else if prm = "" then con - else con ^ " '" ^ prm ^ "'" -;; - -let locerr () = invalid_arg "Lexer: flocation function";; - -let tsz = 256;; (* up to 2^29 entries on a 32-bit machine, 2^61 on 64-bit *) - -let loct_create () = ref [| |], ref false;; - -let loct_func (loct, ov) i = - match - if i < 0 || i / tsz >= Array.length !loct then None - else if !loct.(i / tsz) = [| |] then - if !ov then Some (nowhere, nowhere) else None - else Array.unsafe_get (Array.unsafe_get !loct (i / tsz)) (i mod tsz) - with - Some loc -> loc - | _ -> locerr () -;; - -let loct_add (loct, ov) i loc = - while i / tsz >= Array.length !loct && not !ov do - let new_tmax = Array.length !loct * 2 + 1 in - if new_tmax < Sys.max_array_length then - let new_loct = Array.make new_tmax [| |] in - Array.blit !loct 0 new_loct 0 (Array.length !loct); loct := new_loct - else ov := true - done; - if not !ov then - begin - if !loct.(i / tsz) = [| |] then !loct.(i / tsz) <- Array.make tsz None; - !loct.(i / tsz).(i mod tsz) <- Some loc - end -;; - -let make_stream_and_flocation next_token_loc = - let loct = loct_create () in - let ts = - Stream.from - (fun i -> - let (tok, loc) = next_token_loc () in loct_add loct i loc; Some tok) - in - ts, loct_func loct -;; - -let lexer_func_of_parser next_token_loc cs = - make_stream_and_flocation (fun () -> next_token_loc cs) -;; - -let lexer_func_of_ocamllex lexfun cs = - let lb = - Lexing.from_function - (fun s n -> - try s.[0] <- Stream.next cs; 1 with - Stream.Failure -> 0) - in - let next_token_loc _ = - let tok = lexfun lb in - let loc = Lexing.lexeme_start_p lb, Lexing.lexeme_end_p lb in tok, loc - in - make_stream_and_flocation next_token_loc -;; - -(* Char and string tokens to real chars and string *) - -let buff = ref (String.create 80);; -let store len x = - if len >= String.length !buff then - buff := !buff ^ String.create (String.length !buff); - !buff.[len] <- x; - succ len -;; -let mstore len s = - let rec add_rec len i = - if i == String.length s then len else add_rec (store len s.[i]) (succ i) - in - add_rec len 0 -;; -let get_buff len = String.sub !buff 0 len;; - -let valch x = Char.code x - Char.code '0';; -let valch_a x = Char.code x - Char.code 'a' + 10;; -let valch_A x = Char.code x - Char.code 'A' + 10;; - -let rec backslash s i = - if i = String.length s then raise Not_found - else - match s.[i] with - 'n' -> '\n', i + 1 - | 'r' -> '\r', i + 1 - | 't' -> '\t', i + 1 - | 'b' -> '\b', i + 1 - | '\\' -> '\\', i + 1 - | '\"' -> '\"', i + 1 - | '\'' -> '\'', i + 1 - | ' ' -> ' ', i + 1 - | '0'..'9' as c -> backslash1 (valch c) s (i + 1) - | 'x' -> backslash1h s (i + 1) - | _ -> raise Not_found -and backslash1 cod s i = - if i = String.length s then raise Not_found - else - match s.[i] with - '0'..'9' as c -> backslash2 (10 * cod + valch c) s (i + 1) - | _ -> raise Not_found -and backslash2 cod s i = - if i = String.length s then raise Not_found - else - match s.[i] with - '0'..'9' as c -> Char.chr (10 * cod + valch c), i + 1 - | _ -> raise Not_found -and backslash1h s i = - if i = String.length s then raise Not_found - else - match s.[i] with - '0'..'9' as c -> backslash2h (valch c) s (i + 1) - | 'a'..'f' as c -> backslash2h (valch_a c) s (i + 1) - | 'A'..'F' as c -> backslash2h (valch_A c) s (i + 1) - | _ -> raise Not_found -and backslash2h cod s i = - if i = String.length s then '\\', i - 2 - else - match s.[i] with - '0'..'9' as c -> Char.chr (16 * cod + valch c), i + 1 - | 'a'..'f' as c -> Char.chr (16 * cod + valch_a c), i + 1 - | 'A'..'F' as c -> Char.chr (16 * cod + valch_A c), i + 1 - | _ -> raise Not_found -;; - -let rec skip_indent s i = - if i = String.length s then i - else - match s.[i] with - ' ' | '\t' -> skip_indent s (i + 1) - | _ -> i -;; - -let skip_opt_linefeed s i = - if i = String.length s then i else if s.[i] = '\010' then i + 1 else i -;; - -let eval_char s = - if String.length s = 1 then s.[0] - else if String.length s = 0 then failwith "invalid char token" - else if s.[0] = '\\' then - if String.length s = 2 && s.[1] = '\'' then '\'' - else - try - let (c, i) = backslash s 1 in - if i = String.length s then c else raise Not_found - with - Not_found -> failwith "invalid char token" - else failwith "invalid char token" -;; - -let eval_string (bp, ep) s = - let rec loop len i = - if i = String.length s then get_buff len - else - let (len, i) = - if s.[i] = '\\' then - let i = i + 1 in - if i = String.length s then failwith "invalid string token" - else if s.[i] = '\"' then store len '\"', i + 1 - else - match s.[i] with - '\010' -> len, skip_indent s (i + 1) - | '\013' -> len, skip_indent s (skip_opt_linefeed s (i + 1)) - | c -> - try let (c, i) = backslash s i in store len c, i with - Not_found -> - let txt = "Invalid backslash escape in string" in - let pos = bp.Lexing.pos_cnum - bp.Lexing.pos_bol + i in - if bp.Lexing.pos_fname = "" then - Printf.eprintf "Warning: line %d, chars %d-%d: %s\n" - bp.Lexing.pos_lnum pos (pos + 1) txt - else - Printf.eprintf - "Warning: File \"%s\", line %d, chars %d-%d: %s\n" - bp.Lexing.pos_fname bp.Lexing.pos_lnum pos (pos + 1) - txt; - store (store len '\\') c, i + 1 - else store len s.[i], i + 1 - in - loop len i - in - loop 0 0 -;; - -let default_match = - function - "ANY", "" -> (fun (con, prm) -> prm) - | "ANY", v -> - (fun (con, prm) -> if v = prm then v else raise Stream.Failure) - | p_con, "" -> - (fun (con, prm) -> if con = p_con then prm else raise Stream.Failure) - | p_con, p_prm -> - fun (con, prm) -> - if con = p_con && prm = p_prm then prm else raise Stream.Failure -;; diff --git a/camlp4/ocaml_src/lib/token.mli b/camlp4/ocaml_src/lib/token.mli deleted file mode 100644 index 715170bd..00000000 --- a/camlp4/ocaml_src/lib/token.mli +++ /dev/null @@ -1,141 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -(** Lexers for Camlp4 grammars. - - This module defines the Camlp4 lexer type to be used in extensible - grammars (see module [Grammar]). It also provides some useful functions - to create lexers (this module should be renamed [Glexer] one day). *) - -type pattern = string * string;; - (** Token patterns come from the EXTEND statement. -- The first string is the constructor name (must start with - an uppercase character). When it is empty, the second string - is supposed to be a keyword. -- The second string is the constructor parameter. Empty if it - has no parameter. -- The way tokens patterns are interpreted to parse tokens is - done by the lexer, function [tok_match] below. *) - -exception Error of string;; - (** An lexing error exception to be used by lexers. *) - -(** {6 Lexer type} *) - -type flocation = Lexing.position * Lexing.position;; - -val nowhere : Lexing.position;; -val dummy_loc : flocation;; - -val make_loc : int * int -> flocation;; -val succ_pos : Lexing.position -> Lexing.position;; -val lt_pos : Lexing.position -> Lexing.position -> bool;; - -type flocation_function = int -> flocation;; - (** The type for a function associating a number of a token in a stream - (starting from 0) to its source location. *) -type 'te lexer_func = char Stream.t -> 'te Stream.t * flocation_function;; - (** The type for a lexer function. The character stream is the input - stream to be lexed. The result is a pair of a token stream and - a location function for this tokens stream. *) - -type 'te glexer = - { tok_func : 'te lexer_func; - tok_using : pattern -> unit; - tok_removing : pattern -> unit; - tok_match : pattern -> 'te -> string; - tok_text : pattern -> string; - mutable tok_comm : flocation list option } -;; - (** The type for a lexer used by Camlp4 grammars. -- The field [tok_func] is the main lexer function. See [lexer_func] - type above. This function may be created from a [char stream parser] - or for an [ocamllex] function using the functions below. -- The field [tok_using] is a function telling the lexer that the grammar - uses this token (pattern). The lexer can check that its constructor - is correct, and interpret some kind of tokens as keywords (to record - them in its tables). Called by [EXTEND] statements. -- The field [tok_removing] is a function telling the lexer that the - grammar does not uses the given token (pattern) any more. If the - lexer has a notion of "keywords", it can release it from its tables. - Called by [DELETE_RULE] statements. -- The field [tok_match] is a function taking a pattern and returning - a function matching a token against the pattern. Warning: for - efficency, write it as a function returning functions according - to the values of the pattern, not a function with two parameters. -- The field [tok_text] returns the name of some token pattern, - used in error messages. -- The field [tok_comm] if not None asks the lexer to record the - locations of the comments. *) - -val lexer_text : pattern -> string;; - (** A simple [tok_text] function for lexers *) - -val default_match : pattern -> string * string -> string;; - (** A simple [tok_match] function for lexers, appling to token type - [(string * string)] *) - -(** {6 Lexers from char stream parsers or ocamllex function} - - The functions below create lexer functions either from a [char stream] - parser or for an [ocamllex] function. With the returned function [f], - the simplest [Token.lexer] can be written: - {[ - { Token.tok_func = f; - Token.tok_using = (fun _ -> ()); - Token.tok_removing = (fun _ -> ()); - Token.tok_match = Token.default_match; - Token.tok_text = Token.lexer_text } - ]} - Note that a better [tok_using] function should check the used tokens - and raise [Token.Error] for incorrect ones. The other functions - [tok_removing], [tok_match] and [tok_text] may have other implementations - as well. *) - -val lexer_func_of_parser : - (char Stream.t -> 'te * flocation) -> 'te lexer_func;; - (** A lexer function from a lexer written as a char stream parser - returning the next token and its location. *) -val lexer_func_of_ocamllex : (Lexing.lexbuf -> 'te) -> 'te lexer_func;; - (** A lexer function from a lexer created by [ocamllex] *) - -val make_stream_and_flocation : - (unit -> 'te * flocation) -> 'te Stream.t * flocation_function;; - (** General function *) - -(** {6 Useful functions} *) - -val eval_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] *) - -val eval_string : flocation -> string -> string;; - (** Convert a string token, where the escape sequences (backslashes) - remain to be interpreted; issue a warning if an incorrect - backslash sequence is found; - [Token.eval_string loc (String.escaped s)] returns [s] *) - -(**/**) - -(* deprecated since version 3.05; use rather type glexer *) -type t = string * string;; -type lexer = - { func : t lexer_func; - using : pattern -> unit; - removing : pattern -> unit; - tparse : pattern -> (t Stream.t -> string) option; - text : pattern -> string } -;; diff --git a/camlp4/ocaml_src/meta/.cvsignore b/camlp4/ocaml_src/meta/.cvsignore deleted file mode 100644 index 45db1720..00000000 --- a/camlp4/ocaml_src/meta/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -camlp4o.out -camlp4r.out diff --git a/camlp4/ocaml_src/meta/.depend b/camlp4/ocaml_src/meta/.depend deleted file mode 100644 index 83b86c27..00000000 --- a/camlp4/ocaml_src/meta/.depend +++ /dev/null @@ -1,16 +0,0 @@ -pa_extend.cmo: ../camlp4/reloc.cmi ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pa_extend.cmx: ../camlp4/reloc.cmx ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -pa_extend_m.cmo: pa_extend.cmo -pa_extend_m.cmx: pa_extend.cmx -pa_macro.cmo: ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pa_macro.cmx: ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -pa_r.cmo: ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pa_r.cmx: ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -pa_rp.cmo: ../camlp4/pcaml.cmi ../camlp4/mLast.cmi -pa_rp.cmx: ../camlp4/pcaml.cmx ../camlp4/mLast.cmi -pr_dump.cmo: ../camlp4/pcaml.cmi $(OTOP)/utils/config.cmi ../camlp4/ast2pt.cmi -pr_dump.cmx: ../camlp4/pcaml.cmx $(OTOP)/utils/config.cmx ../camlp4/ast2pt.cmx -q_MLast.cmo: ../camlp4/reloc.cmi ../camlp4/quotation.cmi ../camlp4/pcaml.cmi \ - ../camlp4/mLast.cmi -q_MLast.cmx: ../camlp4/reloc.cmx ../camlp4/quotation.cmx ../camlp4/pcaml.cmx \ - ../camlp4/mLast.cmi diff --git a/camlp4/ocaml_src/meta/Makefile b/camlp4/ocaml_src/meta/Makefile deleted file mode 100644 index a66dcd75..00000000 --- a/camlp4/ocaml_src/meta/Makefile +++ /dev/null @@ -1,58 +0,0 @@ -# This file has been generated by program: do not edit! - -include ../../config/Makefile - -INCLUDES=-I ../camlp4 -I ../../boot -I $(OTOP)/utils -OCAMLCFLAGS=-warn-error A $(INCLUDES) -OBJS=q_MLast.cmo pa_r.cmo pa_rp.cmo pa_extend.cmo pa_extend_m.cmo pa_macro.cmo pr_dump.cmo -OBJSX=$(OBJS:.cmo=.cmx) -CAMLP4RM=pa_r.cmo pa_rp.cmo pr_dump.cmo -CAMLP4RMX=$(CAMLP4RM:.cmo=.cmx) -SHELL=/bin/sh -COUT=$(OBJS) camlp4r$(EXE) -COPT=$(OBJSX) camlp4r.opt - -all: $(COUT) -opt: $(COPT) - -camlp4r$(EXE): ../camlp4/camlp4$(EXE) $(CAMLP4RM) - rm -f camlp4r$(EXE) - cd ../camlp4; $(MAKE) OTOP=$(OTOP) CAMLP4=../meta/camlp4r$(EXE) CAMLP4M="-I ../meta $(CAMLP4RM)" - -camlp4r.opt: $(CAMLP4RMX) - rm -f camlp4r.opt - cd ../camlp4; $(MAKE) optp4 OTOP=$(OTOP) CAMLP4OPT=../meta/camlp4r.opt CAMLP4M="-I ../meta $(CAMLP4RMX)" - -clean:: - rm -f *.cm* *.pp[io] *.o *.bak .*.bak $(COUT) $(COPT) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -promote: - cp $(COUT) pa_extend.cmi ../../boot/. - -compare: - @for j in $(COUT); do \ - if cmp $$j ../../boot/$$j; then :; else exit 1; fi; \ - done - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" - cp $(OBJS) "$(LIBDIR)/camlp4/." - cp pa_macro.cmi pa_extend.cmi "$(LIBDIR)/camlp4/." - cp camlp4r$(EXE) "$(BINDIR)/." - if test -f camlp4r.opt; then \ - cp camlp4r.opt "$(BINDIR)/camlp4r.opt$(EXE)" ;\ - cp $(OBJSX) "$(LIBDIR)/camlp4/."; \ - for file in $(OBJSX); do \ - cp "`echo $$file | sed -e 's/\.cmx$$/.$(O)/'`" "$(LIBDIR)/camlp4/."; \ - done ; \ - fi - -include .depend diff --git a/camlp4/ocaml_src/meta/pa_extend.ml b/camlp4/ocaml_src/meta/pa_extend.ml deleted file mode 100644 index 0d7bd6c9..00000000 --- a/camlp4/ocaml_src/meta/pa_extend.ml +++ /dev/null @@ -1,2132 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Stdpp;; - -let split_ext = ref false;; - -Pcaml.add_option "-split_ext" (Arg.Set split_ext) - "Split EXTEND by functions to turn around a PowerPC problem.";; - -Pcaml.add_option "-split_gext" (Arg.Set split_ext) - "Old name for the option -split_ext.";; - -type loc = Lexing.position * Lexing.position;; - -type 'e name = { expr : 'e; tvar : string; loc : loc };; - -type styp = - STlid of loc * string - | STapp of loc * styp * styp - | STquo of loc * string - | STself of loc * string - | STtyp of MLast.ctyp -;; - -type 'e text = - TXmeta of loc * string * 'e text list * 'e * styp - | TXlist of loc * bool * 'e text * 'e text option - | TXnext of loc - | TXnterm of loc * 'e name * string option - | TXopt of loc * 'e text - | TXrules of loc * ('e text list * 'e) list - | TXself of loc - | TXtok of loc * string * 'e -;; - -type ('e, 'p) entry = - { name : 'e name; pos : 'e option; levels : ('e, 'p) level list } -and ('e, 'p) level = - { label : string option; assoc : 'e option; rules : ('e, 'p) rule list } -and ('e, 'p) rule = { prod : ('e, 'p) psymbol list; action : 'e option } -and ('e, 'p) psymbol = { pattern : 'p option; symbol : ('e, 'p) symbol } -and ('e, 'p) symbol = { used : string list; text : 'e text; styp : styp } -;; - -type used = - Unused - | UsedScanned - | UsedNotScanned -;; - -let mark_used modif ht n = - try - let rll = Hashtbl.find_all ht n in - List.iter - (fun (r, _) -> - if !r == Unused then begin r := UsedNotScanned; modif := true end) - rll - with - Not_found -> () -;; - -let rec mark_symbol modif ht symb = - List.iter (fun e -> mark_used modif ht e) symb.used -;; - -let check_use nl el = - let ht = Hashtbl.create 301 in - let modif = ref false in - List.iter - (fun e -> - let u = - match e.name.expr with - MLast.ExLid (_, _) -> Unused - | _ -> UsedNotScanned - in - Hashtbl.add ht e.name.tvar (ref u, e)) - el; - List.iter - (fun n -> - try - let rll = Hashtbl.find_all ht n.tvar in - List.iter (fun (r, _) -> r := UsedNotScanned) rll - with - _ -> ()) - nl; - modif := true; - while !modif do - modif := false; - Hashtbl.iter - (fun s (r, e) -> - if !r = UsedNotScanned then - begin - r := UsedScanned; - List.iter - (fun level -> - let rules = level.rules in - List.iter - (fun rule -> - List.iter (fun ps -> mark_symbol modif ht ps.symbol) - rule.prod) - rules) - e.levels - end) - ht - done; - Hashtbl.iter - (fun s (r, e) -> - if !r = Unused then - !(Pcaml.warning) e.name.loc ("Unused local entry \"" ^ s ^ "\"")) - ht -;; - -let locate n = let _loc = n.loc in n.expr;; - -let new_type_var = - let i = ref 0 in fun () -> incr i; "e__" ^ string_of_int !i -;; - -let used_of_rule_list rl = - List.fold_left - (fun nl r -> List.fold_left (fun nl s -> s.symbol.used @ nl) nl r.prod) [] - rl -;; - -let retype_rule_list_without_patterns _loc rl = - try - List.map - (function - {prod = [{pattern = None; symbol = s}]; action = None} -> - {prod = [{pattern = Some (MLast.PaLid (_loc, "x")); symbol = s}]; - action = Some (MLast.ExLid (_loc, "x"))} - | {prod = []; action = Some _} as r -> r - | _ -> raise Exit) - rl - with - Exit -> rl -;; - -let quotify = ref false;; -let meta_action = ref false;; - -module MetaAction = - struct - let not_impl f x = - let desc = - if Obj.is_block (Obj.repr x) then - "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) - else "int_val = " ^ string_of_int (Obj.magic x) - in - failwith (f ^ ", not impl: " ^ desc) - ;; - let _loc = - let nowhere = - {(Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0} - in - nowhere, nowhere - ;; - let rec mlist mf = - function - [] -> MLast.ExUid (_loc, "[]") - | x :: l -> - MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExUid (_loc, "::"), mf x), - mlist mf l) - ;; - let moption mf = - function - None -> MLast.ExUid (_loc, "None") - | Some x -> MLast.ExApp (_loc, MLast.ExUid (_loc, "Some"), mf x) - ;; - let mbool = - function - false -> MLast.ExUid (_loc, "False") - | true -> MLast.ExUid (_loc, "True") - ;; - let mloc = - MLast.ExLet - (_loc, false, - [MLast.PaLid (_loc, "nowhere"), - MLast.ExRec - (_loc, - [MLast.PaAcc - (_loc, MLast.PaUid (_loc, "Lexing"), - MLast.PaLid (_loc, "pos_lnum")), - MLast.ExInt (_loc, "1"); - MLast.PaAcc - (_loc, MLast.PaUid (_loc, "Lexing"), - MLast.PaLid (_loc, "pos_cnum")), - MLast.ExInt (_loc, "0")], - Some - (MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Lexing"), - MLast.ExLid (_loc, "dummy_pos"))))], - MLast.ExTup - (_loc, - [MLast.ExLid (_loc, "nowhere"); MLast.ExLid (_loc, "nowhere")])) - ;; - let rec mexpr = - function - MLast.ExAcc (_loc, e1, e2) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "ExAcc")), - mloc), - mexpr e1), - mexpr e2) - | MLast.ExApp (_loc, e1, e2) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "ExApp")), - mloc), - mexpr e1), - mexpr e2) - | MLast.ExChr (_loc, s) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "ExChr")), - mloc), - MLast.ExStr (_loc, s)) - | MLast.ExFun (_loc, pwel) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "ExFun")), - mloc), - mlist mpwe pwel) - | MLast.ExIfe (_loc, e1, e2, e3) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "ExIfe")), - mloc), - mexpr e1), - mexpr e2), - mexpr e3) - | MLast.ExInt (_loc, s) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "ExInt")), - mloc), - MLast.ExStr (_loc, s)) - | MLast.ExFlo (_loc, s) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "ExFlo")), - mloc), - MLast.ExStr (_loc, s)) - | MLast.ExLet (_loc, rf, pel, e) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "ExLet")), - mloc), - mbool rf), - mlist mpe pel), - mexpr e) - | MLast.ExLid (_loc, s) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "ExLid")), - mloc), - MLast.ExStr (_loc, s)) - | MLast.ExMat (_loc, e, pwel) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "ExMat")), - mloc), - mexpr e), - mlist mpwe pwel) - | MLast.ExRec (_loc, pel, eo) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "ExRec")), - mloc), - mlist mpe pel), - moption mexpr eo) - | MLast.ExSeq (_loc, el) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "ExSeq")), - mloc), - mlist mexpr el) - | MLast.ExSte (_loc, e1, e2) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "ExSte")), - mloc), - mexpr e1), - mexpr e2) - | MLast.ExStr (_loc, s) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "ExStr")), - mloc), - MLast.ExStr (_loc, String.escaped s)) - | MLast.ExTry (_loc, e, pwel) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "ExTry")), - mloc), - mexpr e), - mlist mpwe pwel) - | MLast.ExTup (_loc, el) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "ExTup")), - mloc), - mlist mexpr el) - | MLast.ExTyc (_loc, e, t) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "ExTyc")), - mloc), - mexpr e), - mctyp t) - | MLast.ExUid (_loc, s) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "ExUid")), - mloc), - MLast.ExStr (_loc, s)) - | x -> not_impl "mexpr" x - and mpatt = - function - MLast.PaAcc (_loc, p1, p2) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "PaAcc")), - mloc), - mpatt p1), - mpatt p2) - | MLast.PaAny _loc -> - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "PaAny")), - mloc) - | MLast.PaApp (_loc, p1, p2) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "PaApp")), - mloc), - mpatt p1), - mpatt p2) - | MLast.PaInt (_loc, s) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "PaInt")), - mloc), - MLast.ExStr (_loc, s)) - | MLast.PaLid (_loc, s) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "PaLid")), - mloc), - MLast.ExStr (_loc, s)) - | MLast.PaOrp (_loc, p1, p2) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "PaOrp")), - mloc), - mpatt p1), - mpatt p2) - | MLast.PaStr (_loc, s) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "PaStr")), - mloc), - MLast.ExStr (_loc, String.escaped s)) - | MLast.PaTup (_loc, pl) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "PaTup")), - mloc), - mlist mpatt pl) - | MLast.PaTyc (_loc, p, t) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "PaTyc")), - mloc), - mpatt p), - mctyp t) - | MLast.PaUid (_loc, s) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "PaUid")), - mloc), - MLast.ExStr (_loc, s)) - | x -> not_impl "mpatt" x - and mctyp = - function - MLast.TyAcc (_loc, t1, t2) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "TyAcc")), - mloc), - mctyp t1), - mctyp t2) - | MLast.TyApp (loc, t1, t2) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "TyApp")), - mloc), - mctyp t1), - mctyp t2) - | MLast.TyLid (_loc, s) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "TyLid")), - mloc), - MLast.ExStr (_loc, s)) - | MLast.TyQuo (_loc, s) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "TyQuo")), - mloc), - MLast.ExStr (_loc, s)) - | MLast.TyTup (_loc, tl) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "TyTup")), - mloc), - mlist mctyp tl) - | MLast.TyUid (_loc, s) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), - MLast.ExUid (_loc, "TyUid")), - mloc), - MLast.ExStr (_loc, s)) - | x -> not_impl "mctyp" x - and mpe (p, e) = MLast.ExTup (_loc, [mpatt p; mexpr e]) - and mpwe (p, w, e) = - MLast.ExTup (_loc, [mpatt p; moption mexpr w; mexpr e]) - ;; - end -;; - -let mklistexp _loc = - let rec loop top = - function - [] -> MLast.ExUid (_loc, "[]") - | e1 :: el -> - let _loc = - if top then _loc else fst (MLast.loc_of_expr e1), snd _loc - in - MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExUid (_loc, "::"), e1), - loop false el) - in - loop true -;; - -let mklistpat _loc = - let rec loop top = - function - [] -> MLast.PaUid (_loc, "[]") - | p1 :: pl -> - let _loc = - if top then _loc else fst (MLast.loc_of_patt p1), snd _loc - in - MLast.PaApp - (_loc, MLast.PaApp (_loc, MLast.PaUid (_loc, "::"), p1), - loop false pl) - in - loop true -;; - -let rec expr_fa al = - function - MLast.ExApp (_, f, a) -> expr_fa (a :: al) f - | f -> f, al -;; - -let rec quot_expr e = - let _loc = MLast.loc_of_expr e in - match e with - MLast.ExUid (_, "None") -> - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Option")), - MLast.ExUid (_loc, "None")) - | MLast.ExApp (_, MLast.ExUid (_, "Some"), e) -> - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Option")), - MLast.ExApp (_loc, MLast.ExUid (_loc, "Some"), quot_expr e)) - | MLast.ExUid (_, "False") -> - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Bool")), - MLast.ExUid (_loc, "False")) - | MLast.ExUid (_, "True") -> - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Bool")), - MLast.ExUid (_loc, "True")) - | MLast.ExUid (_, "()") -> e - | MLast.ExApp - (_, MLast.ExAcc (_, MLast.ExUid (_, "Qast"), MLast.ExUid (_, "List")), - _) -> - e - | MLast.ExApp - (_, MLast.ExAcc (_, MLast.ExUid (_, "Qast"), MLast.ExUid (_, "Option")), - _) -> - e - | MLast.ExApp - (_, MLast.ExAcc (_, MLast.ExUid (_, "Qast"), MLast.ExUid (_, "Str")), - _) -> - e - | MLast.ExUid (_, "[]") -> - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "List")), - MLast.ExUid (_loc, "[]")) - | MLast.ExApp - (_, MLast.ExApp (_, MLast.ExUid (_, "::"), e), MLast.ExUid (_, "[]")) -> - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "List")), - MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExUid (_loc, "::"), quot_expr e), - MLast.ExUid (_loc, "[]"))) - | MLast.ExApp (_, MLast.ExApp (_, MLast.ExUid (_, "::"), e1), e2) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Cons")), - quot_expr e1), - quot_expr e2) - | MLast.ExApp (_, _, _) -> - let (f, al) = expr_fa [] e in - begin match f with - MLast.ExUid (_, c) -> - let al = List.map quot_expr al in - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Qast"), - MLast.ExUid (_loc, "Node")), - MLast.ExStr (_loc, c)), - mklistexp _loc al) - | MLast.ExAcc (_, MLast.ExUid (_, "MLast"), MLast.ExUid (_, c)) -> - let al = List.map quot_expr al in - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Qast"), - MLast.ExUid (_loc, "Node")), - MLast.ExStr (_loc, c)), - mklistexp _loc al) - | MLast.ExAcc (_, MLast.ExUid (_, m), MLast.ExUid (_, c)) -> - let al = List.map quot_expr al in - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Qast"), - MLast.ExUid (_loc, "Node")), - MLast.ExStr (_loc, (m ^ "." ^ c))), - mklistexp _loc al) - | MLast.ExLid (_, f) -> - let al = List.map quot_expr al in - List.fold_left (fun f e -> MLast.ExApp (_loc, f, e)) - (MLast.ExLid (_loc, f)) al - | _ -> e - end - | MLast.ExRec (_, pel, None) -> - begin try - let lel = - List.map - (fun (p, e) -> - let lab = - match p with - MLast.PaLid (_, c) -> MLast.ExStr (_loc, c) - | MLast.PaAcc (_, _, MLast.PaLid (_, c)) -> - MLast.ExStr (_loc, c) - | _ -> raise Not_found - in - MLast.ExTup (_loc, [lab; quot_expr e])) - pel - in - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Record")), - mklistexp _loc lel) - with - Not_found -> e - end - | MLast.ExLid (_, s) -> - if s = !(Stdpp.loc_name) then - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Loc")) - else e - | MLast.ExAcc (_, MLast.ExUid (_, "MLast"), MLast.ExUid (_, s)) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Node")), - MLast.ExStr (_loc, s)), - MLast.ExUid (_loc, "[]")) - | MLast.ExAcc (_, MLast.ExUid (_, m), MLast.ExUid (_, s)) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Node")), - MLast.ExStr (_loc, (m ^ "." ^ s))), - MLast.ExUid (_loc, "[]")) - | MLast.ExUid (_, s) -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Node")), - MLast.ExStr (_loc, s)), - MLast.ExUid (_loc, "[]")) - | MLast.ExStr (_, s) -> - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Str")), - MLast.ExStr (_loc, s)) - | MLast.ExTup (_, el) -> - let el = List.map quot_expr el in - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Tuple")), - mklistexp _loc el) - | MLast.ExLet (_, r, pel, e) -> - let pel = List.map (fun (p, e) -> p, quot_expr e) pel in - MLast.ExLet (_loc, r, pel, quot_expr e) - | _ -> e -;; - -let symgen = "xx";; - -let pname_of_ptuple pl = - List.fold_left - (fun pname p -> - match p with - MLast.PaLid (_, s) -> pname ^ s - | _ -> pname) - "" pl -;; - -let quotify_action psl act = - let e = quot_expr act in - List.fold_left - (fun e ps -> - match ps.pattern with - Some (MLast.PaTup (_, pl)) -> - let _loc = - let nowhere = - {(Lexing.dummy_pos) with Lexing.pos_lnum = 1; - Lexing.pos_cnum = 0} - in - nowhere, nowhere - in - let pname = pname_of_ptuple pl in - let (pl1, el1) = - let (l, _) = - List.fold_left - (fun (l, cnt) _ -> - (symgen ^ string_of_int cnt) :: l, cnt + 1) - ([], 1) pl - in - let l = List.rev l in - List.map (fun s -> MLast.PaLid (_loc, s)) l, - List.map (fun s -> MLast.ExLid (_loc, s)) l - in - MLast.ExLet - (_loc, false, - [MLast.PaTup (_loc, pl), - MLast.ExMat - (_loc, MLast.ExLid (_loc, pname), - [MLast.PaApp - (_loc, - MLast.PaAcc - (_loc, MLast.PaUid (_loc, "Qast"), - MLast.PaUid (_loc, "Tuple")), - mklistpat _loc pl1), - None, MLast.ExTup (_loc, el1); - MLast.PaAny _loc, None, - MLast.ExMat (_loc, MLast.ExUid (_loc, "()"), [])])], - e) - | _ -> e) - e psl -;; - -let rec make_ctyp styp tvar = - match styp with - STlid (_loc, s) -> MLast.TyLid (_loc, s) - | STapp (_loc, t1, t2) -> - MLast.TyApp (_loc, make_ctyp t1 tvar, make_ctyp t2 tvar) - | STquo (_loc, s) -> MLast.TyQuo (_loc, s) - | STself (_loc, x) -> - if tvar = "" then - Stdpp.raise_with_loc _loc - (Stream.Error ("'" ^ x ^ "' illegal in anonymous entry level")) - else MLast.TyQuo (_loc, tvar) - | STtyp t -> t -;; - -let rec make_expr gmod tvar = - function - TXmeta (_loc, n, tl, e, t) -> - let el = - List.fold_right - (fun t el -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, MLast.ExUid (_loc, "::"), make_expr gmod "" t), - el)) - tl (MLast.ExUid (_loc, "[]")) - in - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Gramext"), - MLast.ExUid (_loc, "Smeta")), - MLast.ExStr (_loc, n)), - el), - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Obj"), MLast.ExLid (_loc, "repr")), - MLast.ExTyc (_loc, e, make_ctyp t tvar))) - | TXlist (_loc, min, t, ts) -> - let txt = make_expr gmod "" t in - begin match min, ts with - false, None -> - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Gramext"), - MLast.ExUid (_loc, "Slist0")), - txt) - | true, None -> - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Gramext"), - MLast.ExUid (_loc, "Slist1")), - txt) - | false, Some s -> - let x = make_expr gmod tvar s in - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Gramext"), - MLast.ExUid (_loc, "Slist0sep")), - txt), - x) - | true, Some s -> - let x = make_expr gmod tvar s in - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Gramext"), - MLast.ExUid (_loc, "Slist1sep")), - txt), - x) - end - | TXnext _loc -> - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Gramext"), MLast.ExUid (_loc, "Snext")) - | TXnterm (_loc, n, lev) -> - begin match lev with - Some lab -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Gramext"), - MLast.ExUid (_loc, "Snterml")), - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, gmod), - MLast.ExUid (_loc, "Entry")), - MLast.ExLid (_loc, "obj")), - MLast.ExTyc - (_loc, n.expr, - MLast.TyApp - (_loc, - MLast.TyAcc - (_loc, - MLast.TyAcc - (_loc, MLast.TyUid (_loc, gmod), - MLast.TyUid (_loc, "Entry")), - MLast.TyLid (_loc, "e")), - MLast.TyQuo (_loc, n.tvar))))), - MLast.ExStr (_loc, lab)) - | None -> - if n.tvar = tvar then - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Gramext"), - MLast.ExUid (_loc, "Sself")) - else - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Gramext"), - MLast.ExUid (_loc, "Snterm")), - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, gmod), - MLast.ExUid (_loc, "Entry")), - MLast.ExLid (_loc, "obj")), - MLast.ExTyc - (_loc, n.expr, - MLast.TyApp - (_loc, - MLast.TyAcc - (_loc, - MLast.TyAcc - (_loc, MLast.TyUid (_loc, gmod), - MLast.TyUid (_loc, "Entry")), - MLast.TyLid (_loc, "e")), - MLast.TyQuo (_loc, n.tvar))))) - end - | TXopt (_loc, t) -> - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Gramext"), MLast.ExUid (_loc, "Sopt")), - make_expr gmod "" t) - | TXrules (_loc, rl) -> - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Gramext"), - MLast.ExLid (_loc, "srules")), - make_expr_rules _loc gmod rl "") - | TXself _loc -> - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Gramext"), MLast.ExUid (_loc, "Sself")) - | TXtok (_loc, s, e) -> - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Gramext"), - MLast.ExUid (_loc, "Stoken")), - MLast.ExTup (_loc, [MLast.ExStr (_loc, s); e])) -and make_expr_rules _loc gmod rl tvar = - List.fold_left - (fun txt (sl, ac) -> - let sl = - List.fold_right - (fun t txt -> - let x = make_expr gmod tvar t in - MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExUid (_loc, "::"), x), txt)) - sl (MLast.ExUid (_loc, "[]")) - in - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, MLast.ExUid (_loc, "::"), MLast.ExTup (_loc, [sl; ac])), - txt)) - (MLast.ExUid (_loc, "[]")) rl -;; - -let text_of_action _loc psl rtvar act tvar = - let locid = MLast.PaLid (_loc, !(Stdpp.loc_name)) in - let act = - match act with - Some act -> if !quotify then quotify_action psl act else act - | None -> MLast.ExUid (_loc, "()") - in - let e = - MLast.ExFun - (_loc, - [MLast.PaTyc - (_loc, locid, - MLast.TyTup - (_loc, - [MLast.TyAcc - (_loc, MLast.TyUid (_loc, "Lexing"), - MLast.TyLid (_loc, "position")); - MLast.TyAcc - (_loc, MLast.TyUid (_loc, "Lexing"), - MLast.TyLid (_loc, "position"))])), - None, MLast.ExTyc (_loc, act, MLast.TyQuo (_loc, rtvar))]) - in - let txt = - List.fold_left - (fun txt ps -> - match ps.pattern with - None -> MLast.ExFun (_loc, [MLast.PaAny _loc, None, txt]) - | Some p -> - let t = make_ctyp ps.symbol.styp tvar in - let p = - match p with - MLast.PaTup (_, pl) when !quotify -> - MLast.PaLid (_loc, pname_of_ptuple pl) - | _ -> p - in - MLast.ExFun (_loc, [MLast.PaTyc (_loc, p, t), None, txt])) - e psl - in - let txt = - if !meta_action then - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Obj"), MLast.ExLid (_loc, "magic")), - MetaAction.mexpr txt) - else txt - in - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Gramext"), MLast.ExLid (_loc, "action")), - txt) -;; - -let srules loc t rl tvar = - List.map - (fun r -> - let sl = List.map (fun ps -> ps.symbol.text) r.prod in - let ac = text_of_action loc r.prod t r.action tvar in sl, ac) - rl -;; - -let expr_of_delete_rule _loc gmod n sl = - let sl = - List.fold_right - (fun s e -> - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, MLast.ExUid (_loc, "::"), make_expr gmod "" s.text), - e)) - sl (MLast.ExUid (_loc, "[]")) - in - n.expr, sl -;; - -let rec ident_of_expr = - function - MLast.ExLid (_, s) -> s - | MLast.ExUid (_, s) -> s - | MLast.ExAcc (_, e1, e2) -> ident_of_expr e1 ^ "__" ^ ident_of_expr e2 - | _ -> failwith "internal error in pa_extend" -;; - -let mk_name loc e = {expr = e; tvar = ident_of_expr e; loc = loc};; - -let slist loc min sep symb = - let t = - match sep with - Some s -> Some s.text - | None -> None - in - TXlist (loc, min, symb.text, t) -;; - -let sstoken _loc s = - let n = mk_name _loc (MLast.ExLid (_loc, ("a_" ^ s))) in - TXnterm (_loc, n, None) -;; - -let mk_psymbol p s t = - let symb = {used = []; text = s; styp = t} in - {pattern = Some p; symbol = symb} -;; - -let sslist _loc min sep s = - let rl = - let r1 = - let prod = - let n = mk_name _loc (MLast.ExLid (_loc, "a_list")) in - [mk_psymbol (MLast.PaLid (_loc, "a")) (TXnterm (_loc, n, None)) - (STquo (_loc, "a_list"))] - in - let act = MLast.ExLid (_loc, "a") in {prod = prod; action = Some act} - in - let r2 = - let prod = - [mk_psymbol (MLast.PaLid (_loc, "a")) (slist _loc min sep s) - (STapp (_loc, STlid (_loc, "list"), s.styp))] - in - let act = - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "List")), - MLast.ExLid (_loc, "a")) - in - {prod = prod; action = Some act} - in - [r1; r2] - in - let used = - match sep with - Some symb -> symb.used @ s.used - | None -> s.used - in - let used = "a_list" :: used in - let text = TXrules (_loc, srules _loc "a_list" rl "") in - let styp = STquo (_loc, "a_list") in {used = used; text = text; styp = styp} -;; - -let ssopt _loc s = - let rl = - let r1 = - let prod = - let n = mk_name _loc (MLast.ExLid (_loc, "a_opt")) in - [mk_psymbol (MLast.PaLid (_loc, "a")) (TXnterm (_loc, n, None)) - (STquo (_loc, "a_opt"))] - in - let act = MLast.ExLid (_loc, "a") in {prod = prod; action = Some act} - in - let r2 = - let s = - match s.text with - TXtok (_loc, "", MLast.ExStr (_, _)) -> - let rl = - [{prod = - [{pattern = Some (MLast.PaLid (_loc, "x")); symbol = s}]; - action = - Some - (MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Qast"), - MLast.ExUid (_loc, "Str")), - MLast.ExLid (_loc, "x")))}] - in - let t = new_type_var () in - {used = []; text = TXrules (_loc, srules _loc t rl ""); - styp = STquo (_loc, t)} - | _ -> s - in - let prod = - [mk_psymbol (MLast.PaLid (_loc, "a")) (TXopt (_loc, s.text)) - (STapp (_loc, STlid (_loc, "option"), s.styp))] - in - let act = - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Qast"), MLast.ExUid (_loc, "Option")), - MLast.ExLid (_loc, "a")) - in - {prod = prod; action = Some act} - in - [r1; r2] - in - let used = "a_opt" :: s.used in - let text = TXrules (_loc, srules _loc "a_opt" rl "") in - let styp = STquo (_loc, "a_opt") in {used = used; text = text; styp = styp} -;; - -let text_of_entry _loc gmod e = - let ent = - let x = e.name in - let _loc = e.name.loc in - MLast.ExTyc - (_loc, x.expr, - MLast.TyApp - (_loc, - MLast.TyAcc - (_loc, - MLast.TyAcc - (_loc, MLast.TyUid (_loc, gmod), MLast.TyUid (_loc, "Entry")), - MLast.TyLid (_loc, "e")), - MLast.TyQuo (_loc, x.tvar))) - in - let pos = - match e.pos with - Some pos -> MLast.ExApp (_loc, MLast.ExUid (_loc, "Some"), pos) - | None -> MLast.ExUid (_loc, "None") - in - let txt = - List.fold_right - (fun level txt -> - let lab = - match level.label with - Some lab -> - MLast.ExApp - (_loc, MLast.ExUid (_loc, "Some"), MLast.ExStr (_loc, lab)) - | None -> MLast.ExUid (_loc, "None") - in - let ass = - match level.assoc with - Some ass -> MLast.ExApp (_loc, MLast.ExUid (_loc, "Some"), ass) - | None -> MLast.ExUid (_loc, "None") - in - let txt = - let rl = srules _loc e.name.tvar level.rules e.name.tvar in - let e = make_expr_rules _loc gmod rl e.name.tvar in - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, MLast.ExUid (_loc, "::"), - MLast.ExTup (_loc, [lab; ass; e])), - txt) - in - txt) - e.levels (MLast.ExUid (_loc, "[]")) - in - ent, pos, txt -;; - -let let_in_of_extend _loc gmod functor_version gl el args = - match gl with - Some (n1 :: _ as nl) -> - check_use nl el; - let ll = - let same_tvar e n = e.name.tvar = n.tvar in - List.fold_right - (fun e ll -> - match e.name.expr with - MLast.ExLid (_, _) -> - if List.exists (same_tvar e) nl then ll - else if List.exists (same_tvar e) ll then ll - else e.name :: ll - | _ -> ll) - el [] - in - let globals = - List.map - (fun {expr = e; tvar = x; loc = _loc} -> - MLast.PaAny _loc, - MLast.ExTyc - (_loc, e, - MLast.TyApp - (_loc, - MLast.TyAcc - (_loc, - MLast.TyAcc - (_loc, MLast.TyUid (_loc, gmod), - MLast.TyUid (_loc, "Entry")), - MLast.TyLid (_loc, "e")), - MLast.TyQuo (_loc, x)))) - nl - in - let locals = - List.map - (fun {expr = e; tvar = x; loc = _loc} -> - let i = - match e with - MLast.ExLid (_, i) -> i - | _ -> failwith "internal error in pa_extend" - in - MLast.PaLid (_loc, i), - MLast.ExTyc - (_loc, - MLast.ExApp - (_loc, MLast.ExLid (_loc, "grammar_entry_create"), - MLast.ExStr (_loc, i)), - MLast.TyApp - (_loc, - MLast.TyAcc - (_loc, - MLast.TyAcc - (_loc, MLast.TyUid (_loc, gmod), - MLast.TyUid (_loc, "Entry")), - MLast.TyLid (_loc, "e")), - MLast.TyQuo (_loc, x)))) - ll - in - let e = - if ll = [] then args - else if functor_version then - MLast.ExLet - (_loc, false, - [MLast.PaLid (_loc, "grammar_entry_create"), - MLast.ExAcc - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, gmod), - MLast.ExUid (_loc, "Entry")), - MLast.ExLid (_loc, "create"))], - MLast.ExLet (_loc, false, locals, args)) - else - MLast.ExLet - (_loc, false, - [MLast.PaLid (_loc, "grammar_entry_create"), - MLast.ExFun - (_loc, - [MLast.PaLid (_loc, "s"), None, - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, gmod), - MLast.ExUid (_loc, "Entry")), - MLast.ExLid (_loc, "create")), - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, gmod), - MLast.ExLid (_loc, "of_entry")), - locate n1)), - MLast.ExLid (_loc, "s"))])], - MLast.ExLet (_loc, false, locals, args)) - in - MLast.ExLet (_loc, false, globals, e) - | _ -> args -;; - -let text_of_extend _loc gmod gl el f = - if !split_ext then - let args = - List.map - (fun e -> - let (ent, pos, txt) = text_of_entry e.name.loc gmod e in - let ent = - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, gmod), - MLast.ExUid (_loc, "Entry")), - MLast.ExLid (_loc, "obj")), - ent) - in - let e = MLast.ExTup (_loc, [ent; pos; txt]) in - MLast.ExLet - (_loc, false, - [MLast.PaLid (_loc, "aux"), - MLast.ExFun - (_loc, - [MLast.PaUid (_loc, "()"), None, - MLast.ExApp - (_loc, f, - MLast.ExApp - (_loc, - MLast.ExApp (_loc, MLast.ExUid (_loc, "::"), e), - MLast.ExUid (_loc, "[]")))])], - MLast.ExApp - (_loc, MLast.ExLid (_loc, "aux"), MLast.ExUid (_loc, "()")))) - el - in - let args = MLast.ExSeq (_loc, args) in - let_in_of_extend _loc gmod false gl el args - else - let args = - List.fold_right - (fun e el -> - let (ent, pos, txt) = text_of_entry e.name.loc gmod e in - let ent = - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, gmod), - MLast.ExUid (_loc, "Entry")), - MLast.ExLid (_loc, "obj")), - ent) - in - let e = MLast.ExTup (_loc, [ent; pos; txt]) in - MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExUid (_loc, "::"), e), el)) - el (MLast.ExUid (_loc, "[]")) - in - let args = let_in_of_extend _loc gmod false gl el args in - MLast.ExApp (_loc, f, args) -;; - -let text_of_functorial_extend _loc gmod gl el = - let args = - let el = - List.map - (fun e -> - let (ent, pos, txt) = text_of_entry e.name.loc gmod e in - let e = - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, gmod), - MLast.ExLid (_loc, "extend")), - ent), - pos), - txt) - in - if !split_ext then - MLast.ExLet - (_loc, false, - [MLast.PaLid (_loc, "aux"), - MLast.ExFun (_loc, [MLast.PaUid (_loc, "()"), None, e])], - MLast.ExApp - (_loc, MLast.ExLid (_loc, "aux"), MLast.ExUid (_loc, "()"))) - else e) - el - in - MLast.ExSeq (_loc, el) - in - let_in_of_extend _loc gmod true gl el args -;; - -let zero_loc = {(Lexing.dummy_pos) with Lexing.pos_cnum = 0};; - -open Pcaml;; -let symbol = Grammar.Entry.create gram "symbol";; -let semi_sep = - if !syntax_name = "Scheme" then - Grammar.Entry.of_parser gram "'/'" - (fun (strm__ : _ Stream.t) -> - match Stream.peek strm__ with - Some ("", "/") -> Stream.junk strm__; () - | _ -> raise Stream.Failure) - else - Grammar.Entry.of_parser gram "';'" - (fun (strm__ : _ Stream.t) -> - match Stream.peek strm__ with - Some ("", ";") -> Stream.junk strm__; () - | _ -> raise Stream.Failure) -;; - -Grammar.extend - (let _ = (expr : 'expr Grammar.Entry.e) - and _ = (symbol : 'symbol Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry expr) s - in - let extend_body : 'extend_body Grammar.Entry.e = - grammar_entry_create "extend_body" - and gextend_body : 'gextend_body Grammar.Entry.e = - grammar_entry_create "gextend_body" - and delete_rule_body : 'delete_rule_body Grammar.Entry.e = - grammar_entry_create "delete_rule_body" - and gdelete_rule_body : 'gdelete_rule_body Grammar.Entry.e = - grammar_entry_create "gdelete_rule_body" - and efunction : 'efunction Grammar.Entry.e = - grammar_entry_create "efunction" - and global : 'global Grammar.Entry.e = grammar_entry_create "global" - and entry : 'entry Grammar.Entry.e = grammar_entry_create "entry" - and position : 'position Grammar.Entry.e = grammar_entry_create "position" - and level_list : 'level_list Grammar.Entry.e = - grammar_entry_create "level_list" - and level : 'level Grammar.Entry.e = grammar_entry_create "level" - and assoc : 'assoc Grammar.Entry.e = grammar_entry_create "assoc" - and rule_list : 'rule_list Grammar.Entry.e = - grammar_entry_create "rule_list" - and rule : 'rule Grammar.Entry.e = grammar_entry_create "rule" - and psymbol : 'psymbol Grammar.Entry.e = grammar_entry_create "psymbol" - and pattern : 'pattern Grammar.Entry.e = grammar_entry_create "pattern" - and patterns_comma : 'patterns_comma Grammar.Entry.e = - grammar_entry_create "patterns_comma" - and name : 'name Grammar.Entry.e = grammar_entry_create "name" - and qualid : 'qualid Grammar.Entry.e = grammar_entry_create "qualid" - and string : 'string Grammar.Entry.e = grammar_entry_create "string" in - [Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.After "top"), - [None, None, - [[Gramext.Stoken ("", "GDELETE_RULE"); - Gramext.Snterm - (Grammar.Entry.obj - (gdelete_rule_body : 'gdelete_rule_body Grammar.Entry.e)); - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (e : 'gdelete_rule_body) _ - (_loc : Lexing.position * Lexing.position) -> - (e : 'expr)); - [Gramext.Stoken ("", "DELETE_RULE"); - Gramext.Snterm - (Grammar.Entry.obj - (delete_rule_body : 'delete_rule_body Grammar.Entry.e)); - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (e : 'delete_rule_body) _ - (_loc : Lexing.position * Lexing.position) -> - (e : 'expr)); - [Gramext.Stoken ("", "GEXTEND"); - Gramext.Snterm - (Grammar.Entry.obj (gextend_body : 'gextend_body Grammar.Entry.e)); - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (e : 'gextend_body) _ - (_loc : Lexing.position * Lexing.position) -> - (e : 'expr)); - [Gramext.Stoken ("", "EXTEND"); - Gramext.Snterm - (Grammar.Entry.obj (extend_body : 'extend_body Grammar.Entry.e)); - Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (e : 'extend_body) _ - (_loc : Lexing.position * Lexing.position) -> - (e : 'expr))]]; - Grammar.Entry.obj (extend_body : 'extend_body Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (efunction : 'efunction Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (global : 'global Grammar.Entry.e))); - Gramext.Slist1 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (entry : 'entry Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))], - Gramext.action - (fun _ (e : 'entry) - (_loc : Lexing.position * Lexing.position) -> - (e : 'e__1))])], - Gramext.action - (fun (el : 'e__1 list) (sl : 'global option) (f : 'efunction) - (_loc : Lexing.position * Lexing.position) -> - (text_of_extend _loc "Grammar" sl el f : 'extend_body))]]; - Grammar.Entry.obj (gextend_body : 'gextend_body Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("UIDENT", ""); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (global : 'global Grammar.Entry.e))); - Gramext.Slist1 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (entry : 'entry Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))], - Gramext.action - (fun _ (e : 'entry) - (_loc : Lexing.position * Lexing.position) -> - (e : 'e__2))])], - Gramext.action - (fun (el : 'e__2 list) (sl : 'global option) (g : string) - (_loc : Lexing.position * Lexing.position) -> - (text_of_functorial_extend _loc g sl el : 'gextend_body))]]; - Grammar.Entry.obj (delete_rule_body : 'delete_rule_body Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e)), - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))], - Gramext.action - (fun (sl : 'symbol list) _ (n : 'name) - (_loc : Lexing.position * Lexing.position) -> - (let (e, b) = expr_of_delete_rule _loc "Grammar" n sl in - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Grammar"), - MLast.ExLid (_loc, "delete_rule")), - e), - b) : - 'delete_rule_body))]]; - Grammar.Entry.obj - (gdelete_rule_body : 'gdelete_rule_body Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("UIDENT", ""); - Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e)), - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))], - Gramext.action - (fun (sl : 'symbol list) _ (n : 'name) (g : string) - (_loc : Lexing.position * Lexing.position) -> - (let (e, b) = expr_of_delete_rule _loc g n sl in - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, g), - MLast.ExLid (_loc, "delete_rule")), - e), - b) : - 'gdelete_rule_body))]]; - Grammar.Entry.obj (efunction : 'efunction Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (_loc : Lexing.position * Lexing.position) -> - (MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Grammar"), - MLast.ExLid (_loc, "extend")) : - 'efunction)); - [Gramext.Stoken ("UIDENT", "FUNCTION"); Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))], - Gramext.action - (fun _ (f : 'qualid) _ _ (_loc : Lexing.position * Lexing.position) -> - (f : 'efunction))]]; - Grammar.Entry.obj (global : 'global Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("UIDENT", "GLOBAL"); Gramext.Stoken ("", ":"); - Gramext.Slist1 - (Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))], - Gramext.action - (fun _ (sl : 'name list) _ _ - (_loc : Lexing.position * Lexing.position) -> - (sl : 'global))]]; - Grammar.Entry.obj (entry : 'entry Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (position : 'position Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj (level_list : 'level_list Grammar.Entry.e))], - Gramext.action - (fun (ll : 'level_list) (pos : 'position option) _ (n : 'name) - (_loc : Lexing.position * Lexing.position) -> - ({name = n; pos = pos; levels = ll} : 'entry))]]; - Grammar.Entry.obj (position : 'position Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("UIDENT", "LEVEL"); - Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))], - Gramext.action - (fun (n : 'string) _ (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Gramext"), - MLast.ExUid (_loc, "Level")), - n) : - 'position)); - [Gramext.Stoken ("UIDENT", "AFTER"); - Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))], - Gramext.action - (fun (n : 'string) _ (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Gramext"), - MLast.ExUid (_loc, "After")), - n) : - 'position)); - [Gramext.Stoken ("UIDENT", "BEFORE"); - Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))], - Gramext.action - (fun (n : 'string) _ (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Gramext"), - MLast.ExUid (_loc, "Before")), - n) : - 'position)); - [Gramext.Stoken ("UIDENT", "LAST")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - (MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Gramext"), - MLast.ExUid (_loc, "Last")) : - 'position)); - [Gramext.Stoken ("UIDENT", "FIRST")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - (MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Gramext"), - MLast.ExUid (_loc, "First")) : - 'position))]]; - Grammar.Entry.obj (level_list : 'level_list Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm (Grammar.Entry.obj (level : 'level Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (ll : 'level list) _ - (_loc : Lexing.position * Lexing.position) -> - (ll : 'level_list))]]; - Grammar.Entry.obj (level : 'level Grammar.Entry.e), None, - [None, None, - [[Gramext.Sopt (Gramext.Stoken ("STRING", "")); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (assoc : 'assoc Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj (rule_list : 'rule_list Grammar.Entry.e))], - Gramext.action - (fun (rules : 'rule_list) (ass : 'assoc option) (lab : string option) - (_loc : Lexing.position * Lexing.position) -> - ({label = lab; assoc = ass; rules = rules} : 'level))]]; - Grammar.Entry.obj (assoc : 'assoc Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("UIDENT", "NONA")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - (MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Gramext"), - MLast.ExUid (_loc, "NonA")) : - 'assoc)); - [Gramext.Stoken ("UIDENT", "RIGHTA")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - (MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Gramext"), - MLast.ExUid (_loc, "RightA")) : - 'assoc)); - [Gramext.Stoken ("UIDENT", "LEFTA")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - (MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Gramext"), - MLast.ExUid (_loc, "LeftA")) : - 'assoc))]]; - Grammar.Entry.obj (rule_list : 'rule_list Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "["); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (rule : 'rule Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rules : 'rule list) _ - (_loc : Lexing.position * Lexing.position) -> - (retype_rule_list_without_patterns _loc rules : 'rule_list)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")], - Gramext.action - (fun _ _ (_loc : Lexing.position * Lexing.position) -> - ([] : 'rule_list))]]; - Grammar.Entry.obj (rule : 'rule Grammar.Entry.e), None, - [None, None, - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (psymbol : 'psymbol Grammar.Entry.e)), - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e)))], - Gramext.action - (fun (psl : 'psymbol list) - (_loc : Lexing.position * Lexing.position) -> - ({prod = psl; action = None} : 'rule)); - [Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (psymbol : 'psymbol Grammar.Entry.e)), - Gramext.Snterm - (Grammar.Entry.obj (semi_sep : 'semi_sep Grammar.Entry.e))); - Gramext.Stoken ("", "->"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (act : 'expr) _ (psl : 'psymbol list) - (_loc : Lexing.position * Lexing.position) -> - ({prod = psl; action = Some act} : 'rule))]]; - Grammar.Entry.obj (psymbol : 'psymbol Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))], - Gramext.action - (fun (s : 'symbol) (_loc : Lexing.position * Lexing.position) -> - ({pattern = None; symbol = s} : 'psymbol)); - [Gramext.Snterm - (Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))], - Gramext.action - (fun (s : 'symbol) _ (p : 'pattern) - (_loc : Lexing.position * Lexing.position) -> - ({pattern = Some p; symbol = s} : 'psymbol)); - [Gramext.Stoken ("LIDENT", ""); - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("UIDENT", "LEVEL"); - Gramext.Stoken ("STRING", "")], - Gramext.action - (fun (s : string) _ - (_loc : Lexing.position * Lexing.position) -> - (s : 'e__3))])], - Gramext.action - (fun (lev : 'e__3 option) (i : string) - (_loc : Lexing.position * Lexing.position) -> - (let name = mk_name _loc (MLast.ExLid (_loc, i)) in - let text = TXnterm (_loc, name, lev) in - let styp = STquo (_loc, i) in - let symb = {used = [i]; text = text; styp = styp} in - {pattern = None; symbol = symb} : - 'psymbol)); - [Gramext.Stoken ("LIDENT", ""); Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))], - Gramext.action - (fun (s : 'symbol) _ (p : string) - (_loc : Lexing.position * Lexing.position) -> - ({pattern = Some (MLast.PaLid (_loc, p)); symbol = s} : - 'psymbol))]]; - Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e), None, - [Some "top", Some Gramext.NonA, - [[Gramext.Stoken ("UIDENT", "OPT"); Gramext.Sself], - Gramext.action - (fun (s : 'symbol) _ (_loc : Lexing.position * Lexing.position) -> - (if !quotify then ssopt _loc s - else - let styp = STapp (_loc, STlid (_loc, "option"), s.styp) in - let text = TXopt (_loc, s.text) in - {used = s.used; text = text; styp = styp} : - 'symbol)); - [Gramext.Stoken ("UIDENT", "LIST1"); Gramext.Sself; - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("UIDENT", "SEP"); - Gramext.Snterm - (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))], - Gramext.action - (fun (t : 'symbol) _ - (_loc : Lexing.position * Lexing.position) -> - (t : 'e__5))])], - Gramext.action - (fun (sep : 'e__5 option) (s : 'symbol) _ - (_loc : Lexing.position * Lexing.position) -> - (if !quotify then sslist _loc true sep s - else - let used = - match sep with - Some symb -> symb.used @ s.used - | None -> s.used - in - let styp = STapp (_loc, STlid (_loc, "list"), s.styp) in - let text = slist _loc true sep s in - {used = used; text = text; styp = styp} : - 'symbol)); - [Gramext.Stoken ("UIDENT", "LIST0"); Gramext.Sself; - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("UIDENT", "SEP"); - Gramext.Snterm - (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))], - Gramext.action - (fun (t : 'symbol) _ - (_loc : Lexing.position * Lexing.position) -> - (t : 'e__4))])], - Gramext.action - (fun (sep : 'e__4 option) (s : 'symbol) _ - (_loc : Lexing.position * Lexing.position) -> - (if !quotify then sslist _loc false sep s - else - let used = - match sep with - Some symb -> symb.used @ s.used - | None -> s.used - in - let styp = STapp (_loc, STlid (_loc, "list"), s.styp) in - let text = slist _loc false sep s in - {used = used; text = text; styp = styp} : - 'symbol))]; - None, None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (s_t : 'symbol) _ (_loc : Lexing.position * Lexing.position) -> - (s_t : 'symbol)); - [Gramext.Snterm (Grammar.Entry.obj (name : 'name Grammar.Entry.e)); - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("UIDENT", "LEVEL"); - Gramext.Stoken ("STRING", "")], - Gramext.action - (fun (s : string) _ - (_loc : Lexing.position * Lexing.position) -> - (s : 'e__7))])], - Gramext.action - (fun (lev : 'e__7 option) (n : 'name) - (_loc : Lexing.position * Lexing.position) -> - ({used = [n.tvar]; text = TXnterm (_loc, n, lev); - styp = STquo (_loc, n.tvar)} : - 'symbol)); - [Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "."); - Gramext.Snterm (Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e)); - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("UIDENT", "LEVEL"); - Gramext.Stoken ("STRING", "")], - Gramext.action - (fun (s : string) _ - (_loc : Lexing.position * Lexing.position) -> - (s : 'e__6))])], - Gramext.action - (fun (lev : 'e__6 option) (e : 'qualid) _ (i : string) - (_loc : Lexing.position * Lexing.position) -> - (let n = - mk_name _loc (MLast.ExAcc (_loc, MLast.ExUid (_loc, i), e)) - in - {used = [n.tvar]; text = TXnterm (_loc, n, lev); - styp = STquo (_loc, n.tvar)} : - 'symbol)); - [Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))], - Gramext.action - (fun (e : 'string) (_loc : Lexing.position * Lexing.position) -> - (let text = TXtok (_loc, "", e) in - {used = []; text = text; styp = STlid (_loc, "string")} : - 'symbol)); - [Gramext.Stoken ("UIDENT", ""); - Gramext.Snterm (Grammar.Entry.obj (string : 'string Grammar.Entry.e))], - Gramext.action - (fun (e : 'string) (x : string) - (_loc : Lexing.position * Lexing.position) -> - (let text = TXtok (_loc, x, e) in - {used = []; text = text; styp = STlid (_loc, "string")} : - 'symbol)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (x : string) (_loc : Lexing.position * Lexing.position) -> - (let text = - if !quotify then sstoken _loc x - else TXtok (_loc, x, MLast.ExStr (_loc, "")) - in - {used = []; text = text; styp = STlid (_loc, "string")} : - 'symbol)); - [Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm (Grammar.Entry.obj (rule : 'rule Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rl : 'rule list) _ - (_loc : Lexing.position * Lexing.position) -> - (let rl = retype_rule_list_without_patterns _loc rl in - let t = new_type_var () in - {used = used_of_rule_list rl; - text = TXrules (_loc, srules _loc t rl ""); - styp = STquo (_loc, t)} : - 'symbol)); - [Gramext.Stoken ("UIDENT", "NEXT")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - ({used = []; text = TXnext _loc; styp = STself (_loc, "NEXT")} : - 'symbol)); - [Gramext.Stoken ("UIDENT", "SELF")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - ({used = []; text = TXself _loc; styp = STself (_loc, "SELF")} : - 'symbol))]]; - Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.Snterm - (Grammar.Entry.obj - (patterns_comma : 'patterns_comma Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (pl : 'patterns_comma) _ (p : 'pattern) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaTup (_loc, (p :: pl)) : 'pattern)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p : 'pattern) _ (_loc : Lexing.position * Lexing.position) -> - (p : 'pattern)); - [Gramext.Stoken ("", "_")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - (MLast.PaAny _loc : 'pattern)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.PaLid (_loc, i) : 'pattern))]]; - Grammar.Entry.obj (patterns_comma : 'patterns_comma Grammar.Entry.e), - None, - [None, None, - [[Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.Snterm - (Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e))], - Gramext.action - (fun (p : 'pattern) _ (pl : 'patterns_comma) - (_loc : Lexing.position * Lexing.position) -> - (pl @ [p] : 'patterns_comma))]; - None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (pattern : 'pattern Grammar.Entry.e))], - Gramext.action - (fun (p : 'pattern) (_loc : Lexing.position * Lexing.position) -> - ([p] : 'patterns_comma))]]; - Grammar.Entry.obj (name : 'name Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e))], - Gramext.action - (fun (e : 'qualid) (_loc : Lexing.position * Lexing.position) -> - (mk_name _loc e : 'name))]]; - Grammar.Entry.obj (qualid : 'qualid Grammar.Entry.e), None, - [None, None, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (e2 : 'qualid) _ (e1 : 'qualid) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExAcc (_loc, e1, e2) : 'qualid))]; - None, None, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.ExLid (_loc, i) : 'qualid)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.ExUid (_loc, i) : 'qualid))]]; - Grammar.Entry.obj (string : 'string Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (let shift = Reloc.shift_pos (String.length "$") (fst _loc) in - let e = - try Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string i) with - Exc_located ((bp, ep), exc) -> - raise_with_loc (Reloc.adjust_loc shift (bp, ep)) exc - in - Pcaml.expr_reloc (fun (bp, ep) -> Reloc.adjust_loc shift (bp, ep)) - zero_loc e : - 'string)); - [Gramext.Stoken ("STRING", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.ExStr (_loc, s) : 'string))]]]);; - -Pcaml.add_option "-quotify" (Arg.Set quotify) "Generate code for quotations";; - -Pcaml.add_option "-meta_action" (Arg.Set meta_action) "Undocumented";; diff --git a/camlp4/ocaml_src/meta/pa_extend_m.ml b/camlp4/ocaml_src/meta/pa_extend_m.ml deleted file mode 100644 index 44e21767..00000000 --- a/camlp4/ocaml_src/meta/pa_extend_m.ml +++ /dev/null @@ -1,47 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Pa_extend;; - -Grammar.extend - [Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, Some Gramext.NonA, - [[Gramext.Stoken ("UIDENT", "SOPT"); Gramext.Sself], - Gramext.action - (fun (s : 'symbol) _ (_loc : Lexing.position * Lexing.position) -> - (ssopt _loc s : 'symbol)); - [Gramext.srules - [[Gramext.Stoken ("UIDENT", "SLIST1")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - (true : 'e__1)); - [Gramext.Stoken ("UIDENT", "SLIST0")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - (false : 'e__1))]; - Gramext.Sself; - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("UIDENT", "SEP"); - Gramext.Snterm - (Grammar.Entry.obj (symbol : 'symbol Grammar.Entry.e))], - Gramext.action - (fun (t : 'symbol) _ - (_loc : Lexing.position * Lexing.position) -> - (t : 'e__2))])], - Gramext.action - (fun (sep : 'e__2 option) (s : 'symbol) (min : 'e__1) - (_loc : Lexing.position * Lexing.position) -> - (sslist _loc min sep s : 'symbol))]]];; diff --git a/camlp4/ocaml_src/meta/pa_macro.ml b/camlp4/ocaml_src/meta/pa_macro.ml deleted file mode 100644 index 0e834f0d..00000000 --- a/camlp4/ocaml_src/meta/pa_macro.ml +++ /dev/null @@ -1,503 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) - -(* -Added statements: - - At toplevel (structure item): - - DEFINE - DEFINE = - DEFINE () = - IFDEF THEN (END | ENDIF) - IFDEF THEN ELSE (END | ENDIF) - IFNDEF THEN (END | ENDIF) - IFNDEF THEN ELSE (END | ENDIF) - INCLUDE - - In expressions: - - IFDEF THEN ELSE (END | ENDIF) - IFNDEF THEN ELSE (END | ENDIF) - __FILE__ - __LOCATION__ - - In patterns: - - IFDEF THEN ELSE (END | ENDIF) - IFNDEF THEN ELSE (END | ENDIF) - - As Camlp4 options: - - -D define - -U undefine it - -I add to the search path for INCLUDE'd files - - After having used a DEFINE followed by "= ", you - can use it in expressions *and* in patterns. If the expression defining - the macro cannot be used as a pattern, there is an error message if - it is used in a pattern. - - - - The toplevel statement INCLUDE can be used to include a - file containing macro definitions; note that files included in such - a way can not have any non-macro toplevel items. The included files - are looked up in directories passed in via the -I option, falling - back to the current directory. - - The expression __FILE__ returns the current compiled file name. - The expression __LOCATION__ returns the current location of itself. - -*) - -(* #load "pa_extend.cmo" *) -(* #load "q_MLast.cmo" *) - -open Pcaml;; - -type 'a item_or_def = - SdStr of 'a - | SdDef of string * (string list * MLast.expr) option - | SdUnd of string - | SdITE of string * 'a item_or_def list * 'a item_or_def list - | SdInc of string -;; - -let rec list_remove x = - function - (y, _) :: l when y = x -> l - | d :: l -> d :: list_remove x l - | [] -> [] -;; - -let defined = ref [];; - -let is_defined i = List.mem_assoc i !defined;; - -let _loc = - let nowhere = - {(Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0} - in - nowhere, nowhere -;; - -let subst mloc env = - let rec loop = - function - MLast.ExLet (_, rf, pel, e) -> - let pel = List.map (fun (p, e) -> p, loop e) pel in - MLast.ExLet (_loc, rf, pel, loop e) - | MLast.ExIfe (_, e1, e2, e3) -> - MLast.ExIfe (_loc, loop e1, loop e2, loop e3) - | MLast.ExApp (_, e1, e2) -> MLast.ExApp (_loc, loop e1, loop e2) - | MLast.ExFun (_, [args, None, e]) -> - MLast.ExFun (_loc, [args, None, loop e]) - | MLast.ExFun (_, peoel) -> MLast.ExFun (_loc, List.map loop_peoel peoel) - | MLast.ExLid (_, x) | MLast.ExUid (_, x) as e -> - begin try MLast.ExAnt (_loc, List.assoc x env) with - Not_found -> e - end - | MLast.ExTup (_, x) -> MLast.ExTup (_loc, List.map loop x) - | MLast.ExSeq (_, x) -> MLast.ExSeq (_loc, List.map loop x) - | MLast.ExRec (_, pel, None) -> - let pel = List.map (fun (p, e) -> p, loop e) pel in - MLast.ExRec (_loc, pel, None) - | MLast.ExMat (_, e, peoel) -> - MLast.ExMat (_loc, loop e, List.map loop_peoel peoel) - | MLast.ExTry (_, e, pel) -> - let loop' = - function - p, Some e1, e2 -> p, Some (loop e1), loop e2 - | p, None, e2 -> p, None, loop e2 - in - MLast.ExTry (_loc, loop e, List.map loop' pel) - | e -> e - and loop_peoel = - function - p, Some e1, e2 -> p, Some (loop e1), loop e2 - | p, None, e2 -> p, None, loop e2 - in - loop -;; - -let substp mloc env = - let rec loop = - function - MLast.ExApp (_, e1, e2) -> MLast.PaApp (_loc, loop e1, loop e2) - | MLast.ExLid (_, x) -> - begin try MLast.PaAnt (_loc, List.assoc x env) with - Not_found -> MLast.PaLid (_loc, x) - end - | MLast.ExUid (_, x) -> - begin try MLast.PaAnt (_loc, List.assoc x env) with - Not_found -> MLast.PaUid (_loc, x) - end - | MLast.ExInt (_, x) -> MLast.PaInt (_loc, x) - | MLast.ExStr (_, s) -> MLast.PaStr (_loc, s) - | MLast.ExTup (_, x) -> MLast.PaTup (_loc, List.map loop x) - | MLast.ExRec (_, pel, None) -> - let ppl = List.map (fun (p, e) -> p, loop e) pel in - MLast.PaRec (_loc, ppl) - | x -> - Stdpp.raise_with_loc mloc - (Failure - "this macro cannot be used in a pattern (see its definition)") - in - loop -;; - -let incorrect_number loc l1 l2 = - Stdpp.raise_with_loc loc - (Failure - (Printf.sprintf "expected %d parameters; found %d" (List.length l2) - (List.length l1))) -;; - -let define eo x = - begin match eo with - Some ([], e) -> - Grammar.extend - [Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("UIDENT", x)], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - (Pcaml.expr_reloc (fun _ -> _loc) (fst _loc) e : 'expr))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("UIDENT", x)], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - (let p = substp _loc [] e in - Pcaml.patt_reloc (fun _ -> _loc) (fst _loc) p : - 'patt))]]] - | Some (sl, e) -> - Grammar.extend - [Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "apply"), - [None, None, - [[Gramext.Stoken ("UIDENT", x); Gramext.Sself], - Gramext.action - (fun (param : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (let el = - match param with - MLast.ExTup (_, el) -> el - | e -> [e] - in - if List.length el = List.length sl then - let env = List.combine sl el in - let e = subst _loc env e in - Pcaml.expr_reloc (fun _ -> _loc) (fst _loc) e - else incorrect_number _loc el sl : - 'expr))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("UIDENT", x); Gramext.Sself], - Gramext.action - (fun (param : 'patt) _ - (_loc : Lexing.position * Lexing.position) -> - (let pl = - match param with - MLast.PaTup (_, pl) -> pl - | p -> [p] - in - if List.length pl = List.length sl then - let env = List.combine sl pl in - let p = substp _loc env e in - Pcaml.patt_reloc (fun _ -> _loc) (fst _loc) p - else incorrect_number _loc pl sl : - 'patt))]]] - | None -> () - end; - defined := (x, eo) :: !defined -;; - -let undef x = - try - let eo = List.assoc x !defined in - begin match eo with - Some ([], _) -> - Grammar.delete_rule expr [Gramext.Stoken ("UIDENT", x)]; - Grammar.delete_rule patt [Gramext.Stoken ("UIDENT", x)] - | Some (_, _) -> - Grammar.delete_rule expr - [Gramext.Stoken ("UIDENT", x); Gramext.Sself]; - Grammar.delete_rule patt [Gramext.Stoken ("UIDENT", x); Gramext.Sself] - | None -> () - end; - defined := list_remove x !defined - with - Not_found -> () -;; - -(* This is a list of directories to search for INCLUDE statements. *) -let include_dirs = ref [];; - -(* Add something to the above, make sure it ends with a slash. *) -let add_include_dir str = - if str <> "" then - let str = - if String.get str (String.length str - 1) = '/' then str else str ^ "/" - in - include_dirs := !include_dirs @ [str] -;; - -let smlist = Grammar.Entry.create Pcaml.gram "smlist";; - -let parse_include_file = - let dir_ok file dir = Sys.file_exists (dir ^ file) in - fun file -> - let file = - try List.find (dir_ok file) (!include_dirs @ ["./"]) ^ file with - Not_found -> file - in - let ch = open_in file in - let st = Stream.of_channel ch in - let old_input = !(Pcaml.input_file) in - let (bol_ref, lnum_ref, name_ref) = !(Pcaml.position) in - let (old_bol, old_lnum, old_name) = !bol_ref, !lnum_ref, !name_ref in - let restore () = - close_in ch; - bol_ref := old_bol; - lnum_ref := old_lnum; - name_ref := old_name; - Pcaml.input_file := old_input - in - bol_ref := 0; - lnum_ref := 1; - name_ref := file; - Pcaml.input_file := file; - try let items = Grammar.Entry.parse smlist st in restore (); items with - exn -> restore (); raise exn -;; - -let rec execute_macro = - function - SdStr i -> [i] - | SdDef (x, eo) -> define eo x; [] - | SdUnd x -> undef x; [] - | SdITE (i, l1, l2) -> execute_macro_list (if is_defined i then l1 else l2) - | SdInc f -> execute_macro_list (parse_include_file f) -and execute_macro_list = - function - [] -> [] - | hd :: tl -> - let il1 = execute_macro hd in - let il2 = execute_macro_list tl in il1 @ il2 -;; - -Grammar.extend - (let _ = (expr : 'expr Grammar.Entry.e) - and _ = (patt : 'patt Grammar.Entry.e) - and _ = (str_item : 'str_item Grammar.Entry.e) - and _ = (sig_item : 'sig_item Grammar.Entry.e) - and _ = (smlist : 'smlist Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry expr) s - in - let macro_def : 'macro_def Grammar.Entry.e = - grammar_entry_create "macro_def" - and endif : 'endif Grammar.Entry.e = grammar_entry_create "endif" - and str_item_or_macro : 'str_item_or_macro Grammar.Entry.e = - grammar_entry_create "str_item_or_macro" - and opt_macro_value : 'opt_macro_value Grammar.Entry.e = - grammar_entry_create "opt_macro_value" - and uident : 'uident Grammar.Entry.e = grammar_entry_create "uident" in - [Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), - Some Gramext.First, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (macro_def : 'macro_def Grammar.Entry.e))], - Gramext.action - (fun (x : 'macro_def) (_loc : Lexing.position * Lexing.position) -> - (match execute_macro x with - [si] -> si - | sil -> MLast.StDcl (_loc, sil) : - 'str_item))]]; - Grammar.Entry.obj (macro_def : 'macro_def Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "INCLUDE"); Gramext.Stoken ("STRING", "")], - Gramext.action - (fun (fname : string) _ (_loc : Lexing.position * Lexing.position) -> - (SdInc fname : 'macro_def)); - [Gramext.Stoken ("", "IFNDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); - Gramext.Snterm (Grammar.Entry.obj (smlist : 'smlist Grammar.Entry.e)); - Gramext.Stoken ("", "ELSE"); - Gramext.Snterm (Grammar.Entry.obj (smlist : 'smlist Grammar.Entry.e)); - Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))], - Gramext.action - (fun (_ : 'endif) (dl2 : 'smlist) _ (dl1 : 'smlist) _ (i : 'uident) _ - (_loc : Lexing.position * Lexing.position) -> - (SdITE (i, dl2, dl1) : 'macro_def)); - [Gramext.Stoken ("", "IFNDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); - Gramext.Snterm (Grammar.Entry.obj (smlist : 'smlist Grammar.Entry.e)); - Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))], - Gramext.action - (fun (_ : 'endif) (dl : 'smlist) _ (i : 'uident) _ - (_loc : Lexing.position * Lexing.position) -> - (SdITE (i, [], dl) : 'macro_def)); - [Gramext.Stoken ("", "IFDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); - Gramext.Snterm (Grammar.Entry.obj (smlist : 'smlist Grammar.Entry.e)); - Gramext.Stoken ("", "ELSE"); - Gramext.Snterm (Grammar.Entry.obj (smlist : 'smlist Grammar.Entry.e)); - Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))], - Gramext.action - (fun (_ : 'endif) (dl2 : 'smlist) _ (dl1 : 'smlist) _ (i : 'uident) _ - (_loc : Lexing.position * Lexing.position) -> - (SdITE (i, dl1, dl2) : 'macro_def)); - [Gramext.Stoken ("", "IFDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); - Gramext.Snterm (Grammar.Entry.obj (smlist : 'smlist Grammar.Entry.e)); - Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))], - Gramext.action - (fun (_ : 'endif) (dl : 'smlist) _ (i : 'uident) _ - (_loc : Lexing.position * Lexing.position) -> - (SdITE (i, dl, []) : 'macro_def)); - [Gramext.Stoken ("", "UNDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e))], - Gramext.action - (fun (i : 'uident) _ (_loc : Lexing.position * Lexing.position) -> - (SdUnd i : 'macro_def)); - [Gramext.Stoken ("", "DEFINE"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (opt_macro_value : 'opt_macro_value Grammar.Entry.e))], - Gramext.action - (fun (def : 'opt_macro_value) (i : 'uident) _ - (_loc : Lexing.position * Lexing.position) -> - (SdDef (i, def) : 'macro_def))]]; - Grammar.Entry.obj (smlist : 'smlist Grammar.Entry.e), None, - [None, None, - [[Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj - (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e)))], - Gramext.action - (fun (sml : 'str_item_or_macro list) - (_loc : Lexing.position * Lexing.position) -> - (sml : 'smlist))]]; - Grammar.Entry.obj (endif : 'endif Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "ENDIF")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> (() : 'endif)); - [Gramext.Stoken ("", "END")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> (() : 'endif))]]; - Grammar.Entry.obj - (str_item_or_macro : 'str_item_or_macro Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e))], - Gramext.action - (fun (si : 'str_item) (_loc : Lexing.position * Lexing.position) -> - (SdStr si : 'str_item_or_macro)); - [Gramext.Snterm - (Grammar.Entry.obj (macro_def : 'macro_def Grammar.Entry.e))], - Gramext.action - (fun (d : 'macro_def) (_loc : Lexing.position * Lexing.position) -> - (d : 'str_item_or_macro))]]; - Grammar.Entry.obj (opt_macro_value : 'opt_macro_value Grammar.Entry.e), - None, - [None, None, - [[], - Gramext.action - (fun (_loc : Lexing.position * Lexing.position) -> - (None : 'opt_macro_value)); - [Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (Some ([], e) : 'opt_macro_value)); - [Gramext.Stoken ("", "("); - Gramext.Slist1sep - (Gramext.Stoken ("LIDENT", ""), Gramext.Stoken ("", ",")); - Gramext.Stoken ("", ")"); Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ _ (pl : string list) _ - (_loc : Lexing.position * Lexing.position) -> - (Some (pl, e) : 'opt_macro_value))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "IFNDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); Gramext.Sself; - Gramext.Stoken ("", "ELSE"); Gramext.Sself; - Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))], - Gramext.action - (fun (_ : 'endif) (e2 : 'expr) _ (e1 : 'expr) _ (i : 'uident) _ - (_loc : Lexing.position * Lexing.position) -> - (if is_defined i then e2 else e1 : 'expr)); - [Gramext.Stoken ("", "IFDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); Gramext.Sself; - Gramext.Stoken ("", "ELSE"); Gramext.Sself; - Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))], - Gramext.action - (fun (_ : 'endif) (e2 : 'expr) _ (e1 : 'expr) _ (i : 'uident) _ - (_loc : Lexing.position * Lexing.position) -> - (if is_defined i then e1 else e2 : 'expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("LIDENT", "__LOCATION__")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - (let bp = string_of_int (fst _loc).Lexing.pos_cnum in - let ep = string_of_int (snd _loc).Lexing.pos_cnum in - MLast.ExTup - (_loc, [MLast.ExInt (_loc, bp); MLast.ExInt (_loc, ep)]) : - 'expr)); - [Gramext.Stoken ("LIDENT", "__FILE__")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - (MLast.ExStr (_loc, !(Pcaml.input_file)) : 'expr))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "IFNDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); Gramext.Sself; - Gramext.Stoken ("", "ELSE"); Gramext.Sself; - Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))], - Gramext.action - (fun (_ : 'endif) (p2 : 'patt) _ (p1 : 'patt) _ (i : 'uident) _ - (_loc : Lexing.position * Lexing.position) -> - (if is_defined i then p2 else p1 : 'patt)); - [Gramext.Stoken ("", "IFDEF"); - Gramext.Snterm (Grammar.Entry.obj (uident : 'uident Grammar.Entry.e)); - Gramext.Stoken ("", "THEN"); Gramext.Sself; - Gramext.Stoken ("", "ELSE"); Gramext.Sself; - Gramext.Snterm (Grammar.Entry.obj (endif : 'endif Grammar.Entry.e))], - Gramext.action - (fun (_ : 'endif) (p2 : 'patt) _ (p1 : 'patt) _ (i : 'uident) _ - (_loc : Lexing.position * Lexing.position) -> - (if is_defined i then p1 else p2 : 'patt))]]; - Grammar.Entry.obj (uident : 'uident Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (i : 'uident))]]]);; - -Pcaml.add_option "-D" (Arg.String (define None)) - " Define for IFDEF instruction.";; -Pcaml.add_option "-U" (Arg.String undef) - " Undefine for IFDEF instruction.";; -Pcaml.add_option "-I" (Arg.String add_include_dir) - " Add a directory to INCLUDE search path.";; diff --git a/camlp4/ocaml_src/meta/pa_r.ml b/camlp4/ocaml_src/meta/pa_r.ml deleted file mode 100644 index 6e2a1536..00000000 --- a/camlp4/ocaml_src/meta/pa_r.ml +++ /dev/null @@ -1,3179 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Stdpp;; -open Pcaml;; - -Pcaml.no_constructors_arity := false;; - -let help_sequences () = - Printf.eprintf "\ -New syntax: - do {e1; e2; ... ; en} - while e do {e1; e2; ... ; en} - for v = v1 to/downto v2 do {e1; e2; ... ; en} -Old (discouraged) syntax: - do e1; e2; ... ; en-1; return en - while e do e1; e2; ... ; en; done - for v = v1 to/downto v2 do e1; e2; ... ; en; done -To avoid compilation warning use the new syntax. -"; - flush stderr; - exit 1 -;; -Pcaml.add_option "-help_seq" (Arg.Unit help_sequences) - "Print explanations about new sequences and exit.";; - -let odfa = !(Plexer.dollar_for_antiquotation) in -Plexer.dollar_for_antiquotation := false; -let (lexer, pos) = Plexer.make_lexer () in -Pcaml.position := pos; -Grammar.Unsafe.gram_reinit gram lexer; -Plexer.dollar_for_antiquotation := odfa; -Grammar.Unsafe.clear_entry interf; -Grammar.Unsafe.clear_entry implem; -Grammar.Unsafe.clear_entry top_phrase; -Grammar.Unsafe.clear_entry use_file; -Grammar.Unsafe.clear_entry module_type; -Grammar.Unsafe.clear_entry module_expr; -Grammar.Unsafe.clear_entry sig_item; -Grammar.Unsafe.clear_entry str_item; -Grammar.Unsafe.clear_entry expr; -Grammar.Unsafe.clear_entry patt; -Grammar.Unsafe.clear_entry ctyp; -Grammar.Unsafe.clear_entry let_binding; -Grammar.Unsafe.clear_entry type_declaration; -Grammar.Unsafe.clear_entry class_type; -Grammar.Unsafe.clear_entry class_expr; -Grammar.Unsafe.clear_entry class_sig_item; -Grammar.Unsafe.clear_entry class_str_item;; - -Pcaml.parse_interf := Grammar.Entry.parse interf;; -Pcaml.parse_implem := Grammar.Entry.parse implem;; - -let o2b = - function - Some _ -> true - | None -> false -;; - -let mksequence _loc = - function - [e] -> e - | el -> MLast.ExSeq (_loc, el) -;; - -let mkmatchcase _loc p aso w e = - let p = - match aso with - Some p2 -> MLast.PaAli (_loc, p, p2) - | _ -> p - in - p, w, e -;; - -let neg_string n = - let len = String.length n in - if len > 0 && n.[0] = '-' then String.sub n 1 (len - 1) else "-" ^ n -;; - -let mkumin _loc f arg = - match arg with - MLast.ExInt (_, n) -> MLast.ExInt (_loc, neg_string n) - | MLast.ExInt32 (loc, n) -> MLast.ExInt32 (loc, neg_string n) - | MLast.ExInt64 (loc, n) -> MLast.ExInt64 (loc, neg_string n) - | MLast.ExNativeInt (loc, n) -> MLast.ExNativeInt (loc, neg_string n) - | MLast.ExFlo (_, n) -> MLast.ExFlo (_loc, neg_string n) - | _ -> let f = "~" ^ f in MLast.ExApp (_loc, MLast.ExLid (_loc, f), arg) -;; - -let mklistexp _loc last = - let rec loop top = - function - [] -> - begin match last with - Some e -> e - | None -> MLast.ExUid (_loc, "[]") - end - | e1 :: el -> - let _loc = - if top then _loc else fst (MLast.loc_of_expr e1), snd _loc - in - MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExUid (_loc, "::"), e1), - loop false el) - in - loop true -;; - -let mklistpat _loc last = - let rec loop top = - function - [] -> - begin match last with - Some p -> p - | None -> MLast.PaUid (_loc, "[]") - end - | p1 :: pl -> - let _loc = - if top then _loc else fst (MLast.loc_of_patt p1), snd _loc - in - MLast.PaApp - (_loc, MLast.PaApp (_loc, MLast.PaUid (_loc, "::"), p1), - loop false pl) - in - loop true -;; - -let mkexprident _loc ids = - match ids with - [] -> Stdpp.raise_with_loc _loc (Stream.Error "illegal long identifier") - | id :: ids -> - let rec loop m = - function - id :: ids -> loop (MLast.ExAcc (_loc, m, id)) ids - | [] -> m - in - loop id ids -;; - -let mkassert _loc e = - match e with - MLast.ExUid (_, "False") -> MLast.ExAsf _loc - | _ -> MLast.ExAsr (_loc, e) -;; - -let append_elem el e = el @ [e];; - -(* ...suppose to flush the input in case of syntax error to avoid multiple - errors in case of cut-and-paste in the xterm, but work bad: for example - the input "for x = 1;" waits for another line before displaying the - error... -value rec sync cs = - match cs with parser - [ [: `';' :] -> sync_semi cs - | [: `_ :] -> sync cs ] -and sync_semi cs = - match Stream.peek cs with - [ Some ('\010' | '\013') -> () - | _ -> sync cs ] -; -Pcaml.sync.val := sync; -*) - -let ipatt = Grammar.Entry.create gram "ipatt";; -let with_constr = Grammar.Entry.create gram "with_constr";; -let row_field = Grammar.Entry.create gram "row_field";; - -let not_yet_warned_variant = ref true;; -let warn_variant loc = - if !not_yet_warned_variant then - begin - not_yet_warned_variant := false; - !(Pcaml.warning) loc - (Printf.sprintf - "use of syntax of variants types deprecated since version 3.05") - end -;; - -let not_yet_warned = ref true;; -let warn_sequence loc = - if !not_yet_warned then - begin - not_yet_warned := false; - !(Pcaml.warning) loc - "use of syntax of sequences deprecated since version 3.01.1" - end -;; -Pcaml.add_option "-no_warn_seq" (Arg.Clear not_yet_warned) - "No warning when using old syntax for sequences.";; - -Grammar.extend - (let _ = (sig_item : 'sig_item Grammar.Entry.e) - and _ = (str_item : 'str_item Grammar.Entry.e) - and _ = (ctyp : 'ctyp Grammar.Entry.e) - and _ = (patt : 'patt Grammar.Entry.e) - and _ = (expr : 'expr Grammar.Entry.e) - and _ = (module_type : 'module_type Grammar.Entry.e) - and _ = (module_expr : 'module_expr Grammar.Entry.e) - and _ = (class_type : 'class_type Grammar.Entry.e) - and _ = (class_expr : 'class_expr Grammar.Entry.e) - and _ = (class_sig_item : 'class_sig_item Grammar.Entry.e) - and _ = (class_str_item : 'class_str_item Grammar.Entry.e) - and _ = (let_binding : 'let_binding Grammar.Entry.e) - and _ = (type_declaration : 'type_declaration Grammar.Entry.e) - and _ = (ipatt : 'ipatt Grammar.Entry.e) - and _ = (with_constr : 'with_constr Grammar.Entry.e) - and _ = (row_field : 'row_field Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry sig_item) s - in - let rebind_exn : 'rebind_exn Grammar.Entry.e = - grammar_entry_create "rebind_exn" - and module_binding : 'module_binding Grammar.Entry.e = - grammar_entry_create "module_binding" - and module_rec_binding : 'module_rec_binding Grammar.Entry.e = - grammar_entry_create "module_rec_binding" - and module_declaration : 'module_declaration Grammar.Entry.e = - grammar_entry_create "module_declaration" - and module_rec_declaration : 'module_rec_declaration Grammar.Entry.e = - grammar_entry_create "module_rec_declaration" - and cons_expr_opt : 'cons_expr_opt Grammar.Entry.e = - grammar_entry_create "cons_expr_opt" - and dummy : 'dummy Grammar.Entry.e = grammar_entry_create "dummy" - and sequence : 'sequence Grammar.Entry.e = grammar_entry_create "sequence" - and fun_binding : 'fun_binding Grammar.Entry.e = - grammar_entry_create "fun_binding" - and match_case : 'match_case Grammar.Entry.e = - grammar_entry_create "match_case" - and as_patt_opt : 'as_patt_opt Grammar.Entry.e = - grammar_entry_create "as_patt_opt" - and when_expr_opt : 'when_expr_opt Grammar.Entry.e = - grammar_entry_create "when_expr_opt" - and label_expr : 'label_expr Grammar.Entry.e = - grammar_entry_create "label_expr" - and expr_ident : 'expr_ident Grammar.Entry.e = - grammar_entry_create "expr_ident" - and fun_def : 'fun_def Grammar.Entry.e = grammar_entry_create "fun_def" - and cons_patt_opt : 'cons_patt_opt Grammar.Entry.e = - grammar_entry_create "cons_patt_opt" - and label_patt : 'label_patt Grammar.Entry.e = - grammar_entry_create "label_patt" - and patt_label_ident : 'patt_label_ident Grammar.Entry.e = - grammar_entry_create "patt_label_ident" - and label_ipatt : 'label_ipatt Grammar.Entry.e = - grammar_entry_create "label_ipatt" - and type_patt : 'type_patt Grammar.Entry.e = - grammar_entry_create "type_patt" - and constrain : 'constrain Grammar.Entry.e = - grammar_entry_create "constrain" - and type_parameter : 'type_parameter Grammar.Entry.e = - grammar_entry_create "type_parameter" - and constructor_declaration : 'constructor_declaration Grammar.Entry.e = - grammar_entry_create "constructor_declaration" - and label_declaration : 'label_declaration Grammar.Entry.e = - grammar_entry_create "label_declaration" - and ident : 'ident Grammar.Entry.e = grammar_entry_create "ident" - and mod_ident : 'mod_ident Grammar.Entry.e = - grammar_entry_create "mod_ident" - and class_declaration : 'class_declaration Grammar.Entry.e = - grammar_entry_create "class_declaration" - and class_fun_binding : 'class_fun_binding Grammar.Entry.e = - grammar_entry_create "class_fun_binding" - and class_type_parameters : 'class_type_parameters Grammar.Entry.e = - grammar_entry_create "class_type_parameters" - and class_fun_def : 'class_fun_def Grammar.Entry.e = - grammar_entry_create "class_fun_def" - and class_structure : 'class_structure Grammar.Entry.e = - grammar_entry_create "class_structure" - and class_self_patt : 'class_self_patt Grammar.Entry.e = - grammar_entry_create "class_self_patt" - and as_lident : 'as_lident Grammar.Entry.e = - grammar_entry_create "as_lident" - and polyt : 'polyt Grammar.Entry.e = grammar_entry_create "polyt" - and cvalue_binding : 'cvalue_binding Grammar.Entry.e = - grammar_entry_create "cvalue_binding" - and label : 'label Grammar.Entry.e = grammar_entry_create "label" - and class_self_type : 'class_self_type Grammar.Entry.e = - grammar_entry_create "class_self_type" - and class_description : 'class_description Grammar.Entry.e = - grammar_entry_create "class_description" - and class_type_declaration : 'class_type_declaration Grammar.Entry.e = - grammar_entry_create "class_type_declaration" - and field_expr : 'field_expr Grammar.Entry.e = - grammar_entry_create "field_expr" - and meth_list : 'meth_list Grammar.Entry.e = - grammar_entry_create "meth_list" - and field : 'field Grammar.Entry.e = grammar_entry_create "field" - and typevar : 'typevar Grammar.Entry.e = grammar_entry_create "typevar" - and clty_longident : 'clty_longident Grammar.Entry.e = - grammar_entry_create "clty_longident" - and class_longident : 'class_longident Grammar.Entry.e = - grammar_entry_create "class_longident" - and row_field_list : 'row_field_list Grammar.Entry.e = - grammar_entry_create "row_field_list" - and name_tag : 'name_tag Grammar.Entry.e = grammar_entry_create "name_tag" - and patt_tcon : 'patt_tcon Grammar.Entry.e = - grammar_entry_create "patt_tcon" - and ipatt_tcon : 'ipatt_tcon Grammar.Entry.e = - grammar_entry_create "ipatt_tcon" - and eq_expr : 'eq_expr Grammar.Entry.e = grammar_entry_create "eq_expr" - and direction_flag : 'direction_flag Grammar.Entry.e = - grammar_entry_create "direction_flag" - and warning_variant : 'warning_variant Grammar.Entry.e = - grammar_entry_create "warning_variant" - and warning_sequence : 'warning_sequence Grammar.Entry.e = - grammar_entry_create "warning_sequence" - in - [Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "struct"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'str_item) - (_loc : Lexing.position * Lexing.position) -> - (s : 'e__1))]); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'e__1 list) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.MeStr (_loc, st) : 'module_expr)); - [Gramext.Stoken ("", "functor"); Gramext.Stoken ("", "("); - Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")"); Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (me : 'module_expr) _ _ (t : 'module_type) _ (i : string) _ _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.MeFun (_loc, i, t, me) : 'module_expr))]; - None, None, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (me2 : 'module_expr) (me1 : 'module_expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.MeApp (_loc, me1, me2) : 'module_expr))]; - None, None, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (me2 : 'module_expr) _ (me1 : 'module_expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.MeAcc (_loc, me1, me2) : 'module_expr))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (me : 'module_expr) _ - (_loc : Lexing.position * Lexing.position) -> - (me : 'module_expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (mt : 'module_type) _ (me : 'module_expr) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.MeTyc (_loc, me, mt) : 'module_expr)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.MeUid (_loc, i) : 'module_expr))]]; - Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None, - [Some "top", None, - [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) (_loc : Lexing.position * Lexing.position) -> - (MLast.StExp (_loc, e) : 'str_item)); - [Gramext.Stoken ("", "value"); - Gramext.Sopt (Gramext.Stoken ("", "rec")); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (l : 'let_binding list) (r : string option) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.StVal (_loc, o2b r, l) : 'str_item)); - [Gramext.Stoken ("", "type"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (type_declaration : 'type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (tdl : 'type_declaration list) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.StTyp (_loc, tdl) : 'str_item)); - [Gramext.Stoken ("", "open"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'mod_ident) _ (_loc : Lexing.position * Lexing.position) -> - (MLast.StOpn (_loc, i) : 'str_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "type"); - Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (i : string) _ _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.StMty (_loc, i, mt) : 'str_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (module_rec_binding : 'module_rec_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (nmtmes : 'module_rec_binding list) _ _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.StRecMod (_loc, nmtmes) : 'str_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("UIDENT", ""); - Gramext.Snterm - (Grammar.Entry.obj - (module_binding : 'module_binding Grammar.Entry.e))], - Gramext.action - (fun (mb : 'module_binding) (i : string) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.StMod (_loc, i, mb) : 'str_item)); - [Gramext.Stoken ("", "include"); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.StInc (_loc, me) : 'str_item)); - [Gramext.Stoken ("", "external"); Gramext.Stoken ("LIDENT", ""); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Slist1 (Gramext.Stoken ("STRING", ""))], - Gramext.action - (fun (pd : string list) _ (t : 'ctyp) _ (i : string) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.StExt (_loc, i, t, pd) : 'str_item)); - [Gramext.Stoken ("", "exception"); - Gramext.Snterm - (Grammar.Entry.obj - (constructor_declaration : - 'constructor_declaration Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (rebind_exn : 'rebind_exn Grammar.Entry.e))], - Gramext.action - (fun (b : 'rebind_exn) (_, c, tl : 'constructor_declaration) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.StExc (_loc, c, tl, b) : 'str_item)); - [Gramext.Stoken ("", "declare"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'str_item) - (_loc : Lexing.position * Lexing.position) -> - (s : 'e__2))]); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'e__2 list) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.StDcl (_loc, st) : 'str_item))]]; - Grammar.Entry.obj (rebind_exn : 'rebind_exn Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (_loc : Lexing.position * Lexing.position) -> - ([] : 'rebind_exn)); - [Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (sl : 'mod_ident) _ (_loc : Lexing.position * Lexing.position) -> - (sl : 'rebind_exn))]]; - Grammar.Entry.obj (module_binding : 'module_binding Grammar.Entry.e), - None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ - (_loc : Lexing.position * Lexing.position) -> - (me : 'module_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (mt : 'module_type) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.MeTyc (_loc, me, mt) : 'module_binding)); - [Gramext.Stoken ("", "("); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")"); Gramext.Sself], - Gramext.action - (fun (mb : 'module_binding) _ (mt : 'module_type) _ (m : string) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.MeFun (_loc, m, mt, mb) : 'module_binding))]]; - Grammar.Entry.obj - (module_rec_binding : 'module_rec_binding Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (mt : 'module_type) _ (m : string) - (_loc : Lexing.position * Lexing.position) -> - (m, mt, me : 'module_rec_binding))]]; - Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "functor"); Gramext.Stoken ("", "("); - Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ":"); Gramext.Sself; - Gramext.Stoken ("", ")"); Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (mt : 'module_type) _ _ (t : 'module_type) _ (i : string) _ _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.MtFun (_loc, i, t, mt) : 'module_type))]; - None, None, - [[Gramext.Sself; Gramext.Stoken ("", "with"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (with_constr : 'with_constr Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (wcl : 'with_constr list) _ (mt : 'module_type) - (_loc : Lexing.position * Lexing.position) -> - (MLast.MtWit (_loc, mt, wcl) : 'module_type))]; - None, None, - [[Gramext.Stoken ("", "sig"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'sig_item) - (_loc : Lexing.position * Lexing.position) -> - (s : 'e__3))]); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (sg : 'e__3 list) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.MtSig (_loc, sg) : 'module_type))]; - None, None, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (m2 : 'module_type) (m1 : 'module_type) - (_loc : Lexing.position * Lexing.position) -> - (MLast.MtApp (_loc, m1, m2) : 'module_type))]; - None, None, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (m2 : 'module_type) _ (m1 : 'module_type) - (_loc : Lexing.position * Lexing.position) -> - (MLast.MtAcc (_loc, m1, m2) : 'module_type))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (mt : 'module_type) _ - (_loc : Lexing.position * Lexing.position) -> - (mt : 'module_type)); - [Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) -> - (MLast.MtQuo (_loc, i) : 'module_type)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.MtLid (_loc, i) : 'module_type)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.MtUid (_loc, i) : 'module_type))]]; - Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None, - [Some "top", None, - [[Gramext.Stoken ("", "value"); Gramext.Stoken ("LIDENT", ""); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (i : string) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.SgVal (_loc, i, t) : 'sig_item)); - [Gramext.Stoken ("", "type"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (type_declaration : 'type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (tdl : 'type_declaration list) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.SgTyp (_loc, tdl) : 'sig_item)); - [Gramext.Stoken ("", "open"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'mod_ident) _ (_loc : Lexing.position * Lexing.position) -> - (MLast.SgOpn (_loc, i) : 'sig_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "type"); - Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (i : string) _ _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.SgMty (_loc, i, mt) : 'sig_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (module_rec_declaration : - 'module_rec_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (mds : 'module_rec_declaration list) _ _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.SgRecMod (_loc, mds) : 'sig_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("UIDENT", ""); - Gramext.Snterm - (Grammar.Entry.obj - (module_declaration : 'module_declaration Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_declaration) (i : string) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.SgMod (_loc, i, mt) : 'sig_item)); - [Gramext.Stoken ("", "include"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.SgInc (_loc, mt) : 'sig_item)); - [Gramext.Stoken ("", "external"); Gramext.Stoken ("LIDENT", ""); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Slist1 (Gramext.Stoken ("STRING", ""))], - Gramext.action - (fun (pd : string list) _ (t : 'ctyp) _ (i : string) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.SgExt (_loc, i, t, pd) : 'sig_item)); - [Gramext.Stoken ("", "exception"); - Gramext.Snterm - (Grammar.Entry.obj - (constructor_declaration : - 'constructor_declaration Grammar.Entry.e))], - Gramext.action - (fun (_, c, tl : 'constructor_declaration) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.SgExc (_loc, c, tl) : 'sig_item)); - [Gramext.Stoken ("", "declare"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'sig_item) - (_loc : Lexing.position * Lexing.position) -> - (s : 'e__4))]); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'e__4 list) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.SgDcl (_loc, st) : 'sig_item))]]; - Grammar.Entry.obj - (module_declaration : 'module_declaration Grammar.Entry.e), - None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", "("); Gramext.Stoken ("UIDENT", ""); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")"); Gramext.Sself], - Gramext.action - (fun (mt : 'module_declaration) _ (t : 'module_type) _ (i : string) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.MtFun (_loc, i, t, mt) : 'module_declaration)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ - (_loc : Lexing.position * Lexing.position) -> - (mt : 'module_declaration))]]; - Grammar.Entry.obj - (module_rec_declaration : 'module_rec_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (m : string) - (_loc : Lexing.position * Lexing.position) -> - (m, mt : 'module_rec_declaration))]]; - Grammar.Entry.obj (with_constr : 'with_constr Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "module"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (i : 'mod_ident) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.WcMod (_loc, i, me) : 'with_constr)); - [Gramext.Stoken ("", "type"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e)); - Gramext.Slist0 - (Gramext.Snterm - (Grammar.Entry.obj - (type_parameter : 'type_parameter Grammar.Entry.e))); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (tpl : 'type_parameter list) (i : 'mod_ident) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.WcTyp (_loc, i, tpl, t) : 'with_constr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), None, - [Some "top", Some Gramext.RightA, - [[Gramext.Stoken ("", "object"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj - (class_self_patt : 'class_self_patt Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj - (class_structure : 'class_structure Grammar.Entry.e)); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (cf : 'class_structure) (cspo : 'class_self_patt option) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExObj (_loc, cspo, cf) : 'expr)); - [Gramext.Stoken ("", "while"); Gramext.Sself; Gramext.Stoken ("", "do"); - Gramext.Stoken ("", "{"); - Gramext.Snterm - (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e)); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (seq : 'sequence) _ _ (e : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExWhi (_loc, e, seq) : 'expr)); - [Gramext.Stoken ("", "for"); Gramext.Stoken ("LIDENT", ""); - Gramext.Stoken ("", "="); Gramext.Sself; - Gramext.Snterm - (Grammar.Entry.obj - (direction_flag : 'direction_flag Grammar.Entry.e)); - Gramext.Sself; Gramext.Stoken ("", "do"); Gramext.Stoken ("", "{"); - Gramext.Snterm - (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e)); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (seq : 'sequence) _ _ (e2 : 'expr) (df : 'direction_flag) - (e1 : 'expr) _ (i : string) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExFor (_loc, i, e1, e2, df, seq) : 'expr)); - [Gramext.Stoken ("", "do"); Gramext.Stoken ("", "{"); - Gramext.Snterm - (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e)); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (seq : 'sequence) _ _ - (_loc : Lexing.position * Lexing.position) -> - (mksequence _loc seq : 'expr)); - [Gramext.Stoken ("", "if"); Gramext.Sself; Gramext.Stoken ("", "then"); - Gramext.Sself; Gramext.Stoken ("", "else"); Gramext.Sself], - Gramext.action - (fun (e3 : 'expr) _ (e2 : 'expr) _ (e1 : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExIfe (_loc, e1, e2, e3) : 'expr)); - [Gramext.Stoken ("", "try"); Gramext.Sself; Gramext.Stoken ("", "with"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExTry (_loc, e, [p1, None, e1]) : 'expr)); - [Gramext.Stoken ("", "try"); Gramext.Sself; Gramext.Stoken ("", "with"); - Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (match_case : 'match_case Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (l : 'match_case list) _ _ (e : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExTry (_loc, e, l) : 'expr)); - [Gramext.Stoken ("", "match"); Gramext.Sself; - Gramext.Stoken ("", "with"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExMat (_loc, e, [p1, None, e1]) : 'expr)); - [Gramext.Stoken ("", "match"); Gramext.Sself; - Gramext.Stoken ("", "with"); Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (match_case : 'match_case Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (l : 'match_case list) _ _ (e : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExMat (_loc, e, l) : 'expr)); - [Gramext.Stoken ("", "fun"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (fun_def : 'fun_def Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_def) (p : 'ipatt) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExFun (_loc, [p, None, e]) : 'expr)); - [Gramext.Stoken ("", "fun"); Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (match_case : 'match_case Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (l : 'match_case list) _ _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExFun (_loc, l) : 'expr)); - [Gramext.Stoken ("", "let"); Gramext.Stoken ("", "module"); - Gramext.Stoken ("UIDENT", ""); - Gramext.Snterm - (Grammar.Entry.obj - (module_binding : 'module_binding Grammar.Entry.e)); - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (mb : 'module_binding) (m : string) _ _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExLmd (_loc, m, mb, e) : 'expr)); - [Gramext.Stoken ("", "let"); Gramext.Sopt (Gramext.Stoken ("", "rec")); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and")); - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (x : 'expr) _ (l : 'let_binding list) (r : string option) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExLet (_loc, o2b r, l, x) : 'expr))]; - Some "where", None, - [[Gramext.Sself; Gramext.Stoken ("", "where"); - Gramext.Sopt (Gramext.Stoken ("", "rec")); - Gramext.Snterm - (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e))], - Gramext.action - (fun (lb : 'let_binding) (rf : string option) _ (e : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExLet (_loc, o2b rf, [lb], e) : 'expr))]; - Some ":=", Some Gramext.NonA, - [[Gramext.Sself; Gramext.Stoken ("", ":="); Gramext.Sself; - Gramext.Snterm (Grammar.Entry.obj (dummy : 'dummy Grammar.Entry.e))], - Gramext.action - (fun _ (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExAss (_loc, e1, e2) : 'expr))]; - Some "||", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "||"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "||"), e1), e2) : - 'expr))]; - Some "&&", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "&&"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "&&"), e1), e2) : - 'expr))]; - Some "<", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "!="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "!="), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "=="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "=="), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "<>"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "<>"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "="), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", ">="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, ">="), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "<="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "<="), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", ">"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, ">"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "<"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "<"), e1), e2) : - 'expr))]; - Some "^", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "@"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "@"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "^"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "^"), e1), e2) : - 'expr))]; - Some "+", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "-."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "-."), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "+."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "+."), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "-"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "-"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "+"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "+"), e1), e2) : - 'expr))]; - Some "*", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "mod"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "mod"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "lxor"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "lxor"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "lor"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "lor"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "land"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "land"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "/."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "/."), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "*."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "*."), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "/"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "/"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "*"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "*"), e1), e2) : - 'expr))]; - Some "**", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "lsr"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "lsr"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "lsl"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "lsl"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "asr"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "asr"), e1), e2) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "**"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExLid (_loc, "**"), e1), e2) : - 'expr))]; - Some "unary minus", Some Gramext.NonA, - [[Gramext.Stoken ("", "-."); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (mkumin _loc "-." e : 'expr)); - [Gramext.Stoken ("", "-"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (mkumin _loc "-" e : 'expr))]; - Some "apply", Some Gramext.LeftA, - [[Gramext.Stoken ("", "lazy"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (MLast.ExLaz (_loc, e) : 'expr)); - [Gramext.Stoken ("", "assert"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (mkassert _loc e : 'expr)); - [Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp (_loc, e1, e2) : 'expr))]; - Some ".", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExAcc (_loc, e1, e2) : 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Stoken ("", "["); - Gramext.Sself; Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (e2 : 'expr) _ _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExSte (_loc, e1, e2) : 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Stoken ("", "("); - Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (e2 : 'expr) _ _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExAre (_loc, e1, e2) : 'expr))]; - Some "~-", Some Gramext.NonA, - [[Gramext.Stoken ("", "~-."); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp (_loc, MLast.ExLid (_loc, "~-."), e) : 'expr)); - [Gramext.Stoken ("", "~-"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (MLast.ExApp (_loc, MLast.ExLid (_loc, "~-"), e) : 'expr))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (e : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)), - Gramext.Stoken ("", ",")); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (el : 'expr list) _ (e : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExTup (_loc, (e :: el)) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (e : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExTyc (_loc, e, t) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], - Gramext.action - (fun _ _ (_loc : Lexing.position * Lexing.position) -> - (MLast.ExUid (_loc, "()") : 'expr)); - [Gramext.Stoken ("", "{"); Gramext.Stoken ("", "("); Gramext.Sself; - Gramext.Stoken ("", ")"); Gramext.Stoken ("", "with"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (label_expr : 'label_expr Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lel : 'label_expr list) _ _ (e : 'expr) _ _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExRec (_loc, lel, Some e) : 'expr)); - [Gramext.Stoken ("", "{"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (label_expr : 'label_expr Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lel : 'label_expr list) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExRec (_loc, lel, None) : 'expr)); - [Gramext.Stoken ("", "[|"); - Gramext.Slist0sep - (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (el : 'expr list) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExArr (_loc, el) : 'expr)); - [Gramext.Stoken ("", "["); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Snterm - (Grammar.Entry.obj (cons_expr_opt : 'cons_expr_opt Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (last : 'cons_expr_opt) (el : 'expr list) _ - (_loc : Lexing.position * Lexing.position) -> - (mklistexp _loc last el : 'expr)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")], - Gramext.action - (fun _ _ (_loc : Lexing.position * Lexing.position) -> - (MLast.ExUid (_loc, "[]") : 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e))], - Gramext.action - (fun (ids : 'expr_ident) (_loc : Lexing.position * Lexing.position) -> - (mkexprident _loc ids : 'expr)); - [Gramext.Stoken ("CHAR", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.ExChr (_loc, s) : 'expr)); - [Gramext.Stoken ("STRING", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.ExStr (_loc, s) : 'expr)); - [Gramext.Stoken ("FLOAT", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.ExFlo (_loc, s) : 'expr)); - [Gramext.Stoken ("NATIVEINT", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.ExNativeInt (_loc, s) : 'expr)); - [Gramext.Stoken ("INT64", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.ExInt64 (_loc, s) : 'expr)); - [Gramext.Stoken ("INT32", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.ExInt32 (_loc, s) : 'expr)); - [Gramext.Stoken ("INT", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.ExInt (_loc, s) : 'expr))]]; - Grammar.Entry.obj (cons_expr_opt : 'cons_expr_opt Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (_loc : Lexing.position * Lexing.position) -> - (None : 'cons_expr_opt)); - [Gramext.Stoken ("", "::"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (Some e : 'cons_expr_opt))]]; - Grammar.Entry.obj (dummy : 'dummy Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (_loc : Lexing.position * Lexing.position) -> (() : 'dummy))]]; - Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) (_loc : Lexing.position * Lexing.position) -> - ([e] : 'sequence)); - [Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) (_loc : Lexing.position * Lexing.position) -> - ([e] : 'sequence)); - [Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";"); Gramext.Sself], - Gramext.action - (fun (el : 'sequence) _ (e : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (e :: el : 'sequence)); - [Gramext.Stoken ("", "let"); Gramext.Sopt (Gramext.Stoken ("", "rec")); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and")); - Gramext.srules - [[Gramext.Stoken ("", ";")], - Gramext.action - (fun (x : string) (_loc : Lexing.position * Lexing.position) -> - (x : 'e__5)); - [Gramext.Stoken ("", "in")], - Gramext.action - (fun (x : string) (_loc : Lexing.position * Lexing.position) -> - (x : 'e__5))]; - Gramext.Sself], - Gramext.action - (fun (el : 'sequence) _ (l : 'let_binding list) (rf : string option) _ - (_loc : Lexing.position * Lexing.position) -> - ([MLast.ExLet (_loc, o2b rf, l, mksequence _loc el)] : - 'sequence))]]; - Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_binding) (p : 'ipatt) - (_loc : Lexing.position * Lexing.position) -> - (p, e : 'let_binding))]]; - Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExCoe (_loc, e, None, t) : 'fun_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExTyc (_loc, e, t) : 'fun_binding)); - [Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (e : 'fun_binding)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'fun_binding) (p : 'ipatt) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExFun (_loc, [p, None, e]) : 'fun_binding))]]; - Grammar.Entry.obj (match_case : 'match_case Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (as_patt_opt : 'as_patt_opt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (when_expr_opt : 'when_expr_opt Grammar.Entry.e)); - Gramext.Stoken ("", "->"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (w : 'when_expr_opt) (aso : 'as_patt_opt) - (p : 'patt) (_loc : Lexing.position * Lexing.position) -> - (mkmatchcase _loc p aso w e : 'match_case))]]; - Grammar.Entry.obj (as_patt_opt : 'as_patt_opt Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (_loc : Lexing.position * Lexing.position) -> - (None : 'as_patt_opt)); - [Gramext.Stoken ("", "as"); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) _ (_loc : Lexing.position * Lexing.position) -> - (Some p : 'as_patt_opt))]]; - Grammar.Entry.obj (when_expr_opt : 'when_expr_opt Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (_loc : Lexing.position * Lexing.position) -> - (None : 'when_expr_opt)); - [Gramext.Stoken ("", "when"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (Some e : 'when_expr_opt))]]; - Grammar.Entry.obj (label_expr : 'label_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (patt_label_ident : 'patt_label_ident Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_binding) (i : 'patt_label_ident) - (_loc : Lexing.position * Lexing.position) -> - (i, e : 'label_expr))]]; - Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "."); - Gramext.Sself], - Gramext.action - (fun (j : 'expr_ident) _ (i : string) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExUid (_loc, i) :: j : 'expr_ident)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - ([MLast.ExUid (_loc, i)] : 'expr_ident)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - ([MLast.ExLid (_loc, i)] : 'expr_ident))]]; - Grammar.Entry.obj (fun_def : 'fun_def Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", "->"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (e : 'fun_def)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'fun_def) (p : 'ipatt) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExFun (_loc, [p, None, e]) : 'fun_def))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), None, - [None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "|"); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) _ (p1 : 'patt) - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaOrp (_loc, p1, p2) : 'patt))]; - None, Some Gramext.NonA, - [[Gramext.Sself; Gramext.Stoken ("", ".."); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) _ (p1 : 'patt) - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaRng (_loc, p1, p2) : 'patt))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) (p1 : 'patt) - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaApp (_loc, p1, p2) : 'patt))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) _ (p1 : 'patt) - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaAcc (_loc, p1, p2) : 'patt))]; - Some "simple", None, - [[Gramext.Stoken ("", "_")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - (MLast.PaAny _loc : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)), - Gramext.Stoken ("", ",")); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (pl : 'patt list) _ (p : 'patt) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaTup (_loc, (p :: pl)) : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "as"); - Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p2 : 'patt) _ (p : 'patt) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaAli (_loc, p, p2) : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (p : 'patt) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaTyc (_loc, p, t) : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p : 'patt) _ (_loc : Lexing.position * Lexing.position) -> - (p : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], - Gramext.action - (fun _ _ (_loc : Lexing.position * Lexing.position) -> - (MLast.PaUid (_loc, "()") : 'patt)); - [Gramext.Stoken ("", "{"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (label_patt : 'label_patt Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lpl : 'label_patt list) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaRec (_loc, lpl) : 'patt)); - [Gramext.Stoken ("", "[|"); - Gramext.Slist0sep - (Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (pl : 'patt list) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaArr (_loc, pl) : 'patt)); - [Gramext.Stoken ("", "["); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Snterm - (Grammar.Entry.obj (cons_patt_opt : 'cons_patt_opt Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (last : 'cons_patt_opt) (pl : 'patt list) _ - (_loc : Lexing.position * Lexing.position) -> - (mklistpat _loc last pl : 'patt)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")], - Gramext.action - (fun _ _ (_loc : Lexing.position * Lexing.position) -> - (MLast.PaUid (_loc, "[]") : 'patt)); - [Gramext.Stoken ("", "-"); Gramext.Stoken ("FLOAT", "")], - Gramext.action - (fun (s : string) _ (_loc : Lexing.position * Lexing.position) -> - (MLast.PaFlo (_loc, neg_string s) : 'patt)); - [Gramext.Stoken ("", "-"); Gramext.Stoken ("NATIVEINT", "")], - Gramext.action - (fun (s : string) _ (_loc : Lexing.position * Lexing.position) -> - (MLast.PaNativeInt (_loc, neg_string s) : 'patt)); - [Gramext.Stoken ("", "-"); Gramext.Stoken ("INT64", "")], - Gramext.action - (fun (s : string) _ (_loc : Lexing.position * Lexing.position) -> - (MLast.PaInt64 (_loc, neg_string s) : 'patt)); - [Gramext.Stoken ("", "-"); Gramext.Stoken ("INT32", "")], - Gramext.action - (fun (s : string) _ (_loc : Lexing.position * Lexing.position) -> - (MLast.PaInt32 (_loc, neg_string s) : 'patt)); - [Gramext.Stoken ("", "-"); Gramext.Stoken ("INT", "")], - Gramext.action - (fun (s : string) _ (_loc : Lexing.position * Lexing.position) -> - (MLast.PaInt (_loc, neg_string s) : 'patt)); - [Gramext.Stoken ("CHAR", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.PaChr (_loc, s) : 'patt)); - [Gramext.Stoken ("STRING", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.PaStr (_loc, s) : 'patt)); - [Gramext.Stoken ("FLOAT", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.PaFlo (_loc, s) : 'patt)); - [Gramext.Stoken ("NATIVEINT", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.PaNativeInt (_loc, s) : 'patt)); - [Gramext.Stoken ("INT64", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.PaInt64 (_loc, s) : 'patt)); - [Gramext.Stoken ("INT32", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.PaInt32 (_loc, s) : 'patt)); - [Gramext.Stoken ("INT", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.PaInt (_loc, s) : 'patt)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.PaUid (_loc, s) : 'patt)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.PaLid (_loc, s) : 'patt))]]; - Grammar.Entry.obj (cons_patt_opt : 'cons_patt_opt Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (_loc : Lexing.position * Lexing.position) -> - (None : 'cons_patt_opt)); - [Gramext.Stoken ("", "::"); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) _ (_loc : Lexing.position * Lexing.position) -> - (Some p : 'cons_patt_opt))]]; - Grammar.Entry.obj (label_patt : 'label_patt Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (patt_label_ident : 'patt_label_ident Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) _ (i : 'patt_label_ident) - (_loc : Lexing.position * Lexing.position) -> - (i, p : 'label_patt))]]; - Grammar.Entry.obj (patt_label_ident : 'patt_label_ident Grammar.Entry.e), - None, - [None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt_label_ident) _ (p1 : 'patt_label_ident) - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaAcc (_loc, p1, p2) : 'patt_label_ident))]; - Some "simple", Some Gramext.RightA, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.PaLid (_loc, i) : 'patt_label_ident)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.PaUid (_loc, i) : 'patt_label_ident))]]; - Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "_")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - (MLast.PaAny _loc : 'ipatt)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.PaLid (_loc, s) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)), - Gramext.Stoken ("", ",")); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (pl : 'ipatt list) _ (p : 'ipatt) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaTup (_loc, (p :: pl)) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "as"); - Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p2 : 'ipatt) _ (p : 'ipatt) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaAli (_loc, p, p2) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (p : 'ipatt) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaTyc (_loc, p, t) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p : 'ipatt) _ (_loc : Lexing.position * Lexing.position) -> - (p : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], - Gramext.action - (fun _ _ (_loc : Lexing.position * Lexing.position) -> - (MLast.PaUid (_loc, "()") : 'ipatt)); - [Gramext.Stoken ("", "{"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (label_ipatt : 'label_ipatt Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lpl : 'label_ipatt list) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaRec (_loc, lpl) : 'ipatt))]]; - Grammar.Entry.obj (label_ipatt : 'label_ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (patt_label_ident : 'patt_label_ident Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))], - Gramext.action - (fun (p : 'ipatt) _ (i : 'patt_label_ident) - (_loc : Lexing.position * Lexing.position) -> - (i, p : 'label_ipatt))]]; - Grammar.Entry.obj (type_declaration : 'type_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (type_patt : 'type_patt Grammar.Entry.e)); - Gramext.Slist0 - (Gramext.Snterm - (Grammar.Entry.obj - (type_parameter : 'type_parameter Grammar.Entry.e))); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Slist0 - (Gramext.Snterm - (Grammar.Entry.obj (constrain : 'constrain Grammar.Entry.e)))], - Gramext.action - (fun (cl : 'constrain list) (tk : 'ctyp) _ - (tpl : 'type_parameter list) (n : 'type_patt) - (_loc : Lexing.position * Lexing.position) -> - (n, tpl, tk, cl : 'type_declaration))]]; - Grammar.Entry.obj (type_patt : 'type_patt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (n : string) (_loc : Lexing.position * Lexing.position) -> - (_loc, n : 'type_patt))]]; - Grammar.Entry.obj (constrain : 'constrain Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "constraint"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ - (_loc : Lexing.position * Lexing.position) -> - (t1, t2 : 'constrain))]]; - Grammar.Entry.obj (type_parameter : 'type_parameter Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "-"); Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ _ (_loc : Lexing.position * Lexing.position) -> - (i, (false, true) : 'type_parameter)); - [Gramext.Stoken ("", "+"); Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ _ (_loc : Lexing.position * Lexing.position) -> - (i, (true, false) : 'type_parameter)); - [Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) -> - (i, (false, false) : 'type_parameter))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), None, - [None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "=="); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyMan (_loc, t1, t2) : 'ctyp))]; - None, Some Gramext.NonA, - [[Gramext.Stoken ("", "private"); - Gramext.Snterml - (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), "alias")], - Gramext.action - (fun (t : 'ctyp) _ (_loc : Lexing.position * Lexing.position) -> - (MLast.TyPrv (_loc, t) : 'ctyp))]; - Some "alias", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "as"); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyAli (_loc, t1, t2) : 'ctyp))]; - None, Some Gramext.LeftA, - [[Gramext.Stoken ("", "!"); - Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (typevar : 'typevar Grammar.Entry.e))); - Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) _ (pl : 'typevar list) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyPol (_loc, pl, t) : 'ctyp))]; - Some "arrow", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyArr (_loc, t1, t2) : 'ctyp))]; - Some "label", Some Gramext.NonA, - [[Gramext.Stoken ("OPTLABEL", ""); Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) (i : string) - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyOlb (_loc, i, t) : 'ctyp)); - [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) _ (i : string) - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyOlb (_loc, i, t) : 'ctyp)); - [Gramext.Stoken ("LABEL", ""); Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) (i : string) - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyLab (_loc, i, t) : 'ctyp)); - [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) _ (i : string) - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyLab (_loc, i, t) : 'ctyp))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) (t1 : 'ctyp) - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyApp (_loc, t1, t2) : 'ctyp))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyAcc (_loc, t1, t2) : 'ctyp))]; - Some "simple", None, - [[Gramext.Stoken ("", "{"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (label_declaration : 'label_declaration Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (ldl : 'label_declaration list) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyRec (_loc, ldl) : 'ctyp)); - [Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (constructor_declaration : - 'constructor_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (cdl : 'constructor_declaration list) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.TySum (_loc, cdl) : 'ctyp)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (_loc : Lexing.position * Lexing.position) -> - (t : 'ctyp)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "*"); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", "*")); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (tl : 'ctyp list) _ (t : 'ctyp) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyTup (_loc, (t :: tl)) : 'ctyp)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.TyUid (_loc, i) : 'ctyp)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.TyLid (_loc, i) : 'ctyp)); - [Gramext.Stoken ("", "_")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - (MLast.TyAny _loc : 'ctyp)); - [Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) -> - (MLast.TyQuo (_loc, i) : 'ctyp))]]; - Grammar.Entry.obj - (constructor_declaration : 'constructor_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (ci : string) (_loc : Lexing.position * Lexing.position) -> - (_loc, ci, [] : 'constructor_declaration)); - [Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "of"); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (cal : 'ctyp list) _ (ci : string) - (_loc : Lexing.position * Lexing.position) -> - (_loc, ci, cal : 'constructor_declaration))]]; - Grammar.Entry.obj - (label_declaration : 'label_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("LIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Sopt (Gramext.Stoken ("", "mutable")); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) (mf : string option) _ (i : string) - (_loc : Lexing.position * Lexing.position) -> - (_loc, i, o2b mf, t : 'label_declaration))]]; - Grammar.Entry.obj (ident : 'ident Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (i : 'ident)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (i : 'ident))]]; - Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "."); - Gramext.Sself], - Gramext.action - (fun (j : 'mod_ident) _ (i : string) - (_loc : Lexing.position * Lexing.position) -> - (i :: j : 'mod_ident)); - [Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - ([i] : 'mod_ident)); - [Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - ([i] : 'mod_ident))]]; - Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "class"); Gramext.Stoken ("", "type"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_type_declaration : - 'class_type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (ctd : 'class_type_declaration list) _ _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.StClt (_loc, ctd) : 'str_item)); - [Gramext.Stoken ("", "class"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_declaration : 'class_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (cd : 'class_declaration list) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.StCls (_loc, cd) : 'str_item))]]; - Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "class"); Gramext.Stoken ("", "type"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_type_declaration : - 'class_type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (ctd : 'class_type_declaration list) _ _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.SgClt (_loc, ctd) : 'sig_item)); - [Gramext.Stoken ("", "class"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_description : 'class_description Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (cd : 'class_description list) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.SgCls (_loc, cd) : 'sig_item))]]; - Grammar.Entry.obj - (class_declaration : 'class_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Sopt (Gramext.Stoken ("", "virtual")); - Gramext.Stoken ("LIDENT", ""); - Gramext.Snterm - (Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (class_fun_binding : 'class_fun_binding Grammar.Entry.e))], - Gramext.action - (fun (cfb : 'class_fun_binding) (ctp : 'class_type_parameters) - (i : string) (vf : string option) - (_loc : Lexing.position * Lexing.position) -> - ({MLast.ciLoc = _loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = i; MLast.ciExp = cfb} : - 'class_declaration))]]; - Grammar.Entry.obj - (class_fun_binding : 'class_fun_binding Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (cfb : 'class_fun_binding) (p : 'ipatt) - (_loc : Lexing.position * Lexing.position) -> - (MLast.CeFun (_loc, p, cfb) : 'class_fun_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_expr) _ (ct : 'class_type) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.CeTyc (_loc, ce, ct) : 'class_fun_binding)); - [Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_expr) _ - (_loc : Lexing.position * Lexing.position) -> - (ce : 'class_fun_binding))]]; - Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "["); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (type_parameter : 'type_parameter Grammar.Entry.e)), - Gramext.Stoken ("", ",")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (tpl : 'type_parameter list) _ - (_loc : Lexing.position * Lexing.position) -> - (_loc, tpl : 'class_type_parameters)); - [], - Gramext.action - (fun (_loc : Lexing.position * Lexing.position) -> - (_loc, [] : 'class_type_parameters))]]; - Grammar.Entry.obj (class_fun_def : 'class_fun_def Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "->"); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_expr) _ - (_loc : Lexing.position * Lexing.position) -> - (ce : 'class_fun_def)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (ce : 'class_fun_def) (p : 'ipatt) - (_loc : Lexing.position * Lexing.position) -> - (MLast.CeFun (_loc, p, ce) : 'class_fun_def))]]; - Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), None, - [Some "top", None, - [[Gramext.Stoken ("", "let"); Gramext.Sopt (Gramext.Stoken ("", "rec")); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and")); - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (ce : 'class_expr) _ (lb : 'let_binding list) - (rf : string option) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.CeLet (_loc, o2b rf, lb, ce) : 'class_expr)); - [Gramext.Stoken ("", "fun"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (class_fun_def : 'class_fun_def Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_fun_def) (p : 'ipatt) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.CeFun (_loc, p, ce) : 'class_expr))]; - Some "apply", Some Gramext.NonA, - [[Gramext.Sself; - Gramext.Snterml - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), "label")], - Gramext.action - (fun (e : 'expr) (ce : 'class_expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.CeApp (_loc, ce, e) : 'class_expr))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (ce : 'class_expr) _ - (_loc : Lexing.position * Lexing.position) -> - (ce : 'class_expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (ct : 'class_type) _ (ce : 'class_expr) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.CeTyc (_loc, ce, ct) : 'class_expr)); - [Gramext.Stoken ("", "object"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj - (class_self_patt : 'class_self_patt Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj - (class_structure : 'class_structure Grammar.Entry.e)); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (cf : 'class_structure) (cspo : 'class_self_patt option) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.CeStr (_loc, cspo, cf) : 'class_expr)); - [Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e))], - Gramext.action - (fun (ci : 'class_longident) - (_loc : Lexing.position * Lexing.position) -> - (MLast.CeCon (_loc, ci, []) : 'class_expr)); - [Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e)); - Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", ",")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (ctcl : 'ctyp list) _ (ci : 'class_longident) - (_loc : Lexing.position * Lexing.position) -> - (MLast.CeCon (_loc, ci, ctcl) : 'class_expr))]]; - Grammar.Entry.obj (class_structure : 'class_structure Grammar.Entry.e), - None, - [None, None, - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_str_item : 'class_str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (cf : 'class_str_item) - (_loc : Lexing.position * Lexing.position) -> - (cf : 'e__6))])], - Gramext.action - (fun (cf : 'e__6 list) (_loc : Lexing.position * Lexing.position) -> - (cf : 'class_structure))]]; - Grammar.Entry.obj (class_self_patt : 'class_self_patt Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (p : 'patt) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaTyc (_loc, p, t) : 'class_self_patt)); - [Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p : 'patt) _ (_loc : Lexing.position * Lexing.position) -> - (p : 'class_self_patt))]]; - Grammar.Entry.obj (class_str_item : 'class_str_item Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "initializer"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (se : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (MLast.CrIni (_loc, se) : 'class_str_item)); - [Gramext.Stoken ("", "type"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.CrCtr (_loc, t1, t2) : 'class_str_item)); - [Gramext.Stoken ("", "method"); - Gramext.Sopt (Gramext.Stoken ("", "private")); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (polyt : 'polyt Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_binding) (topt : 'polyt option) (l : 'label) - (pf : string option) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.CrMth (_loc, l, o2b pf, e, topt) : 'class_str_item)); - [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); - Gramext.Sopt (Gramext.Stoken ("", "private")); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.CrVir (_loc, l, o2b pf, t) : 'class_str_item)); - [Gramext.Stoken ("", "value"); - Gramext.Sopt (Gramext.Stoken ("", "mutable")); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (cvalue_binding : 'cvalue_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'cvalue_binding) (lab : 'label) (mf : string option) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.CrVal (_loc, lab, o2b mf, e) : 'class_str_item)); - [Gramext.Stoken ("", "inherit"); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (as_lident : 'as_lident Grammar.Entry.e)))], - Gramext.action - (fun (pb : 'as_lident option) (ce : 'class_expr) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.CrInh (_loc, ce, pb) : 'class_str_item)); - [Gramext.Stoken ("", "declare"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_str_item : 'class_str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'class_str_item) - (_loc : Lexing.position * Lexing.position) -> - (s : 'e__7))]); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'e__7 list) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.CrDcl (_loc, st) : 'class_str_item))]]; - Grammar.Entry.obj (as_lident : 'as_lident Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "as"); Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) _ (_loc : Lexing.position * Lexing.position) -> - (i : 'as_lident))]]; - Grammar.Entry.obj (polyt : 'polyt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (_loc : Lexing.position * Lexing.position) -> - (t : 'polyt))]]; - Grammar.Entry.obj (cvalue_binding : 'cvalue_binding Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExCoe (_loc, e, None, t) : 'cvalue_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t2 : 'ctyp) _ (t : 'ctyp) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExCoe (_loc, e, Some t, t2) : 'cvalue_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExTyc (_loc, e, t) : 'cvalue_binding)); - [Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (e : 'cvalue_binding))]]; - Grammar.Entry.obj (label : 'label Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (i : 'label))]]; - Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "object"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj - (class_self_type : 'class_self_type Grammar.Entry.e))); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_sig_item : 'class_sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (csf : 'class_sig_item) - (_loc : Lexing.position * Lexing.position) -> - (csf : 'e__8))]); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (csf : 'e__8 list) (cst : 'class_self_type option) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.CtSig (_loc, cst, csf) : 'class_type)); - [Gramext.Snterm - (Grammar.Entry.obj - (clty_longident : 'clty_longident Grammar.Entry.e))], - Gramext.action - (fun (id : 'clty_longident) - (_loc : Lexing.position * Lexing.position) -> - (MLast.CtCon (_loc, id, []) : 'class_type)); - [Gramext.Snterm - (Grammar.Entry.obj - (clty_longident : 'clty_longident Grammar.Entry.e)); - Gramext.Stoken ("", "["); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", ",")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (tl : 'ctyp list) _ (id : 'clty_longident) - (_loc : Lexing.position * Lexing.position) -> - (MLast.CtCon (_loc, id, tl) : 'class_type)); - [Gramext.Stoken ("", "["); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "]"); Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (ct : 'class_type) _ _ (t : 'ctyp) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.CtFun (_loc, t, ct) : 'class_type))]]; - Grammar.Entry.obj (class_self_type : 'class_self_type Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (_loc : Lexing.position * Lexing.position) -> - (t : 'class_self_type))]]; - Grammar.Entry.obj (class_sig_item : 'class_sig_item Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "type"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.CgCtr (_loc, t1, t2) : 'class_sig_item)); - [Gramext.Stoken ("", "method"); - Gramext.Sopt (Gramext.Stoken ("", "private")); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.CgMth (_loc, l, o2b pf, t) : 'class_sig_item)); - [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); - Gramext.Sopt (Gramext.Stoken ("", "private")); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (pf : string option) _ _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.CgVir (_loc, l, o2b pf, t) : 'class_sig_item)); - [Gramext.Stoken ("", "value"); - Gramext.Sopt (Gramext.Stoken ("", "mutable")); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (mf : string option) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.CgVal (_loc, l, o2b mf, t) : 'class_sig_item)); - [Gramext.Stoken ("", "inherit"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], - Gramext.action - (fun (cs : 'class_type) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.CgInh (_loc, cs) : 'class_sig_item)); - [Gramext.Stoken ("", "declare"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_sig_item : 'class_sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'class_sig_item) - (_loc : Lexing.position * Lexing.position) -> - (s : 'e__9))]); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'e__9 list) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.CgDcl (_loc, st) : 'class_sig_item))]]; - Grammar.Entry.obj - (class_description : 'class_description Grammar.Entry.e), - None, - [None, None, - [[Gramext.Sopt (Gramext.Stoken ("", "virtual")); - Gramext.Stoken ("LIDENT", ""); - Gramext.Snterm - (Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], - Gramext.action - (fun (ct : 'class_type) _ (ctp : 'class_type_parameters) (n : string) - (vf : string option) (_loc : Lexing.position * Lexing.position) -> - ({MLast.ciLoc = _loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = ct} : - 'class_description))]]; - Grammar.Entry.obj - (class_type_declaration : 'class_type_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Sopt (Gramext.Stoken ("", "virtual")); - Gramext.Stoken ("LIDENT", ""); - Gramext.Snterm - (Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], - Gramext.action - (fun (cs : 'class_type) _ (ctp : 'class_type_parameters) (n : string) - (vf : string option) (_loc : Lexing.position * Lexing.position) -> - ({MLast.ciLoc = _loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = cs} : - 'class_type_declaration))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "apply"), - [None, Some Gramext.LeftA, - [[Gramext.Stoken ("", "new"); - Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e))], - Gramext.action - (fun (i : 'class_longident) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExNew (_loc, i) : 'expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "."), - [None, None, - [[Gramext.Sself; Gramext.Stoken ("", "#"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e))], - Gramext.action - (fun (lab : 'label) _ (e : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExSnd (_loc, e, lab) : 'expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "{<"); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (field_expr : 'field_expr Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", ">}")], - Gramext.action - (fun _ (fel : 'field_expr list) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExOvr (_loc, fel) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (e : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExCoe (_loc, e, None, t) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ (e : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExCoe (_loc, e, Some t, t2) : 'expr))]]; - Grammar.Entry.obj (field_expr : 'field_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (l : 'label) - (_loc : Lexing.position * Lexing.position) -> - (l, e : 'field_expr))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "<"); Gramext.Stoken ("", ">")], - Gramext.action - (fun _ _ (_loc : Lexing.position * Lexing.position) -> - (MLast.TyObj (_loc, [], false) : 'ctyp)); - [Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj (meth_list : 'meth_list Grammar.Entry.e)); - Gramext.Stoken ("", ">")], - Gramext.action - (fun _ (ml, v : 'meth_list) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyObj (_loc, ml, v) : 'ctyp)); - [Gramext.Stoken ("", "#"); - Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e))], - Gramext.action - (fun (id : 'class_longident) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyCls (_loc, id) : 'ctyp))]]; - Grammar.Entry.obj (meth_list : 'meth_list Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "..")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - ([], true : 'meth_list)); - [Gramext.Snterm (Grammar.Entry.obj (field : 'field Grammar.Entry.e))], - Gramext.action - (fun (f : 'field) (_loc : Lexing.position * Lexing.position) -> - ([f], false : 'meth_list)); - [Gramext.Snterm (Grammar.Entry.obj (field : 'field Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (f : 'field) (_loc : Lexing.position * Lexing.position) -> - ([f], false : 'meth_list)); - [Gramext.Snterm (Grammar.Entry.obj (field : 'field Grammar.Entry.e)); - Gramext.Stoken ("", ";"); Gramext.Sself], - Gramext.action - (fun (ml, v : 'meth_list) _ (f : 'field) - (_loc : Lexing.position * Lexing.position) -> - (f :: ml, v : 'meth_list))]]; - Grammar.Entry.obj (field : 'field Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("LIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (lab : string) - (_loc : Lexing.position * Lexing.position) -> - (lab, t : 'field))]]; - Grammar.Entry.obj (typevar : 'typevar Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) -> - (i : 'typevar))]]; - Grammar.Entry.obj (clty_longident : 'clty_longident Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - ([i] : 'clty_longident)); - [Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "."); - Gramext.Sself], - Gramext.action - (fun (l : 'clty_longident) _ (m : string) - (_loc : Lexing.position * Lexing.position) -> - (m :: l : 'clty_longident))]]; - Grammar.Entry.obj (class_longident : 'class_longident Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - ([i] : 'class_longident)); - [Gramext.Stoken ("UIDENT", ""); Gramext.Stoken ("", "."); - Gramext.Sself], - Gramext.action - (fun (l : 'class_longident) _ (m : string) - (_loc : Lexing.position * Lexing.position) -> - (m :: l : 'class_longident))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "[<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", ">"); - Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e))); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (ntl : 'name_tag list) _ (rfl : 'row_field_list) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyVrn (_loc, rfl, Some (Some ntl)) : 'ctyp)); - [Gramext.Stoken ("", "[<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyVrn (_loc, rfl, Some (Some [])) : 'ctyp)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", ">"); - Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e))); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (ntl : 'name_tag list) _ (rfl : 'row_field_list) _ _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyVrn (_loc, rfl, Some (Some ntl)) : 'ctyp)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyVrn (_loc, rfl, Some (Some [])) : 'ctyp)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", ">"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyVrn (_loc, rfl, Some None) : 'ctyp)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyVrn (_loc, rfl, None) : 'ctyp))]]; - Grammar.Entry.obj (row_field_list : 'row_field_list Grammar.Entry.e), - None, - [None, None, - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e)), - Gramext.Stoken ("", "|"))], - Gramext.action - (fun (rfl : 'row_field list) - (_loc : Lexing.position * Lexing.position) -> - (rfl : 'row_field_list))]]; - Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) (_loc : Lexing.position * Lexing.position) -> - (MLast.RfInh t : 'row_field)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e)); - Gramext.Stoken ("", "of"); Gramext.Sopt (Gramext.Stoken ("", "&")); - Gramext.Slist1sep - (Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", "&"))], - Gramext.action - (fun (l : 'ctyp list) (ao : string option) _ (i : 'ident) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.RfTag (i, o2b ao, l) : 'row_field)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) -> - (MLast.RfTag (i, true, []) : 'row_field))]]; - Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) -> - (i : 'name_tag))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "?"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e))); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'eq_expr option) (p : 'patt_tcon) _ _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaOlb (_loc, "", Some (p, eo)) : 'patt)); - [Gramext.Stoken ("QUESTIONIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.PaOlb (_loc, i, None) : 'patt)); - [Gramext.Stoken ("OPTLABEL", ""); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e))); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'eq_expr option) (p : 'patt_tcon) _ (i : string) - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaOlb (_loc, i, Some (p, eo)) : 'patt)); - [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e))); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'eq_expr option) (p : 'patt_tcon) _ _ (i : string) - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaOlb (_loc, i, Some (p, eo)) : 'patt)); - [Gramext.Stoken ("TILDEIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.PaLab (_loc, i, None) : 'patt)); - [Gramext.Stoken ("LABEL", ""); Gramext.Sself], - Gramext.action - (fun (p : 'patt) (i : string) - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaLab (_loc, i, Some p) : 'patt)); - [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Sself], - Gramext.action - (fun (p : 'patt) _ (i : string) - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaLab (_loc, i, Some p) : 'patt)); - [Gramext.Stoken ("", "#"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (sl : 'mod_ident) _ (_loc : Lexing.position * Lexing.position) -> - (MLast.PaTyp (_loc, sl) : 'patt)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (s : 'ident) _ (_loc : Lexing.position * Lexing.position) -> - (MLast.PaVrn (_loc, s) : 'patt))]]; - Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) (_loc : Lexing.position * Lexing.position) -> - (p : 'patt_tcon)); - [Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (p : 'patt) - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaTyc (_loc, p, t) : 'patt_tcon))]]; - Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "?"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e))); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'eq_expr option) (p : 'ipatt_tcon) _ _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaOlb (_loc, "", Some (p, eo)) : 'ipatt)); - [Gramext.Stoken ("QUESTIONIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.PaOlb (_loc, i, None) : 'ipatt)); - [Gramext.Stoken ("OPTLABEL", ""); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e))); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'eq_expr option) (p : 'ipatt_tcon) _ (i : string) - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaOlb (_loc, i, Some (p, eo)) : 'ipatt)); - [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e)); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e))); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'eq_expr option) (p : 'ipatt_tcon) _ _ (i : string) - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaOlb (_loc, i, Some (p, eo)) : 'ipatt)); - [Gramext.Stoken ("TILDEIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.PaLab (_loc, i, None) : 'ipatt)); - [Gramext.Stoken ("LABEL", ""); Gramext.Sself], - Gramext.action - (fun (p : 'ipatt) (i : string) - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaLab (_loc, i, Some p) : 'ipatt)); - [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Sself], - Gramext.action - (fun (p : 'ipatt) _ (i : string) - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaLab (_loc, i, Some p) : 'ipatt))]]; - Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))], - Gramext.action - (fun (p : 'ipatt) (_loc : Lexing.position * Lexing.position) -> - (p : 'ipatt_tcon)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (p : 'ipatt) - (_loc : Lexing.position * Lexing.position) -> - (MLast.PaTyc (_loc, p, t) : 'ipatt_tcon))]]; - Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (e : 'eq_expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.After "apply"), - [Some "label", Some Gramext.NonA, - [[Gramext.Stoken ("QUESTIONIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.ExOlb (_loc, i, None) : 'expr)); - [Gramext.Stoken ("OPTLABEL", ""); Gramext.Sself], - Gramext.action - (fun (e : 'expr) (i : string) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExOlb (_loc, i, Some e) : 'expr)); - [Gramext.Stoken ("QUESTIONIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (i : string) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExOlb (_loc, i, Some e) : 'expr)); - [Gramext.Stoken ("TILDEIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.ExLab (_loc, i, None) : 'expr)); - [Gramext.Stoken ("LABEL", ""); Gramext.Sself], - Gramext.action - (fun (e : 'expr) (i : string) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExLab (_loc, i, Some e) : 'expr)); - [Gramext.Stoken ("TILDEIDENT", ""); Gramext.Stoken ("", ":"); - Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (i : string) - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExLab (_loc, i, Some e) : 'expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (s : 'ident) _ (_loc : Lexing.position * Lexing.position) -> - (MLast.ExVrn (_loc, s) : 'expr))]]; - Grammar.Entry.obj (direction_flag : 'direction_flag Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "downto")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - (false : 'direction_flag)); - [Gramext.Stoken ("", "to")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - (true : 'direction_flag))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", ">"); - Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e))); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (ntl : 'name_tag list) _ (rfl : 'row_field_list) _ _ _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyVrn (_loc, rfl, Some (Some ntl)) : 'ctyp)); - [Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyVrn (_loc, rfl, Some (Some [])) : 'ctyp)); - [Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Stoken ("", ">"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyVrn (_loc, rfl, Some None) : 'ctyp)); - [Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.TyVrn (_loc, rfl, None) : 'ctyp))]]; - Grammar.Entry.obj (warning_variant : 'warning_variant Grammar.Entry.e), - None, - [None, None, - [[], - Gramext.action - (fun (_loc : Lexing.position * Lexing.position) -> - (warn_variant _loc : 'warning_variant))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "while"); Gramext.Sself; Gramext.Stoken ("", "do"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (e : 'e__12))]); - Gramext.Snterm - (Grammar.Entry.obj - (warning_sequence : 'warning_sequence Grammar.Entry.e)); - Gramext.Stoken ("", "done")], - Gramext.action - (fun _ _ (seq : 'e__12 list) _ (e : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExWhi (_loc, e, seq) : 'expr)); - [Gramext.Stoken ("", "for"); Gramext.Stoken ("LIDENT", ""); - Gramext.Stoken ("", "="); Gramext.Sself; - Gramext.Snterm - (Grammar.Entry.obj - (direction_flag : 'direction_flag Grammar.Entry.e)); - Gramext.Sself; Gramext.Stoken ("", "do"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (e : 'e__11))]); - Gramext.Snterm - (Grammar.Entry.obj - (warning_sequence : 'warning_sequence Grammar.Entry.e)); - Gramext.Stoken ("", "done")], - Gramext.action - (fun _ _ (seq : 'e__11 list) _ (e2 : 'expr) (df : 'direction_flag) - (e1 : 'expr) _ (i : string) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExFor (_loc, i, e1, e2, df, seq) : 'expr)); - [Gramext.Stoken ("", "do"); - Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (e : 'e__10))]); - Gramext.Stoken ("", "return"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_sequence : 'warning_sequence Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ _ (seq : 'e__10 list) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.ExSeq (_loc, append_elem seq e) : 'expr))]]; - Grammar.Entry.obj (warning_sequence : 'warning_sequence Grammar.Entry.e), - None, - [None, None, - [[], - Gramext.action - (fun (_loc : Lexing.position * Lexing.position) -> - (warn_sequence _loc : 'warning_sequence))]]]);; - -Grammar.extend - (let _ = (interf : 'interf Grammar.Entry.e) - and _ = (implem : 'implem Grammar.Entry.e) - and _ = (use_file : 'use_file Grammar.Entry.e) - and _ = (top_phrase : 'top_phrase Grammar.Entry.e) - and _ = (expr : 'expr Grammar.Entry.e) - and _ = (patt : 'patt Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry interf) s - in - let sig_item_semi : 'sig_item_semi Grammar.Entry.e = - grammar_entry_create "sig_item_semi" - and str_item_semi : 'str_item_semi Grammar.Entry.e = - grammar_entry_create "str_item_semi" - and phrase : 'phrase Grammar.Entry.e = grammar_entry_create "phrase" in - [Grammar.Entry.obj (interf : 'interf Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - ([], false : 'interf)); - [Gramext.Snterm - (Grammar.Entry.obj (sig_item_semi : 'sig_item_semi Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (sil, stopped : 'interf) (si : 'sig_item_semi) - (_loc : Lexing.position * Lexing.position) -> - (si :: sil, stopped : 'interf)); - [Gramext.Stoken ("", "#"); Gramext.Stoken ("LIDENT", ""); - Gramext.Sopt - (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (dp : 'expr option) (n : string) _ - (_loc : Lexing.position * Lexing.position) -> - ([MLast.SgDir (_loc, n, dp), _loc], true : 'interf))]]; - Grammar.Entry.obj (sig_item_semi : 'sig_item_semi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (si : 'sig_item) (_loc : Lexing.position * Lexing.position) -> - (si, _loc : 'sig_item_semi))]]; - Grammar.Entry.obj (implem : 'implem Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - ([], false : 'implem)); - [Gramext.Snterm - (Grammar.Entry.obj (str_item_semi : 'str_item_semi Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (sil, stopped : 'implem) (si : 'str_item_semi) - (_loc : Lexing.position * Lexing.position) -> - (si :: sil, stopped : 'implem)); - [Gramext.Stoken ("", "#"); Gramext.Stoken ("LIDENT", ""); - Gramext.Sopt - (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (dp : 'expr option) (n : string) _ - (_loc : Lexing.position * Lexing.position) -> - ([MLast.StDir (_loc, n, dp), _loc], true : 'implem))]]; - Grammar.Entry.obj (str_item_semi : 'str_item_semi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (si : 'str_item) (_loc : Lexing.position * Lexing.position) -> - (si, _loc : 'str_item_semi))]]; - Grammar.Entry.obj (top_phrase : 'top_phrase Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - (None : 'top_phrase)); - [Gramext.Snterm (Grammar.Entry.obj (phrase : 'phrase Grammar.Entry.e))], - Gramext.action - (fun (ph : 'phrase) (_loc : Lexing.position * Lexing.position) -> - (Some ph : 'top_phrase))]]; - Grammar.Entry.obj (use_file : 'use_file Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - ([], false : 'use_file)); - [Gramext.Snterm - (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";"); Gramext.Sself], - Gramext.action - (fun (sil, stopped : 'use_file) _ (si : 'str_item) - (_loc : Lexing.position * Lexing.position) -> - (si :: sil, stopped : 'use_file)); - [Gramext.Stoken ("", "#"); Gramext.Stoken ("LIDENT", ""); - Gramext.Sopt - (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (dp : 'expr option) (n : string) _ - (_loc : Lexing.position * Lexing.position) -> - ([MLast.StDir (_loc, n, dp)], true : 'use_file))]]; - Grammar.Entry.obj (phrase : 'phrase Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (sti : 'str_item) (_loc : Lexing.position * Lexing.position) -> - (sti : 'phrase)); - [Gramext.Stoken ("", "#"); Gramext.Stoken ("LIDENT", ""); - Gramext.Sopt - (Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (dp : 'expr option) (n : string) _ - (_loc : Lexing.position * Lexing.position) -> - (MLast.StDir (_loc, n, dp) : 'phrase))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("QUOTATION", "")], - Gramext.action - (fun (x : string) (_loc : Lexing.position * Lexing.position) -> - (let x = - try - let i = String.index x ':' in - String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1) - with - Not_found -> "", x - in - Pcaml.handle_expr_quotation _loc x : - 'expr)); - [Gramext.Stoken ("LOCATE", "")], - Gramext.action - (fun (x : string) (_loc : Lexing.position * Lexing.position) -> - (let x = - try - let i = String.index x ':' in - {(Lexing.dummy_pos) with - Lexing.pos_cnum = int_of_string (String.sub x 0 i)}, - String.sub x (i + 1) (String.length x - i - 1) - with - Not_found | Failure _ -> - {(Lexing.dummy_pos) with Lexing.pos_cnum = 0}, x - in - Pcaml.handle_expr_locate _loc x : - 'expr))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("QUOTATION", "")], - Gramext.action - (fun (x : string) (_loc : Lexing.position * Lexing.position) -> - (let x = - try - let i = String.index x ':' in - String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1) - with - Not_found -> "", x - in - Pcaml.handle_patt_quotation _loc x : - 'patt)); - [Gramext.Stoken ("LOCATE", "")], - Gramext.action - (fun (x : string) (_loc : Lexing.position * Lexing.position) -> - (let x = - try - let i = String.index x ':' in - {(Lexing.dummy_pos) with - Lexing.pos_cnum = int_of_string (String.sub x 0 i)}, - String.sub x (i + 1) (String.length x - i - 1) - with - Not_found | Failure _ -> - {(Lexing.dummy_pos) with Lexing.pos_cnum = 0}, x - in - Pcaml.handle_patt_locate _loc x : - 'patt))]]]);; diff --git a/camlp4/ocaml_src/meta/pa_rp.ml b/camlp4/ocaml_src/meta/pa_rp.ml deleted file mode 100644 index 0bcfc17c..00000000 --- a/camlp4/ocaml_src/meta/pa_rp.ml +++ /dev/null @@ -1,660 +0,0 @@ -(* camlp4r pa_extend.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -open Pcaml;; - -type spat_comp = - SpTrm of MLast.loc * MLast.patt * MLast.expr option - | SpNtr of MLast.loc * MLast.patt * MLast.expr - | SpStr of MLast.loc * MLast.patt -;; -type sexp_comp = - SeTrm of MLast.loc * MLast.expr - | SeNtr of MLast.loc * MLast.expr -;; - -let strm_n = "strm__";; -let peek_fun _loc = - MLast.ExAcc (_loc, MLast.ExUid (_loc, "Stream"), MLast.ExLid (_loc, "peek")) -;; -let junk_fun _loc = - MLast.ExAcc (_loc, MLast.ExUid (_loc, "Stream"), MLast.ExLid (_loc, "junk")) -;; - -(* Parsers. *) -(* In syntax generated, many cases are optimisations. *) - -let rec pattern_eq_expression p e = - match p, e with - MLast.PaLid (_, a), MLast.ExLid (_, b) -> a = b - | MLast.PaUid (_, a), MLast.ExUid (_, b) -> a = b - | MLast.PaApp (_, p1, p2), MLast.ExApp (_, e1, e2) -> - pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2 - | _ -> false -;; - -let is_raise e = - match e with - MLast.ExApp (_, MLast.ExLid (_, "raise"), _) -> true - | _ -> false -;; - -let is_raise_failure e = - match e with - MLast.ExApp - (_, MLast.ExLid (_, "raise"), - MLast.ExAcc - (_, MLast.ExUid (_, "Stream"), MLast.ExUid (_, "Failure"))) -> - true - | _ -> false -;; - -let rec handle_failure e = - match e with - MLast.ExTry - (_, te, - [MLast.PaAcc - (_, MLast.PaUid (_, "Stream"), MLast.PaUid (_, "Failure")), None, - e]) -> - handle_failure e - | MLast.ExMat (_, me, pel) -> - handle_failure me && - List.for_all - (function - _, None, e -> handle_failure e - | _ -> false) - pel - | MLast.ExLet (_, false, pel, e) -> - List.for_all (fun (p, e) -> handle_failure e) pel && handle_failure e - | MLast.ExLid (_, _) | MLast.ExInt (_, _) | MLast.ExStr (_, _) | - MLast.ExChr (_, _) | MLast.ExFun (_, _) | MLast.ExUid (_, _) -> - true - | MLast.ExApp (_, MLast.ExLid (_, "raise"), e) -> - begin match e with - MLast.ExAcc - (_, MLast.ExUid (_, "Stream"), MLast.ExUid (_, "Failure")) -> - false - | _ -> true - end - | MLast.ExApp (_, f, x) -> - is_constr_apply f && handle_failure f && handle_failure x - | _ -> false -and is_constr_apply = - function - MLast.ExUid (_, _) -> true - | MLast.ExLid (_, _) -> false - | MLast.ExApp (_, x, _) -> is_constr_apply x - | _ -> false -;; - -let rec subst v e = - let _loc = MLast.loc_of_expr e in - match e with - MLast.ExLid (_, x) -> - let x = if x = v then strm_n else x in MLast.ExLid (_loc, x) - | MLast.ExUid (_, _) -> e - | MLast.ExInt (_, _) -> e - | MLast.ExChr (_, _) -> e - | MLast.ExStr (_, _) -> e - | MLast.ExAcc (_, _, _) -> e - | MLast.ExLet (_, rf, pel, e) -> - MLast.ExLet (_loc, rf, List.map (subst_pe v) pel, subst v e) - | MLast.ExApp (_, e1, e2) -> MLast.ExApp (_loc, subst v e1, subst v e2) - | MLast.ExTup (_, el) -> MLast.ExTup (_loc, List.map (subst v) el) - | _ -> raise Not_found -and subst_pe v (p, e) = - match p with - MLast.PaLid (_, v') when v <> v' -> p, subst v e - | _ -> raise Not_found -;; - -let stream_pattern_component skont ckont = - function - SpTrm (_loc, p, wo) -> - MLast.ExMat - (_loc, MLast.ExApp (_loc, peek_fun _loc, MLast.ExLid (_loc, strm_n)), - [MLast.PaApp (_loc, MLast.PaUid (_loc, "Some"), p), wo, - MLast.ExSeq - (_loc, - [MLast.ExApp (_loc, junk_fun _loc, MLast.ExLid (_loc, strm_n)); - skont]); - MLast.PaAny _loc, None, ckont]) - | SpNtr (_loc, p, e) -> - let e = - match e with - MLast.ExFun - (_, - [MLast.PaTyc - (_, MLast.PaLid (_, v), - MLast.TyApp - (_, - MLast.TyAcc - (_, MLast.TyUid (_, "Stream"), MLast.TyLid (_, "t")), - MLast.TyAny _)), None, e]) - when v = strm_n -> - e - | _ -> MLast.ExApp (_loc, e, MLast.ExLid (_loc, strm_n)) - in - if pattern_eq_expression p skont then - if is_raise_failure ckont then e - else if handle_failure e then e - else - MLast.ExTry - (_loc, e, - [MLast.PaAcc - (_loc, MLast.PaUid (_loc, "Stream"), - MLast.PaUid (_loc, "Failure")), - None, ckont]) - else if is_raise_failure ckont then - MLast.ExLet (_loc, false, [p, e], skont) - else if - pattern_eq_expression - (MLast.PaApp (_loc, MLast.PaUid (_loc, "Some"), p)) skont - then - MLast.ExTry - (_loc, MLast.ExApp (_loc, MLast.ExUid (_loc, "Some"), e), - [MLast.PaAcc - (_loc, MLast.PaUid (_loc, "Stream"), - MLast.PaUid (_loc, "Failure")), - None, ckont]) - else if is_raise ckont then - let tst = - if handle_failure e then e - else - MLast.ExTry - (_loc, e, - [MLast.PaAcc - (_loc, MLast.PaUid (_loc, "Stream"), - MLast.PaUid (_loc, "Failure")), - None, ckont]) - in - MLast.ExLet (_loc, false, [p, tst], skont) - else - MLast.ExMat - (_loc, - MLast.ExTry - (_loc, MLast.ExApp (_loc, MLast.ExUid (_loc, "Some"), e), - [MLast.PaAcc - (_loc, MLast.PaUid (_loc, "Stream"), - MLast.PaUid (_loc, "Failure")), - None, MLast.ExUid (_loc, "None")]), - [MLast.PaApp (_loc, MLast.PaUid (_loc, "Some"), p), None, skont; - MLast.PaAny _loc, None, ckont]) - | SpStr (_loc, p) -> - try - match p with - MLast.PaLid (_, v) -> subst v skont - | _ -> raise Not_found - with - Not_found -> - MLast.ExLet (_loc, false, [p, MLast.ExLid (_loc, strm_n)], skont) -;; - -let rec stream_pattern _loc epo e ekont = - function - [] -> - begin match epo with - Some ep -> - MLast.ExLet - (_loc, false, - [ep, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Stream"), - MLast.ExLid (_loc, "count")), - MLast.ExLid (_loc, strm_n))], - e) - | _ -> e - end - | (spc, err) :: spcl -> - let skont = - let ekont err = - let str = - match err with - Some estr -> estr - | _ -> MLast.ExStr (_loc, "") - in - MLast.ExApp - (_loc, MLast.ExLid (_loc, "raise"), - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Stream"), - MLast.ExUid (_loc, "Error")), - str)) - in - stream_pattern _loc epo e ekont spcl - in - let ckont = ekont err in stream_pattern_component skont ckont spc -;; - -let stream_patterns_term _loc ekont tspel = - let pel = - List.map - (fun (p, w, _loc, spcl, epo, e) -> - let p = MLast.PaApp (_loc, MLast.PaUid (_loc, "Some"), p) in - let e = - let ekont err = - let str = - match err with - Some estr -> estr - | _ -> MLast.ExStr (_loc, "") - in - MLast.ExApp - (_loc, MLast.ExLid (_loc, "raise"), - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Stream"), - MLast.ExUid (_loc, "Error")), - str)) - in - let skont = stream_pattern _loc epo e ekont spcl in - MLast.ExSeq - (_loc, - [MLast.ExApp (_loc, junk_fun _loc, MLast.ExLid (_loc, strm_n)); - skont]) - in - p, w, e) - tspel - in - let pel = pel @ [MLast.PaAny _loc, None, ekont ()] in - MLast.ExMat - (_loc, MLast.ExApp (_loc, peek_fun _loc, MLast.ExLid (_loc, strm_n)), pel) -;; - -let rec group_terms = - function - ((SpTrm (_loc, p, w), None) :: spcl, epo, e) :: spel -> - let (tspel, spel) = group_terms spel in - (p, w, _loc, spcl, epo, e) :: tspel, spel - | spel -> [], spel -;; - -let rec parser_cases _loc = - function - [] -> - MLast.ExApp - (_loc, MLast.ExLid (_loc, "raise"), - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Stream"), - MLast.ExUid (_loc, "Failure"))) - | spel -> - match group_terms spel with - [], (spcl, epo, e) :: spel -> - stream_pattern _loc epo e (fun _ -> parser_cases _loc spel) spcl - | tspel, spel -> - stream_patterns_term _loc (fun _ -> parser_cases _loc spel) tspel -;; - -let cparser _loc bpo pc = - let e = parser_cases _loc pc in - let e = - match bpo with - Some bp -> - MLast.ExLet - (_loc, false, - [bp, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Stream"), - MLast.ExLid (_loc, "count")), - MLast.ExLid (_loc, strm_n))], - e) - | None -> e - in - let p = - MLast.PaTyc - (_loc, MLast.PaLid (_loc, strm_n), - MLast.TyApp - (_loc, - MLast.TyAcc - (_loc, MLast.TyUid (_loc, "Stream"), MLast.TyLid (_loc, "t")), - MLast.TyAny _loc)) - in - MLast.ExFun (_loc, [p, None, e]) -;; - -let cparser_match _loc me bpo pc = - let pc = parser_cases _loc pc in - let e = - match bpo with - Some bp -> - MLast.ExLet - (_loc, false, - [bp, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Stream"), - MLast.ExLid (_loc, "count")), - MLast.ExLid (_loc, strm_n))], - pc) - | None -> pc - in - match me with - MLast.ExLid (_, x) when x = strm_n -> e - | _ -> - MLast.ExLet - (_loc, false, - [MLast.PaTyc - (_loc, MLast.PaLid (_loc, strm_n), - MLast.TyApp - (_loc, - MLast.TyAcc - (_loc, MLast.TyUid (_loc, "Stream"), - MLast.TyLid (_loc, "t")), - MLast.TyAny _loc)), - me], - e) -;; - -(* streams *) - -let rec not_computing = - function - MLast.ExLid (_, _) | MLast.ExUid (_, _) | MLast.ExInt (_, _) | - MLast.ExFlo (_, _) | MLast.ExChr (_, _) | MLast.ExStr (_, _) -> - true - | MLast.ExApp (_, x, y) -> is_cons_apply_not_computing x && not_computing y - | _ -> false -and is_cons_apply_not_computing = - function - MLast.ExUid (_, _) -> true - | MLast.ExLid (_, _) -> false - | MLast.ExApp (_, x, y) -> is_cons_apply_not_computing x && not_computing y - | _ -> false -;; - -let slazy _loc e = - match e with - MLast.ExApp (_, f, MLast.ExUid (_, "()")) -> - begin match f with - MLast.ExLid (_, _) -> f - | _ -> MLast.ExFun (_loc, [MLast.PaAny _loc, None, e]) - end - | _ -> MLast.ExFun (_loc, [MLast.PaAny _loc, None, e]) -;; - -let rec cstream gloc = - function - [] -> - let _loc = gloc in - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Stream"), MLast.ExLid (_loc, "sempty")) - | [SeTrm (_loc, e)] -> - if not_computing e then - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Stream"), - MLast.ExLid (_loc, "ising")), - e) - else - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Stream"), - MLast.ExLid (_loc, "lsing")), - slazy _loc e) - | SeTrm (_loc, e) :: secl -> - if not_computing e then - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Stream"), - MLast.ExLid (_loc, "icons")), - e), - cstream gloc secl) - else - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Stream"), - MLast.ExLid (_loc, "lcons")), - slazy _loc e), - cstream gloc secl) - | [SeNtr (_loc, e)] -> - if not_computing e then e - else - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Stream"), - MLast.ExLid (_loc, "slazy")), - slazy _loc e) - | SeNtr (_loc, e) :: secl -> - if not_computing e then - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Stream"), - MLast.ExLid (_loc, "iapp")), - e), - cstream gloc secl) - else - MLast.ExApp - (_loc, - MLast.ExApp - (_loc, - MLast.ExAcc - (_loc, MLast.ExUid (_loc, "Stream"), - MLast.ExLid (_loc, "lapp")), - slazy _loc e), - cstream gloc secl) -;; - -(* Syntax extensions in Revised Syntax grammar *) - -Grammar.extend - (let _ = (expr : 'expr Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry expr) s - in - let parser_case : 'parser_case Grammar.Entry.e = - grammar_entry_create "parser_case" - and stream_patt : 'stream_patt Grammar.Entry.e = - grammar_entry_create "stream_patt" - and stream_patt_comp_err : 'stream_patt_comp_err Grammar.Entry.e = - grammar_entry_create "stream_patt_comp_err" - and stream_patt_comp : 'stream_patt_comp Grammar.Entry.e = - grammar_entry_create "stream_patt_comp" - and ipatt : 'ipatt Grammar.Entry.e = grammar_entry_create "ipatt" - and stream_expr_comp : 'stream_expr_comp Grammar.Entry.e = - grammar_entry_create "stream_expr_comp" - in - [Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "match"); Gramext.Sself; - Gramext.Stoken ("", "with"); Gramext.Stoken ("", "parser"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e))], - Gramext.action - (fun (pc : 'parser_case) (po : 'ipatt option) _ _ (e : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (cparser_match _loc e po [pc] : 'expr)); - [Gramext.Stoken ("", "match"); Gramext.Sself; - Gramext.Stoken ("", "with"); Gramext.Stoken ("", "parser"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))); - Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (pcl : 'parser_case list) _ (po : 'ipatt option) _ _ - (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (cparser_match _loc e po pcl : 'expr)); - [Gramext.Stoken ("", "parser"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))); - Gramext.Snterm - (Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e))], - Gramext.action - (fun (pc : 'parser_case) (po : 'ipatt option) _ - (_loc : Lexing.position * Lexing.position) -> - (cparser _loc po [pc] : 'expr)); - [Gramext.Stoken ("", "parser"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))); - Gramext.Stoken ("", "["); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e)), - Gramext.Stoken ("", "|")); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (pcl : 'parser_case list) _ (po : 'ipatt option) _ - (_loc : Lexing.position * Lexing.position) -> - (cparser _loc po pcl : 'expr))]]; - Grammar.Entry.obj (parser_case : 'parser_case Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "[:"); - Gramext.Snterm - (Grammar.Entry.obj (stream_patt : 'stream_patt Grammar.Entry.e)); - Gramext.Stoken ("", ":]"); - Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))); - Gramext.Stoken ("", "->"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (po : 'ipatt option) _ (sp : 'stream_patt) _ - (_loc : Lexing.position * Lexing.position) -> - (sp, po, e : 'parser_case))]]; - Grammar.Entry.obj (stream_patt : 'stream_patt Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (_loc : Lexing.position * Lexing.position) -> - ([] : 'stream_patt)); - [Gramext.Snterm - (Grammar.Entry.obj - (stream_patt_comp : 'stream_patt_comp Grammar.Entry.e)); - Gramext.Stoken ("", ";"); - Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (stream_patt_comp_err : - 'stream_patt_comp_err Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (sp : 'stream_patt_comp_err list) _ (spc : 'stream_patt_comp) - (_loc : Lexing.position * Lexing.position) -> - ((spc, None) :: sp : 'stream_patt)); - [Gramext.Snterm - (Grammar.Entry.obj - (stream_patt_comp : 'stream_patt_comp Grammar.Entry.e))], - Gramext.action - (fun (spc : 'stream_patt_comp) - (_loc : Lexing.position * Lexing.position) -> - ([spc, None] : 'stream_patt))]]; - Grammar.Entry.obj - (stream_patt_comp_err : 'stream_patt_comp_err Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (stream_patt_comp : 'stream_patt_comp Grammar.Entry.e)); - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "?"); - Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (e : 'e__1))])], - Gramext.action - (fun (eo : 'e__1 option) (spc : 'stream_patt_comp) - (_loc : Lexing.position * Lexing.position) -> - (spc, eo : 'stream_patt_comp_err))]]; - Grammar.Entry.obj (stream_patt_comp : 'stream_patt_comp Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) (_loc : Lexing.position * Lexing.position) -> - (SpStr (_loc, p) : 'stream_patt_comp)); - [Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (p : 'patt) - (_loc : Lexing.position * Lexing.position) -> - (SpNtr (_loc, p, e) : 'stream_patt_comp)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "when"); - Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (e : 'e__2))])], - Gramext.action - (fun (eo : 'e__2 option) (p : 'patt) _ - (_loc : Lexing.position * Lexing.position) -> - (SpTrm (_loc, p, eo) : 'stream_patt_comp))]]; - Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (MLast.PaLid (_loc, i) : 'ipatt))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "[:"); - Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (stream_expr_comp : 'stream_expr_comp Grammar.Entry.e)), - Gramext.Stoken ("", ";")); - Gramext.Stoken ("", ":]")], - Gramext.action - (fun _ (se : 'stream_expr_comp list) _ - (_loc : Lexing.position * Lexing.position) -> - (cstream _loc se : 'expr))]]; - Grammar.Entry.obj (stream_expr_comp : 'stream_expr_comp Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) (_loc : Lexing.position * Lexing.position) -> - (SeNtr (_loc, e) : 'stream_expr_comp)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (SeTrm (_loc, e) : 'stream_expr_comp))]]]);; diff --git a/camlp4/ocaml_src/meta/pr_dump.ml b/camlp4/ocaml_src/meta/pr_dump.ml deleted file mode 100644 index db422853..00000000 --- a/camlp4/ocaml_src/meta/pr_dump.ml +++ /dev/null @@ -1,48 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -let open_out_file () = - match !(Pcaml.output_file) with - Some f -> open_out_bin f - | None -> set_binary_mode_out stdout true; stdout -;; - -let interf ast = - let pt = Ast2pt.interf (List.map fst ast) in - let oc = open_out_file () in - let fname = !(Pcaml.input_file) in - output_string oc Config.ast_intf_magic_number; - output_value oc (if fname = "-" then "" else fname); - output_value oc pt; - flush oc; - match !(Pcaml.output_file) with - Some _ -> close_out oc - | None -> () -;; - -let implem ast = - let pt = Ast2pt.implem (List.map fst ast) in - let oc = open_out_file () in - let fname = !(Pcaml.input_file) in - output_string oc Config.ast_impl_magic_number; - output_value oc (if fname = "-" then "" else fname); - output_value oc pt; - flush oc; - match !(Pcaml.output_file) with - Some _ -> close_out oc - | None -> () -;; - -Pcaml.print_interf := interf;; -Pcaml.print_implem := implem;; diff --git a/camlp4/ocaml_src/meta/q_MLast.ml b/camlp4/ocaml_src/meta/q_MLast.ml deleted file mode 100644 index 881f29df..00000000 --- a/camlp4/ocaml_src/meta/q_MLast.ml +++ /dev/null @@ -1,5320 +0,0 @@ -(* camlp4r pa_extend.cmo pa_extend_m.cmo q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -let (gram, q_position) = - let (lexer, pos) = Plexer.make_lexer () in Grammar.gcreate lexer, pos -;; - -module Qast = - struct - type t = - Node of string * t list - | List of t list - | Tuple of t list - | Option of t option - | Int of string - | Str of string - | Bool of bool - | Cons of t * t - | Apply of string * t list - | Record of (string * t) list - | Loc - | Antiquot of MLast.loc * string - ;; - let _loc = - let nowhere = - {(Lexing.dummy_pos) with Lexing.pos_lnum = 1; Lexing.pos_cnum = 0} - in - nowhere, nowhere - ;; - let rec to_expr = - function - Node (n, al) -> - List.fold_left (fun e a -> MLast.ExApp (_loc, e, to_expr a)) - (MLast.ExAcc - (_loc, MLast.ExUid (_loc, "MLast"), MLast.ExUid (_loc, n))) - al - | List al -> - List.fold_right - (fun a e -> - MLast.ExApp - (_loc, - MLast.ExApp (_loc, MLast.ExUid (_loc, "::"), to_expr a), e)) - al (MLast.ExUid (_loc, "[]")) - | Tuple al -> MLast.ExTup (_loc, List.map to_expr al) - | Option None -> MLast.ExUid (_loc, "None") - | Option (Some a) -> - MLast.ExApp (_loc, MLast.ExUid (_loc, "Some"), to_expr a) - | Int s -> MLast.ExInt (_loc, s) - | Str s -> MLast.ExStr (_loc, s) - | Bool true -> MLast.ExUid (_loc, "True") - | Bool false -> MLast.ExUid (_loc, "False") - | Cons (a1, a2) -> - MLast.ExApp - (_loc, MLast.ExApp (_loc, MLast.ExUid (_loc, "::"), to_expr a1), - to_expr a2) - | Apply (f, al) -> - List.fold_left (fun e a -> MLast.ExApp (_loc, e, to_expr a)) - (MLast.ExLid (_loc, f)) al - | Record lal -> MLast.ExRec (_loc, List.map to_expr_label lal, None) - | Loc -> MLast.ExLid (_loc, !(Stdpp.loc_name)) - | Antiquot (loc, s) -> - let (bolpos, lnum, _) = !(Pcaml.position) in - let (bolposv, lnumv) = !bolpos, !lnum in - let zero_pos () = bolpos := 0; lnum := 1 in - let restore_pos () = bolpos := bolposv; lnum := lnumv in - let e = - try - let _ = zero_pos () in - let result = - Grammar.Entry.parse Pcaml.expr_eoi (Stream.of_string s) - in - let _ = restore_pos () in result - with - Stdpp.Exc_located ((bp, ep), exc) -> - restore_pos (); - raise - (Stdpp.Exc_located - (Reloc.adjust_loc (fst loc) (bp, ep), exc)) - | exc -> restore_pos (); raise exc - in - MLast.ExAnt (_loc, e) - and to_expr_label (l, a) = - MLast.PaAcc (_loc, MLast.PaUid (_loc, "MLast"), MLast.PaLid (_loc, l)), - to_expr a - ;; - let rec to_patt = - function - Node (n, al) -> - List.fold_left (fun e a -> MLast.PaApp (_loc, e, to_patt a)) - (MLast.PaAcc - (_loc, MLast.PaUid (_loc, "MLast"), MLast.PaUid (_loc, n))) - al - | List al -> - List.fold_right - (fun a p -> - MLast.PaApp - (_loc, - MLast.PaApp (_loc, MLast.PaUid (_loc, "::"), to_patt a), p)) - al (MLast.PaUid (_loc, "[]")) - | Tuple al -> MLast.PaTup (_loc, List.map to_patt al) - | Option None -> MLast.PaUid (_loc, "None") - | Option (Some a) -> - MLast.PaApp (_loc, MLast.PaUid (_loc, "Some"), to_patt a) - | Int s -> MLast.PaInt (_loc, s) - | Str s -> MLast.PaStr (_loc, s) - | Bool true -> MLast.PaUid (_loc, "True") - | Bool false -> MLast.PaUid (_loc, "False") - | Cons (a1, a2) -> - MLast.PaApp - (_loc, MLast.PaApp (_loc, MLast.PaUid (_loc, "::"), to_patt a1), - to_patt a2) - | Apply (_, _) -> failwith "bad pattern" - | Record lal -> MLast.PaRec (_loc, List.map to_patt_label lal) - | Loc -> MLast.PaAny _loc - | Antiquot (loc, s) -> - let (bolpos, lnum, _) = !(Pcaml.position) in - let (bolposv, lnumv) = !bolpos, !lnum in - let zero_pos () = bolpos := 0; lnum := 1 in - let restore_pos () = bolpos := bolposv; lnum := lnumv in - let p = - try - let _ = zero_pos () in - let result = - Grammar.Entry.parse Pcaml.patt_eoi (Stream.of_string s) - in - let _ = restore_pos () in result - with - Stdpp.Exc_located ((bp, ep), exc) -> - restore_pos (); - raise - (Stdpp.Exc_located - (Reloc.adjust_loc (fst loc) (bp, ep), exc)) - | exc -> restore_pos (); raise exc - in - MLast.PaAnt (_loc, p) - and to_patt_label (l, a) = - MLast.PaAcc (_loc, MLast.PaUid (_loc, "MLast"), MLast.PaLid (_loc, l)), - to_patt a - ;; - end -;; - -let antiquot k (bp, ep) x = - let shift = - if k = "" then String.length "$" - else String.length "$" + String.length k + String.length ":" - in - Qast.Antiquot ((Reloc.shift_pos shift bp, Reloc.shift_pos (-1) ep), x) -;; - -let sig_item = Grammar.Entry.create gram "signature item";; -let str_item = Grammar.Entry.create gram "structure item";; -let ctyp = Grammar.Entry.create gram "type";; -let patt = Grammar.Entry.create gram "pattern";; -let expr = Grammar.Entry.create gram "expression";; - -let module_type = Grammar.Entry.create gram "module type";; -let module_expr = Grammar.Entry.create gram "module expression";; - -let class_type = Grammar.Entry.create gram "class type";; -let class_expr = Grammar.Entry.create gram "class expr";; -let class_sig_item = Grammar.Entry.create gram "class signature item";; -let class_str_item = Grammar.Entry.create gram "class structure item";; - -let ipatt = Grammar.Entry.create gram "ipatt";; -let let_binding = Grammar.Entry.create gram "let_binding";; -let type_declaration = Grammar.Entry.create gram "type_declaration";; -let with_constr = Grammar.Entry.create gram "with_constr";; -let row_field = Grammar.Entry.create gram "row_field";; - -let a_list = Grammar.Entry.create gram "a_list";; -let a_opt = Grammar.Entry.create gram "a_opt";; -let a_UIDENT = Grammar.Entry.create gram "a_UIDENT";; -let a_LIDENT = Grammar.Entry.create gram "a_LIDENT";; -let a_INT = Grammar.Entry.create gram "a_INT";; -let a_INT32 = Grammar.Entry.create gram "a_INT32";; -let a_INT64 = Grammar.Entry.create gram "a_INT64";; -let a_NATIVEINT = Grammar.Entry.create gram "a__NATIVEINT";; -let a_FLOAT = Grammar.Entry.create gram "a_FLOAT";; -let a_STRING = Grammar.Entry.create gram "a_STRING";; -let a_CHAR = Grammar.Entry.create gram "a_CHAR";; -let a_TILDEIDENT = Grammar.Entry.create gram "a_TILDEIDENT";; -let a_LABEL = Grammar.Entry.create gram "a_LABEL";; -let a_QUESTIONIDENT = Grammar.Entry.create gram "a_QUESTIONIDENT";; -let a_OPTLABEL = Grammar.Entry.create gram "a_OPTLABEL";; - -let o2b = - function - Qast.Option (Some _) -> Qast.Bool true - | Qast.Option None -> Qast.Bool false - | x -> x -;; - -let mksequence _ = - function - Qast.List [e] -> e - | el -> Qast.Node ("ExSeq", [Qast.Loc; el]) -;; - -let mkmatchcase _ p aso w e = - let p = - match aso with - Qast.Option (Some p2) -> Qast.Node ("PaAli", [Qast.Loc; p; p2]) - | Qast.Option None -> p - | _ -> Qast.Node ("PaAli", [Qast.Loc; p; aso]) - in - Qast.Tuple [p; w; e] -;; - -let neg_string n = - let len = String.length n in - if len > 0 && n.[0] = '-' then String.sub n 1 (len - 1) else "-" ^ n -;; - -let mkumin _ f arg = - match arg with - Qast.Node - (("ExInt" | "ExInt32" | "ExInt64" | "ExNativeInt" as exi), - [Qast.Loc; Qast.Str n]) - when int_of_string n > 0 -> - let n = neg_string n in Qast.Node (exi, [Qast.Loc; Qast.Str n]) - | Qast.Node ("ExFlo", [Qast.Loc; Qast.Str n]) - when float_of_string n > 0.0 -> - let n = neg_string n in Qast.Node ("ExFlo", [Qast.Loc; Qast.Str n]) - | _ -> - match f with - Qast.Str f -> - let f = "~" ^ f in - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str f]); arg]) - | _ -> assert false -;; - -let mkuminpat _ f is_int s = - let s = - match s with - Qast.Str s -> Qast.Str (neg_string s) - | s -> failwith "bad unary minus" - in - match is_int with - Qast.Bool true -> Qast.Node ("PaInt", [Qast.Loc; s]) - | Qast.Bool false -> Qast.Node ("PaFlo", [Qast.Loc; s]) - | _ -> assert false -;; - -let mklistexp _ last = - let rec loop top = - function - Qast.List [] -> - begin match last with - Qast.Option (Some e) -> e - | Qast.Option None -> Qast.Node ("ExUid", [Qast.Loc; Qast.Str "[]"]) - | a -> a - end - | Qast.List (e1 :: el) -> - Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExUid", [Qast.Loc; Qast.Str "::"]); - e1]); - loop false (Qast.List el)]) - | a -> a - in - loop true -;; - -let mklistpat _ last = - let rec loop top = - function - Qast.List [] -> - begin match last with - Qast.Option (Some p) -> p - | Qast.Option None -> Qast.Node ("PaUid", [Qast.Loc; Qast.Str "[]"]) - | a -> a - end - | Qast.List (p1 :: pl) -> - Qast.Node - ("PaApp", - [Qast.Loc; - Qast.Node - ("PaApp", - [Qast.Loc; Qast.Node ("PaUid", [Qast.Loc; Qast.Str "::"]); - p1]); - loop false (Qast.List pl)]) - | a -> a - in - loop true -;; - -let mkexprident loc i j = - let rec loop m = - function - Qast.Node ("ExAcc", [_; x; y]) -> - loop (Qast.Node ("ExAcc", [Qast.Loc; m; x])) y - | e -> Qast.Node ("ExAcc", [Qast.Loc; m; e]) - in - loop (Qast.Node ("ExUid", [Qast.Loc; i])) j -;; - -let mkassert _ e = - match e with - Qast.Node ("ExUid", [_; Qast.Str "False"]) -> - Qast.Node ("ExAsf", [Qast.Loc]) - | _ -> Qast.Node ("ExAsr", [Qast.Loc; e]) -;; - -let append_elem el e = Qast.Apply ("@", [el; Qast.List [e]]);; - -let not_yet_warned_antiq = ref true;; -let warn_antiq loc vers = - if !not_yet_warned_antiq then - begin - not_yet_warned_antiq := false; - !(Pcaml.warning) loc - (Printf.sprintf - "use of antiquotation syntax deprecated since version %s" vers) - end -;; - -let not_yet_warned_variant = ref true;; -let warn_variant _ = - if !not_yet_warned_variant then - begin - not_yet_warned_variant := false; - !(Pcaml.warning) (Lexing.dummy_pos, Reloc.shift_pos 1 Lexing.dummy_pos) - (Printf.sprintf - "use of syntax of variants types deprecated since version 3.05") - end -;; - -let not_yet_warned_seq = ref true;; -let warn_sequence _ = - if !not_yet_warned_seq then - begin - not_yet_warned_seq := false; - !(Pcaml.warning) (Lexing.dummy_pos, Reloc.shift_pos 1 Lexing.dummy_pos) - (Printf.sprintf - "use of syntax of sequences deprecated since version 3.01.1") - end -;; - -Grammar.extend - (let _ = (sig_item : 'sig_item Grammar.Entry.e) - and _ = (str_item : 'str_item Grammar.Entry.e) - and _ = (ctyp : 'ctyp Grammar.Entry.e) - and _ = (patt : 'patt Grammar.Entry.e) - and _ = (expr : 'expr Grammar.Entry.e) - and _ = (module_type : 'module_type Grammar.Entry.e) - and _ = (module_expr : 'module_expr Grammar.Entry.e) - and _ = (class_type : 'class_type Grammar.Entry.e) - and _ = (class_expr : 'class_expr Grammar.Entry.e) - and _ = (class_sig_item : 'class_sig_item Grammar.Entry.e) - and _ = (class_str_item : 'class_str_item Grammar.Entry.e) - and _ = (let_binding : 'let_binding Grammar.Entry.e) - and _ = (type_declaration : 'type_declaration Grammar.Entry.e) - and _ = (ipatt : 'ipatt Grammar.Entry.e) - and _ = (with_constr : 'with_constr Grammar.Entry.e) - and _ = (row_field : 'row_field Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry sig_item) s - in - let rebind_exn : 'rebind_exn Grammar.Entry.e = - grammar_entry_create "rebind_exn" - and module_binding : 'module_binding Grammar.Entry.e = - grammar_entry_create "module_binding" - and module_rec_binding : 'module_rec_binding Grammar.Entry.e = - grammar_entry_create "module_rec_binding" - and module_declaration : 'module_declaration Grammar.Entry.e = - grammar_entry_create "module_declaration" - and module_rec_declaration : 'module_rec_declaration Grammar.Entry.e = - grammar_entry_create "module_rec_declaration" - and cons_expr_opt : 'cons_expr_opt Grammar.Entry.e = - grammar_entry_create "cons_expr_opt" - and dummy : 'dummy Grammar.Entry.e = grammar_entry_create "dummy" - and fun_binding : 'fun_binding Grammar.Entry.e = - grammar_entry_create "fun_binding" - and match_case : 'match_case Grammar.Entry.e = - grammar_entry_create "match_case" - and as_patt_opt : 'as_patt_opt Grammar.Entry.e = - grammar_entry_create "as_patt_opt" - and label_expr : 'label_expr Grammar.Entry.e = - grammar_entry_create "label_expr" - and fun_def : 'fun_def Grammar.Entry.e = grammar_entry_create "fun_def" - and cons_patt_opt : 'cons_patt_opt Grammar.Entry.e = - grammar_entry_create "cons_patt_opt" - and label_patt : 'label_patt Grammar.Entry.e = - grammar_entry_create "label_patt" - and label_ipatt : 'label_ipatt Grammar.Entry.e = - grammar_entry_create "label_ipatt" - and type_patt : 'type_patt Grammar.Entry.e = - grammar_entry_create "type_patt" - and constrain : 'constrain Grammar.Entry.e = - grammar_entry_create "constrain" - and type_parameter : 'type_parameter Grammar.Entry.e = - grammar_entry_create "type_parameter" - and constructor_declaration : 'constructor_declaration Grammar.Entry.e = - grammar_entry_create "constructor_declaration" - and label_declaration : 'label_declaration Grammar.Entry.e = - grammar_entry_create "label_declaration" - and ident : 'ident Grammar.Entry.e = grammar_entry_create "ident" - and class_declaration : 'class_declaration Grammar.Entry.e = - grammar_entry_create "class_declaration" - and class_fun_binding : 'class_fun_binding Grammar.Entry.e = - grammar_entry_create "class_fun_binding" - and class_type_parameters : 'class_type_parameters Grammar.Entry.e = - grammar_entry_create "class_type_parameters" - and class_fun_def : 'class_fun_def Grammar.Entry.e = - grammar_entry_create "class_fun_def" - and class_structure : 'class_structure Grammar.Entry.e = - grammar_entry_create "class_structure" - and class_self_patt : 'class_self_patt Grammar.Entry.e = - grammar_entry_create "class_self_patt" - and as_lident : 'as_lident Grammar.Entry.e = - grammar_entry_create "as_lident" - and polyt : 'polyt Grammar.Entry.e = grammar_entry_create "polyt" - and cvalue_binding : 'cvalue_binding Grammar.Entry.e = - grammar_entry_create "cvalue_binding" - and label : 'label Grammar.Entry.e = grammar_entry_create "label" - and class_self_type : 'class_self_type Grammar.Entry.e = - grammar_entry_create "class_self_type" - and class_description : 'class_description Grammar.Entry.e = - grammar_entry_create "class_description" - and class_type_declaration : 'class_type_declaration Grammar.Entry.e = - grammar_entry_create "class_type_declaration" - and field_expr : 'field_expr Grammar.Entry.e = - grammar_entry_create "field_expr" - and field : 'field Grammar.Entry.e = grammar_entry_create "field" - and typevar : 'typevar Grammar.Entry.e = grammar_entry_create "typevar" - and row_field_list : 'row_field_list Grammar.Entry.e = - grammar_entry_create "row_field_list" - and name_tag : 'name_tag Grammar.Entry.e = grammar_entry_create "name_tag" - and patt_tcon : 'patt_tcon Grammar.Entry.e = - grammar_entry_create "patt_tcon" - and ipatt_tcon : 'ipatt_tcon Grammar.Entry.e = - grammar_entry_create "ipatt_tcon" - and eq_expr : 'eq_expr Grammar.Entry.e = grammar_entry_create "eq_expr" - and warning_variant : 'warning_variant Grammar.Entry.e = - grammar_entry_create "warning_variant" - and warning_sequence : 'warning_sequence Grammar.Entry.e = - grammar_entry_create "warning_sequence" - and sequence : 'sequence Grammar.Entry.e = grammar_entry_create "sequence" - and expr_ident : 'expr_ident Grammar.Entry.e = - grammar_entry_create "expr_ident" - and patt_label_ident : 'patt_label_ident Grammar.Entry.e = - grammar_entry_create "patt_label_ident" - and when_expr_opt : 'when_expr_opt Grammar.Entry.e = - grammar_entry_create "when_expr_opt" - and mod_ident : 'mod_ident Grammar.Entry.e = - grammar_entry_create "mod_ident" - and clty_longident : 'clty_longident Grammar.Entry.e = - grammar_entry_create "clty_longident" - and class_longident : 'class_longident Grammar.Entry.e = - grammar_entry_create "class_longident" - and direction_flag : 'direction_flag Grammar.Entry.e = - grammar_entry_create "direction_flag" - in - [Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "struct"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'str_item) - (_loc : Lexing.position * Lexing.position) -> - (s : 'e__1))])], - Gramext.action - (fun (a : 'e__1 list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("MeStr", [Qast.Loc; st]) : 'module_expr)); - [Gramext.Stoken ("", "functor"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")"); Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (me : 'module_expr) _ _ (t : 'module_type) _ (i : 'a_UIDENT) _ _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("MeFun", [Qast.Loc; i; t; me]) : 'module_expr))]; - None, None, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (me2 : 'module_expr) (me1 : 'module_expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("MeApp", [Qast.Loc; me1; me2]) : 'module_expr))]; - None, None, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (me2 : 'module_expr) _ (me1 : 'module_expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("MeAcc", [Qast.Loc; me1; me2]) : 'module_expr))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (me : 'module_expr) _ - (_loc : Lexing.position * Lexing.position) -> - (me : 'module_expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (mt : 'module_type) _ (me : 'module_expr) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("MeTyc", [Qast.Loc; me; mt]) : 'module_expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_UIDENT) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("MeUid", [Qast.Loc; i]) : 'module_expr))]]; - Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None, - [Some "top", None, - [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("StExp", [Qast.Loc; e]) : 'str_item)); - [Gramext.Stoken ("", "value"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "rec")], - Gramext.action - (fun (x : string) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__3))])], - Gramext.action - (fun (a : 'e__3 option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'let_binding list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]], - Gramext.action - (fun (l : 'a_list) (r : 'a_opt) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("StVal", [Qast.Loc; o2b r; l]) : 'str_item)); - [Gramext.Stoken ("", "type"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (type_declaration : 'type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'type_declaration list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]], - Gramext.action - (fun (tdl : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("StTyp", [Qast.Loc; tdl]) : 'str_item)); - [Gramext.Stoken ("", "open"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'mod_ident) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("StOpn", [Qast.Loc; i]) : 'str_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "type"); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (i : 'a_UIDENT) _ _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("StMty", [Qast.Loc; i; mt]) : 'str_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (module_rec_binding : - 'module_rec_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'module_rec_binding list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]], - Gramext.action - (fun (nmtmes : 'a_list) _ _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("StRecMod", [Qast.Loc; nmtmes]) : 'str_item)); - [Gramext.Stoken ("", "module"); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (module_binding : 'module_binding Grammar.Entry.e))], - Gramext.action - (fun (mb : 'module_binding) (i : 'a_UIDENT) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("StMod", [Qast.Loc; i; mb]) : 'str_item)); - [Gramext.Stoken ("", "include"); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("StInc", [Qast.Loc; me]) : 'str_item)); - [Gramext.Stoken ("", "external"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.srules - [[Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e)))], - Gramext.action - (fun (a : 'a_STRING list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]], - Gramext.action - (fun (pd : 'a_list) _ (t : 'ctyp) _ (i : 'a_LIDENT) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("StExt", [Qast.Loc; i; t; pd]) : 'str_item)); - [Gramext.Stoken ("", "exception"); - Gramext.Snterm - (Grammar.Entry.obj - (constructor_declaration : - 'constructor_declaration Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (rebind_exn : 'rebind_exn Grammar.Entry.e))], - Gramext.action - (fun (b : 'rebind_exn) (ctl : 'constructor_declaration) _ - (_loc : Lexing.position * Lexing.position) -> - (let (_, c, tl) = - match ctl with - Qast.Tuple [xx1; xx2; xx3] -> xx1, xx2, xx3 - | _ -> match () with _ -> raise (Match_failure ("", 332, 19)) - in - Qast.Node ("StExc", [Qast.Loc; c; tl; b]) : - 'str_item)); - [Gramext.Stoken ("", "declare"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'str_item) - (_loc : Lexing.position * Lexing.position) -> - (s : 'e__2))])], - Gramext.action - (fun (a : 'e__2 list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("StDcl", [Qast.Loc; st]) : 'str_item))]]; - Grammar.Entry.obj (rebind_exn : 'rebind_exn Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (_loc : Lexing.position * Lexing.position) -> - (Qast.List [] : 'rebind_exn)); - [Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (sl : 'mod_ident) _ (_loc : Lexing.position * Lexing.position) -> - (sl : 'rebind_exn))]]; - Grammar.Entry.obj (module_binding : 'module_binding Grammar.Entry.e), - None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ - (_loc : Lexing.position * Lexing.position) -> - (me : 'module_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (mt : 'module_type) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("MeTyc", [Qast.Loc; me; mt]) : 'module_binding)); - [Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")"); Gramext.Sself], - Gramext.action - (fun (mb : 'module_binding) _ (mt : 'module_type) _ (m : 'a_UIDENT) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("MeFun", [Qast.Loc; m; mt; mb]) : 'module_binding))]]; - Grammar.Entry.obj - (module_rec_binding : 'module_rec_binding Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (mt : 'module_type) _ (m : 'a_UIDENT) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Tuple [m; me; mt] : 'module_rec_binding))]]; - Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "functor"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Sself; Gramext.Stoken ("", ")"); - Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (mt : 'module_type) _ _ (t : 'module_type) _ (i : 'a_UIDENT) _ _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("MtFun", [Qast.Loc; i; t; mt]) : 'module_type))]; - None, None, - [[Gramext.Sself; Gramext.Stoken ("", "with"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (with_constr : 'with_constr Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'with_constr list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]], - Gramext.action - (fun (wcl : 'a_list) _ (mt : 'module_type) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("MtWit", [Qast.Loc; mt; wcl]) : 'module_type))]; - None, None, - [[Gramext.Stoken ("", "sig"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (sig_item : 'sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'sig_item) - (_loc : Lexing.position * Lexing.position) -> - (s : 'e__4))])], - Gramext.action - (fun (a : 'e__4 list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (sg : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("MtSig", [Qast.Loc; sg]) : 'module_type))]; - None, None, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (m2 : 'module_type) (m1 : 'module_type) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("MtApp", [Qast.Loc; m1; m2]) : 'module_type))]; - None, None, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (m2 : 'module_type) _ (m1 : 'module_type) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("MtAcc", [Qast.Loc; m1; m2]) : 'module_type))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (mt : 'module_type) _ - (_loc : Lexing.position * Lexing.position) -> - (mt : 'module_type)); - [Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("MtQuo", [Qast.Loc; i]) : 'module_type)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("MtLid", [Qast.Loc; i]) : 'module_type)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_UIDENT) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("MtUid", [Qast.Loc; i]) : 'module_type))]]; - Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None, - [Some "top", None, - [[Gramext.Stoken ("", "value"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (i : 'a_LIDENT) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("SgVal", [Qast.Loc; i; t]) : 'sig_item)); - [Gramext.Stoken ("", "type"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (type_declaration : 'type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'type_declaration list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]], - Gramext.action - (fun (tdl : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("SgTyp", [Qast.Loc; tdl]) : 'sig_item)); - [Gramext.Stoken ("", "open"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'mod_ident) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("SgOpn", [Qast.Loc; i]) : 'sig_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "rec"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (module_rec_declaration : - 'module_rec_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'module_rec_declaration list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]], - Gramext.action - (fun (mds : 'a_list) _ _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("SgRecMod", [Qast.Loc; mds]) : 'sig_item)); - [Gramext.Stoken ("", "module"); Gramext.Stoken ("", "type"); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (i : 'a_UIDENT) _ _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("SgMty", [Qast.Loc; i; mt]) : 'sig_item)); - [Gramext.Stoken ("", "module"); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (module_declaration : 'module_declaration Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_declaration) (i : 'a_UIDENT) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("SgMod", [Qast.Loc; i; mt]) : 'sig_item)); - [Gramext.Stoken ("", "include"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("SgInc", [Qast.Loc; mt]) : 'sig_item)); - [Gramext.Stoken ("", "external"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.srules - [[Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e)))], - Gramext.action - (fun (a : 'a_STRING list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]], - Gramext.action - (fun (pd : 'a_list) _ (t : 'ctyp) _ (i : 'a_LIDENT) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("SgExt", [Qast.Loc; i; t; pd]) : 'sig_item)); - [Gramext.Stoken ("", "exception"); - Gramext.Snterm - (Grammar.Entry.obj - (constructor_declaration : - 'constructor_declaration Grammar.Entry.e))], - Gramext.action - (fun (ctl : 'constructor_declaration) _ - (_loc : Lexing.position * Lexing.position) -> - (let (_, c, tl) = - match ctl with - Qast.Tuple [xx1; xx2; xx3] -> xx1, xx2, xx3 - | _ -> match () with _ -> raise (Match_failure ("", 390, 19)) - in - Qast.Node ("SgExc", [Qast.Loc; c; tl]) : - 'sig_item)); - [Gramext.Stoken ("", "declare"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (sig_item : 'sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'sig_item) - (_loc : Lexing.position * Lexing.position) -> - (s : 'e__5))])], - Gramext.action - (fun (a : 'e__5 list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("SgDcl", [Qast.Loc; st]) : 'sig_item))]]; - Grammar.Entry.obj - (module_declaration : 'module_declaration Grammar.Entry.e), - None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("", ")"); Gramext.Sself], - Gramext.action - (fun (mt : 'module_declaration) _ (t : 'module_type) _ (i : 'a_UIDENT) - _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("MtFun", [Qast.Loc; i; t; mt]) : 'module_declaration)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ - (_loc : Lexing.position * Lexing.position) -> - (mt : 'module_declaration))]]; - Grammar.Entry.obj - (module_rec_declaration : 'module_rec_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e))], - Gramext.action - (fun (mt : 'module_type) _ (m : 'a_UIDENT) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Tuple [m; mt] : 'module_rec_declaration))]]; - Grammar.Entry.obj (with_constr : 'with_constr Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "module"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e))], - Gramext.action - (fun (me : 'module_expr) _ (i : 'mod_ident) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("WcMod", [Qast.Loc; i; me]) : 'with_constr)); - [Gramext.Stoken ("", "type"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e)); - Gramext.srules - [[Gramext.Slist0 - (Gramext.Snterm - (Grammar.Entry.obj - (type_parameter : 'type_parameter Grammar.Entry.e)))], - Gramext.action - (fun (a : 'type_parameter list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (tpl : 'a_list) (i : 'mod_ident) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("WcTyp", [Qast.Loc; i; tpl; t]) : 'with_constr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), None, - [Some "top", Some Gramext.RightA, - [[Gramext.Stoken ("", "while"); Gramext.Sself; Gramext.Stoken ("", "do"); - Gramext.Stoken ("", "{"); - Gramext.Snterm - (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e)); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (seq : 'sequence) _ _ (e : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExWhi", [Qast.Loc; e; seq]) : 'expr)); - [Gramext.Stoken ("", "for"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "="); Gramext.Sself; - Gramext.Snterm - (Grammar.Entry.obj - (direction_flag : 'direction_flag Grammar.Entry.e)); - Gramext.Sself; Gramext.Stoken ("", "do"); Gramext.Stoken ("", "{"); - Gramext.Snterm - (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e)); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (seq : 'sequence) _ _ (e2 : 'expr) (df : 'direction_flag) - (e1 : 'expr) _ (i : 'a_LIDENT) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExFor", [Qast.Loc; i; e1; e2; df; seq]) : 'expr)); - [Gramext.Stoken ("", "do"); Gramext.Stoken ("", "{"); - Gramext.Snterm - (Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e)); - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (seq : 'sequence) _ _ - (_loc : Lexing.position * Lexing.position) -> - (mksequence Qast.Loc seq : 'expr)); - [Gramext.Stoken ("", "if"); Gramext.Sself; Gramext.Stoken ("", "then"); - Gramext.Sself; Gramext.Stoken ("", "else"); Gramext.Sself], - Gramext.action - (fun (e3 : 'expr) _ (e2 : 'expr) _ (e1 : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExIfe", [Qast.Loc; e1; e2; e3]) : 'expr)); - [Gramext.Stoken ("", "try"); Gramext.Sself; Gramext.Stoken ("", "with"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExTry", - [Qast.Loc; e; - Qast.List [Qast.Tuple [p1; Qast.Option None; e1]]]) : - 'expr)); - [Gramext.Stoken ("", "try"); Gramext.Sself; Gramext.Stoken ("", "with"); - Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (match_case : 'match_case Grammar.Entry.e)), - Gramext.Stoken ("", "|"))], - Gramext.action - (fun (a : 'match_case list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (l : 'a_list) _ _ (e : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExTry", [Qast.Loc; e; l]) : 'expr)); - [Gramext.Stoken ("", "match"); Gramext.Sself; - Gramext.Stoken ("", "with"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (e1 : 'expr) _ (p1 : 'ipatt) _ (e : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExMat", - [Qast.Loc; e; - Qast.List [Qast.Tuple [p1; Qast.Option None; e1]]]) : - 'expr)); - [Gramext.Stoken ("", "match"); Gramext.Sself; - Gramext.Stoken ("", "with"); Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (match_case : 'match_case Grammar.Entry.e)), - Gramext.Stoken ("", "|"))], - Gramext.action - (fun (a : 'match_case list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (l : 'a_list) _ _ (e : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExMat", [Qast.Loc; e; l]) : 'expr)); - [Gramext.Stoken ("", "fun"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (fun_def : 'fun_def Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_def) (p : 'ipatt) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExFun", - [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]) : - 'expr)); - [Gramext.Stoken ("", "fun"); Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (match_case : 'match_case Grammar.Entry.e)), - Gramext.Stoken ("", "|"))], - Gramext.action - (fun (a : 'match_case list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (l : 'a_list) _ _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExFun", [Qast.Loc; l]) : 'expr)); - [Gramext.Stoken ("", "let"); Gramext.Stoken ("", "module"); - Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (module_binding : 'module_binding Grammar.Entry.e)); - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (mb : 'module_binding) (m : 'a_UIDENT) _ _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExLmd", [Qast.Loc; m; mb; e]) : 'expr)); - [Gramext.Stoken ("", "let"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "rec")], - Gramext.action - (fun (x : string) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__6))])], - Gramext.action - (fun (a : 'e__6 option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'let_binding list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (x : 'expr) _ (l : 'a_list) (r : 'a_opt) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExLet", [Qast.Loc; o2b r; l; x]) : 'expr))]; - Some "where", None, - [[Gramext.Sself; Gramext.Stoken ("", "where"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "rec")], - Gramext.action - (fun (x : string) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__7))])], - Gramext.action - (fun (a : 'e__7 option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.Snterm - (Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e))], - Gramext.action - (fun (lb : 'let_binding) (rf : 'a_opt) _ (e : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExLet", [Qast.Loc; o2b rf; Qast.List [lb]; e]) : - 'expr))]; - Some ":=", Some Gramext.NonA, - [[Gramext.Sself; Gramext.Stoken ("", ":="); Gramext.Sself; - Gramext.Snterm (Grammar.Entry.obj (dummy : 'dummy Grammar.Entry.e))], - Gramext.action - (fun _ (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExAss", [Qast.Loc; e1; e2]) : 'expr))]; - Some "||", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "||"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "||"]); - e1]); - e2]) : - 'expr))]; - Some "&&", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "&&"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "&&"]); - e1]); - e2]) : - 'expr))]; - Some "<", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "!="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "!="]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "=="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "=="]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "<>"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "<>"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "="]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", ">="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str ">="]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "<="); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "<="]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", ">"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str ">"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "<"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "<"]); - e1]); - e2]) : - 'expr))]; - Some "^", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "@"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "@"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "^"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "^"]); - e1]); - e2]) : - 'expr))]; - Some "+", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "-."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "-."]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "+."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "+."]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "-"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "-"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "+"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "+"]); - e1]); - e2]) : - 'expr))]; - Some "*", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "mod"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "mod"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "lxor"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node ("ExLid", [Qast.Loc; Qast.Str "lxor"]); e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "lor"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "lor"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "land"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node ("ExLid", [Qast.Loc; Qast.Str "land"]); e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "/."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "/."]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "*."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "*."]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "/"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "/"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "*"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "*"]); - e1]); - e2]) : - 'expr))]; - Some "**", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "lsr"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "lsr"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "lsl"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "lsl"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "asr"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "asr"]); - e1]); - e2]) : - 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "**"); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; - Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "**"]); - e1]); - e2]) : - 'expr))]; - Some "unary minus", Some Gramext.NonA, - [[Gramext.Stoken ("", "-."); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (mkumin Qast.Loc (Qast.Str "-.") e : 'expr)); - [Gramext.Stoken ("", "-"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (mkumin Qast.Loc (Qast.Str "-") e : 'expr))]; - Some "apply", Some Gramext.LeftA, - [[Gramext.Stoken ("", "lazy"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExLaz", [Qast.Loc; e]) : 'expr)); - [Gramext.Stoken ("", "assert"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (mkassert Qast.Loc e : 'expr)); - [Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExApp", [Qast.Loc; e1; e2]) : 'expr))]; - Some ".", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (e2 : 'expr) _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExAcc", [Qast.Loc; e1; e2]) : 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Stoken ("", "["); - Gramext.Sself; Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (e2 : 'expr) _ _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExSte", [Qast.Loc; e1; e2]) : 'expr)); - [Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Stoken ("", "("); - Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (e2 : 'expr) _ _ (e1 : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExAre", [Qast.Loc; e1; e2]) : 'expr))]; - Some "~-", Some Gramext.NonA, - [[Gramext.Stoken ("", "~-."); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "~-."]); - e]) : - 'expr)); - [Gramext.Stoken ("", "~-"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExApp", - [Qast.Loc; Qast.Node ("ExLid", [Qast.Loc; Qast.Str "~-"]); - e]) : - 'expr))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (e : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)), - Gramext.Stoken ("", ","))], - Gramext.action - (fun (a : 'expr list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (el : 'a_list) _ (e : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExTup", [Qast.Loc; Qast.Cons (e, el)]) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (e : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExTyc", [Qast.Loc; e; t]) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], - Gramext.action - (fun _ _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExUid", [Qast.Loc; Qast.Str "()"]) : 'expr)); - [Gramext.Stoken ("", "{"); Gramext.Stoken ("", "("); Gramext.Sself; - Gramext.Stoken ("", ")"); Gramext.Stoken ("", "with"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (label_expr : 'label_expr Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'label_expr list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lel : 'a_list) _ _ (e : 'expr) _ _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExRec", [Qast.Loc; lel; Qast.Option (Some e)]) : - 'expr)); - [Gramext.Stoken ("", "{"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (label_expr : 'label_expr Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'label_expr list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lel : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExRec", [Qast.Loc; lel; Qast.Option None]) : 'expr)); - [Gramext.Stoken ("", "[|"); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'expr list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (el : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExArr", [Qast.Loc; el]) : 'expr)); - [Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'expr list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Snterm - (Grammar.Entry.obj (cons_expr_opt : 'cons_expr_opt Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (last : 'cons_expr_opt) (el : 'a_list) _ - (_loc : Lexing.position * Lexing.position) -> - (mklistexp Qast.Loc last el : 'expr)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")], - Gramext.action - (fun _ _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExUid", [Qast.Loc; Qast.Str "[]"]) : 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'expr_ident) (_loc : Lexing.position * Lexing.position) -> - (i : 'expr)); - [Gramext.Snterm (Grammar.Entry.obj (a_CHAR : 'a_CHAR Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_CHAR) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExChr", [Qast.Loc; s]) : 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_STRING) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExStr", [Qast.Loc; s]) : 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_FLOAT : 'a_FLOAT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_FLOAT) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExFlo", [Qast.Loc; s]) : 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_NATIVEINT : 'a_NATIVEINT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_NATIVEINT) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExNativeInt", [Qast.Loc; s]) : 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_INT64 : 'a_INT64 Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_INT64) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExInt64", [Qast.Loc; s]) : 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_INT32 : 'a_INT32 Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_INT32) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExInt32", [Qast.Loc; s]) : 'expr)); - [Gramext.Snterm (Grammar.Entry.obj (a_INT : 'a_INT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_INT) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExInt", [Qast.Loc; s]) : 'expr))]]; - Grammar.Entry.obj (cons_expr_opt : 'cons_expr_opt Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (_loc : Lexing.position * Lexing.position) -> - (Qast.Option None : 'cons_expr_opt)); - [Gramext.Stoken ("", "::"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Option (Some e) : 'cons_expr_opt))]]; - Grammar.Entry.obj (dummy : 'dummy Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (_loc : Lexing.position * Lexing.position) -> (() : 'dummy))]]; - Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) (_loc : Lexing.position * Lexing.position) -> - (Qast.List [e] : 'sequence)); - [Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) (_loc : Lexing.position * Lexing.position) -> - (Qast.List [e] : 'sequence)); - [Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";"); Gramext.Sself], - Gramext.action - (fun (el : 'sequence) _ (e : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Cons (e, el) : 'sequence)); - [Gramext.Stoken ("", "let"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "rec")], - Gramext.action - (fun (x : string) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__8))])], - Gramext.action - (fun (a : 'e__8 option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'let_binding list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.srules - [[Gramext.Stoken ("", ";")], - Gramext.action - (fun (x : string) (_loc : Lexing.position * Lexing.position) -> - (x : 'e__9)); - [Gramext.Stoken ("", "in")], - Gramext.action - (fun (x : string) (_loc : Lexing.position * Lexing.position) -> - (x : 'e__9))]; - Gramext.Sself], - Gramext.action - (fun (el : 'sequence) _ (l : 'a_list) (rf : 'a_opt) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.List - [Qast.Node - ("ExLet", [Qast.Loc; o2b rf; l; mksequence Qast.Loc el])] : - 'sequence))]]; - Grammar.Entry.obj (let_binding : 'let_binding Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_binding) (p : 'ipatt) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Tuple [p; e] : 'let_binding))]]; - Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExTyc", [Qast.Loc; e; t]) : 'fun_binding)); - [Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (e : 'fun_binding)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'fun_binding) (p : 'ipatt) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExFun", - [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]) : - 'fun_binding))]]; - Grammar.Entry.obj (match_case : 'match_case Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (as_patt_opt : 'as_patt_opt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (when_expr_opt : 'when_expr_opt Grammar.Entry.e)); - Gramext.Stoken ("", "->"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (w : 'when_expr_opt) (aso : 'as_patt_opt) - (p : 'patt) (_loc : Lexing.position * Lexing.position) -> - (mkmatchcase Qast.Loc p aso w e : 'match_case))]]; - Grammar.Entry.obj (as_patt_opt : 'as_patt_opt Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (_loc : Lexing.position * Lexing.position) -> - (Qast.Option None : 'as_patt_opt)); - [Gramext.Stoken ("", "as"); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Option (Some p) : 'as_patt_opt))]]; - Grammar.Entry.obj (when_expr_opt : 'when_expr_opt Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (_loc : Lexing.position * Lexing.position) -> - (Qast.Option None : 'when_expr_opt)); - [Gramext.Stoken ("", "when"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Option (Some e) : 'when_expr_opt))]]; - Grammar.Entry.obj (label_expr : 'label_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (patt_label_ident : 'patt_label_ident Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_binding) (i : 'patt_label_ident) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Tuple [i; e] : 'label_expr))]]; - Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (j : 'expr_ident) _ (i : 'a_UIDENT) - (_loc : Lexing.position * Lexing.position) -> - (mkexprident Qast.Loc i j : 'expr_ident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_UIDENT) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExUid", [Qast.Loc; i]) : 'expr_ident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExLid", [Qast.Loc; i]) : 'expr_ident))]]; - Grammar.Entry.obj (fun_def : 'fun_def Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Stoken ("", "->"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (e : 'fun_def)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'fun_def) (p : 'ipatt) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("ExFun", - [Qast.Loc; Qast.List [Qast.Tuple [p; Qast.Option None; e]]]) : - 'fun_def))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), None, - [None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "|"); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) _ (p1 : 'patt) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaOrp", [Qast.Loc; p1; p2]) : 'patt))]; - None, Some Gramext.NonA, - [[Gramext.Sself; Gramext.Stoken ("", ".."); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) _ (p1 : 'patt) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaRng", [Qast.Loc; p1; p2]) : 'patt))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) (p1 : 'patt) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaApp", [Qast.Loc; p1; p2]) : 'patt))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt) _ (p1 : 'patt) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaAcc", [Qast.Loc; p1; p2]) : 'patt))]; - Some "simple", None, - [[Gramext.Stoken ("", "_")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaAny", [Qast.Loc]) : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)), - Gramext.Stoken ("", ","))], - Gramext.action - (fun (a : 'patt list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (pl : 'a_list) _ (p : 'patt) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaTup", [Qast.Loc; Qast.Cons (p, pl)]) : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "as"); - Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p2 : 'patt) _ (p : 'patt) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaAli", [Qast.Loc; p; p2]) : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (p : 'patt) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p : 'patt) _ (_loc : Lexing.position * Lexing.position) -> - (p : 'patt)); - [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], - Gramext.action - (fun _ _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaUid", [Qast.Loc; Qast.Str "()"]) : 'patt)); - [Gramext.Stoken ("", "{"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (label_patt : 'label_patt Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'label_patt list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lpl : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaRec", [Qast.Loc; lpl]) : 'patt)); - [Gramext.Stoken ("", "[|"); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'patt list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (pl : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaArr", [Qast.Loc; pl]) : 'patt)); - [Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'patt list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Snterm - (Grammar.Entry.obj (cons_patt_opt : 'cons_patt_opt Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (last : 'cons_patt_opt) (pl : 'a_list) _ - (_loc : Lexing.position * Lexing.position) -> - (mklistpat Qast.Loc last pl : 'patt)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "]")], - Gramext.action - (fun _ _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaUid", [Qast.Loc; Qast.Str "[]"]) : 'patt)); - [Gramext.Stoken ("", "-"); - Gramext.Snterm - (Grammar.Entry.obj (a_FLOAT : 'a_FLOAT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_FLOAT) _ (_loc : Lexing.position * Lexing.position) -> - (mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool false) s : 'patt)); - [Gramext.Stoken ("", "-"); - Gramext.Snterm - (Grammar.Entry.obj (a_NATIVEINT : 'a_NATIVEINT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_NATIVEINT) _ - (_loc : Lexing.position * Lexing.position) -> - (mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool true) s : 'patt)); - [Gramext.Stoken ("", "-"); - Gramext.Snterm - (Grammar.Entry.obj (a_INT64 : 'a_INT64 Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_INT64) _ (_loc : Lexing.position * Lexing.position) -> - (mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool true) s : 'patt)); - [Gramext.Stoken ("", "-"); - Gramext.Snterm - (Grammar.Entry.obj (a_INT32 : 'a_INT32 Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_INT32) _ (_loc : Lexing.position * Lexing.position) -> - (mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool true) s : 'patt)); - [Gramext.Stoken ("", "-"); - Gramext.Snterm (Grammar.Entry.obj (a_INT : 'a_INT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_INT) _ (_loc : Lexing.position * Lexing.position) -> - (mkuminpat Qast.Loc (Qast.Str "-") (Qast.Bool true) s : 'patt)); - [Gramext.Snterm (Grammar.Entry.obj (a_CHAR : 'a_CHAR Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_CHAR) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaChr", [Qast.Loc; s]) : 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_STRING) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaStr", [Qast.Loc; s]) : 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_FLOAT : 'a_FLOAT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_FLOAT) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaFlo", [Qast.Loc; s]) : 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_NATIVEINT : 'a_NATIVEINT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_NATIVEINT) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaNativeInt", [Qast.Loc; s]) : 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_INT64 : 'a_INT64 Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_INT64) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaInt64", [Qast.Loc; s]) : 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_INT32 : 'a_INT32 Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_INT32) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaInt32", [Qast.Loc; s]) : 'patt)); - [Gramext.Snterm (Grammar.Entry.obj (a_INT : 'a_INT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_INT) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaInt", [Qast.Loc; s]) : 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_UIDENT) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaUid", [Qast.Loc; s]) : 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaLid", [Qast.Loc; s]) : 'patt))]]; - Grammar.Entry.obj (cons_patt_opt : 'cons_patt_opt Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (_loc : Lexing.position * Lexing.position) -> - (Qast.Option None : 'cons_patt_opt)); - [Gramext.Stoken ("", "::"); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Option (Some p) : 'cons_patt_opt))]]; - Grammar.Entry.obj (label_patt : 'label_patt Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (patt_label_ident : 'patt_label_ident Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) _ (i : 'patt_label_ident) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Tuple [i; p] : 'label_patt))]]; - Grammar.Entry.obj (patt_label_ident : 'patt_label_ident Grammar.Entry.e), - None, - [None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (p2 : 'patt_label_ident) _ (p1 : 'patt_label_ident) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaAcc", [Qast.Loc; p1; p2]) : 'patt_label_ident))]; - Some "simple", Some Gramext.RightA, - [[Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaLid", [Qast.Loc; i]) : 'patt_label_ident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_UIDENT) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaUid", [Qast.Loc; i]) : 'patt_label_ident))]]; - Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "_")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaAny", [Qast.Loc]) : 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (s : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaLid", [Qast.Loc; s]) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ","); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)), - Gramext.Stoken ("", ","))], - Gramext.action - (fun (a : 'ipatt list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (pl : 'a_list) _ (p : 'ipatt) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaTup", [Qast.Loc; Qast.Cons (p, pl)]) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "as"); - Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p2 : 'ipatt) _ (p : 'ipatt) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaAli", [Qast.Loc; p; p2]) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (p : 'ipatt) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p : 'ipatt) _ (_loc : Lexing.position * Lexing.position) -> - (p : 'ipatt)); - [Gramext.Stoken ("", "("); Gramext.Stoken ("", ")")], - Gramext.action - (fun _ _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaUid", [Qast.Loc; Qast.Str "()"]) : 'ipatt)); - [Gramext.Stoken ("", "{"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (label_ipatt : 'label_ipatt Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'label_ipatt list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (lpl : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaRec", [Qast.Loc; lpl]) : 'ipatt))]]; - Grammar.Entry.obj (label_ipatt : 'label_ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (patt_label_ident : 'patt_label_ident Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))], - Gramext.action - (fun (p : 'ipatt) _ (i : 'patt_label_ident) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Tuple [i; p] : 'label_ipatt))]]; - Grammar.Entry.obj (type_declaration : 'type_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (type_patt : 'type_patt Grammar.Entry.e)); - Gramext.srules - [[Gramext.Slist0 - (Gramext.Snterm - (Grammar.Entry.obj - (type_parameter : 'type_parameter Grammar.Entry.e)))], - Gramext.action - (fun (a : 'type_parameter list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.srules - [[Gramext.Slist0 - (Gramext.Snterm - (Grammar.Entry.obj - (constrain : 'constrain Grammar.Entry.e)))], - Gramext.action - (fun (a : 'constrain list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]], - Gramext.action - (fun (cl : 'a_list) (tk : 'ctyp) _ (tpl : 'a_list) (n : 'type_patt) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Tuple [n; tpl; tk; cl] : 'type_declaration))]]; - Grammar.Entry.obj (type_patt : 'type_patt Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (n : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) -> - (Qast.Tuple [Qast.Loc; n] : 'type_patt))]]; - Grammar.Entry.obj (constrain : 'constrain Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "constraint"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Tuple [t1; t2] : 'constrain))]]; - Grammar.Entry.obj (type_parameter : 'type_parameter Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "-"); Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Tuple [i; Qast.Tuple [Qast.Bool false; Qast.Bool true]] : - 'type_parameter)); - [Gramext.Stoken ("", "+"); Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Tuple [i; Qast.Tuple [Qast.Bool true; Qast.Bool false]] : - 'type_parameter)); - [Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Tuple [i; Qast.Tuple [Qast.Bool false; Qast.Bool false]] : - 'type_parameter))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), None, - [None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "=="); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("TyMan", [Qast.Loc; t1; t2]) : 'ctyp))]; - None, Some Gramext.NonA, - [[Gramext.Stoken ("", "private"); - Gramext.Snterml - (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), "alias")], - Gramext.action - (fun (t : 'ctyp) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("TyPrv", [Qast.Loc; t]) : 'ctyp))]; - Some "alias", Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "as"); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("TyAli", [Qast.Loc; t1; t2]) : 'ctyp))]; - None, Some Gramext.LeftA, - [[Gramext.Stoken ("", "!"); - Gramext.srules - [[Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (typevar : 'typevar Grammar.Entry.e)))], - Gramext.action - (fun (a : 'typevar list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) _ (pl : 'a_list) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("TyPol", [Qast.Loc; pl; t]) : 'ctyp))]; - Some "arrow", Some Gramext.RightA, - [[Gramext.Sself; Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("TyArr", [Qast.Loc; t1; t2]) : 'ctyp))]; - Some "label", Some Gramext.NonA, - [[Gramext.Snterm - (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) (i : 'a_OPTLABEL) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("TyOlb", [Qast.Loc; i; t]) : 'ctyp)); - [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) _ (i : 'a_QUESTIONIDENT) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("TyOlb", [Qast.Loc; i; t]) : 'ctyp)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) (i : 'a_LABEL) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("TyLab", [Qast.Loc; i; t]) : 'ctyp)); - [Gramext.Snterm - (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Sself], - Gramext.action - (fun (t : 'ctyp) _ (i : 'a_TILDEIDENT) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("TyLab", [Qast.Loc; i; t]) : 'ctyp))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) (t1 : 'ctyp) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("TyApp", [Qast.Loc; t1; t2]) : 'ctyp))]; - None, Some Gramext.LeftA, - [[Gramext.Sself; Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("TyAcc", [Qast.Loc; t1; t2]) : 'ctyp))]; - Some "simple", None, - [[Gramext.Stoken ("", "{"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (label_declaration : 'label_declaration Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'label_declaration list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "}")], - Gramext.action - (fun _ (ldl : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("TyRec", [Qast.Loc; ldl]) : 'ctyp)); - [Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (constructor_declaration : - 'constructor_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "|"))], - Gramext.action - (fun (a : 'constructor_declaration list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (cdl : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("TySum", [Qast.Loc; cdl]) : 'ctyp)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (_loc : Lexing.position * Lexing.position) -> - (t : 'ctyp)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", "*"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", "*"))], - Gramext.action - (fun (a : 'ctyp list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (tl : 'a_list) _ (t : 'ctyp) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("TyTup", [Qast.Loc; Qast.Cons (t, tl)]) : 'ctyp)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_UIDENT) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("TyUid", [Qast.Loc; i]) : 'ctyp)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("TyLid", [Qast.Loc; i]) : 'ctyp)); - [Gramext.Stoken ("", "_")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("TyAny", [Qast.Loc]) : 'ctyp)); - [Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("TyQuo", [Qast.Loc; i]) : 'ctyp))]]; - Grammar.Entry.obj - (constructor_declaration : 'constructor_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (ci : 'a_UIDENT) (_loc : Lexing.position * Lexing.position) -> - (Qast.Tuple [Qast.Loc; ci; Qast.List []] : - 'constructor_declaration)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "of"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'ctyp list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]], - Gramext.action - (fun (cal : 'a_list) _ (ci : 'a_UIDENT) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Tuple [Qast.Loc; ci; cal] : 'constructor_declaration))]]; - Grammar.Entry.obj - (label_declaration : 'label_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "mutable")], - Gramext.action - (fun (x : string) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__10))])], - Gramext.action - (fun (a : 'e__10 option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) (mf : 'a_opt) _ (i : 'a_LIDENT) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Tuple [Qast.Loc; i; o2b mf; t] : 'label_declaration))]]; - Grammar.Entry.obj (ident : 'ident Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_UIDENT) (_loc : Lexing.position * Lexing.position) -> - (i : 'ident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) -> - (i : 'ident))]]; - Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e), None, - [None, Some Gramext.RightA, - [[Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (j : 'mod_ident) _ (i : 'a_UIDENT) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Cons (i, j) : 'mod_ident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) -> - (Qast.List [i] : 'mod_ident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_UIDENT) (_loc : Lexing.position * Lexing.position) -> - (Qast.List [i] : 'mod_ident))]]; - Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "class"); Gramext.Stoken ("", "type"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_type_declaration : - 'class_type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'class_type_declaration list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]], - Gramext.action - (fun (ctd : 'a_list) _ _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("StClt", [Qast.Loc; ctd]) : 'str_item)); - [Gramext.Stoken ("", "class"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_declaration : 'class_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'class_declaration list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]], - Gramext.action - (fun (cd : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("StCls", [Qast.Loc; cd]) : 'str_item))]]; - Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "class"); Gramext.Stoken ("", "type"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_type_declaration : - 'class_type_declaration Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'class_type_declaration list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]], - Gramext.action - (fun (ctd : 'a_list) _ _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("SgClt", [Qast.Loc; ctd]) : 'sig_item)); - [Gramext.Stoken ("", "class"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (class_description : 'class_description Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'class_description list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]], - Gramext.action - (fun (cd : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("SgCls", [Qast.Loc; cd]) : 'sig_item))]]; - Grammar.Entry.obj - (class_declaration : 'class_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "virtual")], - Gramext.action - (fun (x : string) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__11))])], - Gramext.action - (fun (a : 'e__11 option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (class_fun_binding : 'class_fun_binding Grammar.Entry.e))], - Gramext.action - (fun (cfb : 'class_fun_binding) (ctp : 'class_type_parameters) - (i : 'a_LIDENT) (vf : 'a_opt) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Record - ["ciLoc", Qast.Loc; "ciVir", o2b vf; "ciPrm", ctp; "ciNam", i; - "ciExp", cfb] : - 'class_declaration))]]; - Grammar.Entry.obj - (class_fun_binding : 'class_fun_binding Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (cfb : 'class_fun_binding) (p : 'ipatt) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CeFun", [Qast.Loc; p; cfb]) : 'class_fun_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_expr) _ (ct : 'class_type) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CeTyc", [Qast.Loc; ce; ct]) : 'class_fun_binding)); - [Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_expr) _ - (_loc : Lexing.position * Lexing.position) -> - (ce : 'class_fun_binding))]]; - Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (type_parameter : 'type_parameter Grammar.Entry.e)), - Gramext.Stoken ("", ","))], - Gramext.action - (fun (a : 'type_parameter list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (tpl : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Tuple [Qast.Loc; tpl] : 'class_type_parameters)); - [], - Gramext.action - (fun (_loc : Lexing.position * Lexing.position) -> - (Qast.Tuple [Qast.Loc; Qast.List []] : 'class_type_parameters))]]; - Grammar.Entry.obj (class_fun_def : 'class_fun_def Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "->"); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_expr) _ - (_loc : Lexing.position * Lexing.position) -> - (ce : 'class_fun_def)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (ce : 'class_fun_def) (p : 'ipatt) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CeFun", [Qast.Loc; p; ce]) : 'class_fun_def))]]; - Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), None, - [Some "top", None, - [[Gramext.Stoken ("", "let"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "rec")], - Gramext.action - (fun (x : string) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__12))])], - Gramext.action - (fun (a : 'e__12 option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'let_binding list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (ce : 'class_expr) _ (lb : 'a_list) (rf : 'a_opt) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CeLet", [Qast.Loc; o2b rf; lb; ce]) : 'class_expr)); - [Gramext.Stoken ("", "fun"); - Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (class_fun_def : 'class_fun_def Grammar.Entry.e))], - Gramext.action - (fun (ce : 'class_fun_def) (p : 'ipatt) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CeFun", [Qast.Loc; p; ce]) : 'class_expr))]; - Some "apply", Some Gramext.NonA, - [[Gramext.Sself; - Gramext.Snterml - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), "label")], - Gramext.action - (fun (e : 'expr) (ce : 'class_expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CeApp", [Qast.Loc; ce; e]) : 'class_expr))]; - Some "simple", None, - [[Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (ce : 'class_expr) _ - (_loc : Lexing.position * Lexing.position) -> - (ce : 'class_expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (ct : 'class_type) _ (ce : 'class_expr) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CeTyc", [Qast.Loc; ce; ct]) : 'class_expr)); - [Gramext.Stoken ("", "object"); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj - (class_self_patt : 'class_self_patt Grammar.Entry.e)))], - Gramext.action - (fun (a : 'class_self_patt option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.Snterm - (Grammar.Entry.obj - (class_structure : 'class_structure Grammar.Entry.e)); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (cf : 'class_structure) (cspo : 'a_opt) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CeStr", [Qast.Loc; cspo; cf]) : 'class_expr)); - [Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e))], - Gramext.action - (fun (ci : 'class_longident) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CeCon", [Qast.Loc; ci; Qast.List []]) : 'class_expr)); - [Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e)); - Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", ","))], - Gramext.action - (fun (a : 'ctyp list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (ctcl : 'a_list) _ (ci : 'class_longident) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CeCon", [Qast.Loc; ci; ctcl]) : 'class_expr))]]; - Grammar.Entry.obj (class_structure : 'class_structure Grammar.Entry.e), - None, - [None, None, - [[Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_str_item : 'class_str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (cf : 'class_str_item) - (_loc : Lexing.position * Lexing.position) -> - (cf : 'e__13))])], - Gramext.action - (fun (a : 'e__13 list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]], - Gramext.action - (fun (cf : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (cf : 'class_structure))]]; - Grammar.Entry.obj (class_self_patt : 'class_self_patt Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (p : 'patt) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'class_self_patt)); - [Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (p : 'patt) _ (_loc : Lexing.position * Lexing.position) -> - (p : 'class_self_patt))]]; - Grammar.Entry.obj (class_str_item : 'class_str_item Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "initializer"); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (se : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CrIni", [Qast.Loc; se]) : 'class_str_item)); - [Gramext.Stoken ("", "type"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CrCtr", [Qast.Loc; t1; t2]) : 'class_str_item)); - [Gramext.Stoken ("", "method"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "private")], - Gramext.action - (fun (x : string) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__17))])], - Gramext.action - (fun (a : 'e__17 option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (polyt : 'polyt Grammar.Entry.e)))], - Gramext.action - (fun (a : 'polyt option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.Snterm - (Grammar.Entry.obj (fun_binding : 'fun_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'fun_binding) (topt : 'a_opt) (l : 'label) (pf : 'a_opt) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CrMth", [Qast.Loc; l; o2b pf; e; topt]) : - 'class_str_item)); - [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "private")], - Gramext.action - (fun (x : string) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__16))])], - Gramext.action - (fun (a : 'e__16 option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (pf : 'a_opt) _ _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CrVir", [Qast.Loc; l; o2b pf; t]) : 'class_str_item)); - [Gramext.Stoken ("", "value"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "mutable")], - Gramext.action - (fun (x : string) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__15))])], - Gramext.action - (fun (a : 'e__15 option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (cvalue_binding : 'cvalue_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'cvalue_binding) (lab : 'label) (mf : 'a_opt) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CrVal", [Qast.Loc; lab; o2b mf; e]) : - 'class_str_item)); - [Gramext.Stoken ("", "inherit"); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj - (as_lident : 'as_lident Grammar.Entry.e)))], - Gramext.action - (fun (a : 'as_lident option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]], - Gramext.action - (fun (pb : 'a_opt) (ce : 'class_expr) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CrInh", [Qast.Loc; ce; pb]) : 'class_str_item)); - [Gramext.Stoken ("", "declare"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_str_item : 'class_str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'class_str_item) - (_loc : Lexing.position * Lexing.position) -> - (s : 'e__14))])], - Gramext.action - (fun (a : 'e__14 list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CrDcl", [Qast.Loc; st]) : 'class_str_item))]]; - Grammar.Entry.obj (as_lident : 'as_lident Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "as"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) _ (_loc : Lexing.position * Lexing.position) -> - (i : 'as_lident))]]; - Grammar.Entry.obj (polyt : 'polyt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (_loc : Lexing.position * Lexing.position) -> - (t : 'polyt))]]; - Grammar.Entry.obj (cvalue_binding : 'cvalue_binding Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option None; t]) : - 'cvalue_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t2 : 'ctyp) _ (t : 'ctyp) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option (Some t); t2]) : - 'cvalue_binding)); - [Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (t : 'ctyp) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExTyc", [Qast.Loc; e; t]) : 'cvalue_binding)); - [Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (e : 'cvalue_binding))]]; - Grammar.Entry.obj (label : 'label Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) -> - (i : 'label))]]; - Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "object"); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj - (class_self_type : 'class_self_type Grammar.Entry.e)))], - Gramext.action - (fun (a : 'class_self_type option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_sig_item : 'class_sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (csf : 'class_sig_item) - (_loc : Lexing.position * Lexing.position) -> - (csf : 'e__18))])], - Gramext.action - (fun (a : 'e__18 list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (csf : 'a_list) (cst : 'a_opt) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CtSig", [Qast.Loc; cst; csf]) : 'class_type)); - [Gramext.Snterm - (Grammar.Entry.obj - (clty_longident : 'clty_longident Grammar.Entry.e))], - Gramext.action - (fun (id : 'clty_longident) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CtCon", [Qast.Loc; id; Qast.List []]) : 'class_type)); - [Gramext.Snterm - (Grammar.Entry.obj - (clty_longident : 'clty_longident Grammar.Entry.e)); - Gramext.Stoken ("", "["); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", ","))], - Gramext.action - (fun (a : 'ctyp list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (tl : 'a_list) _ (id : 'clty_longident) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CtCon", [Qast.Loc; id; tl]) : 'class_type)); - [Gramext.Stoken ("", "["); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "]"); Gramext.Stoken ("", "->"); Gramext.Sself], - Gramext.action - (fun (ct : 'class_type) _ _ (t : 'ctyp) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CtFun", [Qast.Loc; t; ct]) : 'class_type))]]; - Grammar.Entry.obj (class_self_type : 'class_self_type Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (_loc : Lexing.position * Lexing.position) -> - (t : 'class_self_type))]]; - Grammar.Entry.obj (class_sig_item : 'class_sig_item Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "type"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t2 : 'ctyp) _ (t1 : 'ctyp) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CgCtr", [Qast.Loc; t1; t2]) : 'class_sig_item)); - [Gramext.Stoken ("", "method"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "private")], - Gramext.action - (fun (x : string) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__22))])], - Gramext.action - (fun (a : 'e__22 option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (pf : 'a_opt) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CgMth", [Qast.Loc; l; o2b pf; t]) : 'class_sig_item)); - [Gramext.Stoken ("", "method"); Gramext.Stoken ("", "virtual"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "private")], - Gramext.action - (fun (x : string) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__21))])], - Gramext.action - (fun (a : 'e__21 option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (pf : 'a_opt) _ _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CgVir", [Qast.Loc; l; o2b pf; t]) : 'class_sig_item)); - [Gramext.Stoken ("", "value"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "mutable")], - Gramext.action - (fun (x : string) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__20))])], - Gramext.action - (fun (a : 'e__20 option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (mf : 'a_opt) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CgVal", [Qast.Loc; l; o2b mf; t]) : 'class_sig_item)); - [Gramext.Stoken ("", "inherit"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], - Gramext.action - (fun (cs : 'class_type) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CgInh", [Qast.Loc; cs]) : 'class_sig_item)); - [Gramext.Stoken ("", "declare"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_sig_item : 'class_sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (s : 'class_sig_item) - (_loc : Lexing.position * Lexing.position) -> - (s : 'e__19))])], - Gramext.action - (fun (a : 'e__19 list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (st : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("CgDcl", [Qast.Loc; st]) : 'class_sig_item))]]; - Grammar.Entry.obj - (class_description : 'class_description Grammar.Entry.e), - None, - [None, None, - [[Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "virtual")], - Gramext.action - (fun (x : string) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__23))])], - Gramext.action - (fun (a : 'e__23 option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], - Gramext.action - (fun (ct : 'class_type) _ (ctp : 'class_type_parameters) - (n : 'a_LIDENT) (vf : 'a_opt) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Record - ["ciLoc", Qast.Loc; "ciVir", o2b vf; "ciPrm", ctp; "ciNam", n; - "ciExp", ct] : - 'class_description))]]; - Grammar.Entry.obj - (class_type_declaration : 'class_type_declaration Grammar.Entry.e), - None, - [None, None, - [[Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "virtual")], - Gramext.action - (fun (x : string) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__24))])], - Gramext.action - (fun (a : 'e__24 option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (class_type_parameters : 'class_type_parameters Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e))], - Gramext.action - (fun (cs : 'class_type) _ (ctp : 'class_type_parameters) - (n : 'a_LIDENT) (vf : 'a_opt) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Record - ["ciLoc", Qast.Loc; "ciVir", o2b vf; "ciPrm", ctp; "ciNam", n; - "ciExp", cs] : - 'class_type_declaration))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "apply"), - [None, Some Gramext.LeftA, - [[Gramext.Stoken ("", "new"); - Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e))], - Gramext.action - (fun (i : 'class_longident) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExNew", [Qast.Loc; i]) : 'expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "."), - [None, None, - [[Gramext.Sself; Gramext.Stoken ("", "#"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e))], - Gramext.action - (fun (lab : 'label) _ (e : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExSnd", [Qast.Loc; e; lab]) : 'expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "{<"); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj - (field_expr : 'field_expr Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'field_expr list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", ">}")], - Gramext.action - (fun _ (fel : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExOvr", [Qast.Loc; fel]) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t : 'ctyp) _ (e : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option None; t]) : 'expr)); - [Gramext.Stoken ("", "("); Gramext.Sself; Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ":>"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ (e : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExCoe", [Qast.Loc; e; Qast.Option (Some t); t2]) : - 'expr))]]; - Grammar.Entry.obj (field_expr : 'field_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (l : 'label) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Tuple [l; e] : 'field_expr))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "<"); - Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (field : 'field Grammar.Entry.e)), - Gramext.Stoken ("", ";"))], - Gramext.action - (fun (a : 'field list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "..")], - Gramext.action - (fun (x : string) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__25))])], - Gramext.action - (fun (a : 'e__25 option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.Stoken ("", ">")], - Gramext.action - (fun _ (v : 'a_opt) (ml : 'a_list) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("TyObj", [Qast.Loc; ml; o2b v]) : 'ctyp)); - [Gramext.Stoken ("", "#"); - Gramext.Snterm - (Grammar.Entry.obj - (class_longident : 'class_longident Grammar.Entry.e))], - Gramext.action - (fun (id : 'class_longident) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("TyCls", [Qast.Loc; id]) : 'ctyp))]]; - Grammar.Entry.obj (field : 'field Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (lab : 'a_LIDENT) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Tuple [lab; t] : 'field))]]; - Grammar.Entry.obj (typevar : 'typevar Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "'"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) -> - (i : 'typevar))]]; - Grammar.Entry.obj (clty_longident : 'clty_longident Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) -> - (Qast.List [i] : 'clty_longident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (l : 'clty_longident) _ (m : 'a_UIDENT) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Cons (m, l) : 'clty_longident))]]; - Grammar.Entry.obj (class_longident : 'class_longident Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_LIDENT) (_loc : Lexing.position * Lexing.position) -> - (Qast.List [i] : 'class_longident)); - [Gramext.Snterm - (Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "."); Gramext.Sself], - Gramext.action - (fun (l : 'class_longident) _ (m : 'a_UIDENT) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Cons (m, l) : 'class_longident))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "[<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", ">"); - Gramext.srules - [[Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e)))], - Gramext.action - (fun (a : 'name_tag list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (ntl : 'a_list) _ (rfl : 'row_field_list) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("TyVrn", - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))]) : - 'ctyp)); - [Gramext.Stoken ("", "[<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("TyVrn", - [Qast.Loc; rfl; - Qast.Option (Some (Qast.Option (Some (Qast.List []))))]) : - 'ctyp)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", ">"); - Gramext.srules - [[Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e)))], - Gramext.action - (fun (a : 'name_tag list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (ntl : 'a_list) _ (rfl : 'row_field_list) _ _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("TyVrn", - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))]) : - 'ctyp)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("TyVrn", - [Qast.Loc; rfl; - Qast.Option (Some (Qast.Option (Some (Qast.List []))))]) : - 'ctyp)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", ">"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("TyVrn", - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option None))]) : - 'ctyp)); - [Gramext.Stoken ("", "["); Gramext.Stoken ("", "="); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("TyVrn", [Qast.Loc; rfl; Qast.Option None]) : - 'ctyp))]]; - Grammar.Entry.obj (row_field_list : 'row_field_list Grammar.Entry.e), - None, - [None, None, - [[Gramext.srules - [[Gramext.Slist0sep - (Gramext.Snterm - (Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e)), - Gramext.Stoken ("", "|"))], - Gramext.action - (fun (a : 'row_field list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]], - Gramext.action - (fun (rfl : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (rfl : 'row_field_list))]]; - Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("RfInh", [t]) : 'row_field)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e)); - Gramext.Stoken ("", "of"); - Gramext.srules - [[Gramext.Sopt - (Gramext.srules - [[Gramext.Stoken ("", "&")], - Gramext.action - (fun (x : string) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Str x : 'e__26))])], - Gramext.action - (fun (a : 'e__26 option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)), - Gramext.Stoken ("", "&"))], - Gramext.action - (fun (a : 'ctyp list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]], - Gramext.action - (fun (l : 'a_list) (ao : 'a_opt) _ (i : 'ident) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("RfTag", [i; o2b ao; l]) : 'row_field)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("RfTag", [i; Qast.Bool true; Qast.List []]) : - 'row_field))]]; - Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (i : 'ident) _ (_loc : Lexing.position * Lexing.position) -> - (i : 'name_tag))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "?"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], - Gramext.action - (fun (a : 'eq_expr option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'a_opt) (p : 'patt_tcon) _ _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; Qast.Str ""; - Qast.Option (Some (Qast.Tuple [p; eo]))]) : - 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_QUESTIONIDENT) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaOlb", [Qast.Loc; i; Qast.Option None]) : 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e)); - Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], - Gramext.action - (fun (a : 'eq_expr option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'a_opt) (p : 'patt_tcon) _ (i : 'a_OPTLABEL) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) : - 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], - Gramext.action - (fun (a : 'eq_expr option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'a_opt) (p : 'patt_tcon) _ _ (i : 'a_QUESTIONIDENT) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) : - 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_TILDEIDENT) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option None]) : 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (p : 'patt) (i : 'a_LABEL) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) : - 'patt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Sself], - Gramext.action - (fun (p : 'patt) _ (i : 'a_TILDEIDENT) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) : - 'patt)); - [Gramext.Stoken ("", "#"); - Gramext.Snterm - (Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e))], - Gramext.action - (fun (sl : 'mod_ident) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaTyp", [Qast.Loc; sl]) : 'patt)); - [Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (s : 'ident) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaVrn", [Qast.Loc; s]) : 'patt))]]; - Grammar.Entry.obj (patt_tcon : 'patt_tcon Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e))], - Gramext.action - (fun (p : 'patt) (_loc : Lexing.position * Lexing.position) -> - (p : 'patt_tcon)); - [Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (p : 'patt) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'patt_tcon))]]; - Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "?"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], - Gramext.action - (fun (a : 'eq_expr option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'a_opt) (p : 'ipatt_tcon) _ _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; Qast.Str ""; - Qast.Option (Some (Qast.Tuple [p; eo]))]) : - 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_QUESTIONIDENT) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaOlb", [Qast.Loc; i; Qast.Option None]) : 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e)); - Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], - Gramext.action - (fun (a : 'eq_expr option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'a_opt) (p : 'ipatt_tcon) _ (i : 'a_OPTLABEL) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) : - 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Stoken ("", "("); - Gramext.Snterm - (Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e)); - Gramext.srules - [[Gramext.Sopt - (Gramext.Snterm - (Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e)))], - Gramext.action - (fun (a : 'eq_expr option) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Option a : 'a_opt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_opt) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_opt))]; - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (eo : 'a_opt) (p : 'ipatt_tcon) _ _ (i : 'a_QUESTIONIDENT) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("PaOlb", - [Qast.Loc; i; Qast.Option (Some (Qast.Tuple [p; eo]))]) : - 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_TILDEIDENT) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option None]) : 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (p : 'ipatt) (i : 'a_LABEL) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) : - 'ipatt)); - [Gramext.Snterm - (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Sself], - Gramext.action - (fun (p : 'ipatt) _ (i : 'a_TILDEIDENT) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaLab", [Qast.Loc; i; Qast.Option (Some p)]) : - 'ipatt))]]; - Grammar.Entry.obj (ipatt_tcon : 'ipatt_tcon Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e))], - Gramext.action - (fun (p : 'ipatt) (_loc : Lexing.position * Lexing.position) -> - (p : 'ipatt_tcon)); - [Gramext.Snterm (Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (p : 'ipatt) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaTyc", [Qast.Loc; p; t]) : 'ipatt_tcon))]]; - Grammar.Entry.obj (eq_expr : 'eq_expr Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "="); - Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) _ (_loc : Lexing.position * Lexing.position) -> - (e : 'eq_expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.After "apply"), - [Some "label", Some Gramext.NonA, - [[Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_QUESTIONIDENT) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExOlb", [Qast.Loc; i; Qast.Option None]) : 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'expr) (i : 'a_OPTLABEL) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExOlb", [Qast.Loc; i; Qast.Option (Some e)]) : - 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj - (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (i : 'a_QUESTIONIDENT) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExOlb", [Qast.Loc; i; Qast.Option (Some e)]) : - 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e))], - Gramext.action - (fun (i : 'a_TILDEIDENT) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExLab", [Qast.Loc; i; Qast.Option None]) : 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'expr) (i : 'a_LABEL) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExLab", [Qast.Loc; i; Qast.Option (Some e)]) : - 'expr)); - [Gramext.Snterm - (Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e)); - Gramext.Stoken ("", ":"); Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ (i : 'a_TILDEIDENT) - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExLab", [Qast.Loc; i; Qast.Option (Some e)]) : - 'expr))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "`"); - Gramext.Snterm (Grammar.Entry.obj (ident : 'ident Grammar.Entry.e))], - Gramext.action - (fun (s : 'ident) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExVrn", [Qast.Loc; s]) : 'expr))]]; - Grammar.Entry.obj (direction_flag : 'direction_flag Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "downto")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Bool false : 'direction_flag)); - [Gramext.Stoken ("", "to")], - Gramext.action - (fun _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Bool true : 'direction_flag))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", ">"); - Gramext.srules - [[Gramext.Slist1 - (Gramext.Snterm - (Grammar.Entry.obj (name_tag : 'name_tag Grammar.Entry.e)))], - Gramext.action - (fun (a : 'name_tag list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (ntl : 'a_list) _ (rfl : 'row_field_list) _ _ _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("TyVrn", - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option (Some ntl)))]) : - 'ctyp)); - [Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Stoken ("", "<"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("TyVrn", - [Qast.Loc; rfl; - Qast.Option (Some (Qast.Option (Some (Qast.List []))))]) : - 'ctyp)); - [Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Stoken ("", ">"); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node - ("TyVrn", - [Qast.Loc; rfl; Qast.Option (Some (Qast.Option None))]) : - 'ctyp)); - [Gramext.Stoken ("", "[|"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_variant : 'warning_variant Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (row_field_list : 'row_field_list Grammar.Entry.e)); - Gramext.Stoken ("", "|]")], - Gramext.action - (fun _ (rfl : 'row_field_list) _ _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("TyVrn", [Qast.Loc; rfl; Qast.Option None]) : - 'ctyp))]]; - Grammar.Entry.obj (warning_variant : 'warning_variant Grammar.Entry.e), - None, - [None, None, - [[], - Gramext.action - (fun (_loc : Lexing.position * Lexing.position) -> - (warn_variant Qast.Loc : 'warning_variant))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "while"); Gramext.Sself; Gramext.Stoken ("", "do"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (e : 'e__29))])], - Gramext.action - (fun (a : 'e__29 list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Snterm - (Grammar.Entry.obj - (warning_sequence : 'warning_sequence Grammar.Entry.e)); - Gramext.Stoken ("", "done")], - Gramext.action - (fun _ _ (seq : 'a_list) _ (e : 'expr) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExWhi", [Qast.Loc; e; seq]) : 'expr)); - [Gramext.Stoken ("", "for"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Stoken ("", "="); Gramext.Sself; - Gramext.Snterm - (Grammar.Entry.obj - (direction_flag : 'direction_flag Grammar.Entry.e)); - Gramext.Sself; Gramext.Stoken ("", "do"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (e : 'e__28))])], - Gramext.action - (fun (a : 'e__28 list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Snterm - (Grammar.Entry.obj - (warning_sequence : 'warning_sequence Grammar.Entry.e)); - Gramext.Stoken ("", "done")], - Gramext.action - (fun _ _ (seq : 'a_list) _ (e2 : 'expr) (df : 'direction_flag) - (e1 : 'expr) _ (i : 'a_LIDENT) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExFor", [Qast.Loc; i; e1; e2; df; seq]) : 'expr)); - [Gramext.Stoken ("", "do"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (e : 'expr) - (_loc : Lexing.position * Lexing.position) -> - (e : 'e__27))])], - Gramext.action - (fun (a : 'e__27 list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "return"); - Gramext.Snterm - (Grammar.Entry.obj - (warning_sequence : 'warning_sequence Grammar.Entry.e)); - Gramext.Sself], - Gramext.action - (fun (e : 'expr) _ _ (seq : 'a_list) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExSeq", [Qast.Loc; append_elem seq e]) : 'expr))]]; - Grammar.Entry.obj (warning_sequence : 'warning_sequence Grammar.Entry.e), - None, - [None, None, - [[], - Gramext.action - (fun (_loc : Lexing.position * Lexing.position) -> - (warn_sequence Qast.Loc : 'warning_sequence))]]; - Grammar.Entry.obj (sequence : 'sequence Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "list")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "list" _loc a : 'sequence))]]; - Grammar.Entry.obj (expr_ident : 'expr_ident Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'expr_ident))]]; - Grammar.Entry.obj (patt_label_ident : 'patt_label_ident Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'patt_label_ident))]]; - Grammar.Entry.obj (when_expr_opt : 'when_expr_opt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "when")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "when" _loc a : 'when_expr_opt))]]; - Grammar.Entry.obj (mod_ident : 'mod_ident Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'mod_ident))]]; - Grammar.Entry.obj (clty_longident : 'clty_longident Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'clty_longident))]]; - Grammar.Entry.obj (class_longident : 'class_longident Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'class_longident))]]; - Grammar.Entry.obj (direction_flag : 'direction_flag Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "to")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "to" _loc a : 'direction_flag))]]; - Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "object"); Gramext.Stoken ("ANTIQUOT", ""); - Gramext.Stoken ("", ";"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_str_item : 'class_str_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (cf : 'class_str_item) - (_loc : Lexing.position * Lexing.position) -> - (cf : 'e__30))])], - Gramext.action - (fun (a : 'e__30 list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (csl : 'a_list) _ (x : string) _ - (_loc : Lexing.position * Lexing.position) -> - (let _ = warn_antiq _loc "3.05" in - Qast.Node - ("CeStr", - [Qast.Loc; Qast.Option None; - Qast.Cons (antiquot "" _loc x, csl)]) : - 'class_expr)); - [Gramext.Stoken ("", "object"); Gramext.Stoken ("ANTIQUOT", ""); - Gramext.Snterm - (Grammar.Entry.obj - (class_structure : 'class_structure Grammar.Entry.e)); - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (cf : 'class_structure) (x : string) _ - (_loc : Lexing.position * Lexing.position) -> - (let _ = warn_antiq _loc "3.05" in - Qast.Node ("CeStr", [Qast.Loc; antiquot "" _loc x; cf]) : - 'class_expr))]]; - Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "object"); Gramext.Stoken ("ANTIQUOT", ""); - Gramext.Stoken ("", ";"); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_sig_item : 'class_sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (csf : 'class_sig_item) - (_loc : Lexing.position * Lexing.position) -> - (csf : 'e__32))])], - Gramext.action - (fun (a : 'e__32 list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (csf : 'a_list) _ (x : string) _ - (_loc : Lexing.position * Lexing.position) -> - (let _ = warn_antiq _loc "3.05" in - Qast.Node - ("CtSig", - [Qast.Loc; Qast.Option None; - Qast.Cons (antiquot "" _loc x, csf)]) : - 'class_type)); - [Gramext.Stoken ("", "object"); Gramext.Stoken ("ANTIQUOT", ""); - Gramext.srules - [[Gramext.Slist0 - (Gramext.srules - [[Gramext.Snterm - (Grammar.Entry.obj - (class_sig_item : 'class_sig_item Grammar.Entry.e)); - Gramext.Stoken ("", ";")], - Gramext.action - (fun _ (csf : 'class_sig_item) - (_loc : Lexing.position * Lexing.position) -> - (csf : 'e__31))])], - Gramext.action - (fun (a : 'e__31 list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "end")], - Gramext.action - (fun _ (csf : 'a_list) (x : string) _ - (_loc : Lexing.position * Lexing.position) -> - (let _ = warn_antiq _loc "3.05" in - Qast.Node ("CtSig", [Qast.Loc; antiquot "" _loc x; csf]) : - 'class_type))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "let"); Gramext.Stoken ("ANTIQUOT", "rec"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'let_binding list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (x : 'expr) _ (l : 'a_list) (r : string) _ - (_loc : Lexing.position * Lexing.position) -> - (let _ = warn_antiq _loc "3.06+18" in - Qast.Node ("ExLet", [Qast.Loc; antiquot "rec" _loc r; l; x]) : - 'expr))]]; - Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "value"); Gramext.Stoken ("ANTIQUOT", "rec"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'let_binding list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]], - Gramext.action - (fun (l : 'a_list) (r : string) _ - (_loc : Lexing.position * Lexing.position) -> - (let _ = warn_antiq _loc "3.06+18" in - Qast.Node ("StVal", [Qast.Loc; antiquot "rec" _loc r; l]) : - 'str_item))]]; - Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("", "let"); Gramext.Stoken ("ANTIQUOT", "rec"); - Gramext.srules - [[Gramext.Slist1sep - (Gramext.Snterm - (Grammar.Entry.obj - (let_binding : 'let_binding Grammar.Entry.e)), - Gramext.Stoken ("", "and"))], - Gramext.action - (fun (a : 'let_binding list) - (_loc : Lexing.position * Lexing.position) -> - (Qast.List a : 'a_list)); - [Gramext.Snterm - (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) (_loc : Lexing.position * Lexing.position) -> - (a : 'a_list))]; - Gramext.Stoken ("", "in"); Gramext.Sself], - Gramext.action - (fun (ce : 'class_expr) _ (lb : 'a_list) (r : string) _ - (_loc : Lexing.position * Lexing.position) -> - (let _ = warn_antiq _loc "3.06+18" in - Qast.Node ("CeLet", [Qast.Loc; antiquot "rec" _loc r; lb; ce]) : - 'class_expr))]]; - Grammar.Entry.obj (class_str_item : 'class_str_item Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "value"); Gramext.Stoken ("ANTIQUOT", "mut"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj - (cvalue_binding : 'cvalue_binding Grammar.Entry.e))], - Gramext.action - (fun (e : 'cvalue_binding) (lab : 'label) (mf : string) _ - (_loc : Lexing.position * Lexing.position) -> - (let _ = warn_antiq _loc "3.06+18" in - Qast.Node ("CrVal", [Qast.Loc; lab; antiquot "mut" _loc mf; e]) : - 'class_str_item)); - [Gramext.Stoken ("", "inherit"); - Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e)); - Gramext.Stoken ("ANTIQUOT", "as")], - Gramext.action - (fun (pb : string) (ce : 'class_expr) _ - (_loc : Lexing.position * Lexing.position) -> - (let _ = warn_antiq _loc "3.06+18" in - Qast.Node ("CrInh", [Qast.Loc; ce; antiquot "as" _loc pb]) : - 'class_str_item))]]; - Grammar.Entry.obj (class_sig_item : 'class_sig_item Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("", "value"); Gramext.Stoken ("ANTIQUOT", "mut"); - Gramext.Snterm (Grammar.Entry.obj (label : 'label Grammar.Entry.e)); - Gramext.Stoken ("", ":"); - Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e))], - Gramext.action - (fun (t : 'ctyp) _ (l : 'label) (mf : string) _ - (_loc : Lexing.position * Lexing.position) -> - (let _ = warn_antiq _loc "3.06+18" in - Qast.Node ("CgVal", [Qast.Loc; l; antiquot "mut" _loc mf; t]) : - 'class_sig_item))]]]);; - -Grammar.extend - (let _ = (str_item : 'str_item Grammar.Entry.e) - and _ = (sig_item : 'sig_item Grammar.Entry.e) in - let grammar_entry_create s = - Grammar.Entry.create (Grammar.of_entry str_item) s - in - let dir_param : 'dir_param Grammar.Entry.e = - grammar_entry_create "dir_param" - in - [Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "#"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (dir_param : 'dir_param Grammar.Entry.e))], - Gramext.action - (fun (dp : 'dir_param) (n : 'a_LIDENT) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("StDir", [Qast.Loc; n; dp]) : 'str_item))]]; - Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "#"); - Gramext.Snterm - (Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e)); - Gramext.Snterm - (Grammar.Entry.obj (dir_param : 'dir_param Grammar.Entry.e))], - Gramext.action - (fun (dp : 'dir_param) (n : 'a_LIDENT) _ - (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("SgDir", [Qast.Loc; n; dp]) : 'sig_item))]]; - Grammar.Entry.obj (dir_param : 'dir_param Grammar.Entry.e), None, - [None, None, - [[], - Gramext.action - (fun (_loc : Lexing.position * Lexing.position) -> - (Qast.Option None : 'dir_param)); - [Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e))], - Gramext.action - (fun (e : 'expr) (_loc : Lexing.position * Lexing.position) -> - (Qast.Option (Some e) : 'dir_param)); - [Gramext.Stoken ("ANTIQUOT", "opt")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "opt" _loc a : 'dir_param))]]]);; - -(* Antiquotations *) - -Grammar.extend - [Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'module_expr)); - [Gramext.Stoken ("ANTIQUOT", "mexp")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "mexp" _loc a : 'module_expr))]]; - Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'str_item)); - [Gramext.Stoken ("ANTIQUOT", "stri")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "stri" _loc a : 'str_item))]]; - Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'module_type)); - [Gramext.Stoken ("ANTIQUOT", "mtyp")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "mtyp" _loc a : 'module_type))]]; - Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e), - Some (Gramext.Level "top"), - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'sig_item)); - [Gramext.Stoken ("ANTIQUOT", "sigi")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "sigi" _loc a : 'sig_item))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (el : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExTup", [Qast.Loc; el]) : 'expr)); - [Gramext.Stoken ("ANTIQUOT", "anti")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExAnt", [Qast.Loc; antiquot "anti" _loc a]) : 'expr)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'expr)); - [Gramext.Stoken ("ANTIQUOT", "exp")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "exp" _loc a : 'expr))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (pl : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaTup", [Qast.Loc; pl]) : 'patt)); - [Gramext.Stoken ("ANTIQUOT", "anti")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaAnt", [Qast.Loc; antiquot "anti" _loc a]) : 'patt)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'patt)); - [Gramext.Stoken ("ANTIQUOT", "pat")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "pat" _loc a : 'patt))]]; - Grammar.Entry.obj (ipatt : 'ipatt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (pl : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaTup", [Qast.Loc; pl]) : 'ipatt)); - [Gramext.Stoken ("ANTIQUOT", "anti")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaAnt", [Qast.Loc; antiquot "anti" _loc a]) : 'ipatt)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'ipatt)); - [Gramext.Stoken ("ANTIQUOT", "pat")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "pat" _loc a : 'ipatt))]]; - Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "("); - Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e)); - Gramext.Stoken ("", ")")], - Gramext.action - (fun _ (tl : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("TyTup", [Qast.Loc; tl]) : 'ctyp)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'ctyp)); - [Gramext.Stoken ("ANTIQUOT", "typ")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "typ" _loc a : 'ctyp))]]; - Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'class_expr))]]; - Grammar.Entry.obj (class_str_item : 'class_str_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'class_str_item))]]; - Grammar.Entry.obj (class_sig_item : 'class_sig_item Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'class_sig_item))]]; - Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'class_type))]]; - Grammar.Entry.obj (expr : 'expr Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "{<"); - Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e)); - Gramext.Stoken ("", ">}")], - Gramext.action - (fun _ (fel : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("ExOvr", [Qast.Loc; fel]) : 'expr))]]; - Grammar.Entry.obj (patt : 'patt Grammar.Entry.e), - Some (Gramext.Level "simple"), - [None, None, - [[Gramext.Stoken ("", "#"); - Gramext.Snterm (Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e))], - Gramext.action - (fun (a : 'a_list) _ (_loc : Lexing.position * Lexing.position) -> - (Qast.Node ("PaTyp", [Qast.Loc; a]) : 'patt))]]; - Grammar.Entry.obj (a_list : 'a_list Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "list")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "list" _loc a : 'a_list))]]; - Grammar.Entry.obj (a_opt : 'a_opt Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("ANTIQUOT", "opt")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "opt" _loc a : 'a_opt))]]; - Grammar.Entry.obj (a_UIDENT : 'a_UIDENT Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("UIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Str i : 'a_UIDENT)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'a_UIDENT)); - [Gramext.Stoken ("ANTIQUOT", "uid")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "uid" _loc a : 'a_UIDENT))]]; - Grammar.Entry.obj (a_LIDENT : 'a_LIDENT Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("LIDENT", "")], - Gramext.action - (fun (i : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Str i : 'a_LIDENT)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'a_LIDENT)); - [Gramext.Stoken ("ANTIQUOT", "lid")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "lid" _loc a : 'a_LIDENT))]]; - Grammar.Entry.obj (a_INT : 'a_INT Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("INT", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Str s : 'a_INT)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'a_INT)); - [Gramext.Stoken ("ANTIQUOT", "int")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "int" _loc a : 'a_INT))]]; - Grammar.Entry.obj (a_INT32 : 'a_INT32 Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("INT32", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Str s : 'a_INT32)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'a_INT32)); - [Gramext.Stoken ("ANTIQUOT", "int32")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "int32" _loc a : 'a_INT32))]]; - Grammar.Entry.obj (a_INT64 : 'a_INT64 Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("INT64", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Str s : 'a_INT64)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'a_INT64)); - [Gramext.Stoken ("ANTIQUOT", "int64")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "int64" _loc a : 'a_INT64))]]; - Grammar.Entry.obj (a_NATIVEINT : 'a_NATIVEINT Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("NATIVEINT", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Str s : 'a_NATIVEINT)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'a_NATIVEINT)); - [Gramext.Stoken ("ANTIQUOT", "nativeint")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "nativeint" _loc a : 'a_NATIVEINT))]]; - Grammar.Entry.obj (a_FLOAT : 'a_FLOAT Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("FLOAT", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Str s : 'a_FLOAT)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'a_FLOAT)); - [Gramext.Stoken ("ANTIQUOT", "flo")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "flo" _loc a : 'a_FLOAT))]]; - Grammar.Entry.obj (a_STRING : 'a_STRING Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("STRING", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Str s : 'a_STRING)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'a_STRING)); - [Gramext.Stoken ("ANTIQUOT", "str")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "str" _loc a : 'a_STRING))]]; - Grammar.Entry.obj (a_CHAR : 'a_CHAR Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("CHAR", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Str s : 'a_CHAR)); - [Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'a_CHAR)); - [Gramext.Stoken ("ANTIQUOT", "chr")], - Gramext.action - (fun (a : string) (_loc : Lexing.position * Lexing.position) -> - (antiquot "chr" _loc a : 'a_CHAR))]]; - Grammar.Entry.obj (a_TILDEIDENT : 'a_TILDEIDENT Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("TILDEIDENT", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Str s : 'a_TILDEIDENT)); - [Gramext.Stoken ("", "~"); Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) _ (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'a_TILDEIDENT))]]; - Grammar.Entry.obj (a_LABEL : 'a_LABEL Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("LABEL", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Str s : 'a_LABEL))]]; - Grammar.Entry.obj (a_QUESTIONIDENT : 'a_QUESTIONIDENT Grammar.Entry.e), - None, - [None, None, - [[Gramext.Stoken ("QUESTIONIDENT", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Str s : 'a_QUESTIONIDENT)); - [Gramext.Stoken ("", "?"); Gramext.Stoken ("ANTIQUOT", "")], - Gramext.action - (fun (a : string) _ (_loc : Lexing.position * Lexing.position) -> - (antiquot "" _loc a : 'a_QUESTIONIDENT))]]; - Grammar.Entry.obj (a_OPTLABEL : 'a_OPTLABEL Grammar.Entry.e), None, - [None, None, - [[Gramext.Stoken ("OPTLABEL", "")], - Gramext.action - (fun (s : string) (_loc : Lexing.position * Lexing.position) -> - (Qast.Str s : 'a_OPTLABEL))]]];; - -let apply_entry e = - let f s = - let (bolpos, lnum, fname) = q_position in - let (bolp, ln, _) = !bolpos, !lnum, !fname in - let zero_position () = bolpos := 0; lnum := 1 in - let restore_position () = bolpos := bolp; lnum := ln in - let _ = zero_position () in - try - let result = Grammar.Entry.parse e (Stream.of_string s) in - let _ = restore_position () in result - with - exc -> restore_position (); raise exc - in - let expr s = Qast.to_expr (f s) in - let patt s = Qast.to_patt (f s) in Quotation.ExAst (expr, patt) -;; - - -let sig_item_eoi = Grammar.Entry.create gram "signature item" in -Grammar.extend - [Grammar.Entry.obj (sig_item_eoi : 'sig_item_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (sig_item : 'sig_item Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'sig_item) (_loc : Lexing.position * Lexing.position) -> - (x : 'sig_item_eoi))]]]; -Quotation.add "sig_item" (apply_entry sig_item_eoi);; - -let str_item_eoi = Grammar.Entry.create gram "structure item" in -Grammar.extend - [Grammar.Entry.obj (str_item_eoi : 'str_item_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (str_item : 'str_item Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'str_item) (_loc : Lexing.position * Lexing.position) -> - (x : 'str_item_eoi))]]]; -Quotation.add "str_item" (apply_entry str_item_eoi);; - -let ctyp_eoi = Grammar.Entry.create gram "type" in -Grammar.extend - [Grammar.Entry.obj (ctyp_eoi : 'ctyp_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (ctyp : 'ctyp Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'ctyp) (_loc : Lexing.position * Lexing.position) -> - (x : 'ctyp_eoi))]]]; -Quotation.add "ctyp" (apply_entry ctyp_eoi);; - -let patt_eoi = Grammar.Entry.create gram "pattern" in -Grammar.extend - [Grammar.Entry.obj (patt_eoi : 'patt_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (patt : 'patt Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'patt) (_loc : Lexing.position * Lexing.position) -> - (x : 'patt_eoi))]]]; -Quotation.add "patt" (apply_entry patt_eoi);; - -let expr_eoi = Grammar.Entry.create gram "expression" in -Grammar.extend - [Grammar.Entry.obj (expr_eoi : 'expr_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm (Grammar.Entry.obj (expr : 'expr Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'expr) (_loc : Lexing.position * Lexing.position) -> - (x : 'expr_eoi))]]]; -Quotation.add "expr" (apply_entry expr_eoi);; - -let module_type_eoi = Grammar.Entry.create gram "module type" in -Grammar.extend - [Grammar.Entry.obj (module_type_eoi : 'module_type_eoi Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (module_type : 'module_type Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'module_type) (_loc : Lexing.position * Lexing.position) -> - (x : 'module_type_eoi))]]]; -Quotation.add "module_type" (apply_entry module_type_eoi);; - -let module_expr_eoi = Grammar.Entry.create gram "module expression" in -Grammar.extend - [Grammar.Entry.obj (module_expr_eoi : 'module_expr_eoi Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (module_expr : 'module_expr Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'module_expr) (_loc : Lexing.position * Lexing.position) -> - (x : 'module_expr_eoi))]]]; -Quotation.add "module_expr" (apply_entry module_expr_eoi);; - -let class_type_eoi = Grammar.Entry.create gram "class_type" in -Grammar.extend - [Grammar.Entry.obj (class_type_eoi : 'class_type_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (class_type : 'class_type Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'class_type) (_loc : Lexing.position * Lexing.position) -> - (x : 'class_type_eoi))]]]; -Quotation.add "class_type" (apply_entry class_type_eoi);; - -let class_expr_eoi = Grammar.Entry.create gram "class_expr" in -Grammar.extend - [Grammar.Entry.obj (class_expr_eoi : 'class_expr_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (class_expr : 'class_expr Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'class_expr) (_loc : Lexing.position * Lexing.position) -> - (x : 'class_expr_eoi))]]]; -Quotation.add "class_expr" (apply_entry class_expr_eoi);; - -let class_sig_item_eoi = Grammar.Entry.create gram "class_sig_item" in -Grammar.extend - [Grammar.Entry.obj - (class_sig_item_eoi : 'class_sig_item_eoi Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (class_sig_item : 'class_sig_item Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'class_sig_item) - (_loc : Lexing.position * Lexing.position) -> - (x : 'class_sig_item_eoi))]]]; -Quotation.add "class_sig_item" (apply_entry class_sig_item_eoi);; - -let class_str_item_eoi = Grammar.Entry.create gram "class_str_item" in -Grammar.extend - [Grammar.Entry.obj - (class_str_item_eoi : 'class_str_item_eoi Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj - (class_str_item : 'class_str_item Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'class_str_item) - (_loc : Lexing.position * Lexing.position) -> - (x : 'class_str_item_eoi))]]]; -Quotation.add "class_str_item" (apply_entry class_str_item_eoi);; - -let with_constr_eoi = Grammar.Entry.create gram "with constr" in -Grammar.extend - [Grammar.Entry.obj (with_constr_eoi : 'with_constr_eoi Grammar.Entry.e), - None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (with_constr : 'with_constr Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'with_constr) (_loc : Lexing.position * Lexing.position) -> - (x : 'with_constr_eoi))]]]; -Quotation.add "with_constr" (apply_entry with_constr_eoi);; - -let row_field_eoi = Grammar.Entry.create gram "row_field" in -Grammar.extend - [Grammar.Entry.obj (row_field_eoi : 'row_field_eoi Grammar.Entry.e), None, - [None, None, - [[Gramext.Snterm - (Grammar.Entry.obj (row_field : 'row_field Grammar.Entry.e)); - Gramext.Stoken ("EOI", "")], - Gramext.action - (fun _ (x : 'row_field) (_loc : Lexing.position * Lexing.position) -> - (x : 'row_field_eoi))]]]; -Quotation.add "row_field" (apply_entry row_field_eoi);; diff --git a/camlp4/ocaml_src/odyl/.cvsignore b/camlp4/ocaml_src/odyl/.cvsignore deleted file mode 100644 index 18deb618..00000000 --- a/camlp4/ocaml_src/odyl/.cvsignore +++ /dev/null @@ -1,2 +0,0 @@ -odyl -odyl_config.ml diff --git a/camlp4/ocaml_src/odyl/.depend b/camlp4/ocaml_src/odyl/.depend deleted file mode 100644 index a2629440..00000000 --- a/camlp4/ocaml_src/odyl/.depend +++ /dev/null @@ -1,4 +0,0 @@ -odyl.cmo: odyl_main.cmi odyl_config.cmo -odyl.cmx: odyl_main.cmx odyl_config.cmx -odyl_main.cmo: odyl_config.cmo odyl_main.cmi -odyl_main.cmx: odyl_config.cmx odyl_main.cmi diff --git a/camlp4/ocaml_src/odyl/Makefile b/camlp4/ocaml_src/odyl/Makefile deleted file mode 100644 index d165e692..00000000 --- a/camlp4/ocaml_src/odyl/Makefile +++ /dev/null @@ -1,82 +0,0 @@ -# This file has been generated by program: do not edit! - -include ../../config/Makefile - -SHELL=/bin/sh - -INCLUDES=-I $(OTOP)/otherlibs/dynlink -OCAMLCFLAGS=-warn-error A $(INCLUDES) -LINKFLAGS=$(INCLUDES) - -OBJS=odyl_config.cmo odyl_main.cmo - -all: odyl$(EXE) - -opt: opt$(PROFILING) - -optnoprof: odyl.cmx odyl.cmxa - -optprof: optnoprof odyl.p.cmx odyl.p.cmxa - -odyl$(EXE): odyl.cma odyl.cmo - $(OCAMLC) odyl.cma odyl.cmo -o $@ - -odyl.cma: $(OBJS) - $(OCAMLC) $(LINKFLAGS) dynlink.cma $(OBJS) -a -o $@ - -odyl.cmxa: $(OBJS:.cmo=.cmx) - $(OCAMLOPT) $(LINKFLAGS) $(OBJS:.cmo=.cmx) -a -o $@ - -odyl.p.cmxa: $(OBJS:.cmo=.p.cmx) - $(OCAMLOPT) $(LINKFLAGS) $(OBJS:.cmo=.p.cmx) -a -o $@ - -odyl_main.cmx: odyl_main.ml - $(CAMLP4_COMM) -nolib -DOPT -o odyl_main.ppo odyl_main.ml - $(OCAMLOPT) -c -impl odyl_main.ppo - rm -f odyl_main.ppo - -odyl_main.p.cmx: odyl_main.ml - $(CAMLP4_COMM) -nolib -DOPT -o odyl_main.ppo odyl_main.ml - $(OCAMLOPT) -p -c -o $@ -impl odyl_main.ppo - rm -f odyl_main.ppo - -odyl_config.ml: - (echo 'let standard_library ='; \ - echo ' try Sys.getenv "CAMLP4LIB" with Not_found -> '; \ - echo ' try Sys.getenv "OCAMLLIB" ^ "/camlp4" with Not_found -> '; \ - echo ' try Sys.getenv "CAMLLIB" ^ "/camlp4" with Not_found -> '; \ - echo ' "$(LIBDIR)/camlp4"') \ - | sed -e 's|\\|/|g' > odyl_config.ml - -clean:: - rm -f *.cm* *.pp[io] *.$(O) *.bak .*.bak *.out *.opt *.$(A) - rm -f odyl_config.ml odyl$(EXE) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| $(OTOP)/otherlibs/dynlink/dynlink.cmx||' | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -promote: - -compare: - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" - cp odyl.cmo odyl.cma odyl_main.cmi $(LIBDIR)/camlp4/. - for f in odyl.$(A) odyl.p.$(A) ; do \ - if test -f $$f ; then \ - cp $$f "$(LIBDIR)/camlp4/." && ( cd "$(LIBDIR)/camlp4/." && $(RANLIB) $$f ) ; \ - fi ; \ - done - for f in odyl.cmx odyl.o odyl.p.cmx odyl.p.o odyl.cmxa odyl.p.cmxa ; do \ - if test -f $$f ; then \ - cp $$f "$(LIBDIR)/camlp4/." ; \ - fi ; \ - done - -include .depend diff --git a/camlp4/ocaml_src/odyl/odyl.ml b/camlp4/ocaml_src/odyl/odyl.ml deleted file mode 100644 index d5b6a6ce..00000000 --- a/camlp4/ocaml_src/odyl/odyl.ml +++ /dev/null @@ -1,54 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -let apply_load () = - let i = ref 1 in - let stop = ref false in - while not !stop && !i < Array.length Sys.argv do - let s = Sys.argv.(!i) in - if s = "-I" && !i + 1 < Array.length Sys.argv then - begin Odyl_main.directory Sys.argv.(!i + 1); i := !i + 2 end - else if s = "-nolib" then begin Odyl_main.nolib := true; incr i end - else if s = "-where" then - begin - print_string Odyl_config.standard_library; - print_newline (); - flush stdout; - exit 0 - end - else if s = "-version" then - begin - print_string Sys.ocaml_version; print_newline (); flush stdout; exit 0 - end - else if s = "--" then begin incr i; stop := true; () end - else if String.length s > 0 && s.[0] == '-' then stop := true - else if - Filename.check_suffix s ".cmo" || Filename.check_suffix s ".cma" - then - begin Odyl_main.loadfile s; incr i end - else stop := true - done -;; - -let main () = - try apply_load (); !(Odyl_main.go) () with - Odyl_main.Error (fname, str) -> - flush stdout; - Printf.eprintf "Error while loading \"%s\": " fname; - Printf.eprintf "%s.\n" str; - flush stderr; - exit 2 -;; - -Printexc.catch main ();; diff --git a/camlp4/ocaml_src/odyl/odyl_main.ml b/camlp4/ocaml_src/odyl/odyl_main.ml deleted file mode 100644 index a048f1b0..00000000 --- a/camlp4/ocaml_src/odyl/odyl_main.ml +++ /dev/null @@ -1,76 +0,0 @@ -(* camlp4r pa_macro.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* This file has been generated by program: do not edit! *) - -let go = ref (fun () -> ());; -let name = ref "odyl";; - -let first_arg_no_load () = - let rec loop i = - if i < Array.length Sys.argv then - match Sys.argv.(i) with - "-I" -> loop (i + 2) - | "-nolib" | "-where" | "-version" -> loop (i + 1) - | "--" -> i + 1 - | s -> - if Filename.check_suffix s ".cmo" || Filename.check_suffix s ".cma" - then - loop (i + 1) - else i - else i - in - loop 1 -;; - -Arg.current := first_arg_no_load () - 1;; - -(* Load files in core *) - -let find_in_path path name = - if not (Filename.is_implicit name) then - if Sys.file_exists name then name else raise Not_found - else - let rec try_dir = - function - [] -> raise Not_found - | dir :: rem -> - let fullname = Filename.concat dir name in - if Sys.file_exists fullname then fullname else try_dir rem - in - try_dir path -;; - -exception Error of string * string;; - -let nolib = ref false;; -let initialized = ref false;; -let path = ref ([] : string list);; - -let loadfile file = - if not !initialized then - begin - begin Dynlink.init (); Dynlink.allow_unsafe_modules true end; - initialized := true - end; - let path = - if !nolib then !path else Odyl_config.standard_library :: !path - in - let fname = - try find_in_path (List.rev 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)) -;; - -let directory d = path := d :: !path;; diff --git a/camlp4/ocaml_src/odyl/odyl_main.mli b/camlp4/ocaml_src/odyl/odyl_main.mli deleted file mode 100644 index be441a6c..00000000 --- a/camlp4/ocaml_src/odyl/odyl_main.mli +++ /dev/null @@ -1,13 +0,0 @@ -(* camlp4r *) -(* This file has been generated by program: do not edit! *) - -exception Error of string * string;; - -val nolib : bool ref;; -val initialized : bool ref;; -val path : string list ref;; -val loadfile : string -> unit;; -val directory : string -> unit;; - -val go : (unit -> unit) ref;; -val name : string ref;; diff --git a/camlp4/ocaml_src/tools/camlp4_comm.mpw b/camlp4/ocaml_src/tools/camlp4_comm.mpw deleted file mode 100644 index b3294497..00000000 --- a/camlp4/ocaml_src/tools/camlp4_comm.mpw +++ /dev/null @@ -1,27 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id: camlp4_comm.mpw,v 1.2 2002/07/19 14:53:55 mauny Exp $ - -set echo 0 - -exit if {#} < 1 - -if "{1}" =~ /(Å)¨0.mli/ - echo duplicate -y {1} {¨0}.ppi - duplicate -y "{1}" "{¨0}.ppi" -else if "{1}" =~ /(Å)¨0.ml/ - echo duplicate -y {1} {¨0}.ppo - duplicate -y "{1}" "{¨0}.ppo" -else - echo duplicate -y {1} {1}.ppo - duplicate -y "{1}" "{1}.ppo" -end diff --git a/camlp4/ocaml_src/tools/camlp4_comm.sh b/camlp4/ocaml_src/tools/camlp4_comm.sh deleted file mode 100755 index 357a9295..00000000 --- a/camlp4/ocaml_src/tools/camlp4_comm.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/bin/sh - -if test "`basename $1 .mli`.mli" = "$1"; then - echo cp $1 `basename $1 .mli`.ppi - cp $1 `basename $1 .mli`.ppi -else - echo cp $1 `basename $1 .ml`.ppo - cp $1 `basename $1 .ml`.ppo -fi diff --git a/camlp4/ocaml_src/tools/extract_crc.mpw b/camlp4/ocaml_src/tools/extract_crc.mpw deleted file mode 100644 index 2c4a0ee1..00000000 --- a/camlp4/ocaml_src/tools/extract_crc.mpw +++ /dev/null @@ -1,3 +0,0 @@ -# $Id: extract_crc.mpw,v 1.1 2001/12/13 13:59:25 doligez Exp $ - -"{OTOP}boot:ocamlrun" "{OTOP}otherlibs:dynlink:extract_crc" {"parameters"} diff --git a/camlp4/ocaml_src/tools/extract_crc.sh b/camlp4/ocaml_src/tools/extract_crc.sh deleted file mode 100755 index e69de29b..00000000 diff --git a/camlp4/ocaml_src/tools/ocamlc.mpw b/camlp4/ocaml_src/tools/ocamlc.mpw deleted file mode 100644 index 7e594c03..00000000 --- a/camlp4/ocaml_src/tools/ocamlc.mpw +++ /dev/null @@ -1,3 +0,0 @@ -# - -"{OTOP}boot:ocamlrun" "{OTOP}ocamlc" -I "{OTOP}stdlib" {"parameters"} diff --git a/camlp4/ocaml_src/tools/ocamlc.sh b/camlp4/ocaml_src/tools/ocamlc.sh deleted file mode 100755 index ee654c2c..00000000 --- a/camlp4/ocaml_src/tools/ocamlc.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/sh -e -if test "`basename $OTOP`" != "ocaml_stuff"; then - COMM=$OTOP/ocamlcomp.sh -else - COMM=ocamlc$OPT -fi -echo $COMM $* -$COMM $* diff --git a/camlp4/ocaml_src/tools/ocamlopt.sh b/camlp4/ocaml_src/tools/ocamlopt.sh deleted file mode 100755 index 1fb669d6..00000000 --- a/camlp4/ocaml_src/tools/ocamlopt.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/sh -e -if test "`basename $OTOP`" != "ocaml_stuff"; then - COMM=$OTOP/ocamlcompopt.sh -else - COMM=ocamlopt$OPT -fi -echo $COMM $* -$COMM $* diff --git a/camlp4/ocaml_stuff/otherlibs/dynlink/.depend b/camlp4/ocaml_stuff/otherlibs/dynlink/.depend deleted file mode 100644 index e69de29b..00000000 diff --git a/camlp4/ocaml_stuff/parsing/.depend b/camlp4/ocaml_stuff/parsing/.depend deleted file mode 100644 index 4364f56e..00000000 --- a/camlp4/ocaml_stuff/parsing/.depend +++ /dev/null @@ -1,2 +0,0 @@ -location.cmi: ../utils/warnings.cmi -parsetree.cmi: asttypes.cmi location.cmi longident.cmi diff --git a/camlp4/ocaml_stuff/utils/.depend b/camlp4/ocaml_stuff/utils/.depend deleted file mode 100644 index 28041288..00000000 --- a/camlp4/ocaml_stuff/utils/.depend +++ /dev/null @@ -1,2 +0,0 @@ -config.cmo: config.cmi -config.cmx: config.cmi diff --git a/camlp4/ocpp/.cvsignore b/camlp4/ocpp/.cvsignore deleted file mode 100644 index baef26c6..00000000 --- a/camlp4/ocpp/.cvsignore +++ /dev/null @@ -1,3 +0,0 @@ -*.cm[oia] -ocpp -crc.ml diff --git a/camlp4/ocpp/.depend b/camlp4/ocpp/.depend deleted file mode 100644 index e69de29b..00000000 diff --git a/camlp4/ocpp/Makefile b/camlp4/ocpp/Makefile deleted file mode 100644 index 65e0a213..00000000 --- a/camlp4/ocpp/Makefile +++ /dev/null @@ -1,25 +0,0 @@ -# $Id: Makefile,v 1.8 2004/11/30 18:57:03 doligez Exp $ - -include ../config/Makefile - -SHELL=/bin/sh - -INCLUDES=-I ../camlp4 -I ../boot -I ../odyl -I $(OTOP)/otherlibs/dynlink -OCAMLCFLAGS=-warn-error A $(INCLUDES) -LINKFLAGS=$(INCLUDES) -OBJS=ocpp.cmo - -all: ocpp$(EXE) - -ocpp$(EXE): $(OBJS) - $(OCAMLC) $(LINKFLAGS) ../boot/stdpp.cmo ../camlp4/reloc.cmo ../camlp4/quotation.cmo ../odyl/odyl.cma $(OBJS) ../odyl/odyl.cmo -linkall -o ocpp$(EXE) - -clean:: - rm -f *.cm[ioa] *.pp[io] *.o *.out *.bak .*.bak ocpp$(EXE) - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" - cp $(OBJS) "$(LIBDIR)/camlp4/." - cp ocpp$(EXE) "$(BINDIR)/." - -depend: diff --git a/camlp4/ocpp/ocpp.ml b/camlp4/ocpp/ocpp.ml deleted file mode 100644 index c72cd96b..00000000 --- a/camlp4/ocpp/ocpp.ml +++ /dev/null @@ -1,149 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: ocpp.ml,v 1.6 2004/05/12 15:22:48 mauny Exp $ *) - -value buff = ref (String.create 80); -value store len x = - do { - if len >= String.length buff.val then - buff.val := buff.val ^ String.create (String.length buff.val) - else (); - buff.val.[len] := x; - succ len - } -; -value get_buff len = String.sub buff.val 0 len; - -value rec copy_strip_locate cs = - match cs with parser - [ [: `'$' :] -> maybe_locate cs - | [: `c :] -> do { print_char c; copy_strip_locate cs } - | [: :] -> () ] -and maybe_locate cs = - match cs with parser - [ [: `'1'..'9' :] -> locate cs - | [: :] -> do { print_char '$'; copy_strip_locate cs } ] -and locate cs = - match cs with parser - [ [: `'0'..'9' :] -> locate cs - | [: `':' :] -> inside_locate cs - | [: :] -> raise (Stream.Error "colon char expected") ] -and inside_locate cs = - match cs with parser - [ [: `'$' :] -> copy_strip_locate cs - | [: `'\\'; `c :] -> do { print_char c; inside_locate cs } - | [: `c :] -> do { print_char c; inside_locate cs } - | [: :] -> raise (Stream.Error "end of file in locate directive") ] -; - -value nowhere = { - Lexing.pos_fname = ""; - Lexing.pos_lnum = 0; - Lexing.pos_bol = 0; - Lexing.pos_cnum = 0 -} -; - -value quot name pos str = - let pos = Reloc.shift_pos pos nowhere in - let exp = - try - match Quotation.find name with - [ Quotation.ExStr f -> f - | _ -> raise Not_found ] - with - [ Not_found -> - Stdpp.raise_with_loc (pos, Reloc.shift_pos (String.length str) pos) Not_found ] - in - let new_str = - try exp True str with - [ Stdpp.Exc_located (p1, p2) exc -> - Stdpp.raise_with_loc (Reloc.adjust_loc pos (p1, p2)) exc - | exc -> Stdpp.raise_with_loc (pos, Reloc.shift_pos (String.length str) pos) exc ] - in - let cs = Stream.of_string new_str in copy_strip_locate cs -; - -value rec ident len = - parser - [ [: `('A'..'Z' | 'a'..'z' | '0'..'9' | '_' | ''' as c); s :] -> - ident (store len c) s - | [: :] -> get_buff len ] -; - -value rec copy cs = - match cs with parser - [ [: `'<' :] -> maybe_quot cs - | [: `'"' :] -> do { print_char '"'; inside_string cs } - | [: `c :] -> do { print_char c; copy cs } - | [: :] -> () ] -and maybe_quot cs = - match cs with parser - [ [: `'<' :] ep -> inside_quot "" ep 0 cs - | [: `':'; i = ident 0; `'<' ? "less char expected" :] ep -> - inside_quot i ep 0 cs - | [: :] -> do { print_char '<'; copy cs } ] -and inside_quot name pos len cs = - match cs with parser - [ [: `'>' :] -> maybe_end_quot name pos len cs - | [: `c :] -> inside_quot name pos (store len c) cs - | [: :] -> raise (Stream.Error "end of file in quotation") ] -and maybe_end_quot name pos len cs = - match cs with parser - [ [: `'>' :] -> do { quot name pos (get_buff len); copy cs } - | [: :] -> inside_quot name pos (store len '>') cs ] -and inside_string cs = - match cs with parser - [ [: `'"' :] -> do { print_char '"'; copy cs } - | [: `c :] -> do { print_char c; inside_string cs } - | [: :] -> raise (Stream.Error "end of file in string") ] -; - -value copy_quot cs = do { copy cs; flush stdout; }; - -value loc_fmt = - match Sys.os_type with - [ "MacOS" -> - format_of_string "File \"%s\"; line %d; characters %d to %d\n### " - | _ -> - format_of_string "File \"%s\", line %d, characters %d-%d:\n" ] -; - -value print_location loc file = - let (fname, line, c1, c2) = Stdpp.line_of_loc file loc in - do { Printf.eprintf loc_fmt file line c1 c2; flush stderr; } -; - -value file = ref ""; -Arg.parse [] (fun x -> file.val := x) "ocpp "; - -value main () = - try - if file.val <> "" then - copy_quot (Stream.of_channel (open_in_bin file.val)) - else () - with exc -> - do { - print_newline (); - flush stdout; - let exc = - match exc with - [ Stdpp.Exc_located loc exc -> do { print_location loc file.val; exc } - | exc -> exc ] - in - raise exc - } -; - -Odyl_main.name.val := "ocpp"; -Odyl_main.go.val := main; diff --git a/camlp4/odyl/.cvsignore b/camlp4/odyl/.cvsignore deleted file mode 100644 index 8ae0ebb0..00000000 --- a/camlp4/odyl/.cvsignore +++ /dev/null @@ -1,4 +0,0 @@ -*.cm[oia] -odyl -*.lib -odyl_config.ml diff --git a/camlp4/odyl/.depend b/camlp4/odyl/.depend deleted file mode 100644 index a2629440..00000000 --- a/camlp4/odyl/.depend +++ /dev/null @@ -1,4 +0,0 @@ -odyl.cmo: odyl_main.cmi odyl_config.cmo -odyl.cmx: odyl_main.cmx odyl_config.cmx -odyl_main.cmo: odyl_config.cmo odyl_main.cmi -odyl_main.cmx: odyl_config.cmx odyl_main.cmi diff --git a/camlp4/odyl/Makefile b/camlp4/odyl/Makefile deleted file mode 100644 index 97f6fa93..00000000 --- a/camlp4/odyl/Makefile +++ /dev/null @@ -1,82 +0,0 @@ -# $Id: Makefile,v 1.20 2004/11/30 18:57:03 doligez Exp $ - -include ../config/Makefile - -SHELL=/bin/sh - -INCLUDES=-I $(OTOP)/otherlibs/dynlink -OCAMLCFLAGS=-warn-error A $(INCLUDES) -LINKFLAGS=$(INCLUDES) - -OBJS=odyl_config.cmo odyl_main.cmo - -all: odyl$(EXE) - -opt: opt$(PROFILING) - -optnoprof: odyl.cmx odyl.cmxa - -optprof: optnoprof odyl.p.cmx odyl.p.cmxa - -odyl$(EXE): odyl.cma odyl.cmo - $(OCAMLC) odyl.cma odyl.cmo -o $@ - -odyl.cma: $(OBJS) - $(OCAMLC) $(LINKFLAGS) dynlink.cma $(OBJS) -a -o $@ - -odyl.cmxa: $(OBJS:.cmo=.cmx) - $(OCAMLOPT) $(LINKFLAGS) $(OBJS:.cmo=.cmx) -a -o $@ - -odyl.p.cmxa: $(OBJS:.cmo=.p.cmx) - $(OCAMLOPT) $(LINKFLAGS) $(OBJS:.cmo=.p.cmx) -a -o $@ - -odyl_main.cmx: odyl_main.ml - $(CAMLP4_COMM) -nolib -DOPT -o odyl_main.ppo odyl_main.ml - $(OCAMLOPT) -c -impl odyl_main.ppo - rm -f odyl_main.ppo - -odyl_main.p.cmx: odyl_main.ml - $(CAMLP4_COMM) -nolib -DOPT -o odyl_main.ppo odyl_main.ml - $(OCAMLOPT) -p -c -o $@ -impl odyl_main.ppo - rm -f odyl_main.ppo - -odyl_config.ml: - (echo 'let standard_library ='; \ - echo ' try Sys.getenv "CAMLP4LIB" with Not_found -> '; \ - echo ' try Sys.getenv "OCAMLLIB" ^ "/camlp4" with Not_found -> '; \ - echo ' try Sys.getenv "CAMLLIB" ^ "/camlp4" with Not_found -> '; \ - echo ' "$(LIBDIR)/camlp4"') \ - | sed -e 's|\\|/|g' > odyl_config.ml - -clean:: - rm -f *.cm* *.pp[io] *.$(O) *.bak .*.bak *.out *.opt *.$(A) - rm -f odyl_config.ml odyl$(EXE) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| $(OTOP)/otherlibs/dynlink/dynlink.cmx||' | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -promote: - -compare: - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" - cp odyl.cmo odyl.cma odyl_main.cmi $(LIBDIR)/camlp4/. - for f in odyl.$(A) odyl.p.$(A) ; do \ - if test -f $$f ; then \ - cp $$f "$(LIBDIR)/camlp4/." && ( cd "$(LIBDIR)/camlp4/." && $(RANLIB) $$f ) ; \ - fi ; \ - done - for f in odyl.cmx odyl.o odyl.p.cmx odyl.p.o odyl.cmxa odyl.p.cmxa ; do \ - if test -f $$f ; then \ - cp $$f "$(LIBDIR)/camlp4/." ; \ - fi ; \ - done - -include .depend diff --git a/camlp4/odyl/odyl.ml b/camlp4/odyl/odyl.ml deleted file mode 100644 index 3eeb0356..00000000 --- a/camlp4/odyl/odyl.ml +++ /dev/null @@ -1,57 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: odyl.ml,v 1.3 2004/07/13 12:19:14 xleroy Exp $ *) - -value apply_load () = - let i = ref 1 in - let stop = ref False in - while not stop.val && i.val < Array.length Sys.argv do { - let s = Sys.argv.(i.val) in - if s = "-I" && i.val + 1 < Array.length Sys.argv then do { - Odyl_main.directory Sys.argv.(i.val + 1); - i.val := i.val + 2 - } - else if s = "-nolib" then do { Odyl_main.nolib.val := True; incr i } - else if s = "-where" then do { - print_string Odyl_config.standard_library; - print_newline (); - flush stdout; - exit 0 - } - else if s = "-version" then do { - print_string Sys.ocaml_version; - print_newline (); - flush stdout; - exit 0 - } - else if s = "--" then do { incr i; stop.val := True; () } - else if String.length s > 0 && s.[0] == '-' then stop.val := True - else if Filename.check_suffix s ".cmo" || Filename.check_suffix s ".cma" - then do { Odyl_main.loadfile s; incr i } - else stop.val := True - } -; - -value main () = - try do { apply_load () ; Odyl_main.go.val () } with - [ Odyl_main.Error fname str -> - do { - flush stdout; - Printf.eprintf "Error while loading \"%s\": " fname; - Printf.eprintf "%s.\n" str; - flush stderr; - exit 2 - } ] -; - -Printexc.catch main (); diff --git a/camlp4/odyl/odyl_main.ml b/camlp4/odyl/odyl_main.ml deleted file mode 100644 index 514290e2..00000000 --- a/camlp4/odyl/odyl_main.ml +++ /dev/null @@ -1,82 +0,0 @@ -(* camlp4r pa_macro.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: odyl_main.ml,v 1.5 2004/07/13 12:19:14 xleroy Exp $ *) - -value go = ref (fun () -> ()); -value name = ref "odyl"; - -value first_arg_no_load () = - loop 1 where rec loop i = - if i < Array.length Sys.argv then - match Sys.argv.(i) with - [ "-I" -> loop (i + 2) - | ("-nolib" | "-where" | "-version") -> loop (i + 1) - | "--" -> i + 1 - | s -> - if Filename.check_suffix s ".cmo" - || Filename.check_suffix s ".cma" - then loop (i + 1) - else i ] - else i -; - -Arg.current.val := first_arg_no_load () - 1; - -(* Load files in core *) - -value find_in_path path name = - if not (Filename.is_implicit name) then - if Sys.file_exists name then name else raise Not_found - else - let rec try_dir = - fun - [ [] -> raise Not_found - | [dir :: rem] -> - let fullname = Filename.concat dir name in - if Sys.file_exists fullname then fullname else try_dir rem ] - in - try_dir path -; - -exception Error of string and string; - -value nolib = ref False; -value initialized = ref False; -value path = ref ([] : list string); - -value loadfile file = - IFDEF OPT THEN - raise (Error file "native-code program cannot do a dynamic load") - ELSE do { - if not initialized.val then do { - IFDEF OPT THEN () - ELSE do { Dynlink.init (); Dynlink.allow_unsafe_modules True } - END; - initialized.val := True - } - else (); - let path = - if nolib.val then path.val - else [Odyl_config.standard_library :: path.val] - in - let fname = - try find_in_path (List.rev 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)) ] - } - END -; - -value directory d = path.val := [d :: path.val]; diff --git a/camlp4/odyl/odyl_main.mli b/camlp4/odyl/odyl_main.mli deleted file mode 100644 index 1dc1683a..00000000 --- a/camlp4/odyl/odyl_main.mli +++ /dev/null @@ -1,13 +0,0 @@ -(* camlp4r *) -(* $Id: odyl_main.mli,v 1.2 2002/07/19 14:53:56 mauny Exp $ *) - -exception Error of string and string; - -value nolib : ref bool; -value initialized : ref bool; -value path : ref (list string); -value loadfile : string -> unit; -value directory : string -> unit; - -value go : ref (unit -> unit); -value name : ref string; diff --git a/camlp4/tools/apply.sh b/camlp4/tools/apply.sh deleted file mode 100755 index a5c96fa7..00000000 --- a/camlp4/tools/apply.sh +++ /dev/null @@ -1,33 +0,0 @@ -#!/bin/sh -# $Id: apply.sh,v 1.5 2004/07/13 12:19:15 xleroy Exp $ - -P4TOP=.. -ARGS1= -FILE= -while test "" != "$1"; do - case $1 in - *.ml*) FILE=$1;; - -top) P4TOP="$2"; shift;; - *) ARGS1="$ARGS1 $1";; - esac - shift -done - -# FILE must exist and be non empty (at least one line) -test -s "$FILE" || exit 1 - - - -set - `awk 'NR == 1' "$FILE"` -if test "$2" = "camlp4r" -o "$2" = "camlp4"; then - COMM="$P4TOP/boot/$2 -nolib -I $P4TOP/boot -I $P4TOP/etc" - shift; shift - ARGS2=`echo $* | sed -e "s/[()*]//g"` -else - COMM="$P4TOP/boot/camlp4 -nolib -I $P4TOP/boot -I $P4TOP/etc pa_o.cmo" - ARGS2= -fi - -OTOP=$P4TOP/.. -echo $OTOP/boot/ocamlrun $COMM $ARGS2 $ARGS1 $FILE 1>&2 -$OTOP/boot/ocamlrun $COMM $ARGS2 $ARGS1 $FILE diff --git a/camlp4/tools/camlp4_comm.mpw b/camlp4/tools/camlp4_comm.mpw deleted file mode 100644 index fc68eec9..00000000 --- a/camlp4/tools/camlp4_comm.mpw +++ /dev/null @@ -1,53 +0,0 @@ -####################################################################### -# # -# Camlp4 # -# # -# Damien Doligez, projet Para, INRIA Rocquencourt # -# # -# Copyright 1999 Institut National de Recherche en Informatique et # -# en Automatique. Distributed only by permission. # -# # -####################################################################### - -# $Id: camlp4_comm.mpw,v 1.1 2001/12/13 13:59:25 doligez Exp $ - -set echo 0 - -exit if {#} < 1 - -set args1 "" -set file "" -loop - break if {#} == 0 - if "{1}" =~ /Å.mlÅ/ - set file "{1}" - else - set args1 "{args1} `quote "{1}"`" - end - shift -end - -set firstline "`streamedit -e '1 exit' "{file}"`" ³ dev:null || set status 0 - -if "{firstline}" =~ /[Â ]+ camlp4r (Å)¨0/ - set args0 "`echo "{¨0}" | streamedit -e '1,$ replace -c ° /[()*]/ ""' ¶ - -e '1,$ replace -c ° /.¶// ":"'`" - set comm "{OTOP}boot:ocamlrun ::boot:camlp4r -nolib -I ::boot:" - echo "{comm} {args0} {args1} {file}" - {comm} {args0} {args1} "{file}" -else if "{firstline}" =~ /[Â ]+ camlp4 (Å)¨0/ - set args0 "`echo "{¨0}" | streamedit -e '1,$ replace -c ° /[()*]/ ""' ¶ - -e '1,$ replace -c ° /.¶// ":"'`" - set comm "{OTOP}boot:ocamlrun ::boot:camlp4 -nolib -I ::boot:" - echo "{comm} {args0} {args1} {file}" - {comm} {args0} {args1} "{file}" -else if "{file}" =~ /(Å)¨0.mli/ - echo duplicate -y {file} {¨0}.ppi - duplicate -y "{file}" "{¨0}.ppi" -else if "{file}" =~ /(Å)¨0.ml/ - echo duplicate -y {file} {¨0}.ppo - duplicate -y "{file}" "{¨0}.ppo" -else - echo duplicate -y {file} {file}.ppo - duplicate -y "{file}" "{file}.ppo" -end diff --git a/camlp4/tools/camlp4_comm.sh b/camlp4/tools/camlp4_comm.sh deleted file mode 100755 index 3800beaf..00000000 --- a/camlp4/tools/camlp4_comm.sh +++ /dev/null @@ -1,38 +0,0 @@ -#!/bin/sh -# $Id: camlp4_comm.sh,v 1.9 2004/05/12 15:22:48 mauny Exp $ - -ARGS1= -FILE= -QUIET=no -while test "" != "$1"; do - case $1 in - -q) QUIET=yes;; - *.ml*) FILE=$1;; - *) ARGS1="$ARGS1 $1";; - esac - shift -done - -# FILE must exist and be non empty (at least one line) -test -s "$FILE" || exit 1 - -set - `awk 'NR == 1' "$FILE"` -if test "$2" = "camlp4r" -o "$2" = "camlp4"; then - COMM="ocamlrun$EXE ../boot/$2$EXE -nolib -I ../boot" - if test "`basename $OTOP`" != "ocaml_stuff"; then - COMM="$OTOP/boot/$COMM" - fi - shift; shift - ARGS2=`echo $* | sed -e "s/[()*]//g"` - ARGS1="$ARGS1 -verbose" - if test "$QUIET" = "no"; then echo $COMM $ARGS2 $ARGS1 $FILE; fi - $COMM $ARGS2 $ARGS1 $FILE -else - if test "`basename $FILE .mli`.mli" = "$FILE"; then - OFILE=`basename $FILE .mli`.ppi - else - OFILE=`basename $FILE .ml`.ppo - fi - if test "$QUIET" = "no"; then echo cp $FILE $OFILE; fi - cp $FILE $OFILE -fi diff --git a/camlp4/tools/conv.sh b/camlp4/tools/conv.sh deleted file mode 100755 index 64a4e2b1..00000000 --- a/camlp4/tools/conv.sh +++ /dev/null @@ -1,22 +0,0 @@ -#!/bin/sh -DIR=`expr "$0" : "\(.*\)/.*" "|" "."` - -INCL= -FILE= -while test "" != "$1"; do - case $1 in - -I) INCL="$INCL -I $2"; shift;; - *) FILE=$1;; - esac - shift -done - -set - `awk 'NR == 1' "$FILE"` -if test "$2" = "camlp4r" -o "$2" = "camlp4"; then - COMM="$OTOP/boot/ocamlrun $DIR/../boot/$2 -nolib -I $DIR/../boot $INCL $DIR/../etc/pr_o.cmo" - shift; shift - ARGS=`echo $* | sed -e "s/[()*]//g"` - $COMM $ARGS -ss $FILE -else - cat $FILE -fi diff --git a/camlp4/tools/extract_crc.mpw b/camlp4/tools/extract_crc.mpw deleted file mode 100644 index 2c4a0ee1..00000000 --- a/camlp4/tools/extract_crc.mpw +++ /dev/null @@ -1,3 +0,0 @@ -# $Id: extract_crc.mpw,v 1.1 2001/12/13 13:59:25 doligez Exp $ - -"{OTOP}boot:ocamlrun" "{OTOP}otherlibs:dynlink:extract_crc" {"parameters"} diff --git a/camlp4/tools/extract_crc.sh b/camlp4/tools/extract_crc.sh deleted file mode 100755 index e69de29b..00000000 diff --git a/camlp4/tools/ocamlc.mpw b/camlp4/tools/ocamlc.mpw deleted file mode 100644 index cee6feaa..00000000 --- a/camlp4/tools/ocamlc.mpw +++ /dev/null @@ -1,3 +0,0 @@ -# $Id: ocamlc.mpw,v 1.1 2001/12/13 13:59:25 doligez Exp $ - -"{OTOP}boot:ocamlrun" "{OTOP}ocamlc" -I "{OTOP}stdlib:" {"parameters"} diff --git a/camlp4/tools/ocamlc.sh b/camlp4/tools/ocamlc.sh deleted file mode 100755 index ee654c2c..00000000 --- a/camlp4/tools/ocamlc.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/sh -e -if test "`basename $OTOP`" != "ocaml_stuff"; then - COMM=$OTOP/ocamlcomp.sh -else - COMM=ocamlc$OPT -fi -echo $COMM $* -$COMM $* diff --git a/camlp4/tools/ocamlopt.sh b/camlp4/tools/ocamlopt.sh deleted file mode 100755 index 1fb669d6..00000000 --- a/camlp4/tools/ocamlopt.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/sh -e -if test "`basename $OTOP`" != "ocaml_stuff"; then - COMM=$OTOP/ocamlcompopt.sh -else - COMM=ocamlopt$OPT -fi -echo $COMM $* -$COMM $* diff --git a/camlp4/top/.cvsignore b/camlp4/top/.cvsignore deleted file mode 100644 index df1824f4..00000000 --- a/camlp4/top/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -*.cm[oia] diff --git a/camlp4/top/.depend b/camlp4/top/.depend deleted file mode 100644 index 0fd8a39f..00000000 --- a/camlp4/top/.depend +++ /dev/null @@ -1,12 +0,0 @@ -camlp4_top.cmo: $(OTOP)/utils/warnings.cmi $(OTOP)/toplevel/toploop.cmi \ - $(OTOP)/toplevel/topdirs.cmi ../camlp4/pcaml.cmi \ - $(OTOP)/parsing/parsetree.cmi ../camlp4/mLast.cmi ../camlp4/ast2pt.cmi -camlp4_top.cmx: $(OTOP)/utils/warnings.cmx $(OTOP)/toplevel/toploop.cmx \ - $(OTOP)/toplevel/topdirs.cmx ../camlp4/pcaml.cmx \ - $(OTOP)/parsing/parsetree.cmi ../camlp4/mLast.cmi ../camlp4/ast2pt.cmx -oprint.cmo: $(OTOP)/toplevel/toploop.cmi $(OTOP)/typing/outcometree.cmi -oprint.cmx: $(OTOP)/toplevel/toploop.cmx $(OTOP)/typing/outcometree.cmi -rprint.cmo: $(OTOP)/toplevel/toploop.cmi $(OTOP)/typing/outcometree.cmi \ - $(OTOP)/parsing/asttypes.cmi -rprint.cmx: $(OTOP)/toplevel/toploop.cmx $(OTOP)/typing/outcometree.cmi \ - $(OTOP)/parsing/asttypes.cmi diff --git a/camlp4/top/Makefile b/camlp4/top/Makefile deleted file mode 100644 index b23f1fbe..00000000 --- a/camlp4/top/Makefile +++ /dev/null @@ -1,48 +0,0 @@ -# $Id: Makefile,v 1.15 2004/11/30 18:57:03 doligez Exp $ - -include ../config/Makefile - -INCLUDES=-I ../camlp4 -I ../boot -I $(OTOP)/utils -I $(OTOP)/parsing -I $(OTOP)/typing -I $(OTOP)/toplevel -OCAMLCFLAGS=-warn-error A $(INCLUDES) - -CAMLP4_OBJS=$(OTOP)/utils/config.cmo ../boot/stdpp.cmo ../boot/token.cmo ../boot/plexer.cmo ../boot/gramext.cmo ../boot/grammar.cmo ../boot/extfold.cmo ../boot/extfun.cmo ../boot/fstream.cmo ../camlp4/quotation.cmo ../camlp4/reloc.cmo ../camlp4/spretty.cmo ../camlp4/pcaml.cmo ../camlp4/ast2pt.cmo -TOP=camlp4_top.cmo -ROBJS=$(CAMLP4_OBJS) ../meta/pa_r.cmo ../meta/pa_rp.cmo rprint.cmo $(TOP) -OOBJS=$(CAMLP4_OBJS) ../etc/pa_o.cmo ../etc/pa_op.cmo $(TOP) -OOOBJS=$(CAMLP4_OBJS) ../etc/pa_o.cmo ../etc/pa_oop.cmo $(TOP) -OBJS=$(OTOP)/utils/config.cmo ../camlp4/quotation.cmo ../camlp4/reloc.cmo ../camlp4/spretty.cmo ../camlp4/pcaml.cmo ../camlp4/ast2pt.cmo camlp4_top.cmo - -TARGET=camlp4o.cma camlp4r.cma camlp4_top.cma - -all: $(TARGET) - -camlp4oo.cma: $(OOOBJS) - $(OCAMLC) $(OOOBJS) -linkall -a -o camlp4oo.cma - -camlp4o.cma: $(OOBJS) - $(OCAMLC) $(OOBJS) -linkall -a -o camlp4o.cma - -camlp4r.cma: $(ROBJS) - $(OCAMLC) $(ROBJS) -linkall -a -o camlp4r.cma - -camlp4_top.cma: $(OBJS) - $(OCAMLC) $(OBJS) -a -o camlp4_top.cma - -clean:: - rm -f *.cm[ioa] *.pp[io] *.o *.bak .*.bak $(TARGET) - -depend: - cp .depend .depend.bak - > .depend - @for i in *.mli *.ml; do \ - ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i | \ - sed -e 's| \.\./\.\.| $$(OTOP)|g' >> .depend; \ - done - -get_promote: - -install: - -$(MKDIR) "$(LIBDIR)/camlp4" - cp $(TARGET) "$(LIBDIR)/camlp4/." - -include .depend diff --git a/camlp4/top/camlp4_top.ml b/camlp4/top/camlp4_top.ml deleted file mode 100644 index 1fae381b..00000000 --- a/camlp4/top/camlp4_top.ml +++ /dev/null @@ -1,179 +0,0 @@ -(* camlp4r q_MLast.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: camlp4_top.ml,v 1.17 2005/10/21 15:51:42 mauny Exp $ *) - -open Parsetree; -open Lexing; -open Stdpp; - -value highlight_locations lb loc1 loc2 = - try - let pos0 = - lb.lex_abs_pos in - do { - if pos0 < 0 then raise Exit else (); - let pos_at_bol = ref 0 in - print_string "Toplevel input:\n# "; - for pos = 0 to lb.lex_buffer_len - pos0 - 1 do { - let c = lb.lex_buffer.[pos + pos0] in - if c = '\n' then do { - if pos_at_bol.val <= fst loc1 && snd loc1 <= pos then do { - print_string "\n "; - for i = pos_at_bol.val to fst loc1 - 1 do { print_char ' ' }; - for i = fst loc1 to snd loc1 - 1 do { print_char '^' }; - print_char '\n' - } - else if pos_at_bol.val <= fst loc1 && fst loc1 < pos then do { - print_char '\r'; - print_char (if pos_at_bol.val = 0 then '#' else ' '); - print_char ' '; - for i = pos_at_bol.val to fst loc1 - 1 do { print_char '.' }; - print_char '\n' - } - else if pos_at_bol.val <= snd loc1 && snd loc1 < pos then do { - for i = pos - 1 downto snd loc1 do { print_string "\008.\008" }; - print_char '\n' - } - else print_char '\n'; - pos_at_bol.val := pos + 1; - if pos < lb.lex_buffer_len - pos0 - 1 then - print_string " " - else () - } - else print_char c - }; - flush stdout - } - with - [ Exit -> () ] -; - -value print_location lb loc = - if String.length Toploop.input_name.val = 0 then - highlight_locations lb ((fst loc).Lexing.pos_cnum, (snd loc).Lexing.pos_cnum) (-1, -1) - else Toploop.print_location Format.err_formatter - (Ast2pt.mkloc loc) -; - -value wrap f shfn lb = - let cs = - let shift = shfn lb in - Stream.from - (fun i -> - if i < shift then Some ' ' - else do { - while - lb.lex_curr_pos >= lb.lex_buffer_len && - not lb.lex_eof_reached - do { - lb.refill_buff lb - }; - if lb.lex_curr_pos >= lb.lex_buffer_len then None - else do { - let c = lb.lex_buffer.[lb.lex_curr_pos] in - lb.lex_curr_pos := lb.lex_curr_pos + 1; - Some c - } - }) in - let parse_fun = f lb.lex_curr_p in - try parse_fun cs with - [ Exc_located _ (Sys.Break as x) -> raise x - | End_of_file as x -> raise x - | x -> - let x = - match x with - [ Exc_located loc x -> do { print_location lb loc; x } - | x -> x ] - in - do { - match x with - [ Stream.Failure | Stream.Error _ -> Pcaml.sync.val cs - | _ -> () ]; - Format.open_hovbox 0; - Pcaml.report_error x; - Format.close_box (); - Format.print_newline (); - raise Exit - } ] -; - -value first_phrase = ref True; - -value toplevel_phrase pos cs = - do { - if Sys.interactive.val && first_phrase.val then do { - first_phrase.val := False; - Printf.printf "\tCamlp4 Parsing version %s\n\n%!" Pcaml.version; - } - else (); - match Grammar.Entry.parse Pcaml.top_phrase cs with - [ Some phr -> Ast2pt.phrase phr - | None -> raise End_of_file ]; - } -; - -value use_file pos cs = - let v = Pcaml.input_file.val in - let (bolpos,lnum,fname) = Pcaml.position.val in - let restore = - let (bolp,ln,fn) = (bolpos.val, lnum.val, fname.val) in - fun () -> do { - Pcaml.input_file.val := v; - bolpos.val := bolp; lnum.val := ln; fname.val := fn - } in - do { - Pcaml.input_file.val := Toploop.input_name.val; - bolpos.val := pos.pos_bol; lnum.val := pos.pos_lnum; fname.val := Toploop.input_name.val; - try - let (pl0, eoi) = - loop () where rec loop () = - let (pl, stopped_at_directive) = - Grammar.Entry.parse Pcaml.use_file cs - in - if stopped_at_directive then - match pl with - [ [MLast.StDir _ "load" (Some <:expr< $str:s$ >>)] -> - do { Topdirs.dir_load Format.std_formatter s; loop () } - | [MLast.StDir _ "directory" (Some <:expr< $str:s$ >>)] -> - do { Topdirs.dir_directory s; loop () } - | _ -> (pl, False) ] - else (pl, True) - in - let pl = - if eoi then [] - else - loop () where rec loop () = - let (pl, stopped_at_directive) = - Grammar.Entry.parse Pcaml.use_file cs - in - if stopped_at_directive then pl @ loop () else pl - in - let r = pl0 @ pl in - let r = List.map Ast2pt.phrase r in - do { restore (); r } - with e -> - do { restore (); raise e } - } -; - -Toploop.parse_toplevel_phrase.val := - wrap toplevel_phrase (fun _ -> 0) -; - -Toploop.parse_use_file.val := - wrap use_file (fun lb -> lb.lex_curr_pos - lb.lex_start_pos) -; - -Pcaml.warning.val := - fun loc txt -> - Toploop.print_warning (Ast2pt.mkloc loc) Format.err_formatter - (Warnings.Camlp4 txt); diff --git a/camlp4/top/oprint.ml b/camlp4/top/oprint.ml deleted file mode 100644 index 7a9d435c..00000000 --- a/camlp4/top/oprint.ml +++ /dev/null @@ -1,597 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: oprint.ml,v 1.6 2003/09/23 12:52:34 mauny Exp $ *) - -open Format; -open Outcometree; - -exception Ellipsis; -value cautious f ppf arg = - try f ppf arg with [ Ellipsis -> fprintf ppf "..." ] -; - -value rec print_ident ppf = - fun - [ Oide_ident s -> fprintf ppf "%s" s - | Oide_dot id s -> fprintf ppf "%a.%s" print_ident id s - | Oide_apply id1 id2 -> - fprintf ppf "%a(%a)" print_ident id1 print_ident id2 ] -; - -value value_ident ppf name = - if List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"] - then - fprintf ppf "( %s )" name - else - match name.[0] with - [ 'a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' -> - fprintf ppf "%s" name - | _ -> fprintf ppf "( %s )" name ] -; - -(* Values *) - -value print_out_value ppf tree = - let rec print_tree ppf = - fun - [ Oval_tuple tree_list -> - fprintf ppf "@[%a@]" (print_tree_list print_tree_1 ",") tree_list - | tree -> print_tree_1 ppf tree ] - and print_tree_1 ppf = - fun - [ Oval_constr name [param] -> - fprintf ppf "@[<1>%a@ %a@]" print_ident name print_simple_tree param - | Oval_constr name ([_ :: _] as params) -> - fprintf ppf "@[<1>%a@ (%a)@]" print_ident name - (print_tree_list print_tree_1 ",") params - | Oval_variant name (Some param) -> - fprintf ppf "@[<2>`%s@ %a@]" name print_simple_tree param - | tree -> print_simple_tree ppf tree ] - and print_simple_tree ppf = - fun - [ Oval_int i -> fprintf ppf "%i" i - | Oval_int32 i -> fprintf ppf "%ldl" i - | Oval_int64 i -> fprintf ppf "%LdL" i - | Oval_nativeint i -> fprintf ppf "%ndn" i - | Oval_float f -> fprintf ppf "%F" f - | Oval_char c -> fprintf ppf "%C" c - | Oval_string s -> - try fprintf ppf "%S" s with - [ Invalid_argument "String.create" -> fprintf ppf "" ] - | Oval_list tl -> - fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ";") tl - | Oval_array tl -> - fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ";") tl - | Oval_constr name [] -> print_ident ppf name - | Oval_variant name None -> fprintf ppf "`%s" name - | Oval_stuff s -> fprintf ppf "%s" s - | Oval_record fel -> - fprintf ppf "@[<1>{%a}@]" (cautious (print_fields True)) fel - | Oval_ellipsis -> raise Ellipsis - | Oval_printer f -> f ppf - | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree) tree ] - and print_fields first ppf = - fun - [ [] -> () - | [(name, tree) :: fields] -> - do { - if not first then fprintf ppf ";@ " else (); - fprintf ppf "@[<1>%a@ =@ %a@]" print_ident name - (cautious print_tree) tree; - print_fields False ppf fields - } ] - and print_tree_list print_item sep ppf tree_list = - let rec print_list first ppf = - fun - [ [] -> () - | [tree :: tree_list] -> - do { - if not first then fprintf ppf "%s@ " sep else (); - print_item ppf tree; - print_list False ppf tree_list - } ] - in - cautious (print_list True) ppf tree_list - in - cautious print_tree ppf tree -; - -(* Types *) - -value rec print_list_init pr sep ppf = - fun - [ [] -> () - | [a :: l] -> do { sep ppf; pr ppf a; print_list_init pr sep ppf l } ] -; - -value pr_vars = - print_list (fun ppf s -> fprintf ppf "'%s" s) (fun ppf -> fprintf ppf "@ ") -; - -value rec print_list pr sep ppf = - fun - [ [] -> () - | [a] -> pr ppf a - | [a :: l] -> do { pr ppf a; sep ppf; print_list pr sep ppf l } ] -; - -value pr_present = - print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ") -; - -value rec print_out_type ppf = - fun - [ Otyp_alias ty s -> fprintf ppf "@[%a as '%s@]" print_out_type ty s - | Otyp_poly sl ty -> - fprintf ppf "@[%a.@ %a@]" - pr_vars sl - print_out_type ty - | ty -> print_out_type_1 ppf ty ] -and print_out_type_1 ppf = - fun - [ Otyp_arrow lab ty1 ty2 -> - fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "") - print_out_type_2 ty1 print_out_type_1 ty2 - | ty -> print_out_type_2 ppf ty ] -and print_out_type_2 ppf = - fun - [ Otyp_tuple tyl -> - fprintf ppf "@[<0>%a@]" (print_typlist print_simple_out_type " *") tyl - | ty -> print_simple_out_type ppf ty ] -and print_simple_out_type ppf = - fun - [ Otyp_class ng id tyl -> - fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "") - print_ident id - | Otyp_constr id tyl -> - fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id - | Otyp_object fields rest -> - fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields - | Otyp_stuff s -> fprintf ppf "%s" s - | Otyp_var ng s -> fprintf ppf "'%s%s" (if ng then "_" else "") s - | Otyp_variant non_gen row_fields closed tags -> - let print_present ppf = - fun - [ None | Some [] -> () - | Some l -> fprintf ppf "@;<1 -2>> @[%a@]" pr_present l ] - in - let print_fields ppf = - fun - [ Ovar_fields fields -> - print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ") - ppf fields - | Ovar_name id tyl -> - fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id ] - in - fprintf ppf "%s[%s@[@[%a@]%a]@]" (if non_gen then "_" else "") - (if closed then if tags = None then " " else "< " - else if tags = None then "> " - else "? ") - print_fields row_fields print_present tags - | Otyp_alias _ _ | Otyp_poly _ | Otyp_arrow _ _ _ | Otyp_tuple _ as ty -> - fprintf ppf "@[<1>(%a)@]" print_out_type ty - | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_private _ - | Otyp_manifest _ _ -> () ] -and print_fields rest ppf = - fun - [ [] -> - match rest with - [ Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "") - | None -> () ] - | [(s, t)] -> - do { - fprintf ppf "%s : %a" s print_out_type t; - match rest with - [ Some _ -> fprintf ppf ";@ " - | None -> () ]; - print_fields rest ppf [] - } - | [(s, t) :: l] -> - fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l ] -and print_row_field ppf (l, opt_amp, tyl) = - let pr_of ppf = - if opt_amp then fprintf ppf " of@ &@ " - else if tyl <> [] then fprintf ppf " of@ " - else fprintf ppf "" - in - fprintf ppf "@[`%s%t%a@]" l pr_of (print_typlist print_out_type " &") - tyl -and print_typlist print_elem sep ppf = - fun - [ [] -> () - | [ty] -> print_elem ppf ty - | [ty :: tyl] -> - fprintf ppf "%a%s@ %a" print_elem ty sep (print_typlist print_elem sep) - tyl ] -and print_typargs ppf = - fun - [ [] -> () - | [ty1] -> fprintf ppf "%a@ " print_simple_out_type ty1 - | tyl -> - fprintf ppf "@[<1>(%a)@]@ " (print_typlist print_out_type ",") tyl ] -; - -(* Signature items *) - -value print_out_class_params ppf = - fun - [ [] -> () - | tyl -> - fprintf ppf "@[<1>[%a]@]@ " - (print_list (fun ppf x -> fprintf ppf "'%s" x) - (fun ppf -> fprintf ppf ", ")) - tyl ] -; - -value rec print_out_class_type ppf = - fun - [ Octy_constr id tyl -> - let pr_tyl ppf = - fun - [ [] -> () - | tyl -> - fprintf ppf "@[<1>[%a]@]@ " (print_typlist print_out_type ",") - tyl ] - in - fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id - | Octy_fun lab ty cty -> - fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "") - print_out_type_2 ty print_out_class_type cty - | Octy_signature self_ty csil -> - let pr_param ppf = - fun - [ Some ty -> fprintf ppf "@ @[(%a)@]" print_out_type ty - | None -> () ] - in - fprintf ppf "@[@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty - (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ ")) - csil ] -and print_out_class_sig_item ppf = - fun - [ Ocsg_constraint ty1 ty2 -> - fprintf ppf "@[<2>constraint %a =@ %a@]" print_out_type ty1 - print_out_type ty2 - | Ocsg_method name priv virt ty -> - fprintf ppf "@[<2>method %s%s%s :@ %a@]" - (if priv then "private " else "") (if virt then "virtual " else "") - name print_out_type ty - | Ocsg_value name mut ty -> - fprintf ppf "@[<2>val %s%s :@ %a@]" (if mut then "mutable " else "") - name print_out_type ty ] -; - -value rec print_out_module_type ppf = - fun - [ Omty_abstract -> () - | Omty_functor name mty_arg mty_res -> - fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name - print_out_module_type mty_arg print_out_module_type mty_res - | Omty_ident id -> fprintf ppf "%a" print_ident id - | Omty_signature sg -> - fprintf ppf "@[sig@ %a@;<1 -2>end@]" print_signature_body sg ] -and print_signature_body ppf = - fun - [ [] -> () - | [item] -> print_out_sig_item ppf item - | [item :: items] -> - fprintf ppf "%a@ %a" print_out_sig_item item - print_signature_body items ] -and print_out_sig_item ppf = - fun - [ Osig_class vir_flag name params clt -> - fprintf ppf "@[<2>class%s@ %a%s@ :@ %a@]" - (if vir_flag then " virtual" else "") print_out_class_params params - name print_out_class_type clt - | Osig_class_type vir_flag name params clt -> - fprintf ppf "@[<2>class type%s@ %a%s@ =@ %a@]" - (if vir_flag then " virtual" else "") print_out_class_params params - name print_out_class_type clt - | Osig_exception id tyl -> - fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl) - | Osig_modtype name Omty_abstract -> - fprintf ppf "@[<2>module type %s@]" name - | Osig_modtype name mty -> - fprintf ppf "@[<2>module type %s =@ %a@]" name print_out_module_type mty - | Osig_module name mty -> - fprintf ppf "@[<2>module %s :@ %a@]" name print_out_module_type mty - | Osig_type tdl -> print_out_type_decl_list ppf tdl - | Osig_value name ty prims -> - let kwd = if prims = [] then "val" else "external" in - let pr_prims ppf = - fun - [ [] -> () - | [s :: sl] -> - do { - fprintf ppf "@ = \"%s\"" s; - List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl - } ] - in - fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name - print_out_type ty pr_prims prims ] -and print_out_type_decl_list ppf = - fun - [ [] -> () - | [x] -> print_out_type_decl "type" ppf x - | [x :: l] -> - do { - print_out_type_decl "type" ppf x; - List.iter (fun x -> fprintf ppf "@ %a" (print_out_type_decl "and") x) - l - } ] -and print_out_type_decl kwd ppf (name, args, ty, constraints) = - let print_constraints ppf params = - List.iter - (fun (ty1, ty2) -> - fprintf ppf "@ @[<2>constraint %a =@ %a@]" print_out_type - ty1 print_out_type ty2) - params - in - let type_parameter ppf (ty, (co, cn)) = - fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "") - ty - in - let type_defined ppf = - match args with - [ [] -> fprintf ppf "%s" name - | [arg] -> fprintf ppf "@[%a@ %s@]" type_parameter arg name - | _ -> - fprintf ppf "@[(@[%a)@]@ %s@]" - (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) args - name ] - in - let print_manifest ppf = - fun - [ Otyp_manifest ty _ -> fprintf ppf " =@ %a" print_out_type ty - | _ -> () ] - in - let print_name_args ppf = - fprintf ppf "%s %t%a" kwd type_defined print_manifest ty - in - let ty = - match ty with - [ Otyp_manifest _ ty -> ty - | _ -> ty ] - in - match ty with - [ Otyp_abstract -> - fprintf ppf "@[<2>@[%t@]%a@]" print_name_args print_constraints - constraints - | Otyp_record lbls -> - fprintf ppf "@[<2>@[%t = {%a@;<1 -2>}@]@ %a@]" print_name_args - (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls - print_constraints constraints - | Otyp_sum constrs -> - fprintf ppf "@[<2>@[%t =@;<1 2>%a@]%a@]" print_name_args - (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs - print_constraints constraints - | ty -> - fprintf ppf "@[<2>@[%t =@ %a@]%a@]" print_name_args - print_out_type ty print_constraints constraints ] -and print_out_constr ppf (name, tyl) = - match tyl with - [ [] -> fprintf ppf "%s" name - | _ -> - fprintf ppf "@[<2>%s of@ %a@]" name - (print_typlist print_simple_out_type " *") tyl ] -and print_out_label ppf (name, mut, arg) = - fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name - print_out_type arg -; - -(* Signature items *) - -value print_out_class_params ppf = - fun - [ [] -> () - | tyl -> - fprintf ppf "@[<1>[%a]@]@ " - (print_list (fun ppf x -> fprintf ppf "'%s" x) - (fun ppf -> fprintf ppf ", ")) - tyl ] -; - -value rec print_out_class_type ppf = - fun - [ Octy_constr id tyl -> - let pr_tyl ppf = - fun - [ [] -> () - | tyl -> - fprintf ppf "@[<1>[%a]@]@ " - (print_typlist print_out_type ",") tyl ] - in - fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id - | Octy_fun lab ty cty -> - fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "") - print_out_type_2 ty print_out_class_type cty - | Octy_signature self_ty csil -> - let pr_param ppf = - fun - [ Some ty -> fprintf ppf "@ @[(%a)@]" print_out_type ty - | None -> () ] - in - fprintf ppf "@[@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty - (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ ")) - csil ] -and print_out_class_sig_item ppf = - fun - [ Ocsg_constraint ty1 ty2 -> - fprintf ppf "@[<2>constraint %a =@ %a@]" print_out_type ty1 - print_out_type ty2 - | Ocsg_method name priv virt ty -> - fprintf ppf "@[<2>method %s%s%s :@ %a@]" - (if priv then "private " else "") (if virt then "virtual " else "") - name print_out_type ty - | Ocsg_value name mut ty -> - fprintf ppf "@[<2>val %s%s :@ %a@]" (if mut then "mutable " else "") - name print_out_type ty ] -; - -value rec print_out_module_type ppf = - fun - [ Omty_abstract -> () - | Omty_functor name mty_arg mty_res -> - fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name - print_out_module_type mty_arg print_out_module_type mty_res - | Omty_ident id -> fprintf ppf "%a" print_ident id - | Omty_signature sg -> - fprintf ppf "@[sig@ %a@;<1 -2>end@]" print_signature_body sg ] -and print_signature_body ppf = - fun - [ [] -> () - | [item] -> print_out_sig_item ppf item - | [item :: items] -> - fprintf ppf "%a@ %a" print_out_sig_item item print_signature_body - items ] -and print_out_sig_item ppf = - fun - [ Osig_class vir_flag name params clt -> - fprintf ppf "@[<2>class%s@ %a%s@ :@ %a@]" - (if vir_flag then " virtual" else "") print_out_class_params params - name print_out_class_type clt - | Osig_class_type vir_flag name params clt -> - fprintf ppf "@[<2>class type%s@ %a%s@ =@ %a@]" - (if vir_flag then " virtual" else "") print_out_class_params params - name print_out_class_type clt - | Osig_exception id tyl -> - fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl) - | Osig_modtype name Omty_abstract -> - fprintf ppf "@[<2>module type %s@]" name - | Osig_modtype name mty -> - fprintf ppf "@[<2>module type %s =@ %a@]" name print_out_module_type mty - | Osig_module name mty -> - fprintf ppf "@[<2>module %s :@ %a@]" name print_out_module_type mty - | Osig_type tdl -> print_out_type_decl_list ppf tdl - | Osig_value name ty prims -> - let kwd = if prims = [] then "val" else "external" in - let pr_prims ppf = - fun - [ [] -> () - | [s :: sl] -> - do { - fprintf ppf "@ = \"%s\"" s; - List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl - } ] - in - fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name print_out_type - ty pr_prims prims ] -and print_out_type_decl_list ppf = - fun - [ [] -> () - | [x] -> print_out_type_decl "type" ppf x - | [x :: l] -> - do { - print_out_type_decl "type" ppf x; - List.iter (fun x -> fprintf ppf "@ %a" (print_out_type_decl "and") x) - l - } ] -and print_out_type_decl kwd ppf (name, args, ty, constraints) = - let print_constraints ppf params = - List.iter - (fun (ty1, ty2) -> - fprintf ppf "@ @[<2>constraint %a =@ %a@]" print_out_type ty1 - print_out_type ty2) - params - in - let type_parameter ppf (ty, (co, cn)) = - fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "") - ty - in - let type_defined ppf = - match args with - [ [] -> fprintf ppf "%s" name - | [arg] -> fprintf ppf "@[%a@ %s@]" type_parameter arg name - | _ -> - fprintf ppf "@[(@[%a)@]@ %s@]" - (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) args - name ] - in - let print_manifest ppf = - fun - [ Otyp_manifest ty _ -> fprintf ppf " =@ %a" print_out_type ty - | _ -> () ] - in - let print_name_args ppf = - fprintf ppf "%s %t%a" kwd type_defined print_manifest ty - in - let ty = - match ty with - [ Otyp_manifest _ ty -> ty - | _ -> ty ] - in - match ty with - [ Otyp_abstract -> - fprintf ppf "@[<2>@[%t@]%a@]" print_name_args print_constraints - constraints - | Otyp_record lbls -> - fprintf ppf "@[<2>@[%t = {%a@;<1 -2>}@]@ %a@]" print_name_args - (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls - print_constraints constraints - | Otyp_sum constrs -> - fprintf ppf "@[<2>@[%t =@;<1 2>%a@]%a@]" print_name_args - (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs - print_constraints constraints - | ty -> - fprintf ppf "@[<2>@[%t =@ %a@]%a@]" print_name_args - print_out_type ty print_constraints constraints ] -and print_out_constr ppf (name, tyl) = - match tyl with - [ [] -> fprintf ppf "%s" name - | _ -> - fprintf ppf "@[<2>%s of@ %a@]" name - (print_typlist print_simple_out_type " *") tyl ] -and print_out_label ppf (name, mut, arg) = - fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name - print_out_type arg -; - -(* Phrases *) - -value print_out_exception ppf exn outv = - match exn with - [ Sys.Break -> fprintf ppf "Interrupted.@." - | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@." - | Stack_overflow -> - fprintf ppf "Stack overflow during evaluation (looping recursion?).@." - | _ -> - fprintf ppf "@[Exception:@ %a.@]@." Toploop.print_out_value.val outv ] -; - -value rec print_items ppf = - fun - [ [] -> () - | [(tree, valopt) :: items] -> - do { - match valopt with - [ Some v -> - fprintf ppf "@[<2>%a =@ %a@]" Toploop.print_out_sig_item.val tree - Toploop.print_out_value.val v - | None -> fprintf ppf "@[%a@]" Toploop.print_out_sig_item.val tree ]; - if items <> [] then fprintf ppf "@ %a" print_items items else () - } ] -; - -value print_out_phrase ppf = - fun - [ Ophr_eval outv ty -> - fprintf ppf "@[- : %a@ =@ %a@]@." Toploop.print_out_type.val ty - Toploop.print_out_value.val outv - | Ophr_signature [] -> () - | Ophr_signature items -> fprintf ppf "@[%a@]@." print_items items - | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv ] -; - -Toploop.print_out_value.val := print_out_value; -Toploop.print_out_type.val := print_out_type; -Toploop.print_out_sig_item.val := print_out_sig_item; -Toploop.print_out_phrase.val := print_out_phrase; diff --git a/camlp4/top/rprint.ml b/camlp4/top/rprint.ml deleted file mode 100644 index 86c5aa6e..00000000 --- a/camlp4/top/rprint.ml +++ /dev/null @@ -1,427 +0,0 @@ -(* camlp4r *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: rprint.ml,v 1.18 2005/06/29 04:11:26 garrigue Exp $ *) - -open Format; -open Outcometree; - -exception Ellipsis; -value cautious f ppf arg = - try f ppf arg with [ Ellipsis -> fprintf ppf "..." ] -; - -value rec print_ident ppf = - fun - [ Oide_ident s -> fprintf ppf "%s" s - | Oide_dot id s -> fprintf ppf "%a.%s" print_ident id s - | Oide_apply id1 id2 -> - fprintf ppf "%a(%a)" print_ident id1 print_ident id2 ] -; - -value value_ident ppf name = - if List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"] - then - fprintf ppf "( %s )" name - else - match name.[0] with - [ 'a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' -> - fprintf ppf "%s" name - | _ -> fprintf ppf "( %s )" name ] -; - -(* Values *) - -value print_out_value ppf tree = - let rec print_tree ppf = - fun - [ Oval_constr name ([_ :: _] as params) -> - fprintf ppf "@[<1>%a@ %a@]" print_ident name - (print_tree_list print_simple_tree "") params - | Oval_variant name (Some param) -> - fprintf ppf "@[<2>`%s@ %a@]" name print_simple_tree param - | tree -> print_simple_tree ppf tree ] - and print_simple_tree ppf = - fun - [ Oval_int i -> fprintf ppf "%i" i - | Oval_int32 i -> fprintf ppf "%ldl" i - | Oval_int64 i -> fprintf ppf "%LdL" i - | Oval_nativeint i -> fprintf ppf "%ndn" i - | Oval_float f -> fprintf ppf "%.12g" f - | Oval_char c -> fprintf ppf "'%s'" (Char.escaped c) - | Oval_string s -> - try fprintf ppf "\"%s\"" (String.escaped s) with - [ Invalid_argument "String.create" -> fprintf ppf "" ] - | Oval_list tl -> - fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree ";") tl - | Oval_array tl -> - fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree ";") tl - | Oval_constr (Oide_ident "true") [] -> fprintf ppf "True" - | Oval_constr (Oide_ident "false") [] -> fprintf ppf "False" - | Oval_constr name [] -> print_ident ppf name - | Oval_variant name None -> fprintf ppf "`%s" name - | Oval_stuff s -> fprintf ppf "%s" s - | Oval_record fel -> - fprintf ppf "@[<1>{%a}@]" (cautious (print_fields True)) fel - | Oval_tuple tree_list -> - fprintf ppf "@[(%a)@]" (print_tree_list print_tree ",") tree_list - | Oval_ellipsis -> raise Ellipsis - | Oval_printer f -> f ppf - | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree) tree ] - and print_fields first ppf = - fun - [ [] -> () - | [(name, tree) :: fields] -> - let name = - match name with - [ Oide_ident "contents" -> Oide_ident "val" - | x -> x ] - in - do { - if not first then fprintf ppf ";@ " else (); - fprintf ppf "@[<1>%a=@,%a@]" print_ident name (cautious print_tree) - tree; - print_fields False ppf fields - } ] - and print_tree_list print_item sep ppf tree_list = - let rec print_list first ppf = - fun - [ [] -> () - | [tree :: tree_list] -> - do { - if not first then fprintf ppf "%s@ " sep else (); - print_item ppf tree; - print_list False ppf tree_list - } ] - in - cautious (print_list True) ppf tree_list - in - cautious print_tree ppf tree -; - -value rec print_list pr sep ppf = - fun - [ [] -> () - | [a] -> pr ppf a - | [a :: l] -> do { pr ppf a; sep ppf; print_list pr sep ppf l } ] -; - -value pr_vars = - print_list (fun ppf s -> fprintf ppf "'%s" s) (fun ppf -> fprintf ppf "@ ") -; - -value pr_present = - print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ") -; - -(* Types *) - -value rec print_out_type ppf = - fun - [ Otyp_alias ty s -> fprintf ppf "@[%a as '%s@]" print_out_type ty s - | ty -> print_out_type_1 ppf ty ] -and print_out_type_1 ppf = - fun - [ Otyp_arrow lab ty1 ty2 -> - fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "") - print_out_type_2 ty1 print_out_type_1 ty2 - | Otyp_poly sl ty -> - fprintf ppf "@[!%a.@ %a@]" - pr_vars sl - print_out_type ty - | ty -> print_out_type_2 ppf ty ] -and print_out_type_2 ppf = - fun - [ Otyp_constr id ([_ :: _] as tyl) -> - fprintf ppf "@[%a@;<1 2>%a@]" print_ident id - (print_typlist print_simple_out_type "") tyl - | ty -> print_simple_out_type ppf ty ] -and print_simple_out_type ppf = - let rec print_tkind ppf = - fun - [ Otyp_var ng s -> fprintf ppf "'%s%s" (if ng then "_" else "") s - | Otyp_constr id [] -> fprintf ppf "@[%a@]" print_ident id - | Otyp_tuple tyl -> - fprintf ppf "@[<1>(%a)@]" (print_typlist print_out_type " *") tyl - | Otyp_stuff s -> fprintf ppf "%s" s - | Otyp_variant non_gen row_fields closed tags -> - let print_present ppf = - fun - [ None | Some [] -> () - | Some l -> fprintf ppf "@;<1 -2>> @[%a@]" pr_present l ] - in - let print_fields ppf = - fun - [ Ovar_fields fields -> - print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ") - ppf fields - | Ovar_name id tyl -> - fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id ] - in - fprintf ppf "%s[%s@[@[%a@]%a ]@]" (if non_gen then "_" else "") - (if closed then if tags = None then "= " else "< " - else if tags = None then "> " - else "? ") - print_fields row_fields - print_present tags - | Otyp_object fields rest -> - fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields - | Otyp_class ng id tyl -> - fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "") - print_ident id - | Otyp_manifest ty1 ty2 -> - fprintf ppf "@[<2>%a ==@ %a@]" print_out_type ty1 print_out_type ty2 - | Otyp_sum constrs -> - fprintf ppf "@[[ %a ]@]" - (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs - | Otyp_record lbls -> - fprintf ppf "@[{ %a }@]" - (print_list print_out_label (fun ppf -> fprintf ppf ";@ ")) lbls - | Otyp_abstract -> fprintf ppf "'abstract" - | Otyp_alias _ _ | Otyp_poly _ _ - | Otyp_arrow _ _ _ | Otyp_constr _ [_ :: _] as ty -> - fprintf ppf "@[<1>(%a)@]" print_out_type ty ] - in - print_tkind ppf -and print_out_constr ppf (name, tyl) = - match tyl with - [ [] -> fprintf ppf "%s" name - | _ -> - fprintf ppf "@[<2>%s of@ %a@]" name - (print_typlist print_out_type " and") tyl ] -and print_out_label ppf (name, mut, arg) = - fprintf ppf "@[<2>%s :@ %s%a@]" name (if mut then "mutable " else "") - print_out_type arg -and print_fields rest ppf = - fun - [ [] -> - match rest with - [ Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "") - | None -> () ] - | [(s, t)] -> - do { - fprintf ppf "%s : %a" s print_out_type t; - match rest with - [ Some _ -> fprintf ppf ";@ " - | None -> () ]; - print_fields rest ppf [] - } - | [(s, t) :: l] -> - fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l ] -and print_row_field ppf (l, opt_amp, tyl) = - let pr_of ppf = - if opt_amp then fprintf ppf " of@ &@ " - else if tyl <> [] then fprintf ppf " of@ " - else fprintf ppf "" - in - fprintf ppf "@[`%s%t%a@]" l pr_of (print_typlist print_out_type " &") - tyl -and print_typlist print_elem sep ppf = - fun - [ [] -> () - | [ty] -> print_elem ppf ty - | [ty :: tyl] -> - fprintf ppf "%a%s@ %a" print_elem ty sep (print_typlist print_elem sep) - tyl ] -and print_typargs ppf = - fun - [ [] -> () - | [ty1] -> fprintf ppf "%a@ " print_simple_out_type ty1 - | tyl -> - fprintf ppf "@[<1>(%a)@]@ " (print_typlist print_out_type ",") tyl ] -; - -value type_parameter ppf (ty, (co, cn)) = - fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "") - ty -; - -value print_out_class_params ppf = - fun - [ [] -> () - | tyl -> - fprintf ppf "@[<1>[%a]@]@ " - (print_list type_parameter (fun ppf -> fprintf ppf ", ")) - tyl ] -; - -(* Signature items *) - -value rec print_out_class_type ppf = - fun - [ Octy_constr id tyl -> - let pr_tyl ppf = - fun - [ [] -> () - | tyl -> - fprintf ppf "@[<1>[%a]@]@ " - (print_typlist Toploop.print_out_type.val ",") tyl ] - in - fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id - | Octy_fun lab ty cty -> - fprintf ppf "@[%s[ %a ] ->@ %a@]" (if lab <> "" then lab ^ ":" else "") - Toploop.print_out_type.val ty print_out_class_type cty - | Octy_signature self_ty csil -> - let pr_param ppf = - fun - [ Some ty -> fprintf ppf "@ @[(%a)@]" Toploop.print_out_type.val ty - | None -> () ] - in - fprintf ppf "@[@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty - (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ ")) - csil ] -and print_out_class_sig_item ppf = - fun - [ Ocsg_constraint ty1 ty2 -> - fprintf ppf "@[<2>type %a =@ %a;@]" Toploop.print_out_type.val ty1 - Toploop.print_out_type.val ty2 - | Ocsg_method name priv virt ty -> - fprintf ppf "@[<2>method %s%s%s :@ %a;@]" - (if priv then "private " else "") (if virt then "virtual " else "") - name Toploop.print_out_type.val ty - | Ocsg_value name mut ty -> - fprintf ppf "@[<2>value %s%s :@ %a;@]" (if mut then "mutable " else "") - name Toploop.print_out_type.val ty ] -; - -value rec print_out_module_type ppf = - fun - [ Omty_ident id -> fprintf ppf "%a" print_ident id - | Omty_signature sg -> - fprintf ppf "@[sig@ %a@;<1 -2>end@]" - Toploop.print_out_signature.val sg - | Omty_functor name mty_arg mty_res -> - fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name - print_out_module_type mty_arg print_out_module_type mty_res - | Omty_abstract -> () ] -and print_out_signature ppf = - fun - [ [] -> () - | [item] -> fprintf ppf "%a;" Toploop.print_out_sig_item.val item - | [item :: items] -> - fprintf ppf "%a;@ %a" Toploop.print_out_sig_item.val item - print_out_signature items ] -and print_out_sig_item ppf = - fun - [ Osig_class vir_flag name params clt rs -> - fprintf ppf "@[<2>%s%s@ %a%s@ :@ %a@]" - (if rs = Orec_next then "and" else "class") - (if vir_flag then " virtual" else "") print_out_class_params params - name Toploop.print_out_class_type.val clt - | Osig_class_type vir_flag name params clt rs -> - fprintf ppf "@[<2>%s%s@ %a%s@ =@ %a@]" - (if rs = Orec_next then "and" else "class type") - (if vir_flag then " virtual" else "") print_out_class_params params - name Toploop.print_out_class_type.val clt - | Osig_exception id tyl -> - fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl) - | Osig_modtype name Omty_abstract -> - fprintf ppf "@[<2>module type %s@]" name - | Osig_modtype name mty -> - fprintf ppf "@[<2>module type %s =@ %a@]" name - Toploop.print_out_module_type.val mty - | Osig_module name mty rs -> - fprintf ppf "@[<2>%s %s :@ %a@]" name - (match rs with [ Orec_not -> "module" - | Orec_first -> "module rec" - | Orec_next -> "and" ]) - Toploop.print_out_module_type.val mty - | Osig_type td rs -> - print_out_type_decl - (if rs = Orec_next then "and" else "type") - ppf td - | Osig_value name ty prims -> - let kwd = if prims = [] then "value" else "external" in - let pr_prims ppf = - fun - [ [] -> () - | [s :: sl] -> - do { - fprintf ppf "@ = \"%s\"" s; - List.iter (fun s -> fprintf ppf "@ \"%s\"" s) sl - } ] - in - fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name - Toploop.print_out_type.val ty pr_prims prims ] - -and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) = - let constrain ppf (ty, ty') = - fprintf ppf "@ @[<2>constraint %a =@ %a@]" Toploop.print_out_type.val ty - Toploop.print_out_type.val ty' - in - let print_constraints ppf params = List.iter (constrain ppf) params in - let type_defined ppf = - match args with - [ [] -> fprintf ppf "%s" name - | [arg] -> fprintf ppf "%s %a" name type_parameter arg - | _ -> - fprintf ppf "%s@ %a" name - (print_list type_parameter (fun ppf -> fprintf ppf "@ ")) args ] - and print_kind ppf ty = - fprintf ppf "%s@ %a" - (if priv = Asttypes.Private then " private" else "") - Toploop.print_out_type.val ty - in - let print_types ppf = fun - [ Otyp_manifest ty1 ty2 -> - fprintf ppf "@ @[<2>%a ==%a@]" - Toploop.print_out_type.val ty1 - print_kind ty2 - | ty -> print_kind ppf ty ] - in - fprintf ppf "@[<2>@[@[%s %t@] =%a@]%a@]" kwd type_defined - print_types ty print_constraints constraints -; - -(* Phrases *) - -value print_out_exception ppf exn outv = - match exn with - [ Sys.Break -> fprintf ppf "Interrupted.@." - | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@." - | Stack_overflow -> - fprintf ppf "Stack overflow during evaluation (looping recursion?).@." - | _ -> - fprintf ppf "@[Exception:@ %a.@]@." Toploop.print_out_value.val outv ] -; - -value rec print_items ppf = - fun - [ [] -> () - | [(tree, valopt) :: items] -> - do { - match valopt with - [ Some v -> - fprintf ppf "@[<2>%a =@ %a@]" Toploop.print_out_sig_item.val tree - Toploop.print_out_value.val v - | None -> fprintf ppf "@[%a@]" Toploop.print_out_sig_item.val tree ]; - if items <> [] then fprintf ppf "@ %a" print_items items else () - } ] -; - -value print_out_phrase ppf = - fun - [ Ophr_eval outv ty -> - fprintf ppf "@[- : %a@ =@ %a@]@." Toploop.print_out_type.val ty - Toploop.print_out_value.val outv - | Ophr_signature [] -> () - | Ophr_signature items -> fprintf ppf "@[%a@]@." print_items items - | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv ] -; - -Toploop.print_out_value.val := print_out_value; -Toploop.print_out_type.val := print_out_type; -Toploop.print_out_class_type.val := print_out_class_type; -Toploop.print_out_module_type.val := print_out_module_type; -Toploop.print_out_sig_item.val := print_out_sig_item; -Toploop.print_out_signature.val := print_out_signature; -Toploop.print_out_phrase.val := print_out_phrase; diff --git a/camlp4/unmaintained/Makefile b/camlp4/unmaintained/Makefile deleted file mode 100644 index 9b0bc828..00000000 --- a/camlp4/unmaintained/Makefile +++ /dev/null @@ -1,38 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Camlp4 # -# # -# Copyright 2004 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### -# -# The unmaintained directory -# - -DIRS=format lefteval ocamllex olabl scheme sml - -all: - for dir in $(DIRS); do \ - cd $$dir && $(MAKE) all && cd .. ; \ - done - -opt: - for dir in $(DIRS); do \ - cd $$dir && $(MAKE) opt && cd .. ; \ - done - -depend: - for dir in $(DIRS); do \ - cd $$dir && $(MAKE) depend && cd .. ; \ - done - -clean: - for dir in $(DIRS); do \ - cd $$dir && $(MAKE) clean && cd .. ; \ - done - -install: diff --git a/camlp4/unmaintained/format/.depend b/camlp4/unmaintained/format/.depend deleted file mode 100644 index e69de29b..00000000 diff --git a/camlp4/unmaintained/format/Makefile b/camlp4/unmaintained/format/Makefile deleted file mode 100644 index c3887209..00000000 --- a/camlp4/unmaintained/format/Makefile +++ /dev/null @@ -1,61 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Camlp4 # -# # -# Copyright 2004 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### -# -# Makefile for pa_format -# M.Mauny -# - -include ../../config/Makefile.cnf - -OCAMLTOP=../../.. -CAMLP4=../../camlp4/camlp4$(EXE) - -OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) -OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) - -P4INCLUDES= -nolib -I ../../lib -I ../../meta -I ../../etc -OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../lib -I ../../camlp4 -OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) - -SRC=pa_format.ml -OBJS=$(SRC:.ml=.cmo) -OBJSX=$(SRC:.ml=.cmx) - -all: $(OBJS) - -opt: $(OBJSX) - -depend: - cp .depend .depend.bak - > .depend - for file in $(SRC); do \ - $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \ - sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \ - done - -clean: - rm -f *.cm* *.$(O) *.bak .*.bak - - -.SUFFIXES: .cmx .cmo .cmi .ml .mli - -.mli.cmi: - $(OCAMLC) $(OCAMLCFLAGS) -c $< - - -.ml.cmo: - $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< - -.ml.cmx: - $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< - -include .depend diff --git a/camlp4/unmaintained/format/README b/camlp4/unmaintained/format/README deleted file mode 100644 index 809d42f2..00000000 --- a/camlp4/unmaintained/format/README +++ /dev/null @@ -1,15 +0,0 @@ -This is an application of or an extension for Camlp4. Although it is -currently distributed with OCaml/Camlp4, it may or may not be -actively maintained. - -It probably won't be part of future OCaml/Camlp4 distributions but be -accessible from the Camlp4 hump. If you are interested in developing -this package further and/or actively maintain it, please let us know -(caml@inria.fr) - -This package is distributed under the same license as the Objective -Caml Library (that is, LGPL with a special exception allowing both -static and dynamic link). - --- Michel Mauny - diff --git a/camlp4/unmaintained/format/pa_format.ml b/camlp4/unmaintained/format/pa_format.ml deleted file mode 100644 index d71599f3..00000000 --- a/camlp4/unmaintained/format/pa_format.ml +++ /dev/null @@ -1,52 +0,0 @@ -(* pa_r.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU Library General Public License, with *) -(* the special exception on linking described in file *) -(* ../../../LICENSE. *) -(* *) -(***********************************************************************) -(* $Id: pa_format.ml,v 1.2 2004/07/13 12:25:05 xleroy Exp $ *) - -open Pcaml; - -EXTEND - GLOBAL: expr; - expr: LEVEL "top" - [ [ n = box_type; d = SELF; "begin"; - el = LIST0 [ e = box_expr; ";" -> e ]; "end" -> - let el = [<:expr< Format.$lid:"open_" ^ n$ $d$ >> :: el] in - let el = el @ [<:expr< Format.close_box () >>] in - <:expr< do { $list:el$ } >> - | "hbox"; "begin"; el = LIST0 [ e = box_expr; ";" -> e ]; "end" -> - let el = [<:expr< Format.open_hbox () >> :: el] in - let el = el @ [<:expr< Format.close_box () >>] in - <:expr< do { $list:el$ } >> - | "nobox"; "begin"; el = LIST0 [ e = box_expr; ";" -> e ]; "end" -> - match el with - [ [e] -> e - | _ -> <:expr< do { $list:el$ } >> ] ] ] - ; - box_type: - [ [ n = "hovbox" -> n - | n = "hvbox" -> n - | n = "vbox" -> n - | n = "box" -> n ] ] - ; - box_expr: - [ [ s = STRING -> <:expr< Format.print_string $str:s$ >> - | UIDENT "STRING"; e = expr -> <:expr< Format.print_string $e$ >> - | UIDENT "INT"; e = expr -> <:expr< Format.print_int $e$ >> - | "/-" -> <:expr< Format.print_space () >> - | "//" -> <:expr< Format.print_cut () >> - | "!/" -> <:expr< Format.force_newline () >> - | "?/" -> <:expr< Format.print_if_newline () >> - | e = expr -> e ] ] - ; -END; diff --git a/camlp4/unmaintained/lefteval/.depend b/camlp4/unmaintained/lefteval/.depend deleted file mode 100644 index e69de29b..00000000 diff --git a/camlp4/unmaintained/lefteval/Makefile b/camlp4/unmaintained/lefteval/Makefile deleted file mode 100644 index 7e5cdd02..00000000 --- a/camlp4/unmaintained/lefteval/Makefile +++ /dev/null @@ -1,61 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Camlp4 # -# # -# Copyright 2004 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### -# -# Makefile for pa_lefteval -# M.Mauny -# - -include ../../config/Makefile.cnf - -OCAMLTOP=../../.. -CAMLP4=../../camlp4/camlp4$(EXE) - -OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) -OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) - -P4INCLUDES= -nolib -I ../../meta -I ../../etc -OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../camlp4 -OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) - -SRC=pa_lefteval.ml -OBJS=$(SRC:.ml=.cmo) -OBJSX=$(SRC:.ml=.cmx) - -all: $(OBJS) - -opt: $(OBJSX) - -depend: - cp .depend .depend.bak - > .depend - for file in $(SRC); do \ - $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \ - sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \ - done - -clean: - rm -f *.cm* *.$(O) *.bak .*.bak - - -.SUFFIXES: .cmx .cmo .cmi .ml .mli - -.mli.cmi: - $(OCAMLC) $(OCAMLCFLAGS) -c $< - - -.ml.cmo: - $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< - -.ml.cmx: - $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< - -include .depend diff --git a/camlp4/unmaintained/lefteval/README b/camlp4/unmaintained/lefteval/README deleted file mode 100644 index 809d42f2..00000000 --- a/camlp4/unmaintained/lefteval/README +++ /dev/null @@ -1,15 +0,0 @@ -This is an application of or an extension for Camlp4. Although it is -currently distributed with OCaml/Camlp4, it may or may not be -actively maintained. - -It probably won't be part of future OCaml/Camlp4 distributions but be -accessible from the Camlp4 hump. If you are interested in developing -this package further and/or actively maintain it, please let us know -(caml@inria.fr) - -This package is distributed under the same license as the Objective -Caml Library (that is, LGPL with a special exception allowing both -static and dynamic link). - --- Michel Mauny - diff --git a/camlp4/unmaintained/lefteval/pa_lefteval.ml b/camlp4/unmaintained/lefteval/pa_lefteval.ml deleted file mode 100644 index 7822b537..00000000 --- a/camlp4/unmaintained/lefteval/pa_lefteval.ml +++ /dev/null @@ -1,241 +0,0 @@ -(* pa_r.cmo q_MLast.cmo pr_dump.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU Library General Public License, with *) -(* the special exception on linking described in file *) -(* ../../../LICENSE. *) -(* *) -(***********************************************************************) -(* $Id: pa_lefteval.ml,v 1.2 2004/07/13 12:25:06 xleroy Exp $ *) - -value not_impl name x = - let desc = - if Obj.is_block (Obj.repr x) then - "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) - else "int_val = " ^ string_of_int (Obj.magic x) - in - failwith ("pa_lefteval: not impl: " ^ name ^ "; " ^ desc ^ ">") -; - -value rec expr_fa al = - fun - [ <:expr< $f$ $a$ >> -> expr_fa [a :: al] f - | f -> (f, al) ] -; - -(* generating let..in before functions calls which evaluates - several (more than one) of their arguments *) - -value no_side_effects_ht = - let ht = Hashtbl.create 73 in - do { - List.iter (fun s -> Hashtbl.add ht s True) - ["<"; "="; "@"; "^"; "+"; "-"; "ref"]; - ht - } -; - -value no_side_effects = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $uid:_$ . $uid:_$ >> -> True - | <:expr< $lid:s$ >> -> - try Hashtbl.find no_side_effects_ht s with [ Not_found -> False ] - | _ -> False ] -; - -value rec may_side_effect = - fun - [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $str:_$ >> | - <:expr< $chr:_$ >> | <:expr< $int:_$ >> | <:expr< $flo:_$ >> | - <:expr< $_$ . $_$ >> | <:expr< fun [ $list:_$ ] >> -> - False - | <:expr< ($list:el$) >> -> List.exists may_side_effect el - | <:expr< $_$ $_$ >> as e -> - let (f, el) = expr_fa [] e in - not (no_side_effects f) || List.exists may_side_effect el - | _ -> True ] -; - -value rec may_be_side_effect_victim = - fun - [ <:expr< $lid:_$ . $_$ >> -> True - | <:expr< $uid:_$ . $e$ >> -> may_be_side_effect_victim e - | _ -> False ] -; - -value rec may_depend_on_order el = - loop False False el where rec loop - side_effect_found side_effect_victim_found = - fun - [ [e :: el] -> - if may_side_effect e then - if side_effect_found || side_effect_victim_found then True - else loop True True el - else if may_be_side_effect_victim e then - if side_effect_found then True else loop False True el - else loop side_effect_found side_effect_victim_found el - | [] -> False ] -; - -value gen_let_in loc expr el = - let (pel, el) = - loop 0 (List.rev el) where rec loop n = - fun - [ [e :: el] -> - if may_side_effect e || may_be_side_effect_victim e then - if n = 0 then - let (pel, el) = loop 1 el in - (pel, [expr e :: el]) - else - let id = "xxx" ^ string_of_int n in - let (pel, el) = loop (n + 1) el in - ([(<:patt< $lid:id$ >>, expr e) :: pel], - [<:expr< $lid:id$ >> :: el]) - else - let (pel, el) = loop n el in - (pel, [expr e :: el]) - | [] -> ([], []) ] - in - match List.rev el with - [ [e :: el] -> (pel, e, el) - | _ -> assert False ] -; - -value left_eval_apply loc expr e1 e2 = - let (f, el) = expr_fa [] <:expr< $e1$ $e2$ >> in - if not (may_depend_on_order [f :: el]) then <:expr< $expr e1$ $expr e2$ >> - else - let (pel, e, el) = gen_let_in loc expr [f :: el] in - let e = List.fold_left (fun e e1 -> <:expr< $e$ $e1$ >>) e el in - List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>) e pel -; - -value left_eval_tuple loc expr el = - if not (may_depend_on_order el) then <:expr< ($list:List.map expr el$) >> - else - let (pel, e, el) = gen_let_in loc expr el in - List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>) - <:expr< ($list:[e :: el]$) >> pel -; - -value left_eval_record loc expr lel = - let el = List.map snd lel in - if not (may_depend_on_order el) then - let lel = List.map (fun (p, e) -> (p, expr e)) lel in - <:expr< { $list:lel$ } >> - else - let (pel, e, el) = gen_let_in loc expr el in - let e = - let lel = List.combine (List.map fst lel) [e :: el] in - <:expr< { $list:lel$ } >> - in - List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>) e pel -; - -value left_eval_assign loc expr e1 e2 = <:expr< $e1$ := $expr e2$ >>; - -(* scanning the input tree, calling "left_eval_*" functions if necessary *) - -value map_option f = - fun - [ Some x -> Some (f x) - | None -> None ] -; - -value class_infos f ci = - {MLast.ciLoc = ci.MLast.ciLoc; MLast.ciVir = ci.MLast.ciVir; - MLast.ciPrm = ci.MLast.ciPrm; MLast.ciNam = ci.MLast.ciNam; - MLast.ciExp = f ci.MLast.ciExp} -; - -value rec expr x = - let loc = MLast.loc_of_expr x in - match x with - [ <:expr< fun [ $list:pwel$ ] >> -> - <:expr< fun [ $list:List.map match_assoc pwel$ ] >> - | <:expr< match $e$ with [ $list:pwel$ ] >> -> - <:expr< match $expr e$ with [ $list:List.map match_assoc pwel$ ] >> - | <:expr< try $e$ with [ $list:pwel$ ] >> -> - <:expr< try $expr e$ with [ $list:List.map match_assoc pwel$ ] >> - | <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> - <:expr< let $opt:rf$ $list:List.map let_binding pel$ in $expr e$ >> - | <:expr< let module $s$ = $me$ in $e$ >> -> - <:expr< let module $s$ = $module_expr me$ in $expr e$ >> - | <:expr< if $e1$ then $e2$ else $e3$ >> -> - <:expr< if $expr e1$ then $expr e2$ else $expr e3$ >> - | <:expr< while $e$ do { $list:el$ } >> -> - <:expr< while $expr e$ do { $list:List.map expr el$ } >> - | <:expr< do { $list:el$ } >> -> <:expr< do { $list:List.map expr el$ } >> - | <:expr< $e$ # $s$ >> -> <:expr< $expr e$ # $s$ >> - | <:expr< ($e$ : $t$) >> -> <:expr< ($expr e$ : $t$) >> - | <:expr< $e1$ || $e2$ >> -> <:expr< $expr e1$ || $expr e2$ >> - | <:expr< $e1$ && $e2$ >> -> <:expr< $expr e1$ && $expr e2$ >> - | <:expr< $e1$ $e2$ >> -> left_eval_apply loc expr e1 e2 - | <:expr< ($list:el$) >> -> left_eval_tuple loc expr el - | <:expr< { $list:lel$ } >> -> left_eval_record loc expr lel - | <:expr< $e1$ := $e2$ >> -> left_eval_assign loc expr e1 e2 - | <:expr< $_$ . $_$ >> | <:expr< $uid:_$ >> | <:expr< $lid:_$ >> | - <:expr< $str:_$ >> | <:expr< $chr:_$ >> | <:expr< $int:_$ >> | - <:expr< $flo:_$ >> | <:expr< new $list:_$ >> -> - x - | x -> not_impl "expr" x ] -and let_binding (p, e) = (p, expr e) -and match_assoc (p, eo, e) = (p, map_option expr eo, expr e) -and module_expr x = - let loc = MLast.loc_of_module_expr x in - match x with - [ <:module_expr< functor ($s$ : $mt$) -> $me$ >> -> - <:module_expr< functor ($s$ : $mt$) -> $module_expr me$ >> - | <:module_expr< ($me$ : $mt$) >> -> - <:module_expr< ($module_expr me$ : $mt$) >> - | <:module_expr< struct $list:sil$ end >> -> - <:module_expr< struct $list:List.map str_item sil$ end >> - | <:module_expr< $_$ . $_$ >> | <:module_expr< $_$ $_$ >> | - <:module_expr< $uid:_$ >> -> - x ] -and str_item x = - let loc = MLast.loc_of_str_item x in - match x with - [ <:str_item< module $s$ = $me$ >> -> - <:str_item< module $s$ = $module_expr me$ >> - | <:str_item< value $opt:rf$ $list:pel$ >> -> - <:str_item< value $opt:rf$ $list:List.map let_binding pel$ >> - | <:str_item< declare $list:sil$ end >> -> - <:str_item< declare $list:List.map str_item sil$ end >> - | <:str_item< class $list:ce$ >> -> - <:str_item< class $list:List.map (class_infos class_expr) ce$ >> - | <:str_item< $exp:e$ >> -> <:str_item< $exp:expr e$ >> - | <:str_item< open $_$ >> | <:str_item< type $list:_$ >> | - <:str_item< exception $_$ of $list:_$ = $_$ >> | - <:str_item< module type $_$ = $_$ >> | <:str_item< # $_$ $opt:_$ >> -> - x - | x -> not_impl "str_item" x ] -and class_expr x = - let loc = MLast.loc_of_class_expr x in - match x with - [ <:class_expr< object $opt:p$ $list:csil$ end >> -> - <:class_expr< object $opt:p$ $list:List.map class_str_item csil$ end >> - | x -> not_impl "class_expr" x ] -and class_str_item x = - let loc = MLast.loc_of_class_str_item x in - match x with - [ <:class_str_item< value $opt:mf$ $s$ = $e$ >> -> - <:class_str_item< value $opt:mf$ $s$ = $expr e$ >> - | <:class_str_item< method $s$ = $e$ >> -> - <:class_str_item< method $s$ = $expr e$ >> - | x -> not_impl "class_str_item" x ] -; - -value parse_implem = Pcaml.parse_implem.val; -value parse_implem_with_left_eval strm = - let (r, b) = parse_implem strm in - (List.map (fun (si, loc) -> (str_item si, loc)) r, b) -; -Pcaml.parse_implem.val := parse_implem_with_left_eval; diff --git a/camlp4/unmaintained/ocamllex/Makefile b/camlp4/unmaintained/ocamllex/Makefile deleted file mode 100644 index b232023e..00000000 --- a/camlp4/unmaintained/ocamllex/Makefile +++ /dev/null @@ -1,59 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Camlp4 # -# # -# Copyright 2004 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### -# -# Makefile for pa_ocamllex -# M.Mauny -# - -include ../../config/Makefile.cnf - -OCAMLTOP=../../.. - -CAMLP4=../../camlp4/camlp4$(EXE) - -OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) -OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) - -P4INCLUDES= -nolib -I ../../etc -I ../../meta -OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../camlp4 -I ../../lib -I $(OCAMLTOP)/lex -OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) - -SRC=pa_ocamllex.ml -OBJS=pa_ocamllex.cmo -OBJSX=$(OBJS:.cmo=.cmx) - -all: $(OBJS) pa_ocamllex.cma - -opt: $(OBJSX) pa_ocamllex.cmxa - -pa_ocamllex.cma: pa_ocamllex.cmo - $(OCAMLC) $(OCAMLCFLAGS) cset.cmo syntax.cmo table.cmo lexgen.cmo compact.cmo pa_ocamllex.cmo -a -o pa_ocamllex.cma - -pa_ocamllex.cmxa: pa_ocamllex.cmo - $(OCAMLOPT) $(OCAMLCFLAGS) cset.cmx syntax.cmx table.cmx lexgen.cmx compact.cmx pa_ocamllex.cmx -a -o pa_ocamllex.cmxa - -clean: - rm -f *.cm* *.$(O) *.$(A) *.bak .*.bak - -depend: - -.SUFFIXES: .cmx .cmo .cmi .ml .mli - -.mli.cmi: - $(OCAMLC) $(OCAMLCFLAGS) -c $< - - -.ml.cmo: - $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< - -.ml.cmx: - $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< diff --git a/camlp4/unmaintained/ocamllex/README b/camlp4/unmaintained/ocamllex/README deleted file mode 100644 index 809d42f2..00000000 --- a/camlp4/unmaintained/ocamllex/README +++ /dev/null @@ -1,15 +0,0 @@ -This is an application of or an extension for Camlp4. Although it is -currently distributed with OCaml/Camlp4, it may or may not be -actively maintained. - -It probably won't be part of future OCaml/Camlp4 distributions but be -accessible from the Camlp4 hump. If you are interested in developing -this package further and/or actively maintain it, please let us know -(caml@inria.fr) - -This package is distributed under the same license as the Objective -Caml Library (that is, LGPL with a special exception allowing both -static and dynamic link). - --- Michel Mauny - diff --git a/camlp4/unmaintained/ocamllex/pa_ocamllex.ml b/camlp4/unmaintained/ocamllex/pa_ocamllex.ml deleted file mode 100644 index 172dcff8..00000000 --- a/camlp4/unmaintained/ocamllex/pa_ocamllex.ml +++ /dev/null @@ -1,356 +0,0 @@ -(* pa_o.cmo q_MLast.cmo pa_extend.cmo pr_dump.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Alain Frisch, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU Library General Public License, with *) -(* the special exception on linking described in file *) -(* ../../../LICENSE. *) -(* *) -(***********************************************************************) -(* $Id: pa_ocamllex.ml,v 1.2 2004/07/13 12:25:06 xleroy Exp $ *) - -open Syntax -open Lexgen -open Compact - -(* Adapted from output.ml *) -(**************************) - -(* Output the DFA tables and its entry points *) - -(* To output an array of short ints, encoded as a string *) - -let output_byte buf b = - Buffer.add_char buf '\\'; - Buffer.add_char buf (Char.chr(48 + b / 100)); - Buffer.add_char buf (Char.chr(48 + (b / 10) mod 10)); - Buffer.add_char buf (Char.chr(48 + b mod 10)) - -let loc = (Lexing.dummy_pos,Lexing.dummy_pos) - -let output_array v = - let b = Buffer.create (Array.length v * 3) in - for i = 0 to Array.length v - 1 do - output_byte b (v.(i) land 0xFF); - output_byte b ((v.(i) asr 8) land 0xFF); - if i land 7 = 7 then Buffer.add_string b "\\\n " - done; - let s = Buffer.contents b in - <:expr< $str:s$ >> - -let output_byte_array v = - let b = Buffer.create (Array.length v * 2) in - for i = 0 to Array.length v - 1 do - output_byte b (v.(i) land 0xFF); - if i land 15 = 15 then Buffer.add_string b "\\\n " - done; - let s = Buffer.contents b in - <:expr< $str:s$ >> - - - -(* Output the tables *) - -let output_tables tbl = - <:str_item< value lex_tables = { - Lexing.lex_base = $output_array tbl.tbl_base$; - Lexing.lex_backtrk = $output_array tbl.tbl_backtrk$; - Lexing.lex_default = $output_array tbl.tbl_default$; - Lexing.lex_trans = $output_array tbl.tbl_trans$; - Lexing.lex_check = $output_array tbl.tbl_check$; - Lexing.lex_base_code = $output_array tbl.tbl_base_code$; - Lexing.lex_backtrk_code = $output_array tbl.tbl_backtrk_code$; - Lexing.lex_default_code = $output_array tbl.tbl_default_code$; - Lexing.lex_trans_code = $output_array tbl.tbl_trans_code$; - Lexing.lex_check_code = $output_array tbl.tbl_check_code$; - Lexing.lex_code = $output_byte_array tbl.tbl_code$ - } >> - -(* Output the entries *) - -let rec make_alias n = function - | [] -> [] - | h::t -> - (h, "__ocaml_lex_arg_" ^ (string_of_int n)) :: (make_alias (succ n) t) - -let abstraction = - List.fold_right (fun (p,a) e -> <:expr< fun ($p$ as $lid:a$) -> $e$ >>) - - -let application = - List.fold_left (fun f (_,a) -> <:expr< $f$ $lid:a$ >>) - -let int i = <:expr< $int:string_of_int i$ >> - -let output_memory_actions acts = - let aux = function - | Copy (tgt, src) -> - <:expr< lexbuf.Lexing.lex_mem.($int tgt$) := - lexbuf.Lexing.lex_mem.($int src$) >> - | Set tgt -> - <:expr< lexbuf.Lexing.lex_mem.($int tgt$) := - lexbuf.Lexing.lex_curr_pos >> - in - <:expr< do { $list:List.map aux acts$ } >> - -let output_base_mem = function - | Mem i -> <:expr< lexbuf.Lexing.lex_mem.($int i$) >> - | Start -> <:expr< lexbuf.Lexing.lex_start_pos >> - | End -> <:expr< lexbuf.Lexing.lex_curr_pos >> - -let output_tag_access = function - | Sum (a,0) -> output_base_mem a - | Sum (a,i) -> <:expr< $output_base_mem a$ + $int i$ >> - -let rec output_env e = function - | [] -> e - | (x, Ident_string (o,nstart,nend)) :: rem -> - <:expr< - let $lid:x$ = - Lexing.$lid:if o then "sub_lexeme_opt" else "sub_lexeme"$ - lexbuf $output_tag_access nstart$ $output_tag_access nend$ - in $output_env e rem$ - >> - | (x, Ident_char (o,nstart)) :: rem -> - <:expr< - let $lid:x$ = - Lexing.$lid: if o then "sub_lexeme_char_opt" else "sub_lexeme_char"$ - lexbuf $output_tag_access nstart$ - in $output_env e rem$ - >> - -let output_entry e = - let init_num, init_moves = e.auto_initial_state in - let args = make_alias 0 (e.auto_args @ [ <:patt< lexbuf >> ]) in - let f = "__ocaml_lex_rec_" ^ e.auto_name ^ "_rec" in - let call_f = application <:expr< $lid:f$ >> args in - let body_wrapper = - <:expr< - do { - lexbuf.Lexing.lex_mem := Array.create $int e.auto_mem_size$ (-1) ; - $output_memory_actions init_moves$; - $call_f$ $int init_num$ - } >> in - let cases = - List.map - (fun (num, env, (loc,e)) -> - <:patt< $int:string_of_int num$ >>, - None, - output_env <:expr< $e$ >> env - (* Note: the <:expr<...>> above is there to set the location *) - ) e.auto_actions @ - [ <:patt< __ocaml_lex_n >>, - None, - <:expr< do - { lexbuf.Lexing.refill_buff lexbuf; $call_f$ __ocaml_lex_n }>> ] - in - let engine = - if e.auto_mem_size = 0 - then <:expr< Lexing.engine >> - else <:expr< Lexing.new_engine >> in - let body = - <:expr< fun state -> - match $engine$ lex_tables state lexbuf with [ $list:cases$ ] >> in - [ - <:patt< $lid:e.auto_name$ >>, (abstraction args body_wrapper); - <:patt< $lid:f$ >>, (abstraction args body) - ] - -(* Main output function *) - -exception Table_overflow - -let output_lexdef tables entry_points = - Printf.eprintf - "pa_ocamllex: lexer found; %d states, %d transitions, table size %d bytes\n" - (Array.length tables.tbl_base) - (Array.length tables.tbl_trans) - (2 * (Array.length tables.tbl_base + Array.length tables.tbl_backtrk + - Array.length tables.tbl_default + Array.length tables.tbl_trans + - Array.length tables.tbl_check)); - let size_groups = - (2 * (Array.length tables.tbl_base_code + - Array.length tables.tbl_backtrk_code + - Array.length tables.tbl_default_code + - Array.length tables.tbl_trans_code + - Array.length tables.tbl_check_code) + - Array.length tables.tbl_code) in - if size_groups > 0 then - Printf.eprintf "pa_ocamllex: %d additional bytes used for bindings\n" - size_groups ; - flush stderr; - if Array.length tables.tbl_trans > 0x8000 then raise Table_overflow; - - let entries = List.map output_entry entry_points in - [output_tables tables; <:str_item< value rec $list:List.flatten entries$ >> ] - - -(* Adapted from parser.mly and main.ml *) -(***************************************) - -(* Auxiliaries for the parser. *) - -let char s = Char.code (Token.eval_char s) - -let named_regexps = - (Hashtbl.create 13 : (string, regular_expression) Hashtbl.t) - -let regexp_for_string s = - let rec re_string n = - if n >= String.length s then Epsilon - else if succ n = String.length s then - Characters (Cset.singleton (Char.code s.[n])) - else - Sequence - (Characters(Cset.singleton (Char.code s.[n])), - re_string (succ n)) - in re_string 0 - -let char_class c1 c2 = Cset.interval c1 c2 - -let all_chars = Cset.all_chars - -let rec remove_as = function - | Bind (e,_) -> remove_as e - | Epsilon|Eof|Characters _ as e -> e - | Sequence (e1, e2) -> Sequence (remove_as e1, remove_as e2) - | Alternative (e1, e2) -> Alternative (remove_as e1, remove_as e2) - | Repetition e -> Repetition (remove_as e) - -let () = - Hashtbl.add named_regexps "eof" (Characters Cset.eof) - -(* The parser *) - -let let_regexp = Grammar.Entry.create Pcaml.gram "pa_ocamllex let" -let header = Grammar.Entry.create Pcaml.gram "pa_ocamllex header" -let lexer_def = Grammar.Entry.create Pcaml.gram "pa_ocaml lexerdef" - -EXTEND - GLOBAL: Pcaml.str_item let_regexp header lexer_def; - - let_regexp: [ - [ x = LIDENT; "="; r = regexp -> - if Hashtbl.mem named_regexps x then - Printf.eprintf - "pa_ocamllex (warning): multiple definition of named regexp '%s'\n" - x; - Hashtbl.add named_regexps x r; - ] - ]; - - lexer_def: [ - [ def = LIST0 definition SEP "and" -> - (try - let (entries, transitions) = make_dfa def in - let tables = compact_tables transitions in - let output = output_lexdef tables entries in - <:str_item< declare $list: output$ end >> - with - |Table_overflow -> - failwith "Transition table overflow in lexer, automaton is too big" - | Lexgen.Memory_overflow -> - failwith "Position memory overflow in lexer, too many as variables") - ] - ]; - - - Pcaml.str_item: [ - [ "pa_ocamllex"; LIDENT "rule"; d = lexer_def -> d - | "pa_ocamllex"; "let"; let_regexp -> - <:str_item< declare $list: []$ end >> - ] - ]; - - definition: [ - [ x=LIDENT; pl = LIST0 Pcaml.patt LEVEL "simple"; "="; - short=[ LIDENT "parse" -> false | LIDENT "shortest" -> true ]; - OPT "|"; l = LIST0 [ r=regexp; a=action -> (r,a) ] SEP "|" -> - { name=x ; shortest=short ; args=pl ; clauses = l } ] - ]; - - action: [ - [ "{"; e = OPT Pcaml.expr; "}" -> - let e = match e with - | Some e -> e - | None -> <:expr< () >> - in - (loc,e) - ] - ]; - - header: [ - [ "{"; e = LIST0 [ si = Pcaml.str_item; OPT ";;" -> si ]; "}" -> - [<:str_item< declare $list:e$ end>>, loc] ] - | [ -> [] ] - ]; - - regexp: [ - [ r = regexp; "as"; i = LIDENT -> Bind (r,i) ] - | [ r1 = regexp; "|"; r2 = regexp -> Alternative(r1,r2) ] - | [ r1 = regexp; r2 = regexp -> Sequence(r1,r2) ] - | [ r = regexp; "*" -> Repetition r - | r = regexp; "+" -> Sequence(Repetition (remove_as r), r) - | r = regexp; "?" -> Alternative(Epsilon, r) - | "("; r = regexp; ")" -> r - | "_" -> Characters all_chars - | c = CHAR -> Characters (Cset.singleton (char c)) - | s = STRING -> regexp_for_string (Token.eval_string loc s) - | "["; cc = ch_class; "]" -> Characters cc - | x = LIDENT -> - try Hashtbl.find named_regexps x - with Not_found -> - failwith - ("pa_ocamllex (error): reference to unbound regexp name `"^x^"'") - ] - ]; - - ch_class: [ - [ "^"; cc = ch_class -> Cset.complement cc] - | [ c1 = CHAR; "-"; c2 = CHAR -> Cset.interval (char c1) (char c2) - | c = CHAR -> Cset.singleton (char c) - | cc1 = ch_class; cc2 = ch_class -> Cset.union cc1 cc2 - ] - ]; -END - -(* We have to be careful about "rule"; in standalone mode, - it is used as a keyword (otherwise, there is a conflict - with named regexp); in normal mode, it is used as LIDENT - (we do not want to reserve such an useful identifier). - - Plexer does not like identifiers used as keyword _and_ - as LIDENT ... -*) - -let standalone = - let already = ref false in - fun () -> - if not (!already) then - begin - already := true; - Printf.eprintf "pa_ocamllex: stand-alone mode\n"; - - DELETE_RULE Pcaml.str_item: "pa_ocamllex"; LIDENT "rule";lexer_def END; - DELETE_RULE Pcaml.str_item: "pa_ocamllex"; "let"; let_regexp END; - let ocamllex = Grammar.Entry.create Pcaml.gram "pa_ocamllex" in - EXTEND GLOBAL: ocamllex let_regexp header lexer_def; - ocamllex: [ - [ h = header; - l = [LIST0 ["let"; let_regexp]; "rule"; d = lexer_def -> (d,loc)]; - t = header; EOI -> h @ (l :: t) ,false - ] - ]; - END; - Pcaml.parse_implem := Grammar.Entry.parse ocamllex - end - -let () = - Pcaml.add_option "-ocamllex" (Arg.Unit standalone) - "Activate (standalone) ocamllex emulation mode." - diff --git a/camlp4/unmaintained/olabl/.depend b/camlp4/unmaintained/olabl/.depend deleted file mode 100644 index e69de29b..00000000 diff --git a/camlp4/unmaintained/olabl/Makefile b/camlp4/unmaintained/olabl/Makefile deleted file mode 100644 index f928d458..00000000 --- a/camlp4/unmaintained/olabl/Makefile +++ /dev/null @@ -1,61 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Camlp4 # -# # -# Copyright 2004 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### -# -# Makefile for pa_lefteval -# M.Mauny -# - -include ../../config/Makefile.cnf - -OCAMLTOP=../../.. -CAMLP4=../../camlp4/camlp4$(EXE) - -OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) -OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) - -P4INCLUDES= -nolib -I ../../meta -I ../../lib -I ../../etc -OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../lib -I ../../camlp4 -OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) - -SRC=pa_olabl.ml -OBJS=$(SRC:.ml=.cmo) -OBJSX=$(SRC:.ml=.cmx) - -all: $(OBJS) - -opt: $(OBJSX) - -depend: - cp .depend .depend.bak - > .depend - for file in $(SRC); do \ - $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \ - sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \ - done - -clean: - rm -f *.cm* *.$(O) *.bak .*.bak - - -.SUFFIXES: .cmx .cmo .cmi .ml .mli - -.mli.cmi: - $(OCAMLC) $(OCAMLCFLAGS) -c $< - - -.ml.cmo: - $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< - -.ml.cmx: - $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< - -include .depend diff --git a/camlp4/unmaintained/olabl/README b/camlp4/unmaintained/olabl/README deleted file mode 100644 index 809d42f2..00000000 --- a/camlp4/unmaintained/olabl/README +++ /dev/null @@ -1,15 +0,0 @@ -This is an application of or an extension for Camlp4. Although it is -currently distributed with OCaml/Camlp4, it may or may not be -actively maintained. - -It probably won't be part of future OCaml/Camlp4 distributions but be -accessible from the Camlp4 hump. If you are interested in developing -this package further and/or actively maintain it, please let us know -(caml@inria.fr) - -This package is distributed under the same license as the Objective -Caml Library (that is, LGPL with a special exception allowing both -static and dynamic link). - --- Michel Mauny - diff --git a/camlp4/unmaintained/olabl/pa_olabl.ml b/camlp4/unmaintained/olabl/pa_olabl.ml deleted file mode 100644 index 1dc169e2..00000000 --- a/camlp4/unmaintained/olabl/pa_olabl.ml +++ /dev/null @@ -1,2022 +0,0 @@ -(* pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU Library General Public License, with *) -(* the special exception on linking described in file *) -(* ../../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id: pa_olabl.ml,v 1.2 2004/07/13 12:25:07 xleroy Exp $ *) - -module Plexer = - struct - open Stdpp; - open Token; - value buff = ref (String.create 80); - value store len x = - do { - if len >= String.length buff.val then - buff.val := buff.val ^ String.create (String.length buff.val) - else (); - buff.val.[len] := x; - succ len - } - ; - value mstore len s = - add_rec len 0 where rec add_rec len i = - if i == String.length s then len - else add_rec (store len s.[i]) (succ i) - ; - value get_buff len = String.sub buff.val 0 len; - value rec ident len = - parser - [ [: `('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | - '\248'..'\255' | '0'..'9' | '_' | ''' as - c) - ; - s :] -> - ident (store len c) s - | [: :] -> len ] - and ident2 len = - parser - [ [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' | '.' | ':' | '<' | '>' | '|' as - c) - ; - s :] -> - ident2 (store len c) s - | [: :] -> len ] - and ident3 len = - parser - [ [: `('0'..'9' | 'A'..'Z' | 'a'..'z' | '\192'..'\214' | - '\216'..'\246' | '\248'..'\255' | '_' | '!' | '%' | '&' | '*' | - '+' | '-' | '.' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '^' | - '|' | '~' | ''' | '$' as - c) - ; - s :] -> - ident3 (store len c) s - | [: :] -> len ] - and ident4 len = - parser - [ [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' | '.' | '<' | '>' | '|' as - c) - ; - s :] -> - ident4 (store len c) s - | [: :] -> len ] - and base_number len = - parser - [ [: `'o' | 'O'; s :] -> octal_digits (store len 'o') s - | [: `'x' | 'X'; s :] -> hexa_digits (store len 'x') s - | [: `'b' | 'B'; s :] -> binary_digits (store len 'b') s - | [: a = number len :] -> a ] - and octal_digits len = - parser - [ [: `('0'..'7' as d); s :] -> octal_digits (store len d) s - | [: :] -> ("INT", get_buff len) ] - and hexa_digits len = - parser - [ [: `('0'..'9' | 'a'..'f' | 'A'..'F' as d); s :] -> - hexa_digits (store len d) s - | [: :] -> ("INT", get_buff len) ] - and binary_digits len = - parser - [ [: `('0'..'1' as d); s :] -> binary_digits (store len d) s - | [: :] -> ("INT", get_buff len) ] - and number len = - parser - [ [: `('0'..'9' as c); s :] -> number (store len c) s - | [: `'.'; s :] -> decimal_part (store len '.') s - | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s - | [: :] -> ("INT", get_buff len) ] - and decimal_part len = - parser - [ [: `('0'..'9' as c); s :] -> decimal_part (store len c) s - | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s - | [: :] -> ("FLOAT", get_buff len) ] - and exponent_part len = - parser - [ [: `('+' | '-' as c); s :] -> end_exponent_part (store len c) s - | [: a = end_exponent_part len :] -> a ] - and end_exponent_part len = - parser - [ [: `('0'..'9' as c); s :] -> end_exponent_part (store len c) s - | [: :] -> ("FLOAT", get_buff len) ] - ; - value valch x = Char.code x - Char.code '0'; - value rec backslash s i = - if i = String.length s then raise Not_found - else - match s.[i] with - [ 'n' -> ('\n', i + 1) - | 'r' -> ('\r', i + 1) - | 't' -> ('\t', i + 1) - | 'b' -> ('\b', i + 1) - | '\\' -> ('\\', i + 1) - | '0'..'9' as c -> backslash1 (valch c) s (i + 1) - | _ -> raise Not_found ] - and backslash1 cod s i = - if i = String.length s then (Char.chr cod, i) - else - match s.[i] with - [ '0'..'9' as c -> backslash2 (10 * cod + valch c) s (i + 1) - | _ -> (Char.chr cod, i) ] - and backslash2 cod s i = - if i = String.length s then (Char.chr cod, i) - else - match s.[i] with - [ '0'..'9' as c -> (Char.chr (10 * cod + valch c), i + 1) - | _ -> (Char.chr cod, i) ] - ; - value rec skip_indent s i = - if i = String.length s then i - else - match s.[i] with - [ ' ' | '\t' -> skip_indent s (i + 1) - | _ -> i ] - ; - value skip_opt_linefeed s i = - if i = String.length s then i else if s.[i] = '\010' then i + 1 else i - ; - value char_of_char_token s = - if String.length s = 1 then s.[0] - else if String.length s = 0 then failwith "invalid char token" - else if s.[0] = '\\' then - if String.length s = 2 && s.[1] = ''' then ''' - else - try - let (c, i) = backslash s 1 in - if i = String.length s then c else raise Not_found - with - [ Not_found -> failwith "invalid char token" ] - else failwith "invalid char token" - ; - value string_of_string_token s = - loop 0 0 where rec loop len i = - if i = String.length s then get_buff len - else - let (len, i) = - if s.[i] = '\\' then - let i = i + 1 in - if i = String.length s then failwith "invalid string token" - else if s.[i] = '"' then (store len '"', i + 1) - else - match s.[i] with - [ '\010' -> (len, skip_indent s (i + 1)) - | '\013' -> (len, skip_indent s (skip_opt_linefeed s (i + 1))) - | c -> - try - let (c, i) = backslash s i in - (store len c, i) - with - [ Not_found -> (store (store len '\\') c, i + 1) ] ] - else (store len s.[i], i + 1) - in - loop len i - ; - value rec skip_spaces = - parser - [ [: `' ' | '\n' | '\r' | '\t' | '\026' | '\012'; s :] -> skip_spaces s - | [: :] -> () ] - ; - value error_on_unknown_keywords = ref False; - value next_token_fun find_id_kwd find_spe_kwd fname lnum bolpos = - let make_pos p = - {Lexing.pos_fname = fname.val; Lexing.pos_lnum = lnum.val; - Lexing.pos_bol = bolpos.val; Lexing.pos_cnum = p} in - let mkloc (bp, ep) = (make_pos bp, make_pos ep) in - - let err loc msg = raise_with_loc loc (Token.Error msg) in - let keyword_or_error (bp,ep) s = - try ("", find_spe_kwd s) with - [ Not_found -> - if error_on_unknown_keywords.val then - err (mkloc (bp, ep)) ("illegal token: " ^ s) - else ("", s) ] - in - let rec next_token = - parser bp - [ [: `('A'..'Z' | 'À'..'Ö' | 'Ø'..'Þ' as c); s :] -> - let id = get_buff (ident (store 0 c) s) in - try ("", find_id_kwd id) with [ Not_found -> ("UIDENT", id) ] - | [: `('a'..'z' | 'ß'..'ö' | 'ø'..'ÿ' | '_' as c); s :] -> - let id = get_buff (ident (store 0 c) s) in - let is_label = - match Stream.peek s with - [ Some ':' -> - match Stream.npeek 2 s with - [ [_; ':' | '=' | '>'] -> False - | _ -> True ] - | _ -> False ] - in - if is_label then do { Stream.junk s; ("LABEL", id) } - else try ("", find_id_kwd id) with [ Not_found -> ("LIDENT", id) ] - | [: `('1'..'9' as c); s :] -> number (store 0 c) s - | [: `'0'; s :] -> base_number (store 0 '0') s - | [: `'''; s :] ep -> - match Stream.npeek 2 s with - [ [_; '''] | ['\\'; _] -> ("CHAR", char bp 0 s) - | _ -> keyword_or_error (bp, ep) "'" ] - | [: `'"'; s :] -> ("STRING", string bp 0 s) - | [: `'$'; s :] -> locate_or_antiquot bp 0 s - | [: `('!' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' as - c) - ; - s :] -> - let id = get_buff (ident2 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id - | [: `('?' as c); s :] -> - let id = get_buff (ident4 (store 0 c) s) in - keyword_or_error (bp, Stream.count s) id - | [: `'<'; s :] -> less bp s - | [: `(':' as c1); - (is_label, len) = - parser - [ [: `(']' | ':' | '=' | '>' as c2) :] -> - (False, store (store 0 c1) c2) - | [: `('a'..'z' | 'ß'..'ö' | 'ø'..'ÿ' | '_' as c); s :] -> - (True, ident (store 0 c) s) - | [: :] -> (False, store 0 c1) ] :] ep -> - let id = get_buff len in - if is_label then ("ELABEL", id) else keyword_or_error (bp, ep) id - | [: `('>' | '|' as c1); - len = - parser - [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2 - | [: a = ident2 (store 0 c1) :] -> a ] :] ep -> - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `('[' | '{' as c1); s :] -> - let len = - match Stream.npeek 2 s with - [ ['<'; '<' | ':'] -> store 0 c1 - | _ -> - match s with parser - [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2 - | [: :] -> store 0 c1 ] ] - in - let ep = Stream.count s in - let id = get_buff len in - keyword_or_error (bp, ep) id - | [: `'.'; id = parser [ [: `'.' :] -> ".." | [: :] -> "." ] :] ep -> - keyword_or_error (bp, ep) id - | [: `';'; id = parser [ [: `';' :] -> ";;" | [: :] -> ";" ] :] ep -> - keyword_or_error (bp, ep) id - | [: `'\\'; s :] -> ("LIDENT", get_buff (ident3 0 s)) - | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c) ] - and less bp = - parser - [ [: `'<'; s :] -> ("QUOTATION", ":" ^ get_buff (quotation bp 0 s)) - | [: `':'; i = parser [: len = ident 0 :] -> get_buff len; - `'<' ? "character '<' expected"; s :] -> - ("QUOTATION", i ^ ":" ^ get_buff (quotation bp 0 s)) - | [: s :] ep -> - let id = get_buff (ident2 (store 0 '<') s) in - keyword_or_error (bp, ep) id ] - and string bp len = - parser - [ [: `'"' :] -> get_buff len - | [: `'\\'; `c; s :] -> string bp (store (store len '\\') c) s - | [: `c; s :] -> string bp (store len c) s - | [: :] ep -> err (mkloc (bp, ep)) "string not terminated" ] - and char bp len = - parser - [ [: `'''; s :] -> - if len = 0 then char bp (store len ''') s else get_buff len - | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s - | [: `c; s :] -> char bp (store len c) s - | [: :] ep -> err (mkloc(bp,ep)) "char not terminated" ] - and locate_or_antiquot bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s - | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s - | [: `':'; s :] -> - let k = get_buff len in - ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err (mkloc(bp,ep)) "antiquotation not terminated" ] - and maybe_locate bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s - | [: `':'; s :] -> - ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err (mkloc(bp,ep)) "antiquotation not terminated" ] - and antiquot bp len = - parser - [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) - | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] -> - antiquot bp (store len c) s - | [: `':'; s :] -> - let k = get_buff len in - ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) - | [: `'\\'; `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: `c; s :] -> - ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) - | [: :] ep -> err (mkloc(bp,ep)) "antiquotation not terminated" ] - and locate_or_antiquot_rest bp len = - parser - [ [: `'$' :] -> get_buff len - | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s - | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s - | [: :] ep -> err (mkloc(bp,ep)) "antiquotation not terminated" ] - and quotation bp len = - parser - [ [: `'>'; s :] -> maybe_end_quotation bp len s - | [: `'<'; s :] -> - quotation bp (maybe_nested_quotation bp (store len '<') strm__) s - | [: `'\\'; - len = - parser - [ [: `('>' | '<' | '\\' as c) :] -> store len c - | [: :] -> store len '\\' ]; - s :] -> - quotation bp len s - | [: `c; s :] -> quotation bp (store len c) s - | [: :] ep -> err (mkloc(bp,ep)) "quotation not terminated" ] - and maybe_nested_quotation bp len = - parser - [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" - | [: `':'; len = ident (store len ':'); - a = - parser - [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" - | [: :] -> len ] :] -> - a - | [: :] -> len ] - and maybe_end_quotation bp len = - parser - [ [: `'>' :] -> len - | [: a = quotation bp (store len '>') :] -> a ] - in - let rec next_token_loc = - parser bp - [ [: `' ' | '\n' | '\r' | '\t' | '\026' | '\012'; s :] -> - next_token_loc s - | [: `'('; s :] -> maybe_comment bp s - | [: `'#'; _ = spaces_tabs; a = linenum bp :] -> a - | [: tok = next_token :] ep -> (tok, mkloc(bp, ep)) - | [: _ = Stream.empty :] -> (("EOI", ""), mkloc(bp, succ bp)) ] - and maybe_comment bp = - parser - [ [: `'*'; s :] -> do { comment bp s; next_token_loc s } - | [: :] ep -> - let tok = keyword_or_error (bp, ep) "(" in - (tok, mkloc(bp, ep)) ] - and comment bp = - parser - [ [: `'('; s :] -> maybe_nested_comment bp s - | [: `'*'; s :] -> maybe_end_comment bp s - | [: `c; s :] -> comment bp s - | [: :] ep -> err (mkloc(bp,ep)) "comment not terminated" ] - and maybe_nested_comment bp = - parser - [ [: `'*'; s :] -> do { comment bp s; comment bp s } - | [: a = comment bp :] -> a ] - and maybe_end_comment bp = - parser [ [: `')' :] -> () | [: a = comment bp :] -> a ] - and linenum bp = - parser - [ [: `'0'..'9'; _ = digits; _ = spaces_tabs; `'"'; _ = any_to_nl; - s :] -> - next_token_loc s - | [: :] -> (keyword_or_error (bp, bp + 1) "#", mkloc(bp, bp + 1)) ] - and spaces_tabs = - parser [ [: `' ' | '\t'; s :] -> spaces_tabs s | [: :] -> () ] - and digits = parser [ [: `'0'..'9'; s :] -> digits s | [: :] -> () ] - and any_to_nl = - parser - [ [: `'\r' | '\n' :] -> () - | [: `_; s :] -> any_to_nl s - | [: :] -> () ] - in - fun cstrm -> - try next_token_loc cstrm with - [ Stream.Error str -> - err (mkloc(Stream.count cstrm, Stream.count cstrm + 1)) str ] - ; - value locerr () = invalid_arg "Lexer: location function"; - value loct_create () = ref (Array.create 1024 None); - value loct_func loct i = - match - if i < 0 || i >= Array.length loct.val then None - else Array.unsafe_get loct.val i - with - [ Some loc -> loc - | _ -> locerr () ] - ; - value loct_add loct i loc = - do { - if i >= Array.length loct.val then do { - let new_tmax = Array.length loct.val * 2 in - let new_loct = Array.create new_tmax None in - Array.blit loct.val 0 new_loct 0 (Array.length loct.val); - loct.val := new_loct - } - else (); - loct.val.(i) := Some loc - } - ; - value func kwd_table = - let bolpos = ref 0 in - let lnum = ref 0 in - let fname = ref "" in - let find = Hashtbl.find kwd_table in - let lex cstrm = - let next_token_loc = next_token_fun find find fname lnum bolpos in - let loct = loct_create () in - let ts = - Stream.from - (fun i -> - let (tok, loc) = next_token_loc cstrm in - do { loct_add loct i loc; Some tok }) - in - let locf = loct_func loct in - (ts, locf) - in - lex - ; - value rec check_keyword_stream = - parser [: _ = check; _ = Stream.empty :] -> True - and check = - parser - [ [: `'A'..'Z' | 'a'..'z' | 'À'..'Ö' | 'Ø'..'ö' | 'ø'..'ÿ'; s :] -> - check_ident s - | [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' | '.' - ; - s :] -> - check_ident2 s - | [: `'<'; s :] -> - match Stream.npeek 1 s with - [ [':' | '<'] -> () - | _ -> check_ident2 s ] - | [: `':'; - _ = - parser - [ [: `']' | ':' | '=' | '>' :] -> () - | [: :] -> () ] :] ep -> - () - | [: `'>' | '|'; - _ = - parser - [ [: `']' | '}' :] -> () - | [: a = check_ident2 :] -> a ] :] -> - () - | [: `'[' | '{'; s :] -> - match Stream.npeek 2 s with - [ ['<'; '<' | ':'] -> () - | _ -> - match s with parser - [ [: :] -> - match Stream.peek strm__ with - [ Some ('|' | '<' | ':') -> Stream.junk strm__ - | _ -> () ] ] ] - | [: `';'; _ = parser [ [: `';' :] -> () | [: :] -> () ] :] -> () - | [: `_ :] -> () ] - and check_ident = - parser - [ [: `'A'..'Z' | 'a'..'z' | 'À'..'Ö' | 'Ø'..'ö' | 'ø'..'ÿ' | '0'..'9' | - '_' | ''' - ; - s :] -> - check_ident s - | [: :] -> () ] - and check_ident2 = - parser - [ [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | - '%' | '.' | ':' | '<' | '>' | '|' - ; - s :] -> - check_ident2 s - | [: :] -> () ] - ; - value check_keyword s = - try check_keyword_stream (Stream.of_string s) with _ -> False - ; - value using_token kwd_table (p_con, p_prm) = - match p_con with - [ "" -> - try - let _ = Hashtbl.find kwd_table p_prm in - () - with - [ Not_found -> - if check_keyword p_prm then Hashtbl.add kwd_table p_prm p_prm - else - raise - (Token.Error - ("the token \"" ^ p_prm ^ - "\" does not respect Plexer rules")) ] - | "LIDENT" | "UIDENT" | "INT" | "FLOAT" | "CHAR" | "STRING" | - "QUOTATION" | "ANTIQUOT" | "LOCATE" | "LABEL" | "ELABEL" | "EOI" -> - () - | _ -> - raise - (Token.Error - ("the constructor \"" ^ p_con ^ - "\" is not recognized by Llexer")) ] - ; - value removing_token kwd_table (p_con, p_prm) = - if p_con = "" then Hashtbl.remove kwd_table p_prm else () - ; - value text = - fun - [ ("", t) -> "'" ^ t ^ "'" - | ("LIDENT", "") -> "lowercase identifier" - | ("LIDENT", t) -> "'" ^ t ^ "'" - | ("UIDENT", "") -> "uppercase identifier" - | ("UIDENT", t) -> "'" ^ t ^ "'" - | ("INT", "") -> "integer" - | ("INT", s) -> "'" ^ s ^ "'" - | ("FLOAT", "") -> "float" - | ("STRING", "") -> "string" - | ("CHAR", "") -> "char" - | ("QUOTATION", "") -> "quotation" - | ("ANTIQUOT", k) -> "antiquot \"" ^ k ^ "\"" - | ("LOCATE", "") -> "locate" - | ("LABEL", "") -> "label" - | ("ELABEL", "") -> "elabel" - | ("EOI", "") -> "end of input" - | (con, "") -> con - | (con, prm) -> con ^ " \"" ^ prm ^ "\"" ] - ; - value eq_before_colon p e = - loop 0 where rec loop i = - if i == String.length e then - failwith "Internal error in Plexer: incorrect ANTIQUOT" - else if i == String.length p then e.[i] == ':' - else if p.[i] == e.[i] then loop (i + 1) - else False - ; - value after_colon e = - try - let i = String.index e ':' in - String.sub e (i + 1) (String.length e - i - 1) - with - [ Not_found -> "" ] - ; - value gmake () = - let kwd_table = Hashtbl.create 301 in - {tok_func = func kwd_table; tok_using = using_token kwd_table; - tok_removing = removing_token kwd_table; - tok_match = Token.default_match; tok_text = text; tok_comm = None} - ; - end -; - -open Stdpp; -open Pcaml; - -Pcaml.no_constructors_arity.val := True; - -do { - Grammar.Unsafe.gram_reinit gram (Plexer.gmake ()); - Grammar.Unsafe.clear_entry interf; - Grammar.Unsafe.clear_entry implem; - Grammar.Unsafe.clear_entry top_phrase; - Grammar.Unsafe.clear_entry use_file; - Grammar.Unsafe.clear_entry module_type; - Grammar.Unsafe.clear_entry module_expr; - Grammar.Unsafe.clear_entry sig_item; - Grammar.Unsafe.clear_entry str_item; - Grammar.Unsafe.clear_entry expr; - Grammar.Unsafe.clear_entry patt; - Grammar.Unsafe.clear_entry ctyp; - Grammar.Unsafe.clear_entry let_binding; - Grammar.Unsafe.clear_entry class_type; - Grammar.Unsafe.clear_entry class_expr; - Grammar.Unsafe.clear_entry class_sig_item; - Grammar.Unsafe.clear_entry class_str_item -}; - -Pcaml.parse_interf.val := Grammar.Entry.parse interf; -Pcaml.parse_implem.val := Grammar.Entry.parse implem; - -value o2b = - fun - [ Some _ -> True - | None -> False ] -; - -value mkumin loc f arg = - match arg with - [ <:expr< $int:n$ >> when int_of_string n > 0 -> - let n = "-" ^ n in - <:expr< $int:n$ >> - | <:expr< $flo:n$ >> when float_of_string n > 0.0 -> - let n = "-" ^ n in - <:expr< $flo:n$ >> - | _ -> - let f = "~" ^ f in - <:expr< $lid:f$ $arg$ >> ] -; - -external loc_of_node : 'a -> MLast.loc = "%field0"; - -value mklistexp loc last = - loop True where rec loop top = - fun - [ [] -> - match last with - [ Some e -> e - | None -> <:expr< [] >> ] - | [e1 :: el] -> - let loc = if top then loc else (fst (loc_of_node e1), snd loc) in - <:expr< [$e1$ :: $loop False el$] >> ] -; - -value mklistpat loc last = - loop True where rec loop top = - fun - [ [] -> - match last with - [ Some p -> p - | None -> <:patt< [] >> ] - | [p1 :: pl] -> - let loc = if top then loc else (fst (loc_of_node p1), snd loc) in - <:patt< [$p1$ :: $loop False pl$] >> ] -; - -value neg s = string_of_int (- int_of_string s); - -value is_operator = - let ht = Hashtbl.create 73 in - let ct = Hashtbl.create 73 in - do { - List.iter (fun x -> Hashtbl.add ht x True) - ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"]; - List.iter (fun x -> Hashtbl.add ct x True) - ['!'; '&'; '*'; '+'; '-'; '/'; ':'; '<'; '='; '>'; '@'; '^'; '|'; '~'; - '?'; '%'; '.']; - fun x -> - try Hashtbl.find ht x with - [ Not_found -> try Hashtbl.find ct x.[0] with _ -> False ] - } -; - -(* -value p_operator strm = - match Stream.peek strm with - [ Some (Token.Tterm "(") -> - match Stream.npeek 3 strm with - [ [_; Token.Tterm x; Token.Tterm ")"] when is_operator x -> - do { Stream.junk strm; Stream.junk strm; Stream.junk strm; x } - | _ -> raise Stream.Failure ] - | _ -> raise Stream.Failure ] -; - -value operator = Grammar.Entry.of_parser gram "operator" p_operator; -*) - -value operator = - Grammar.Entry.of_parser gram "operator" - (parser [: `("", x) when is_operator x :] -> x) -; - -value symbolchar = - let list = - ['!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?'; - '@'; '^'; '|'; '~'] - in - let rec loop s i = - if i == String.length s then True - else if List.mem s.[i] list then loop s (i + 1) - else False - in - loop -; - -value prefixop = - let list = ['!'; '?'; '~'] in - let excl = ["!="] in - Grammar.Entry.of_parser gram "prefixop" - (parser - [: `("", x) - when - not (List.mem x excl) && String.length x >= 2 && - List.mem x.[0] list && symbolchar x 1 :] -> - x) -; - -value infixop0 = - let list = ['='; '<'; '>'; '|'; '&'; '$'] in - let excl = ["<-"; "||"; "&&"] in - Grammar.Entry.of_parser gram "infixop0" - (parser - [: `("", x) - when - not (List.mem x excl) && String.length x >= 2 && - List.mem x.[0] list && symbolchar x 1 :] -> - x) -; - -value infixop1 = - let list = ['@'; '^'] in - Grammar.Entry.of_parser gram "infixop1" - (parser - [: `("", x) - when - String.length x >= 2 && List.mem x.[0] list && - symbolchar x 1 :] -> - x) -; - -value infixop2 = - let list = ['+'; '-'] in - Grammar.Entry.of_parser gram "infixop2" - (parser - [: `("", x) - when - x <> "->" && String.length x >= 2 && List.mem x.[0] list && - symbolchar x 1 :] -> - x) -; - -value infixop3 = - let list = ['*'; '/'; '%'] in - Grammar.Entry.of_parser gram "infixop3" - (parser - [: `("", x) - when - String.length x >= 2 && List.mem x.[0] list && - symbolchar x 1 :] -> - x) -; - -value infixop4 = - Grammar.Entry.of_parser gram "infixop4" - (parser - [: `("", x) - when - String.length x >= 3 && x.[0] == '*' && x.[1] == '*' && - symbolchar x 2 :] -> - x) -; - -value test_constr_decl = - Grammar.Entry.of_parser gram "test_constr_decl" - (fun strm -> - match Stream.npeek 1 strm with - [ [("UIDENT", _)] -> - match Stream.npeek 2 strm with - [ [_; ("", ".")] -> raise Stream.Failure - | [_; ("", "(")] -> raise Stream.Failure - | [_ :: _] -> () - | _ -> raise Stream.Failure ] - | [("", "|")] -> () - | _ -> raise Stream.Failure ]) -; - -value stream_peek_nth n strm = - loop n (Stream.npeek n strm) where rec loop n = - fun - [ [] -> None - | [x] -> if n == 1 then Some x else None - | [_ :: l] -> loop (n - 1) l ] -; - -value test_label_eq = - let rec test lev strm = - match stream_peek_nth lev strm with - [ Some (("UIDENT", _) | ("LIDENT", _) | ("", ".")) -> test (lev + 1) strm - | Some ("", "=") -> () - | _ -> raise Stream.Failure ] - in - Grammar.Entry.of_parser gram "test_label_eq" (test 1) -; - -value constr_arity = ref [("Some", 1); ("Match_Failure", 1)]; - -value rec constr_expr_arity = - fun - [ <:expr< $uid:c$ >> -> - try List.assoc c constr_arity.val with [ Not_found -> 0 ] - | <:expr< $uid:_$.$e$ >> -> constr_expr_arity e - | _ -> 1 ] -; - -value rec constr_patt_arity = - fun - [ <:patt< $uid:c$ >> -> - try List.assoc c constr_arity.val with [ Not_found -> 0 ] - | <:patt< $uid:_$.$p$ >> -> constr_patt_arity p - | _ -> 1 ] -; - -value rec get_seq = - fun - [ <:expr< do { $list:el$ } >> -> el - | e -> [e] ] -; - -value choose_tvar tpl = - let rec find_alpha v = - let s = String.make 1 v in - if List.mem_assoc s tpl then - if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1)) - else Some (String.make 1 v) - in - let rec make_n n = - let v = "a" ^ string_of_int n in - if List.mem_assoc v tpl then make_n (succ n) else v - in - match find_alpha 'a' with - [ Some x -> x - | None -> make_n 1 ] -; - -value rec patt_lid = - fun - [ <:patt< $lid:i$ $p$ >> -> Some (i, [p]) - | <:patt< $p1$ $p2$ >> -> - match patt_lid p1 with - [ Some (i, pl) -> Some (i, [p2 :: pl]) - | None -> None ] - | _ -> None ] -; - -value type_parameter = Grammar.Entry.create gram "type_parameter"; -value fun_def = Grammar.Entry.create gram "fun_def"; -value fun_binding = Grammar.Entry.create gram "fun_binding"; - -EXTEND - GLOBAL: interf implem top_phrase use_file sig_item str_item ctyp patt expr - module_type module_expr let_binding type_parameter fun_def fun_binding; - (* Main entry points *) - interf: - [ [ st = LIST0 [ s = sig_item; OPT ";;" -> (s, loc) ]; EOI -> - (st, False) ] ] - ; - implem: - [ [ st = LIST0 [ s = str_item; OPT ";;" -> (s, loc) ]; EOI -> - (st, False) ] ] - ; - top_phrase: - [ [ ph = phrase; ";;" -> Some ph - | EOI -> None ] ] - ; - use_file: - [ [ l = LIST0 [ ph = phrase; OPT ";;" -> ph ]; EOI -> (l, False) ] ] - ; - phrase: - [ [ sti = str_item -> sti - | "#"; n = LIDENT; dp = dir_param -> MLast.StDir loc n dp ] ] - ; - dir_param: - [ [ -> None - | e = expr -> Some e ] ] - ; - (* Module expressions *) - module_expr: - [ [ "functor"; "("; i = UIDENT; ":"; t = module_type; ")"; "->"; - me = SELF -> - <:module_expr< functor ( $i$ : $t$ ) -> $me$ >> - | "struct"; st = LIST0 [ s = str_item; OPT ";;" -> s ]; "end" -> - <:module_expr< struct $list:st$ end >> ] - | [ me1 = SELF; me2 = SELF -> <:module_expr< $me1$ $me2$ >> ] - | [ i = mod_expr_ident -> i - | "("; me = SELF; ":"; mt = module_type; ")" -> - <:module_expr< ( $me$ : $mt$ ) >> - | "("; me = SELF; ")" -> <:module_expr< $me$ >> ] ] - ; - mod_expr_ident: - [ LEFTA - [ m1 = SELF; "."; m2 = SELF -> <:module_expr< $m1$ . $m2$ >> ] - | [ m = UIDENT -> <:module_expr< $uid:m$ >> ] ] - ; - str_item: - [ "top" - [ "exception"; (_, c, tl) = constructor_declaration -> - <:str_item< exception $c$ of $list:tl$ >> - | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING -> - <:str_item< external $i$ : $t$ = $list:pd$ >> - | "external"; i = LABEL; t = ctyp; "="; pd = LIST1 STRING -> - <:str_item< external $i$ : $t$ = $list:pd$ >> - | "external"; "("; i = operator; ")"; ":"; t = ctyp; "="; - pd = LIST1 STRING -> - <:str_item< external $i$ : $t$ = $list:pd$ >> - | "module"; i = UIDENT; mb = module_binding -> - <:str_item< module $i$ = $mb$ >> - | "module"; "type"; i = UIDENT; "="; mt = module_type -> - <:str_item< module type $i$ = $mt$ >> - | "open"; i = mod_ident -> <:str_item< open $i$ >> - | "type"; tdl = LIST1 type_declaration SEP "and" -> - <:str_item< type $list:tdl$ >> - | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; - x = expr -> - let e = <:expr< let $opt:o2b r$ $list:l$ in $x$ >> in - <:str_item< $exp:e$ >> - | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and" -> - match l with - [ [(<:patt< _ >>, e)] -> <:str_item< $exp:e$ >> - | _ -> <:str_item< value $opt:o2b r$ $list:l$ >> ] - | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = expr -> - <:str_item< let module $m$ = $mb$ in $e$ >> - | e = expr -> <:str_item< $exp:e$ >> ] ] - ; - module_binding: - [ RIGHTA - [ "("; m = UIDENT; ":"; mt = module_type; ")"; mb = SELF -> - <:module_expr< functor ( $m$ : $mt$ ) -> $mb$ >> - | ":"; mt = module_type; "="; me = module_expr -> - <:module_expr< ( $me$ : $mt$ ) >> - | "="; me = module_expr -> <:module_expr< $me$ >> ] ] - ; - (* Module types *) - module_type: - [ [ "functor"; "("; i = UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF -> - <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] - | [ mt = SELF; "with"; wcl = LIST1 with_constr SEP "and" -> - <:module_type< $mt$ with $list:wcl$ >> ] - | [ "sig"; sg = LIST0 [ s = sig_item; OPT ";;" -> s ]; "end" -> - <:module_type< sig $list:sg$ end >> - | i = mod_type_ident -> i - | "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ] - ; - mod_type_ident: - [ LEFTA - [ m1 = SELF; "."; m2 = SELF -> <:module_type< $m1$ . $m2$ >> - | m1 = SELF; "("; m2 = SELF; ")" -> <:module_type< $m1$ $m2$ >> ] - | [ m = UIDENT -> <:module_type< $uid:m$ >> - | m = LIDENT -> <:module_type< $lid:m$ >> ] ] - ; - sig_item: - [ "top" - [ "exception"; (_, c, tl) = constructor_declaration -> - <:sig_item< exception $c$ of $list:tl$ >> - | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING -> - <:sig_item< external $i$ : $t$ = $list:pd$ >> - | "external"; i = LABEL; t = ctyp; "="; pd = LIST1 STRING -> - <:sig_item< external $i$ : $t$ = $list:pd$ >> - | "external"; "("; i = operator; ")"; ":"; t = ctyp; "="; - pd = LIST1 STRING -> - <:sig_item< external $i$ : $t$ = $list:pd$ >> - | "include"; mt = module_type -> <:sig_item< include $mt$ >> - | "module"; i = UIDENT; mt = module_declaration -> - <:sig_item< module $i$ : $mt$ >> - | "module"; "type"; i = UIDENT; "="; mt = module_type -> - <:sig_item< module type $i$ = $mt$ >> - | "open"; i = mod_ident -> <:sig_item< open $i$ >> - | "type"; tdl = LIST1 type_declaration SEP "and" -> - <:sig_item< type $list:tdl$ >> - | "val"; i = LIDENT; ":"; t = ctyp -> <:sig_item< value $i$ : $t$ >> - | "val"; i = LABEL; t = ctyp -> <:sig_item< value $i$ : $t$ >> - | "val"; "("; i = operator; ")"; ":"; t = ctyp -> - <:sig_item< value $i$ : $t$ >> ] ] - ; - module_declaration: - [ RIGHTA - [ ":"; mt = module_type -> <:module_type< $mt$ >> - | "("; i = UIDENT; ":"; t = module_type; ")"; mt = SELF -> - <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] ] - ; - (* "with" constraints (additional type equations over signature - components) *) - with_constr: - [ [ "type"; tp = type_parameters; i = mod_ident; "="; t = ctyp -> - MLast.WcTyp loc i tp t - | "module"; i = mod_ident; "="; me = module_expr -> - MLast.WcMod loc i me ] ] - ; - (* Core expressions *) - expr: - [ "top" LEFTA - [ e1 = SELF; ";"; e2 = SELF -> - <:expr< do { $list:[e1 :: get_seq e2]$ } >> - | e1 = SELF; ";" -> e1 ] - | "expr1" - [ "let"; o = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; - x = expr LEVEL "top" -> - <:expr< let $opt:o2b o$ $list:l$ in $x$ >> - | "let"; "module"; m = UIDENT; mb = module_binding; "in"; - e = expr LEVEL "top" -> - <:expr< let module $m$ = $mb$ in $e$ >> - | "function"; OPT "|"; l = LIST1 match_case SEP "|" -> - <:expr< fun [ $list:l$ ] >> - | "fun"; p = patt LEVEL "simple"; e = fun_def -> - <:expr< fun [$p$ -> $e$] >> - | "match"; x = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" -> - <:expr< match $x$ with [ $list:l$ ] >> - | "try"; x = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" -> - <:expr< try $x$ with [ $list:l$ ] >> - | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1"; - e3 = [ "else"; e = expr LEVEL "expr1" -> e | -> <:expr< () >> ] -> - <:expr< if $e1$ then $e2$ else $e3$ >> - | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF; - "do"; e = SELF; "done" -> - <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:get_seq e$ } >> - | "while"; e1 = SELF; "do"; e2 = SELF; "done" -> - <:expr< while $e1$ do { $list:get_seq e2$ } >> ] - | [ e = SELF; ","; el = LIST1 NEXT SEP "," -> - <:expr< ( $list:[e :: el]$ ) >> ] - | ":=" NONA - [ e1 = SELF; ":="; e2 = expr LEVEL "expr1" -> - <:expr< $e1$.val := $e2$ >> - | e1 = SELF; "<-"; e2 = expr LEVEL "expr1" -> <:expr< $e1$ := $e2$ >> ] - | "||" RIGHTA - [ e1 = SELF; f = [ op = "or" -> op | op = "||" -> op ]; e2 = SELF -> - <:expr< $lid:f$ $e1$ $e2$ >> ] - | "&&" RIGHTA - [ e1 = SELF; f = [ op = "&" -> op | op = "&&" -> op ]; e2 = SELF -> - <:expr< $lid:f$ $e1$ $e2$ >> ] - | "<" LEFTA - [ e1 = SELF; - f = - [ op = "<" -> op - | op = ">" -> op - | op = "<=" -> op - | op = ">=" -> op - | op = "=" -> op - | op = "<>" -> op - | op = "==" -> op - | op = "!=" -> op - | op = infixop0 -> op ]; - e2 = SELF -> - <:expr< $lid:f$ $e1$ $e2$ >> ] - | "^" RIGHTA - [ e1 = SELF; - f = [ op = "^" -> op | op = "@" -> op | op = infixop1 -> op ]; - e2 = SELF -> - <:expr< $lid:f$ $e1$ $e2$ >> ] - | RIGHTA - [ e1 = SELF; "::"; e2 = SELF -> <:expr< [$e1$ :: $e2$] >> ] - | "+" LEFTA - [ e1 = SELF; - f = - [ op = "+" -> op - | op = "-" -> op - | op = "+." -> op - | op = "-." -> op - | op = infixop2 -> op ]; - e2 = SELF -> - <:expr< $lid:f$ $e1$ $e2$ >> ] - | "*" LEFTA - [ e1 = SELF; - f = - [ op = "*" -> op - | op = "/" -> op - | op = "*." -> op - | op = "/." -> op - | op = "land" -> op - | op = "lor" -> op - | op = "lxor" -> op - | op = "mod" -> op - | op = infixop3 -> op ]; - e2 = SELF -> - <:expr< $lid:f$ $e1$ $e2$ >> ] - | "**" RIGHTA - [ e1 = SELF; - f = - [ op = "**" -> op - | op = "asr" -> op - | op = "lsl" -> op - | op = "lsr" -> op - | op = infixop4 -> op ]; - e2 = SELF -> - <:expr< $lid:f$ $e1$ $e2$ >> ] - | "unary minus" NONA - [ f = [ op = "-" -> op | op = "-." -> op ]; e = SELF -> - <:expr< $mkumin loc f e$ >> ] - | "apply" LEFTA - [ e1 = SELF; e2 = SELF -> - match constr_expr_arity e1 with - [ 1 -> <:expr< $e1$ $e2$ >> - | _ -> - match e2 with - [ <:expr< ( $list:el$ ) >> -> - List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) e1 el - | _ -> <:expr< $e1$ $e2$ >> ] ] - | "assert"; e = expr LEVEL "simple" -> - match e with - [ <:expr< False >> -> MLast.ExAsf loc - | _ -> MLast.ExAsr loc e ] - | "lazy"; e = SELF -> - <:expr< lazy ($e$) >> ] - | "simple" LEFTA - [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >> - | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >> - | e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> - | "!"; e = SELF -> <:expr< $e$ . val>> - | f = - [ op = "~-" -> op - | op = "~-." -> op - | op = "~" -> op - | op = prefixop -> op ]; - e = SELF -> - <:expr< $lid:f$ $e$ >> - | s = INT -> <:expr< $int:s$ >> - | s = FLOAT -> <:expr< $flo:s$ >> - | s = STRING -> <:expr< $str:s$ >> - | c = CHAR -> <:expr< $chr:c$ >> - | i = expr_ident -> i - | s = "false" -> <:expr< False >> - | s = "true" -> <:expr< True >> - | "["; "]" -> <:expr< [] >> - | "["; el = expr1_semi_list; "]" -> <:expr< $mklistexp loc None el$ >> - | "[|"; "|]" -> <:expr< [| |] >> - | "[|"; el = expr1_semi_list; "|]" -> <:expr< [| $list:el$ |] >> - | "{"; test_label_eq; lel = lbl_expr_list; "}" -> - <:expr< { $list:lel$ } >> - | "{"; e = expr LEVEL "simple"; "with"; lel = lbl_expr_list; "}" -> - <:expr< { ($e$) with $list:lel$ } >> - | "("; ")" -> <:expr< () >> - | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >> - | "("; e = SELF; ")" -> <:expr< $e$ >> - | "("; "-"; ")" -> <:expr< $lid:"-"$ >> - | "("; "-."; ")" -> <:expr< $lid:"-."$ >> - | "("; op = operator; ")" -> <:expr< $lid:op$ >> - | "begin"; e = SELF; "end" -> <:expr< $e$ >> - | x = LOCATE -> - let x = - try - let i = String.index x ':' in - ({Lexing.pos_fname = ""; - Lexing.pos_lnum = 0; - Lexing.pos_bol = 0; - Lexing.pos_cnum = int_of_string (String.sub x 0 i)}, - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found | Failure _ -> (Token.nowhere, x) ] - in - Pcaml.handle_expr_locate loc x - | x = QUOTATION -> - let x = - try - let i = String.index x ':' in - (String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found -> ("", x) ] - in - Pcaml.handle_expr_quotation loc x ] ] - ; - let_binding: - [ [ p = patt; e = fun_binding -> - match patt_lid p with - [ Some (i, pl) -> - let e = - List.fold_left (fun e p -> <:expr< fun $p$ -> $e$ >>) e pl - in - (<:patt< $lid:i$ >>, e) - | None -> (p, e) ] ] ] - ; - fun_binding: - [ RIGHTA - [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >> - | "="; e = expr -> <:expr< $e$ >> - | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> ] ] - ; - match_case: - [ [ x1 = patt; w = OPT [ "when"; e = expr -> e ]; "->"; x2 = expr -> - (x1, w, x2) ] ] - ; - lbl_expr_list: - [ [ le = lbl_expr; ";"; lel = SELF -> [le :: lel] - | le = lbl_expr; ";" -> [le] - | le = lbl_expr -> [le] ] ] - ; - lbl_expr: - [ [ i = patt_label_ident; "="; e = expr LEVEL "expr1" -> (i, e) ] ] - ; - expr1_semi_list: - [ [ e = expr LEVEL "expr1"; ";"; el = SELF -> [e :: el] - | e = expr LEVEL "expr1"; ";" -> [e] - | e = expr LEVEL "expr1" -> [e] ] ] - ; - fun_def: - [ RIGHTA - [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >> - | "->"; e = expr -> <:expr< $e$ >> ] ] - ; - expr_ident: - [ RIGHTA - [ i = LIDENT -> <:expr< $lid:i$ >> - | i = UIDENT -> <:expr< $uid:i$ >> - | m = UIDENT; "."; i = SELF -> - let rec loop m = - fun - [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y - | e -> <:expr< $m$ . $e$ >> ] - in - loop <:expr< $uid:m$ >> i - | m = UIDENT; "."; "("; i = operator; ")" -> - <:expr< $uid:m$ . $lid:i$ >> ] ] - ; - (* Patterns *) - patt: - [ LEFTA - [ p1 = SELF; "as"; i = LIDENT -> <:patt< ($p1$ as $lid:i$) >> ] - | LEFTA - [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ] - | [ p = SELF; ","; pl = LIST1 NEXT SEP "," -> - <:patt< ( $list:[p :: pl]$) >> ] - | NONA - [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ] - | RIGHTA - [ p1 = SELF; "::"; p2 = SELF -> <:patt< [$p1$ :: $p2$] >> ] - | LEFTA - [ p1 = SELF; p2 = SELF -> - match constr_patt_arity p1 with - [ 1 -> <:patt< $p1$ $p2$ >> - | n -> - let p2 = - match p2 with - [ <:patt< _ >> when n > 1 -> - let pl = - loop n where rec loop n = - if n = 0 then [] else [<:patt< _ >> :: loop (n - 1)] - in - <:patt< ( $list:pl$ ) >> - | _ -> p2 ] - in - match p2 with - [ <:patt< ( $list:pl$ ) >> -> - List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>) p1 pl - | _ -> <:patt< $p1$ $p2$ >> ] ] ] - | LEFTA - [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ] - | "simple" - [ s = LIDENT -> <:patt< $lid:s$ >> - | s = UIDENT -> <:patt< $uid:s$ >> - | s = INT -> <:patt< $int:s$ >> - | "-"; s = INT -> <:patt< $int:neg s$ >> - | s = STRING -> <:patt< $str:s$ >> - | s = CHAR -> <:patt< $chr:s$ >> - | s = "false" -> <:patt< False >> - | s = "true" -> <:patt< True >> - | "["; "]" -> <:patt< [] >> - | "["; pl = patt_semi_list; "]" -> <:patt< $mklistpat loc None pl$ >> - | "[|"; "|]" -> <:patt< [| |] >> - | "[|"; pl = patt_semi_list; "|]" -> <:patt< [| $list:pl$ |] >> - | "{"; lpl = lbl_patt_list; "}" -> <:patt< { $list:lpl$ } >> - | "("; ")" -> <:patt< () >> - | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> - | "("; p = SELF; ")" -> <:patt< $p$ >> - | "("; "-"; ")" -> <:patt< $lid:"-"$ >> - | "("; op = operator; ")" -> <:patt< $lid:op$ >> - | "_" -> <:patt< _ >> - | x = LOCATE -> - let x = - try - let i = String.index x ':' in - ({Lexing.pos_fname = ""; - Lexing.pos_lnum = 0; - Lexing.pos_bol = 0; - Lexing.pos_cnum = int_of_string (String.sub x 0 i)}, - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found | Failure _ -> (Token.nowhere, x) ] - in - Pcaml.handle_patt_locate loc x - | x = QUOTATION -> - let x = - try - let i = String.index x ':' in - (String.sub x 0 i, - String.sub x (i + 1) (String.length x - i - 1)) - with - [ Not_found -> ("", x) ] - in - Pcaml.handle_patt_quotation loc x ] ] - ; - patt_semi_list: - [ [ p = patt; ";"; pl = SELF -> [p :: pl] - | p = patt; ";" -> [p] - | p = patt -> [p] ] ] - ; - lbl_patt_list: - [ [ le = lbl_patt; ";"; lel = SELF -> [le :: lel] - | le = lbl_patt; ";" -> [le] - | le = lbl_patt -> [le] ] ] - ; - lbl_patt: - [ [ i = patt_label_ident; "="; p = patt -> (i, p) ] ] - ; - patt_label_ident: - [ RIGHTA - [ i = UIDENT -> <:patt< $uid:i$ >> - | i = LIDENT -> <:patt< $lid:i$ >> - | m = UIDENT; "."; i = SELF -> <:patt< $uid:m$ . $i$ >> ] ] - ; - (* Type declaration *) - type_declaration: - [ [ tpl = type_parameters; n = type_patt; "="; tk = type_kind; - cl = LIST0 constrain -> - (n, tpl, tk, cl) - | tpl = type_parameters; n = type_patt; cl = LIST0 constrain -> - (n, tpl, <:ctyp< '$choose_tvar tpl$ >>, cl) ] ] - ; - type_patt: - [ [ n = LIDENT -> (loc, n) ] ] - ; - constrain: - [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ] - ; - type_kind: - [ [ test_constr_decl; OPT "|"; - cdl = LIST1 constructor_declaration SEP "|" -> - <:ctyp< [ $list:cdl$ ] >> - | t = ctyp -> <:ctyp< $t$ >> - | t = ctyp; "="; "{"; ldl = label_declarations; "}" -> - <:ctyp< $t$ == { $list:ldl$ } >> - | t = ctyp; "="; OPT "|"; cdl = LIST1 constructor_declaration SEP "|" -> - <:ctyp< $t$ == [ $list:cdl$ ] >> - | "{"; ldl = label_declarations; "}" -> <:ctyp< { $list:ldl$ } >> ] ] - ; - type_parameters: - [ [ -> (* empty *) [] - | tp = type_parameter -> [tp] - | "("; tpl = LIST1 type_parameter SEP ","; ")" -> tpl ] ] - ; - type_parameter: - [ [ "'"; i = ident -> (i, (False, False)) ] ] - ; - constructor_declaration: - [ [ ci = UIDENT; "of"; cal = LIST1 ctyp LEVEL "ctyp1" SEP "*" -> - (loc, ci, cal) - | ci = UIDENT -> (loc, ci, []) ] ] - ; - label_declarations: - [ [ ld = label_declaration; ";"; ldl = SELF -> [ld :: ldl] - | ld = label_declaration; ";" -> [ld] - | ld = label_declaration -> [ld] ] ] - ; - label_declaration: - [ [ i = LIDENT; ":"; t = ctyp -> (loc, i, False, t) - | i = LABEL; t = ctyp -> (loc, i, False, t) - | "mutable"; i = LIDENT; ":"; t = ctyp -> (loc, i, True, t) - | "mutable"; i = LABEL; t = ctyp -> (loc, i, True, t) ] ] - ; - (* Core types *) - ctyp: - [ [ t1 = SELF; "as"; "'"; i = ident -> <:ctyp< $t1$ as '$i$ >> ] - | "arrow" RIGHTA - [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ] - | [ t = SELF; "*"; tl = LIST1 ctyp LEVEL "ctyp1" SEP "*" -> - <:ctyp< ( $list:[t :: tl]$ ) >> ] - | "ctyp1" - [ t1 = SELF; t2 = SELF -> <:ctyp< $t2$ $t1$ >> ] - | "ctyp2" - [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >> - | t1 = SELF; "("; t2 = SELF; ")" -> <:ctyp< $t1$ $t2$ >> ] - | "simple" - [ "'"; i = ident -> <:ctyp< '$i$ >> - | "_" -> <:ctyp< _ >> - | i = LIDENT -> <:ctyp< $lid:i$ >> - | i = UIDENT -> <:ctyp< $uid:i$ >> - | "("; t = SELF; ","; tl = LIST1 ctyp SEP ","; ")"; - i = ctyp LEVEL "ctyp2" -> - List.fold_left (fun c a -> <:ctyp< $c$ $a$ >>) i [t :: tl] - | "("; t = SELF; ")" -> <:ctyp< $t$ >> ] ] - ; - (* Identifiers *) - ident: - [ [ i = LIDENT -> i - | i = UIDENT -> i ] ] - ; - mod_ident: - [ RIGHTA - [ i = UIDENT -> [i] - | i = LIDENT -> [i] - | m = UIDENT; "."; i = SELF -> [m :: i] ] ] - ; - (* Miscellaneous *) - direction_flag: - [ [ "to" -> True - | "downto" -> False ] ] - ; -END; - -(* Objects and Classes *) - -value rec class_type_of_ctyp loc t = - match t with - [ <:ctyp< $lid:i$ >> -> <:class_type< $list:[i]$ >> - | <:ctyp< $uid:m$.$t$ >> -> <:class_type< $list:[m :: type_id_list t]$ >> - | _ -> raise_with_loc loc (Stream.Error "lowercase identifier expected") ] -and type_id_list = - fun - [ <:ctyp< $uid:m$.$t$ >> -> [m :: type_id_list t] - | <:ctyp< $lid:i$ >> -> [i] - | t -> - raise_with_loc (loc_of_node t) - (Stream.Error "lowercase identifier expected") ] -; - -value class_fun_binding = Grammar.Entry.create gram "class_fun_binding"; - -EXTEND - GLOBAL: str_item sig_item expr ctyp class_sig_item class_str_item class_type - class_expr class_fun_binding; - str_item: - [ [ "class"; cd = LIST1 class_declaration SEP "and" -> - <:str_item< class $list:cd$ >> - | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" -> - <:str_item< class type $list:ctd$ >> ] ] - ; - sig_item: - [ [ "class"; cd = LIST1 class_description SEP "and" -> - <:sig_item< class $list:cd$ >> - | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" -> - <:sig_item< class type $list:ctd$ >> ] ] - ; - (* Class expressions *) - class_declaration: - [ [ vf = OPT "virtual"; ctp = class_type_parameters; i = LIDENT; - cfb = class_fun_binding -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = i; MLast.ciExp = cfb} ] ] - ; - class_fun_binding: - [ [ "="; ce = class_expr -> ce - | ":"; ct = class_type; "="; ce = class_expr -> - <:class_expr< ($ce$ : $ct$) >> - | p = patt LEVEL "simple"; cfb = SELF -> - <:class_expr< fun $p$ -> $cfb$ >> ] ] - ; - class_type_parameters: - [ [ -> (loc, []) - | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (loc, tpl) ] ] - ; - class_fun_def: - [ [ p = patt LEVEL "simple"; "->"; ce = class_expr -> - <:class_expr< fun $p$ -> $ce$ >> - | p = patt LEVEL "simple"; cfd = SELF -> - <:class_expr< fun $p$ -> $cfd$ >> ] ] - ; - class_expr: - [ "top" - [ "fun"; cfd = class_fun_def -> cfd - | "let"; rf = OPT "rec"; lb = LIST1 let_binding SEP "and"; "in"; - ce = SELF -> - <:class_expr< let $opt:o2b rf$ $list:lb$ in $ce$ >> ] - | "apply" NONA - [ ce = SELF; e = expr LEVEL "label" -> - <:class_expr< $ce$ $e$ >> ] - | "simple" - [ "["; ct = ctyp; ","; ctcl = LIST1 ctyp SEP ","; "]"; - ci = class_longident -> - <:class_expr< $list:ci$ [ $list:[ct :: ctcl]$ ] >> - | "["; ct = ctyp; "]"; ci = class_longident -> - <:class_expr< $list:ci$ [ $ct$ ] >> - | ci = class_longident -> <:class_expr< $list:ci$ >> - | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" -> - <:class_expr< object $opt:cspo$ $list:cf$ end >> - | "("; ce = SELF; ":"; ct = class_type; ")" -> - <:class_expr< ($ce$ : $ct$) >> - | "("; ce = SELF; ")" -> ce ] ] - ; - class_structure: - [ [ cf = LIST0 class_str_item -> cf ] ] - ; - class_self_patt: - [ [ "("; p = patt; ")" -> p - | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ] ] - ; - class_str_item: - [ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] -> - <:class_str_item< inherit $ce$ $opt:pb$ >> - | "val"; (lab, mf, e) = cvalue -> - <:class_str_item< value $opt:mf$ $lab$ = $e$ >> - | "method"; "private"; "virtual"; l = label; ":"; t = ctyp -> - <:class_str_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; "private"; l = label; ":"; t = ctyp -> - <:class_str_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; l = label; ":"; t = ctyp -> - <:class_str_item< method virtual $l$ : $t$ >> - | "method"; "private"; l = label; fb = fun_binding -> - <:class_str_item< method private $l$ = $fb$ >> - | "method"; l = label; fb = fun_binding -> - <:class_str_item< method $l$ = $fb$ >> - | "constraint"; t1 = ctyp; "="; t2 = ctyp -> - <:class_str_item< type $t1$ = $t2$ >> - | "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ] - ; - cvalue: - [ [ mf = OPT "mutable"; l = label; "="; e = expr -> (l, o2b mf, e) - | mf = OPT "mutable"; l = label; ":"; t = ctyp; "="; e = expr -> - (l, o2b mf, <:expr< ($e$ : $t$) >>) - | mf = OPT "mutable"; l = label; ":"; t1 = ctyp; ":>"; t2 = ctyp; "="; - e = expr -> - (l, o2b mf, <:expr< ($e$ : $t1$ :> $t2$) >>) - | mf = OPT "mutable"; l = label; ":>"; t = ctyp; "="; e = expr -> - (l, o2b mf, <:expr< ($e$ :> $t$) >>) ] ] - ; - label: - [ [ i = LIDENT -> i ] ] - ; - (* Class types *) - class_type: - [ [ t = ctyp LEVEL "ctyp1" -> class_type_of_ctyp loc t - | t = ctyp LEVEL "ctyp1"; "->"; ct = SELF -> - <:class_type< [ $t$ ] -> $ct$ >> - | t = ctyp LEVEL "ctyp1"; "*"; tl = LIST1 ctyp LEVEL "simple" SEP "*"; - "->"; ct = SELF -> - <:class_type< [ ($t$ * $list:tl$) ] -> $ct$ >> - | cs = class_signature -> cs ] ] - ; - class_signature: - [ [ "["; tl = LIST1 ctyp SEP ","; "]"; id = clty_longident -> - <:class_type< $list:id$ [ $list:tl$ ] >> - | id = clty_longident -> <:class_type< $list:id$ >> - | "object"; cst = OPT class_self_type; csf = LIST0 class_sig_item; - "end" -> - <:class_type< object $opt:cst$ $list:csf$ end >> ] ] - ; - class_self_type: - [ [ "("; t = ctyp; ")" -> t ] ] - ; - class_sig_item: - [ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >> - | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp -> - <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >> - | "method"; "private"; "virtual"; l = label; ":"; t = ctyp -> - <:class_sig_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; "private"; l = label; ":"; t = ctyp -> - <:class_sig_item< method virtual private $l$ : $t$ >> - | "method"; "virtual"; l = label; ":"; t = ctyp -> - <:class_sig_item< method virtual $l$ : $t$ >> - | "method"; "private"; l = label; ":"; t = ctyp -> - <:class_sig_item< method private $l$ : $t$ >> - | "method"; l = label; ":"; t = ctyp -> - <:class_sig_item< method $l$ : $t$ >> - | "constraint"; t1 = ctyp; "="; t2 = ctyp -> - <:class_sig_item< type $t1$ = $t2$ >> ] ] - ; - class_description: - [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; ":"; - ct = class_type -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = ct} - | vf = OPT "virtual"; ctp = class_type_parameters; n = LABEL; - ct = class_type -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = ct} ] ] - ; - class_type_declaration: - [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; "="; - cs = class_signature -> - {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; - MLast.ciNam = n; MLast.ciExp = cs} ] ] - ; - (* Expressions *) - expr: LEVEL "apply" - [ LEFTA - [ "new"; i = class_longident -> <:expr< new $list:i$ >> ] ] - ; - expr: LEVEL "simple" - [ [ e = SELF; "#"; lab = label -> <:expr< $e$ # $lab$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "("; e = SELF; ":"; t1 = ctyp; ":>"; t2 = ctyp; ")" -> - <:expr< ($e$ : $t1$ :> $t2$) >> - | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >> - | "{<"; ">}" -> <:expr< {< >} >> - | "{<"; fel = field_expr_list; ">}" -> <:expr< {< $list:fel$ >} >> ] ] - ; - field_expr_list: - [ [ l = label; "="; e = expr LEVEL "expr1"; ";"; fel = SELF -> - [(l, e) :: fel] - | l = label; "="; e = expr LEVEL "expr1"; ";" -> [(l, e)] - | l = label; "="; e = expr LEVEL "expr1" -> [(l, e)] ] ] - ; - (* Core types *) - ctyp: LEVEL "simple" - [ [ "#"; id = class_longident -> <:ctyp< # $list:id$ >> - | "<"; (ml, v) = meth_list; ">" -> <:ctyp< < $list:ml$ $opt:v$ > >> - | "<"; ">" -> <:ctyp< < > >> ] ] - ; - meth_list: - [ [ f = field; ";"; (ml, v) = SELF -> ([f :: ml], v) - | f = field; ";" -> ([f], False) - | f = field -> ([f], False) - | ".." -> ([], True) ] ] - ; - field: - [ [ lab = LIDENT; ":"; t = ctyp -> (lab, t) - | lab = LABEL; t = ctyp -> (lab, t) ] ] - ; - (* Identifiers *) - clty_longident: - [ [ m = UIDENT; "."; l = SELF -> [m :: l] - | i = LIDENT -> [i] ] ] - ; - class_longident: - [ [ m = UIDENT; "."; l = SELF -> [m :: l] - | i = LIDENT -> [i] ] ] - ; -END; - -(* Labels *) - -EXTEND - GLOBAL: ctyp expr patt fun_def fun_binding class_type class_fun_binding; - ctyp: AFTER "arrow" - [ NONA - [ i = LABEL; t = SELF -> <:ctyp< ~ $i$ : $t$ >> - | "?"; i = LABEL; t = SELF -> <:ctyp< ? $i$ : $t$ >> ] ] - ; - ctyp: LEVEL "simple" - [ [ "["; OPT "|"; rfl = LIST0 row_field SEP "|"; "]" -> - <:ctyp< [ = $list:rfl$ ] >> - | "["; ">"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" -> - <:ctyp< [ > $list:rfl$ ] >> - | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" -> - <:ctyp< [ < $list:rfl$ ] >> - | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; ">"; - ntl = LIST1 name_tag; "]" -> - <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ] - ; - row_field: - [ [ "`"; i = ident -> MLast.RfTag i False [] - | "`"; i = ident; "of"; ao = OPT "&"; l = LIST1 ctyp SEP "&" -> - MLast.RfTag i (o2b ao) l - | "`"; i = ident; "&"; l = LIST1 ctyp SEP "&" -> MLast.RfTag i True l - | "`"; i = ident; l = LIST1 ctyp SEP "&" -> MLast.RfTag i False l ] ] - ; - name_tag: - [ [ "`"; i = ident -> i ] ] - ; - expr: LEVEL "expr1" - [ [ "fun"; p = labeled_patt; e = fun_def -> <:expr< fun $p$ -> $e$ >> ] ] - ; - expr: AFTER "apply" - [ "label" - [ i = LABEL; e = SELF -> <:expr< ~ $i$ : $e$ >> - | i = ELABEL -> <:expr< ~ $i$ >> - | "?"; i = LABEL; e = SELF -> <:expr< ? $i$ : $e$ >> - | "?"; i = ELABEL -> <:expr< ? $i$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "`"; s = ident -> <:expr< ` $s$ >> ] ] - ; - fun_def: - [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ] - ; - fun_binding: - [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ] - ; - patt: LEVEL "simple" - [ [ "`"; s = ident -> <:patt< ` $s$ >> ] ] - ; - labeled_patt: - [ [ i = LABEL; p = patt LEVEL "simple" -> <:patt< ~ $i$ : $p$ >> - | i = ELABEL -> <:patt< ~ $i$ >> - | "?"; i = LABEL; j = LIDENT -> <:patt< ? $i$ : ($lid:j$) >> - | "?"; "("; i = LABEL; j = LIDENT; ")" -> <:patt< ? $i$ : ($lid:j$) >> - | "?"; "("; i = LABEL; j = LIDENT; "="; e = expr; ")" -> - <:patt< ? $i$ : ( $lid:j$ = $e$ ) >> - | "?"; i = ELABEL -> <:patt< ? $i$ : ($lid:i$) >> - | "?"; "("; i = ELABEL; "="; e = expr; ")" -> - <:patt< ? $i$ : ( $lid:i$ = $e$ ) >> ] ] - ; - class_type: - [ [ i = LABEL; t = ctyp LEVEL "ctyp1"; "->"; ct = SELF -> - <:class_type< [ ~ $i$ : $t$ ] -> $ct$ >> - | "?"; i = LABEL; t = ctyp LEVEL "ctyp1"; "->"; ct = SELF -> - <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> ] ] - ; - class_fun_binding: - [ [ p = labeled_patt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ] - ; - ident: - [ [ i = LIDENT -> i - | i = UIDENT -> i ] ] - ; -END; - -type spat_comp = - [ SpTrm of MLast.loc and MLast.patt and option MLast.expr - | SpNtr of MLast.loc and MLast.patt and MLast.expr - | SpStr of MLast.loc and MLast.patt ] -; -type sexp_comp = - [ SeTrm of MLast.loc and MLast.expr | SeNtr of MLast.loc and MLast.expr ] -; - -value strm_n = "strm__"; -value peek_fun loc = <:expr< Stream.peek >>; -value junk_fun loc = <:expr< Stream.junk >>; - -(* Parsers. *) -(* In syntax generated, many cases are optimisations. *) - -value rec pattern_eq_expression p e = - match (p, e) with - [ (<:patt< $lid:a$ >>, <:expr< $lid:b$ >>) -> a = b - | (<:patt< $uid:a$ >>, <:expr< $uid:b$ >>) -> a = b - | (<:patt< $p1$ $p2$ >>, <:expr< $e1$ $e2$ >>) -> - pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2 - | _ -> False ] -; - -value is_raise e = - match e with - [ <:expr< raise $_$ >> -> True - | _ -> False ] -; - -value is_raise_failure e = - match e with - [ <:expr< raise Stream.Failure >> -> True - | _ -> False ] -; - -value rec handle_failure e = - match e with - [ <:expr< try $te$ with [ Stream.Failure -> $e$] >> -> handle_failure e - | <:expr< match $me$ with [ $list:pel$ ] >> -> - handle_failure me && - List.for_all - (fun - [ (_, None, e) -> handle_failure e - | _ -> False ]) - pel - | <:expr< let $list:pel$ in $e$ >> -> - List.for_all (fun (p, e) -> handle_failure e) pel && handle_failure e - | <:expr< $lid:_$ >> | <:expr< $int:_$ >> | <:expr< $str:_$ >> | - <:expr< $chr:_$ >> | <:expr< fun [ $list:_$ ] >> | <:expr< $uid:_$ >> -> - True - | <:expr< raise $e$ >> -> - match e with - [ <:expr< Stream.Failure >> -> False - | _ -> True ] - | <:expr< $f$ $x$ >> -> - is_constr_apply f && handle_failure f && handle_failure x - | _ -> False ] -and is_constr_apply = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $lid:_$ >> -> False - | <:expr< $x$ $_$ >> -> is_constr_apply x - | _ -> False ] -; - -value rec subst v e = - let loc = MLast.loc_of_expr e in - match e with - [ <:expr< $lid:x$ >> -> - let x = if x = v then strm_n else x in - <:expr< $lid:x$ >> - | <:expr< $uid:_$ >> -> e - | <:expr< $int:_$ >> -> e - | <:expr< $chr:_$ >> -> e - | <:expr< $str:_$ >> -> e - | <:expr< $_$ . $_$ >> -> e - | <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> - <:expr< let $opt:rf$ $list:List.map (subst_pe v) pel$ in $subst v e$ >> - | <:expr< $e1$ $e2$ >> -> <:expr< $subst v e1$ $subst v e2$ >> - | <:expr< ( $list:el$ ) >> -> <:expr< ( $list:List.map (subst v) el$ ) >> - | _ -> raise Not_found ] -and subst_pe v (p, e) = - match p with - [ <:patt< $lid:v'$ >> -> if v = v' then (p, e) else (p, subst v e) - | _ -> raise Not_found ] -; - -value stream_pattern_component skont ckont = - fun - [ SpTrm loc p wo -> - <:expr< match $peek_fun loc$ $lid:strm_n$ with - [ Some $p$ $when:wo$ -> - do { $junk_fun loc$ $lid:strm_n$; $skont$ } - | _ -> $ckont$ ] >> - | SpNtr loc p e -> - let e = - match e with - [ <:expr< fun [ ($lid:v$ : Stream.t _) -> $e$ ] >> when v = strm_n -> - e - | _ -> <:expr< $e$ $lid:strm_n$ >> ] - in - if pattern_eq_expression p skont then - if is_raise_failure ckont then e - else if handle_failure e then e - else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> - else if is_raise_failure ckont then <:expr< let $p$ = $e$ in $skont$ >> - else if pattern_eq_expression <:patt< Some $p$ >> skont then - <:expr< try Some $e$ with [ Stream.Failure -> $ckont$ ] >> - else if is_raise ckont then - let tst = - if handle_failure e then e - else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> - in - <:expr< let $p$ = $tst$ in $skont$ >> - else - <:expr< match try Some $e$ with [ Stream.Failure -> None ] with - [ Some $p$ -> $skont$ - | _ -> $ckont$ ] >> - | SpStr loc p -> - try - match p with - [ <:patt< $lid:v$ >> -> subst v skont - | _ -> raise Not_found ] - with - [ Not_found -> <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ] ] -; - -value rec stream_pattern loc epo e ekont = - fun - [ [] -> - match epo with - [ Some ep -> <:expr< let $ep$ = Stream.count $lid:strm_n$ in $e$ >> - | _ -> e ] - | [(spc, err) :: spcl] -> - let skont = - let ekont err = - let str = - match err with - [ Some estr -> estr - | _ -> <:expr< "" >> ] - in - <:expr< raise (Stream.Error $str$) >> - in - stream_pattern loc epo e ekont spcl - in - let ckont = ekont err in - stream_pattern_component skont ckont spc ] -; - -value stream_patterns_term loc ekont tspel = - let pel = - List.map - (fun (p, w, loc, spcl, epo, e) -> - let p = <:patt< Some $p$ >> in - let e = - let ekont err = - let str = - match err with - [ Some estr -> estr - | _ -> <:expr< "" >> ] - in - <:expr< raise (Stream.Error $str$) >> - in - let skont = stream_pattern loc epo e ekont spcl in - <:expr< do { $junk_fun loc$ $lid:strm_n$; $skont$ } >> - in - (p, w, e)) - tspel - in - let pel = pel @ [(<:patt< _ >>, None, ekont ())] in - <:expr< match $peek_fun loc$ $lid:strm_n$ with [ $list:pel$ ] >> -; - -value rec group_terms = - fun - [ [([(SpTrm loc p w, None) :: spcl], epo, e) :: spel] -> - let (tspel, spel) = group_terms spel in - ([(p, w, loc, spcl, epo, e) :: tspel], spel) - | spel -> ([], spel) ] -; - -value rec parser_cases loc = - fun - [ [] -> <:expr< raise Stream.Failure >> - | spel -> - match group_terms spel with - [ ([], [(spcl, epo, e) :: spel]) -> - stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl - | (tspel, spel) -> - stream_patterns_term loc (fun _ -> parser_cases loc spel) tspel ] ] -; - -value cparser loc bpo pc = - let e = parser_cases loc pc in - let e = - match bpo with - [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >> - | None -> e ] - in - let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in - <:expr< fun $p$ -> $e$ >> -; - -value cparser_match loc me bpo pc = - let pc = parser_cases loc pc in - let e = - match bpo with - [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >> - | None -> pc ] - in - <:expr< let $lid:strm_n$ = $me$ in $e$ >> -; - -(* streams *) - -value rec not_computing = - fun - [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $int:_$ >> | - <:expr< $flo:_$ >> | <:expr< $chr:_$ >> | <:expr< $str:_$ >> -> - True - | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y - | _ -> False ] -and is_cons_apply_not_computing = - fun - [ <:expr< $uid:_$ >> -> True - | <:expr< $lid:_$ >> -> False - | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y - | _ -> False ] -; - -value slazy loc e = - match e with - [ <:expr< $f$ () >> -> - match f with - [ <:expr< $lid:_$ >> -> f - | _ -> <:expr< fun _ -> $e$ >> ] - | _ -> <:expr< fun _ -> $e$ >> ] -; - -value rec cstream gloc = - fun - [ [] -> - let loc = gloc in - <:expr< Stream.sempty >> - | [SeTrm loc e] -> - if not_computing e then <:expr< Stream.ising $e$ >> - else <:expr< Stream.lsing $slazy loc e$ >> - | [SeTrm loc e :: secl] -> - if not_computing e then <:expr< Stream.icons $e$ $cstream gloc secl$ >> - else <:expr< Stream.lcons $slazy loc e$ $cstream gloc secl$ >> - | [SeNtr loc e] -> - if not_computing e then e else <:expr< Stream.slazy $slazy loc e$ >> - | [SeNtr loc e :: secl] -> - if not_computing e then <:expr< Stream.iapp $e$ $cstream gloc secl$ >> - else <:expr< Stream.lapp $slazy loc e$ $cstream gloc secl$ >> ] -; - -(* Syntax extensions in Ocaml grammar *) - -EXTEND - GLOBAL: expr; - expr: LEVEL "expr1" - [ [ "parser"; po = OPT ipatt; OPT "|"; pcl = LIST1 parser_case SEP "|" -> - <:expr< $cparser loc po pcl$ >> - | "match"; e = SELF; "with"; "parser"; po = OPT ipatt; OPT "|"; - pcl = LIST1 parser_case SEP "|" -> - <:expr< $cparser_match loc e po pcl$ >> ] ] - ; - parser_case: - [ [ "[<"; sp = stream_patt; ">]"; po = OPT ipatt; "->"; e = expr -> - (sp, po, e) ] ] - ; - stream_patt: - [ [ spc = stream_patt_comp -> [(spc, None)] - | spc = stream_patt_comp; ";" -> [(spc, None)] - | spc = stream_patt_comp; ";"; sp = stream_patt_comp_err_list -> - [(spc, None) :: sp] - | -> (* empty *) [] ] ] - ; - stream_patt_comp_err_list: - [ [ spc = stream_patt_comp_err -> [spc] - | spc = stream_patt_comp_err; ";" -> [spc] - | spc = stream_patt_comp_err; ";"; sp = SELF -> [spc :: sp] ] ] - ; - stream_patt_comp: - [ [ "'"; p = patt; eo = OPT [ "when"; e = expr LEVEL "expr1" -> e ] -> - SpTrm loc p eo - | p = patt; "="; e = expr LEVEL "expr1" -> SpNtr loc p e - | p = patt -> SpStr loc p ] ] - ; - stream_patt_comp_err: - [ [ spc = stream_patt_comp; - eo = OPT [ "?"; e = expr LEVEL "expr1" -> e ] -> - (spc, eo) ] ] - ; - ipatt: - [ [ i = LIDENT -> <:patt< $lid:i$ >> ] ] - ; - expr: LEVEL "simple" - [ [ "[<"; ">]" -> <:expr< $cstream loc []$ >> - | "[<"; sel = stream_expr_comp_list; ">]" -> - <:expr< $cstream loc sel$ >> ] ] - ; - stream_expr_comp_list: - [ [ se = stream_expr_comp; ";"; sel = SELF -> [se :: sel] - | se = stream_expr_comp; ";" -> [se] - | se = stream_expr_comp -> [se] ] ] - ; - stream_expr_comp: - [ [ "'"; e = expr LEVEL "expr1" -> SeTrm loc e - | e = expr LEVEL "expr1" -> SeNtr loc e ] ] - ; -END; diff --git a/camlp4/unmaintained/scheme/.depend b/camlp4/unmaintained/scheme/.depend deleted file mode 100644 index e69de29b..00000000 diff --git a/camlp4/unmaintained/scheme/Makefile b/camlp4/unmaintained/scheme/Makefile deleted file mode 100644 index 01036c22..00000000 --- a/camlp4/unmaintained/scheme/Makefile +++ /dev/null @@ -1,85 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Camlp4 # -# # -# Copyright 2004 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### -# -# Makefile for pa_lefteval -# M.Mauny -# - -include ../../config/Makefile.cnf - -OCAMLTOP=../../.. -CAMLP4=../../camlp4/camlp4$(EXE) - -OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) -OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) - -P4INCLUDES= -nolib -I ../../meta -I ../../etc -OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../camlp4 -I ../../lib -I ../../etc -OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) - -SCHSRC=pa_scheme.sc -SRC=pa_scheme.ml pr_scheme.ml pr_schp_main.ml -OBJS=$(SRC:.ml=.cmo) -OBJSX=$(OCAMLSRC:.ml=.cmx) - -all: $(OBJS) pr_schemep.cmo camlp4sch$(EXE) - -opt: all - -bootstrap: camlp4sch$(EXE) save - ./camlp4sch$(EXE) ../../etc/q_phony.cmo ../../meta/pa_extend.cmo ../../etc/pr_r.cmo ../../etc/pr_extend.cmo ../../etc/pr_rp.cmo -impl pa_scheme.sc \ - | sed -e 's/^;; \(.*\)$$/(* \1 *)/' -e 's/^; \(.*\)$$/(* \1 *)/' \ - -e 's/$$Id.*\$$/File generated by pretty print; do not edit!/' > pa_scheme.ml - @if cmp -s pa_scheme.ml SAVED/pa_scheme.ml; then \ - echo 'pa_scheme.ml and SAVED/pa_scheme.ml are identical' ; \ - else \ - echo '**** Note: pa_scheme.ml differs from SAVED/pa_scheme.ml'; \ - fi - -save: - test -d SAVED || mkdir SAVED - mkdir SAVED.$$$$ && mv SAVED pa_scheme.ml SAVED.$$$$ && mv SAVED.$$$$ SAVED - -restore: - mv SAVED SAVED.$$$$ && mv SAVED.$$$$/* . && rmdir SAVED.$$$$ - -depend: - cp .depend .depend.bak - > .depend - for file in $(SRC); do \ - $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \ - sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \ - done - -clean: - rm -f camlp4sch$(EXE) *.cm* *.$(O) *.bak .*.bak - -camlp4sch: pa_scheme.cmo - rm -f camlp4sch - DIR=`pwd` && cd ../../camlp4 && $(MAKE) CAMLP4=$$DIR/camlp4sch CAMLP4M="-I $$DIR pa_scheme.cmo ../meta/pr_dump.cmo" - -pr_schemep.cmo: pr_schp_main.cmo - $(OCAMLC) ../../etc/parserify.cmo pr_schp_main.cmo -a -o $@ - -.SUFFIXES: .cmx .cmo .cmi .ml .mli - -.mli.cmi: - $(OCAMLC) $(OCAMLCFLAGS) -c $< - - -.ml.cmo: - $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<` -loc loc" -c $< - -.ml.cmx: - $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<` -loc loc" -c $< - -include .depend diff --git a/camlp4/unmaintained/scheme/README b/camlp4/unmaintained/scheme/README deleted file mode 100644 index 809d42f2..00000000 --- a/camlp4/unmaintained/scheme/README +++ /dev/null @@ -1,15 +0,0 @@ -This is an application of or an extension for Camlp4. Although it is -currently distributed with OCaml/Camlp4, it may or may not be -actively maintained. - -It probably won't be part of future OCaml/Camlp4 distributions but be -accessible from the Camlp4 hump. If you are interested in developing -this package further and/or actively maintain it, please let us know -(caml@inria.fr) - -This package is distributed under the same license as the Objective -Caml Library (that is, LGPL with a special exception allowing both -static and dynamic link). - --- Michel Mauny - diff --git a/camlp4/unmaintained/scheme/pa_scheme.ml b/camlp4/unmaintained/scheme/pa_scheme.ml deleted file mode 100644 index f91acd49..00000000 --- a/camlp4/unmaintained/scheme/pa_scheme.ml +++ /dev/null @@ -1,1093 +0,0 @@ -(* pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *) -(* ********************************************************************** *) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU Library General Public License, with *) -(* the special exception on linking described in file *) -(* ../../../LICENSE. *) -(* *) -(* ********************************************************************** *) -(* File generated by pretty print; do not edit! *) - -open Pcaml; -open Stdpp; - -type choice 'a 'b = - [ Left of 'a - | Right of 'b ] -; - -(* Buffer *) - -module Buff = - struct - value buff = ref (String.create 80); - value store len x = - do { - if len >= String.length buff.val then - buff.val := buff.val ^ String.create (String.length buff.val) - else (); - buff.val.[len] := x; - succ len - } - ; - value get len = String.sub buff.val 0 len; - end -; - -(* Lexer *) - -value rec skip_to_eol = - parser - [ [: `'\n' | '\r' :] -> () - | [: `_; s :] -> skip_to_eol s ] -; - -value no_ident = ['('; ')'; '['; ']'; '{'; '}'; ' '; '\t'; '\n'; '\r'; ';']; - -value rec ident len = - parser - [ [: `'.' :] -> (Buff.get len, True) - | [: `x when not (List.mem x no_ident); s :] -> ident (Buff.store len x) s - | [: :] -> (Buff.get len, False) ] -; - -value identifier kwt (s, dot) = - let con = - try do { (Hashtbl.find kwt s : unit); "" } with - [ Not_found -> - match s.[0] with - [ 'A'..'Z' -> if dot then "UIDENTDOT" else "UIDENT" - | _ -> if dot then "LIDENTDOT" else "LIDENT" ] ] - in - (con, s) -; - -value rec string len = - parser - [ [: `'"' :] -> Buff.get len - | [: `'\\'; `c; s :] -> string (Buff.store (Buff.store len '\\') c) s - | [: `x; s :] -> string (Buff.store len x) s ] -; - -value rec end_exponent_part_under len = - parser - [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (Buff.store len c) s - | [: :] -> ("FLOAT", Buff.get len) ] -; - -value end_exponent_part len = - parser - [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (Buff.store len c) s - | [: :] -> raise (Stream.Error "ill-formed floating-point constant") ] -; - -value exponent_part len = - parser - [ [: `('+' | '-' as c); s :] -> end_exponent_part (Buff.store len c) s - | [: a = end_exponent_part len :] -> a ] -; - -value rec decimal_part len = - parser - [ [: `('0'..'9' as c); s :] -> decimal_part (Buff.store len c) s - | [: `'e' | 'E'; s :] -> exponent_part (Buff.store len 'E') s - | [: :] -> ("FLOAT", Buff.get len) ] -; - -value rec number len = - parser - [ [: `('0'..'9' as c); s :] -> number (Buff.store len c) s - | [: `'.'; s :] -> decimal_part (Buff.store len '.') s - | [: `'e' | 'E'; s :] -> exponent_part (Buff.store len 'E') s - | [: :] -> ("INT", Buff.get len) ] -; - -value binary = parser [: `('0'..'1' as c) :] -> c; - -value octal = parser [: `('0'..'7' as c) :] -> c; - -value hexa = parser [: `('0'..'9' | 'a'..'f' | 'A'..'F' as c) :] -> c; - -value rec digits_under kind len = - parser - [ [: d = kind; s :] -> digits_under kind (Buff.store len d) s - | [: :] -> Buff.get len ] -; - -value digits kind bp len = - parser - [ [: d = kind; s :] -> ("INT", digits_under kind (Buff.store len d) s) - | [: s :] ep -> - raise_with_loc - (Reloc.shift_pos bp Reloc.zero_loc, Reloc.shift_pos ep Reloc.zero_loc) - (Failure "ill-formed integer constant") ] -; - -value base_number kwt bp len = - parser - [ [: `'b' | 'B'; s :] -> digits binary bp (Buff.store len 'b') s - | [: `'o' | 'O'; s :] -> digits octal bp (Buff.store len 'o') s - | [: `'x' | 'X'; s :] -> digits hexa bp (Buff.store len 'x') s - | [: id = ident (Buff.store 0 '#') :] -> identifier kwt id ] -; - -value rec operator len = - parser - [ [: `'.' :] -> Buff.get (Buff.store len '.') - | [: :] -> Buff.get len ] -; - -value char_or_quote_id x = - parser - [ [: `''' :] -> ("CHAR", String.make 1 x) - | [: s :] ep -> - if List.mem x no_ident then - Stdpp.raise_with_loc - (Reloc.shift_pos (ep - 2) Reloc.zero_loc, - Reloc.shift_pos (ep - 1) Reloc.zero_loc) - (Stream.Error "bad quote") - else - let len = Buff.store (Buff.store 0 ''') x in - let (s, dot) = ident len s in - (if dot then "LIDENTDOT" else "LIDENT", s) ] -; - -value rec char len = - parser - [ [: `''' :] -> len - | [: `x; s :] -> char (Buff.store len x) s ] -; - -value quote = - parser - [ [: `'\\'; len = char (Buff.store 0 '\\') :] -> ("CHAR", Buff.get len) - | [: `x; s :] -> char_or_quote_id x s ] -; - -(* The system with LIDENTDOT and UIDENTDOT is not great (it would be *) -(* better to have a token DOT (actually SPACEDOT and DOT)) but it is *) -(* the only way (that I have found) to have a good behaviour in the *) -(* toplevel (not expecting tokens after a phrase). Drawbacks: 1/ to be *) -(* complete, we should have STRINGDOT, RIGHTPARENDOT, and so on 2/ the *) -(* parser rule with dot is right associative and we have to reverse *) -(* the resulting tree (using the function leftify). *) -(* This is a complicated issue: the behaviour of the OCaml toplevel *) -(* is strange, anyway. For example, even without Camlp4, The OCaml *) -(* toplevel accepts that: *) -(* # let x = 32;; foo bar match let ) *) - -value rec lexer kwt = parser [: t = lexer0 kwt; _ = no_dot :] -> t -and no_dot = - parser - [ [: `'.' :] ep -> - Stdpp.raise_with_loc - (Reloc.shift_pos (ep - 1) Reloc.zero_loc, - Reloc.shift_pos ep Reloc.zero_loc) - (Stream.Error "bad dot") - | [: :] -> () ] -and lexer0 kwt = - parser bp - [ [: `'\t' | '\n' | '\r'; s :] -> lexer0 kwt s - | [: `' '; s :] -> after_space kwt s - | [: `';'; _ = skip_to_eol; s :] -> lexer kwt s - | [: `'(' :] -> (("", "("), (bp, bp + 1)) - | [: `')'; s :] ep -> (("", rparen s), (bp, ep)) - | [: `'[' :] -> (("", "["), (bp, bp + 1)) - | [: `']' :] -> (("", "]"), (bp, bp + 1)) - | [: `'{' :] -> (("", "{"), (bp, bp + 1)) - | [: `'}' :] -> (("", "}"), (bp, bp + 1)) - | [: `'"'; s = string 0 :] ep -> (("STRING", s), (bp, ep)) - | [: `'''; tok = quote :] ep -> (tok, (bp, ep)) - | [: `'<'; tok = less kwt :] ep -> (tok, (bp, ep)) - | [: `'-'; tok = minus kwt :] ep -> (tok, (bp, ep)) - | [: `'~'; tok = tilde :] ep -> (tok, (bp, ep)) - | [: `'?'; tok = question :] ep -> (tok, (bp, ep)) - | [: `'#'; tok = base_number kwt bp (Buff.store 0 '0') :] ep -> - (tok, (bp, ep)) - | [: `('0'..'9' as c); tok = number (Buff.store 0 c) :] ep -> - (tok, (bp, ep)) - | [: `('+' | '*' | '/' as c); id = operator (Buff.store 0 c) :] ep -> - (identifier kwt (id, False), (bp, ep)) - | [: `x; id = ident (Buff.store 0 x) :] ep -> (identifier kwt id, (bp, ep)) - | [: :] -> (("EOI", ""), (bp, bp + 1)) ] -and rparen = - parser - [ [: `'.' :] -> ")." - | [: ___ :] -> ")" ] -and after_space kwt = - parser - [ [: `'.' :] ep -> (("", "."), (ep - 1, ep)) - | [: x = lexer0 kwt :] -> x ] -and tilde = - parser - [ [: `('a'..'z' as c); (s, dot) = ident (Buff.store 0 c) :] -> - ("TILDEIDENT", s) - | [: :] -> ("LIDENT", "~") ] -and question = - parser - [ [: `('a'..'z' as c); (s, dot) = ident (Buff.store 0 c) :] -> - ("QUESTIONIDENT", s) - | [: :] -> ("LIDENT", "?") ] -and minus kwt = - parser - [ [: `'.' :] -> identifier kwt ("-.", False) - | [: `('0'..'9' as c); n = number (Buff.store (Buff.store 0 '-') c) :] -> - n - | [: id = ident (Buff.store 0 '-') :] -> identifier kwt id ] -and less kwt = - parser - [ [: `':'; lab = label 0; `'<' ? "'<' expected"; q = quotation 0 :] -> - ("QUOT", lab ^ ":" ^ q) - | [: id = ident (Buff.store 0 '<') :] -> identifier kwt id ] -and label len = - parser - [ [: `('a'..'z' | 'A'..'Z' | '_' as c); s :] -> label (Buff.store len c) s - | [: :] -> Buff.get len ] -and quotation len = - parser - [ [: `'>'; s :] -> quotation_greater len s - | [: `x; s :] -> quotation (Buff.store len x) s - | [: :] -> failwith "quotation not terminated" ] -and quotation_greater len = - parser - [ [: `'>' :] -> Buff.get len - | [: a = quotation (Buff.store len '>') :] -> a ] -; - -value lexer_using kwt (con, prm) = - match con with - [ "CHAR" | "EOI" | "INT" | "FLOAT" | "LIDENT" | "LIDENTDOT" | - "QUESTIONIDENT" | "QUOT" | "STRING" | "TILDEIDENT" | "UIDENT" | - "UIDENTDOT" -> - () - | "ANTIQUOT" -> () - | "" -> - try Hashtbl.find kwt prm with [ Not_found -> Hashtbl.add kwt prm () ] - | _ -> - raise - (Token.Error - ("the constructor \"" ^ con ^ "\" is not recognized by Plexer")) ] -; - -value lexer_text (con, prm) = - if con = "" then "'" ^ prm ^ "'" - else if prm = "" then con - else con ^ " \"" ^ prm ^ "\"" -; - -value lexer_gmake () = - let kwt = Hashtbl.create 89 in - {Token.tok_func = - Token.lexer_func_of_parser - (fun s -> - let (r, (bp, ep)) = lexer kwt s in - (r, - (Reloc.shift_pos bp Reloc.zero_loc, - Reloc.shift_pos ep Reloc.zero_loc))); - Token.tok_using = lexer_using kwt; Token.tok_removing = fun []; - Token.tok_match = Token.default_match; Token.tok_text = lexer_text; - Token.tok_comm = None} -; - -(* Building AST *) - -type sexpr = - [ Sacc of MLast.loc and sexpr and sexpr - | Schar of MLast.loc and string - | Sexpr of MLast.loc and list sexpr - | Sint of MLast.loc and string - | Sfloat of MLast.loc and string - | Slid of MLast.loc and string - | Slist of MLast.loc and list sexpr - | Sqid of MLast.loc and string - | Squot of MLast.loc and string and string - | Srec of MLast.loc and list sexpr - | Sstring of MLast.loc and string - | Stid of MLast.loc and string - | Suid of MLast.loc and string ] -; - -value loc_of_sexpr = - fun [ - Sacc loc _ _ | Schar loc _ | Sexpr loc _ | Sint loc _ | Sfloat loc _ | - Slid loc _ | Slist loc _ | Sqid loc _ | Squot loc _ _ | Srec loc _ | - Sstring loc _ | Stid loc _ | Suid loc _ -> - loc ] -; -value error_loc loc err = - raise_with_loc loc (Stream.Error (err ^ " expected")) -; -value error se err = error_loc (loc_of_sexpr se) err; - -value strm_n = "strm__"; -value peek_fun loc = <:expr< Stream.peek >>; -value junk_fun loc = <:expr< Stream.junk >>; - -value assoc_left_parsed_op_list = - ["+"; "*"; "+."; "*."; "land"; "lor"; "lxor"] -; -value assoc_right_parsed_op_list = ["and"; "or"; "^"; "@"]; -value and_by_couple_op_list = ["="; "<>"; "<"; ">"; "<="; ">="; "=="; "!="]; - -value op_apply loc e1 e2 = - fun - [ "and" -> <:expr< $e1$ && $e2$ >> - | "or" -> <:expr< $e1$ || $e2$ >> - | x -> <:expr< $lid:x$ $e1$ $e2$ >> ] -; - -value string_se = - fun - [ Sstring loc s -> s - | se -> error se "string" ] -; - -value mod_ident_se = - fun - [ Suid _ s -> [Pcaml.rename_id.val s] - | Slid _ s -> [Pcaml.rename_id.val s] - | se -> error se "mod_ident" ] -; - -value lident_expr loc s = - if String.length s > 1 && s.[0] = '`' then - let s = String.sub s 1 (String.length s - 1) in - <:expr< ` $s$ >> - else <:expr< $lid:(Pcaml.rename_id.val s)$ >> -; - -value rec module_expr_se = - fun - [ Sexpr loc [Slid _ "functor"; Suid _ s; se1; se2] -> - let s = Pcaml.rename_id.val s in - let mt = module_type_se se1 in - let me = module_expr_se se2 in - <:module_expr< functor ($s$ : $mt$) -> $me$ >> - | Sexpr loc [Slid _ "struct" :: sl] -> - let mel = List.map str_item_se sl in - <:module_expr< struct $list:mel$ end >> - | Sexpr loc [se1; se2] -> - let me1 = module_expr_se se1 in - let me2 = module_expr_se se2 in - <:module_expr< $me1$ $me2$ >> - | Suid loc s -> <:module_expr< $uid:(Pcaml.rename_id.val s)$ >> - | se -> error se "module expr" ] -and module_type_se = - fun - [ Sexpr loc [Slid _ "functor"; Suid _ s; se1; se2] -> - let s = Pcaml.rename_id.val s in - let mt1 = module_type_se se1 in - let mt2 = module_type_se se2 in - <:module_type< functor ($s$ : $mt1$) -> $mt2$ >> - | Sexpr loc [Slid _ "sig" :: sel] -> - let sil = List.map sig_item_se sel in - <:module_type< sig $list:sil$ end >> - | Sexpr loc [Slid _ "with"; se; Sexpr _ sel] -> - let mt = module_type_se se in - let wcl = List.map with_constr_se sel in - <:module_type< $mt$ with $list:wcl$ >> - | Suid loc s -> <:module_type< $uid:(Pcaml.rename_id.val s)$ >> - | se -> error se "module type" ] -and with_constr_se = - fun - [ Sexpr loc [Slid _ "type"; se1; se2] -> - let tn = mod_ident_se se1 in - let te = ctyp_se se2 in - MLast.WcTyp loc tn [] te - | se -> error se "with constr" ] -and sig_item_se = - fun - [ Sexpr loc [Slid _ "type" :: sel] -> - let tdl = type_declaration_list_se sel in - <:sig_item< type $list:tdl$ >> - | Sexpr loc [Slid _ "exception"; Suid _ c :: sel] -> - let c = Pcaml.rename_id.val c in - let tl = List.map ctyp_se sel in - <:sig_item< exception $c$ of $list:tl$ >> - | Sexpr loc [Slid _ "value"; Slid _ s; se] -> - let s = Pcaml.rename_id.val s in - let t = ctyp_se se in - <:sig_item< value $s$ : $t$ >> - | Sexpr loc [Slid _ "external"; Slid _ i; se :: sel] -> - let i = Pcaml.rename_id.val i in - let pd = List.map string_se sel in - let t = ctyp_se se in - <:sig_item< external $i$ : $t$ = $list:pd$ >> - | Sexpr loc [Slid _ "module"; Suid _ s; se] -> - let s = Pcaml.rename_id.val s in - let mb = module_type_se se in - <:sig_item< module $s$ : $mb$ >> - | Sexpr loc [Slid _ "moduletype"; Suid _ s; se] -> - let s = Pcaml.rename_id.val s in - let mt = module_type_se se in - <:sig_item< module type $s$ = $mt$ >> - | se -> error se "sig item" ] -and str_item_se se = - match se with - [ Sexpr loc [Slid _ "open"; se] -> - let s = mod_ident_se se in - <:str_item< open $s$ >> - | Sexpr loc [Slid _ "type" :: sel] -> - let tdl = type_declaration_list_se sel in - <:str_item< type $list:tdl$ >> - | Sexpr loc [Slid _ "exception"; Suid _ c :: sel] -> - let c = Pcaml.rename_id.val c in - let tl = List.map ctyp_se sel in - <:str_item< exception $c$ of $list:tl$ >> - | Sexpr loc [Slid _ ("define" | "definerec" as r); se :: sel] -> - let r = r = "definerec" in - let (p, e) = fun_binding_se se (begin_se loc sel) in - <:str_item< value $opt:r$ $p$ = $e$ >> - | Sexpr loc [Slid _ ("define*" | "definerec*" as r) :: sel] -> - let r = r = "definerec*" in - let lbs = List.map let_binding_se sel in - <:str_item< value $opt:r$ $list:lbs$ >> - | Sexpr loc [Slid _ "external"; Slid _ i; se :: sel] -> - let i = Pcaml.rename_id.val i in - let pd = List.map string_se sel in - let t = ctyp_se se in - <:str_item< external $i$ : $t$ = $list:pd$ >> - | Sexpr loc [Slid _ "module"; Suid _ i; se] -> - let i = Pcaml.rename_id.val i in - let mb = module_binding_se se in - <:str_item< module $i$ = $mb$ >> - | Sexpr loc [Slid _ "moduletype"; Suid _ s; se] -> - let s = Pcaml.rename_id.val s in - let mt = module_type_se se in - <:str_item< module type $s$ = $mt$ >> - | _ -> - let loc = loc_of_sexpr se in - let e = expr_se se in - <:str_item< $exp:e$ >> ] -and module_binding_se se = module_expr_se se -and expr_se = - fun - [ Sacc loc se1 se2 -> - let e1 = expr_se se1 in - match se2 with - [ Slist loc [se2] -> - let e2 = expr_se se2 in - <:expr< $e1$ .[ $e2$ ] >> - | Sexpr loc [se2] -> - let e2 = expr_se se2 in - <:expr< $e1$ .( $e2$ ) >> - | _ -> - let e2 = expr_se se2 in - <:expr< $e1$ . $e2$ >> ] - | Slid loc s -> lident_expr loc s - | Suid loc s -> <:expr< $uid:(Pcaml.rename_id.val s)$ >> - | Sint loc s -> <:expr< $int:s$ >> - | Sfloat loc s -> <:expr< $flo:s$ >> - | Schar loc s -> <:expr< $chr:s$ >> - | Sstring loc s -> <:expr< $str:s$ >> - | Stid loc s -> <:expr< ~ $(Pcaml.rename_id.val s)$ >> - | Sqid loc s -> <:expr< ? $(Pcaml.rename_id.val s)$ >> - | Sexpr loc [] -> <:expr< () >> - | Sexpr loc [Slid _ s; e1 :: ([_ :: _] as sel)] - when List.mem s assoc_left_parsed_op_list -> - let rec loop e1 = - fun - [ [] -> e1 - | [e2 :: el] -> loop (op_apply loc e1 e2 s) el ] - in - loop (expr_se e1) (List.map expr_se sel) - | Sexpr loc [Slid _ s :: ([_; _ :: _] as sel)] - when List.mem s assoc_right_parsed_op_list -> - let rec loop = - fun - [ [] -> assert False - | [e1] -> e1 - | [e1 :: el] -> - let e2 = loop el in - op_apply loc e1 e2 s ] - in - loop (List.map expr_se sel) - | Sexpr loc [Slid _ s :: ([_; _ :: _] as sel)] - when List.mem s and_by_couple_op_list -> - let rec loop = - fun - [ [] | [_] -> assert False - | [e1; e2] -> <:expr< $lid:s$ $e1$ $e2$ >> - | [e1 :: ([e2; _ :: _] as el)] -> - let a1 = op_apply loc e1 e2 s in - let a2 = loop el in - <:expr< $a1$ && $a2$ >> ] - in - loop (List.map expr_se sel) - | Sexpr loc [Stid _ s; se] -> - let e = expr_se se in - <:expr< ~ $s$ : $e$ >> - | Sexpr loc [Slid _ "-"; se] -> - let e = expr_se se in - <:expr< - $e$ >> - | Sexpr loc [Slid _ "if"; se; se1] -> - let e = expr_se se in - let e1 = expr_se se1 in - <:expr< if $e$ then $e1$ else () >> - | Sexpr loc [Slid _ "if"; se; se1; se2] -> - let e = expr_se se in - let e1 = expr_se se1 in - let e2 = expr_se se2 in - <:expr< if $e$ then $e1$ else $e2$ >> - | Sexpr loc [Slid _ "cond" :: sel] -> - let rec loop = - fun - [ [Sexpr loc [Slid _ "else" :: sel]] -> begin_se loc sel - | [Sexpr loc [se1 :: sel1] :: sel] -> - let e1 = expr_se se1 in - let e2 = begin_se loc sel1 in - let e3 = loop sel in - <:expr< if $e1$ then $e2$ else $e3$ >> - | [] -> <:expr< () >> - | [se :: _] -> error se "cond clause" ] - in - loop sel - | Sexpr loc [Slid _ "while"; se :: sel] -> - let e = expr_se se in - let el = List.map expr_se sel in - <:expr< while $e$ do { $list:el$ } >> - | Sexpr loc [Slid _ "for"; Slid _ i; se1; se2 :: sel] -> - let i = Pcaml.rename_id.val i in - let e1 = expr_se se1 in - let e2 = expr_se se2 in - let el = List.map expr_se sel in - <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >> - | Sexpr loc [Slid loc1 "lambda"] -> <:expr< fun [] >> - | Sexpr loc [Slid loc1 "lambda"; sep :: sel] -> - let e = begin_se loc1 sel in - match ipatt_opt_se sep with - [ Left p -> <:expr< fun $p$ -> $e$ >> - | Right (se, sel) -> - List.fold_right - (fun se e -> - let p = ipatt_se se in - <:expr< fun $p$ -> $e$ >>) - [se :: sel] e ] - | Sexpr loc [Slid _ "lambda_match" :: sel] -> - let pel = List.map (match_case loc) sel in - <:expr< fun [ $list:pel$ ] >> - | Sexpr loc [Slid _ ("let" | "letrec" as r) :: sel] -> - match sel with - [ [Sexpr _ sel1 :: sel2] -> - let r = r = "letrec" in - let lbs = List.map let_binding_se sel1 in - let e = begin_se loc sel2 in - <:expr< let $opt:r$ $list:lbs$ in $e$ >> - | [Slid _ n; Sexpr _ sl :: sel] -> - let n = Pcaml.rename_id.val n in - let (pl, el) = - List.fold_right - (fun se (pl, el) -> - match se with - [ Sexpr _ [se1; se2] -> - ([patt_se se1 :: pl], [expr_se se2 :: el]) - | se -> error se "named let" ]) - sl ([], []) - in - let e1 = - List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) pl - (begin_se loc sel) - in - let e2 = - List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) - <:expr< $lid:n$ >> el - in - <:expr< let rec $lid:n$ = $e1$ in $e2$ >> - | [se :: _] -> error se "let_binding" - | _ -> error_loc loc "let_binding" ] - | Sexpr loc [Slid _ "let*" :: sel] -> - match sel with - [ [Sexpr _ sel1 :: sel2] -> - List.fold_right - (fun se ek -> - let (p, e) = let_binding_se se in - <:expr< let $p$ = $e$ in $ek$ >>) - sel1 (begin_se loc sel2) - | [se :: _] -> error se "let_binding" - | _ -> error_loc loc "let_binding" ] - | Sexpr loc [Slid _ "match"; se :: sel] -> - let e = expr_se se in - let pel = List.map (match_case loc) sel in - <:expr< match $e$ with [ $list:pel$ ] >> - | Sexpr loc [Slid _ "parser" :: sel] -> - let e = - match sel with - [ [(Slid _ _ as se) :: sel] -> - let p = patt_se se in - let pc = parser_cases_se loc sel in - <:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >> - | _ -> parser_cases_se loc sel ] - in - <:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >> - | Sexpr loc [Slid _ "match_with_parser"; se :: sel] -> - let me = expr_se se in - let (bpo, sel) = - match sel with - [ [(Slid _ _ as se) :: sel] -> (Some (patt_se se), sel) - | _ -> (None, sel) ] - in - let pc = parser_cases_se loc sel in - let e = - match bpo with - [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >> - | None -> pc ] - in - match me with - [ <:expr< $lid:x$ >> when x = strm_n -> e - | _ -> <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >> ] - | Sexpr loc [Slid _ "try"; se :: sel] -> - let e = expr_se se in - let pel = List.map (match_case loc) sel in - <:expr< try $e$ with [ $list:pel$ ] >> - | Sexpr loc [Slid _ "begin" :: sel] -> - let el = List.map expr_se sel in - <:expr< do { $list:el$ } >> - | Sexpr loc [Slid _ ":="; se1; se2] -> - let e1 = expr_se se1 in - let e2 = expr_se se2 in - <:expr< $e1$ := $e2$ >> - | Sexpr loc [Slid _ "values" :: sel] -> - let el = List.map expr_se sel in - <:expr< ( $list:el$ ) >> - | Srec loc [Slid _ "with"; se :: sel] -> - let e = expr_se se in - let lel = List.map (label_expr_se loc) sel in - <:expr< { ($e$) with $list:lel$ } >> - | Srec loc sel -> - let lel = List.map (label_expr_se loc) sel in - <:expr< { $list:lel$ } >> - | Sexpr loc [Slid _ ":"; se1; se2] -> - let e = expr_se se1 in - let t = ctyp_se se2 in - <:expr< ( $e$ : $t$ ) >> - | Sexpr loc [se] -> - let e = expr_se se in - <:expr< $e$ () >> - | Sexpr loc [Slid _ "assert"; Suid _ "False"] -> <:expr< assert False >> - | Sexpr loc [Slid _ "assert"; se] -> - let e = expr_se se in - <:expr< assert $e$ >> - | Sexpr loc [Slid _ "lazy"; se] -> - let e = expr_se se in - <:expr< lazy $e$ >> - | Sexpr loc [se :: sel] -> - List.fold_left - (fun e se -> - let e1 = expr_se se in - <:expr< $e$ $e1$ >>) - (expr_se se) sel - | Slist loc sel -> - let rec loop = - fun - [ [] -> <:expr< [] >> - | [se1; Slid _ "."; se2] -> - let e = expr_se se1 in - let el = expr_se se2 in - <:expr< [$e$ :: $el$] >> - | [se :: sel] -> - let e = expr_se se in - let el = loop sel in - <:expr< [$e$ :: $el$] >> ] - in - loop sel - | Squot loc typ txt -> Pcaml.handle_expr_quotation loc (typ, txt) ] -and begin_se loc = - fun - [ [] -> <:expr< () >> - | [se] -> expr_se se - | sel -> - let el = List.map expr_se sel in - let loc = (fst (loc_of_sexpr (List.hd sel)), snd loc) in - <:expr< do { $list:el$ } >> ] -and let_binding_se = - fun - [ Sexpr loc [se :: sel] -> - let e = begin_se loc sel in - match ipatt_opt_se se with - [ Left p -> (p, e) - | Right _ -> fun_binding_se se e ] - | se -> error se "let_binding" ] -and fun_binding_se se e = - match se with - [ Sexpr _ [Slid _ "values" :: _] -> (ipatt_se se, e) - | Sexpr _ [Slid loc s :: sel] -> - let s = Pcaml.rename_id.val s in - let e = - List.fold_right - (fun se e -> - let loc = (fst (loc_of_sexpr se), snd (MLast.loc_of_expr e)) in - let p = ipatt_se se in - <:expr< fun $p$ -> $e$ >>) - sel e - in - let p = <:patt< $lid:s$ >> in - (p, e) - | _ -> (ipatt_se se, e) ] -and match_case loc = - fun - [ Sexpr loc [Sexpr _ [Slid _ "when"; se; sew] :: sel] -> - (patt_se se, Some (expr_se sew), begin_se loc sel) - | Sexpr loc [se :: sel] -> (patt_se se, None, begin_se loc sel) - | se -> error se "match_case" ] -and label_expr_se loc = - fun - [ Sexpr _ [se1; se2] -> (patt_se se1, expr_se se2) - | se -> error se "label_expr" ] -and label_patt_se loc = - fun - [ Sexpr _ [se1; se2] -> (patt_se se1, patt_se se2) - | se -> error se "label_patt" ] -and parser_cases_se loc = - fun - [ [] -> <:expr< raise Stream.Failure >> - | [Sexpr loc [Sexpr _ spsel :: act] :: sel] -> - let ekont _ = parser_cases_se loc sel in - let act = - match act with - [ [se] -> expr_se se - | [sep; se] -> - let p = patt_se sep in - let e = expr_se se in - <:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >> - | _ -> error_loc loc "parser_case" ] - in - stream_pattern_se loc act ekont spsel - | [se :: _] -> error se "parser_case" ] -and stream_pattern_se loc act ekont = - fun - [ [] -> act - | [se :: sel] -> - let ckont err = <:expr< raise (Stream.Error $err$) >> in - let skont = stream_pattern_se loc act ckont sel in - stream_pattern_component skont ekont <:expr< "" >> se ] -and stream_pattern_component skont ekont err = - fun - [ Sexpr loc [Slid _ "`"; se :: wol] -> - let wo = - match wol with - [ [se] -> Some (expr_se se) - | [] -> None - | _ -> error_loc loc "stream_pattern_component" ] - in - let e = peek_fun loc in - let p = patt_se se in - let j = junk_fun loc in - let k = ekont err in - <:expr< match $e$ $lid:strm_n$ with - [ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ } - | _ -> $k$ ] >> - | Sexpr loc [se1; se2] -> - let p = patt_se se1 in - let e = - let e = expr_se se2 in - <:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >> - in - let k = ekont err in - <:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >> - | Sexpr loc [Slid _ "?"; se1; se2] -> - stream_pattern_component skont ekont (expr_se se2) se1 - | Slid loc s -> - let s = Pcaml.rename_id.val s in - <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >> - | se -> error se "stream_pattern_component" ] -and patt_se = - fun - [ Sacc loc se1 se2 -> - let p1 = patt_se se1 in - let p2 = patt_se se2 in - <:patt< $p1$ . $p2$ >> - | Slid loc "_" -> <:patt< _ >> - | Slid loc s -> <:patt< $lid:(Pcaml.rename_id.val s)$ >> - | Suid loc s -> <:patt< $uid:(Pcaml.rename_id.val s)$ >> - | Sint loc s -> <:patt< $int:s$ >> - | Sfloat loc s -> <:patt< $flo:s$ >> - | Schar loc s -> <:patt< $chr:s$ >> - | Sstring loc s -> <:patt< $str:s$ >> - | Stid loc _ -> error_loc loc "patt" - | Sqid loc _ -> error_loc loc "patt" - | Srec loc sel -> - let lpl = List.map (label_patt_se loc) sel in - <:patt< { $list:lpl$ } >> - | Sexpr loc [Slid _ ":"; se1; se2] -> - let p = patt_se se1 in - let t = ctyp_se se2 in - <:patt< ($p$ : $t$) >> - | Sexpr loc [Slid _ "or"; se :: sel] -> - List.fold_left - (fun p se -> - let p1 = patt_se se in - <:patt< $p$ | $p1$ >>) - (patt_se se) sel - | Sexpr loc [Slid _ "range"; se1; se2] -> - let p1 = patt_se se1 in - let p2 = patt_se se2 in - <:patt< $p1$ .. $p2$ >> - | Sexpr loc [Slid _ "values" :: sel] -> - let pl = List.map patt_se sel in - <:patt< ( $list:pl$ ) >> - | Sexpr loc [Slid _ "as"; se1; se2] -> - let p1 = patt_se se1 in - let p2 = patt_se se2 in - <:patt< ($p1$ as $p2$) >> - | Sexpr loc [se :: sel] -> - List.fold_left - (fun p se -> - let p1 = patt_se se in - <:patt< $p$ $p1$ >>) - (patt_se se) sel - | Sexpr loc [] -> <:patt< () >> - | Slist loc sel -> - let rec loop = - fun - [ [] -> <:patt< [] >> - | [se1; Slid _ "."; se2] -> - let p = patt_se se1 in - let pl = patt_se se2 in - <:patt< [$p$ :: $pl$] >> - | [se :: sel] -> - let p = patt_se se in - let pl = loop sel in - <:patt< [$p$ :: $pl$] >> ] - in - loop sel - | Squot loc typ txt -> Pcaml.handle_patt_quotation loc (typ, txt) ] -and ipatt_se se = - match ipatt_opt_se se with - [ Left p -> p - | Right (se, _) -> error se "ipatt" ] -and ipatt_opt_se = - fun - [ Slid loc "_" -> Left <:patt< _ >> - | Slid loc s -> Left <:patt< $lid:(Pcaml.rename_id.val s)$ >> - | Stid loc s -> Left <:patt< ~ $(Pcaml.rename_id.val s)$ >> - | Sqid loc s -> Left <:patt< ? $(Pcaml.rename_id.val s)$ >> - | Sexpr loc [Sqid _ s; se] -> - let s = Pcaml.rename_id.val s in - let e = expr_se se in - Left <:patt< ? ( $lid:s$ = $e$ ) >> - | Sexpr loc [Slid _ ":"; se1; se2] -> - let p = ipatt_se se1 in - let t = ctyp_se se2 in - Left <:patt< ($p$ : $t$) >> - | Sexpr loc [Slid _ "values" :: sel] -> - let pl = List.map ipatt_se sel in - Left <:patt< ( $list:pl$ ) >> - | Sexpr loc [] -> Left <:patt< () >> - | Sexpr loc [se :: sel] -> Right (se, sel) - | se -> error se "ipatt" ] -and type_declaration_list_se = - fun - [ [se1; se2 :: sel] -> - let (n1, loc1, tpl) = - match se1 with - [ Sexpr _ [Slid loc n :: sel] -> - (n, loc, List.map type_parameter_se sel) - | Slid loc n -> (n, loc, []) - | se -> error se "type declaration" ] - in - [((loc1, Pcaml.rename_id.val n1), tpl, ctyp_se se2, []) :: - type_declaration_list_se sel] - | [] -> [] - | [se :: _] -> error se "type_declaration" ] -and type_parameter_se = - fun - [ Slid _ s when String.length s >= 2 && s.[0] = ''' -> - (String.sub s 1 (String.length s - 1), (False, False)) - | se -> error se "type_parameter" ] -and ctyp_se = - fun - [ Sexpr loc [Slid _ "sum" :: sel] -> - let cdl = List.map constructor_declaration_se sel in - <:ctyp< [ $list:cdl$ ] >> - | Srec loc sel -> - let ldl = List.map label_declaration_se sel in - <:ctyp< { $list:ldl$ } >> - | Sexpr loc [Slid _ "->" :: ([_; _ :: _] as sel)] -> - let rec loop = - fun - [ [] -> assert False - | [se] -> ctyp_se se - | [se :: sel] -> - let t1 = ctyp_se se in - let loc = (fst (loc_of_sexpr se), snd loc) in - let t2 = loop sel in - <:ctyp< $t1$ -> $t2$ >> ] - in - loop sel - | Sexpr loc [Slid _ "*" :: sel] -> - let tl = List.map ctyp_se sel in - <:ctyp< ($list:tl$) >> - | Sexpr loc [se :: sel] -> - List.fold_left - (fun t se -> - let t2 = ctyp_se se in - <:ctyp< $t$ $t2$ >>) - (ctyp_se se) sel - | Sacc loc se1 se2 -> - let t1 = ctyp_se se1 in - let t2 = ctyp_se se2 in - <:ctyp< $t1$ . $t2$ >> - | Slid loc "_" -> <:ctyp< _ >> - | Slid loc s -> - if s.[0] = ''' then - let s = String.sub s 1 (String.length s - 1) in - <:ctyp< '$s$ >> - else <:ctyp< $lid:(Pcaml.rename_id.val s)$ >> - | Suid loc s -> <:ctyp< $uid:(Pcaml.rename_id.val s)$ >> - | se -> error se "ctyp" ] -and constructor_declaration_se = - fun - [ Sexpr loc [Suid _ ci :: sel] -> - (loc, Pcaml.rename_id.val ci, List.map ctyp_se sel) - | se -> error se "constructor_declaration" ] -and label_declaration_se = - fun - [ Sexpr loc [Slid _ lab; Slid _ "mutable"; se] -> - (loc, Pcaml.rename_id.val lab, True, ctyp_se se) - | Sexpr loc [Slid _ lab; se] -> - (loc, Pcaml.rename_id.val lab, False, ctyp_se se) - | se -> error se "label_declaration" ] -; - -value directive_se = - fun - [ Sexpr _ [Slid _ s] -> (s, None) - | Sexpr _ [Slid _ s; se] -> - let e = expr_se se in - (s, Some e) - | se -> error se "directive" ] -; - -(* Parser *) - -Pcaml.syntax_name.val := "Scheme"; -Pcaml.no_constructors_arity.val := False; - -do { - Grammar.Unsafe.gram_reinit gram (lexer_gmake ()); - Grammar.Unsafe.clear_entry interf; - Grammar.Unsafe.clear_entry implem; - Grammar.Unsafe.clear_entry top_phrase; - Grammar.Unsafe.clear_entry use_file; - Grammar.Unsafe.clear_entry module_type; - Grammar.Unsafe.clear_entry module_expr; - Grammar.Unsafe.clear_entry sig_item; - Grammar.Unsafe.clear_entry str_item; - Grammar.Unsafe.clear_entry expr; - Grammar.Unsafe.clear_entry patt; - Grammar.Unsafe.clear_entry ctyp; - Grammar.Unsafe.clear_entry let_binding; - Grammar.Unsafe.clear_entry type_declaration; - Grammar.Unsafe.clear_entry class_type; - Grammar.Unsafe.clear_entry class_expr; - Grammar.Unsafe.clear_entry class_sig_item; - Grammar.Unsafe.clear_entry class_str_item -}; - -Pcaml.parse_interf.val := Grammar.Entry.parse interf; -Pcaml.parse_implem.val := Grammar.Entry.parse implem; - -value sexpr = Grammar.Entry.create gram "sexpr"; - -value rec leftify = - fun - [ Sacc loc1 se1 se2 -> - match leftify se2 with - [ Sacc loc2 se2 se3 -> Sacc loc1 (Sacc loc2 se1 se2) se3 - | se2 -> Sacc loc1 se1 se2 ] - | x -> x ] -; - -EXTEND - GLOBAL: implem interf top_phrase use_file str_item sig_item expr patt sexpr; - implem: - [ [ "#"; se = sexpr -> - let (n, dp) = directive_se se in - ([(<:str_item< # $n$ $opt:dp$ >>, loc)], True) - | si = str_item; x = SELF -> - let (sil, stopped) = x in - let loc = MLast.loc_of_str_item si in - ([(si, loc) :: sil], stopped) - | EOI -> ([], False) ] ] - ; - interf: - [ [ "#"; se = sexpr -> - let (n, dp) = directive_se se in - ([(<:sig_item< # $n$ $opt:dp$ >>, loc)], True) - | si = sig_item; x = SELF -> - let (sil, stopped) = x in - let loc = MLast.loc_of_sig_item si in - ([(si, loc) :: sil], stopped) - | EOI -> ([], False) ] ] - ; - top_phrase: - [ [ "#"; se = sexpr -> - let (n, dp) = directive_se se in - Some <:str_item< # $n$ $opt:dp$ >> - | se = sexpr -> Some (str_item_se se) - | EOI -> None ] ] - ; - use_file: - [ [ "#"; se = sexpr -> - let (n, dp) = directive_se se in - ([<:str_item< # $n$ $opt:dp$ >>], True) - | si = str_item; x = SELF -> - let (sil, stopped) = x in - ([si :: sil], stopped) - | EOI -> ([], False) ] ] - ; - str_item: - [ [ se = sexpr -> str_item_se se - | e = expr -> <:str_item< $exp:e$ >> ] ] - ; - sig_item: - [ [ se = sexpr -> sig_item_se se ] ] - ; - expr: - [ "top" - [ se = sexpr -> expr_se se ] ] - ; - patt: - [ [ se = sexpr -> patt_se se ] ] - ; - sexpr: - [ [ se1 = sexpr_dot; se2 = SELF -> leftify (Sacc loc se1 se2) ] - | [ "("; sl = LIST0 sexpr; ")" -> Sexpr loc sl - | "("; sl = LIST0 sexpr; ")."; se = SELF -> - leftify (Sacc loc (Sexpr loc sl) se) - | "["; sl = LIST0 sexpr; "]" -> Slist loc sl - | "{"; sl = LIST0 sexpr; "}" -> Srec loc sl - | a = pa_extend_keyword -> Slid loc a - | s = LIDENT -> Slid loc s - | s = UIDENT -> Suid loc s - | s = TILDEIDENT -> Stid loc s - | s = QUESTIONIDENT -> Sqid loc s - | s = INT -> Sint loc s - | s = FLOAT -> Sfloat loc s - | s = CHAR -> Schar loc s - | s = STRING -> Sstring loc s - | s = QUOT -> - let i = String.index s ':' in - let typ = String.sub s 0 i in - let txt = String.sub s (i + 1) (String.length s - i - 1) in - Squot loc typ txt ] ] - ; - sexpr_dot: - [ [ s = LIDENTDOT -> Slid loc s - | s = UIDENTDOT -> Suid loc s ] ] - ; - pa_extend_keyword: - [ [ "_" -> "_" - | "," -> "," - | "=" -> "=" - | ":" -> ":" - | "." -> "." - | "/" -> "/" ] ] - ; -END; diff --git a/camlp4/unmaintained/scheme/pa_scheme.sc b/camlp4/unmaintained/scheme/pa_scheme.sc deleted file mode 100644 index fbad5244..00000000 --- a/camlp4/unmaintained/scheme/pa_scheme.sc +++ /dev/null @@ -1,1030 +0,0 @@ -; pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo -; ********************************************************************** -; -; Camlp4 -; -; Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt -; -; Copyright 2002 Institut National de Recherche en Informatique et -; en Automatique. All rights reserved. This file is distributed -; under the terms of the GNU Library General Public License, with -; the special exception on linking described in file -; ../../../LICENSE. -; -; ********************************************************************** -; $Id: pa_scheme.sc,v 1.2 2004/07/13 12:25:08 xleroy Exp $ - -(open Pcaml) -(open Stdpp) - -(type (choice 'a 'b) (sum (Left 'a) (Right 'b))) - -; Buffer - -(module Buff - (struct - (define buff (ref (String.create 80))) - (define (store len x) - (if (>= len (String.length buff.val)) - (:= buff.val (^ buff.val (String.create (String.length buff.val))))) - (:= buff.val.[len] x) - (succ len)) - (define (get len) (String.sub buff.val 0 len)))) - -; Lexer - -(definerec skip_to_eol - (parser - (((` (or '\n' '\r'))) ()) - (((` _) s) (skip_to_eol s)))) - -(define no_ident ['(' ')' '[' ']' '{' '}' ' ' '\t' '\n' '\r' ';']) - -(definerec (ident len) - (parser - (((` '.')) (values (Buff.get len) True)) - (((` x (not (List.mem x no_ident))) s) (ident (Buff.store len x) s)) - (() (values (Buff.get len) False)))) - -(define (identifier kwt (values s dot)) - (let ((con - (try (begin (: (Hashtbl.find kwt s) unit) "") - (Not_found - (match s.[0] - ((range 'A' 'Z') (if dot "UIDENTDOT" "UIDENT")) - (_ (if dot "LIDENTDOT" "LIDENT"))))))) - (values con s))) - -(definerec (string len) - (parser - (((` '"')) (Buff.get len)) - (((` '\\') (` c) s) (string (Buff.store (Buff.store len '\\') c) s)) - (((` x) s) (string (Buff.store len x) s)))) - -(definerec (end_exponent_part_under len) - (parser - (((` (as (range '0' '9') c)) s) - (end_exponent_part_under (Buff.store len c) s)) - (() (values "FLOAT" (Buff.get len))))) - -(define (end_exponent_part len) - (parser - (((` (as (range '0' '9') c)) s) - (end_exponent_part_under (Buff.store len c) s)) - (() (raise (Stream.Error "ill-formed floating-point constant"))))) - -(define (exponent_part len) - (parser - (((` (as (or '+' '-') c)) s) (end_exponent_part (Buff.store len c) s)) - (((a (end_exponent_part len))) a))) - -(definerec (decimal_part len) - (parser - (((` (as (range '0' '9') c)) s) (decimal_part (Buff.store len c) s)) - (((` (or 'e' 'E')) s) (exponent_part (Buff.store len 'E') s)) - (() (values "FLOAT" (Buff.get len))))) - -(definerec (number len) - (parser - (((` (as (range '0' '9') c)) s) (number (Buff.store len c) s)) - (((` '.') s) (decimal_part (Buff.store len '.') s)) - (((` (or 'e' 'E')) s) (exponent_part (Buff.store len 'E') s)) - (() (values "INT" (Buff.get len))))) - -(define binary - (parser - (((` (as (range '0' '1') c))) c))) - -(define octal - (parser - (((` (as (range '0' '7') c))) c))) - -(define hexa - (parser - (((` (as (or (range '0' '9') (range 'a' 'f') (range 'A' 'F')) c))) c))) - -(definerec (digits_under kind len) - (parser - (((d kind) s) (digits_under kind (Buff.store len d) s)) - (() (Buff.get len)))) - -(define (digits kind bp len) - (parser - (((d kind) s) (values "INT" (digits_under kind (Buff.store len d) s))) - ((s) ep - (raise_with_loc (values - (Reloc.shift_pos bp Reloc.zero_loc) - (Reloc.shift_pos ep Reloc.zero_loc)) - (Failure "ill-formed integer constant"))))) - -(define (base_number kwt bp len) - (parser - (((` (or 'b' 'B')) s) (digits binary bp (Buff.store len 'b') s)) - (((` (or 'o' 'O')) s) (digits octal bp (Buff.store len 'o') s)) - (((` (or 'x' 'X')) s) (digits hexa bp (Buff.store len 'x') s)) - (((id (ident (Buff.store 0 '#')))) (identifier kwt id)))) - -(definerec (operator len) - (parser - (((` '.')) (Buff.get (Buff.store len '.'))) - (() (Buff.get len)))) - -(define (char_or_quote_id x) - (parser - (((` ''')) (values "CHAR" (String.make 1 x))) - ((s) ep - (if (List.mem x no_ident) - (Stdpp.raise_with_loc (values - (Reloc.shift_pos (- ep 2) Reloc.zero_loc) - (Reloc.shift_pos (- ep 1) Reloc.zero_loc)) - (Stream.Error "bad quote")) - (let* ((len (Buff.store (Buff.store 0 ''') x)) - ((values s dot) (ident len s))) - (values (if dot "LIDENTDOT" "LIDENT") s)))))) - -(definerec (char len) - (parser - (((` ''')) len) - (((` x) s) (char (Buff.store len x) s)))) - -(define quote - (parser - (((` '\\') (len (char (Buff.store 0 '\\')))) - (values "CHAR" (Buff.get len))) - (((` x) s) (char_or_quote_id x s)))) - -; The system with LIDENTDOT and UIDENTDOT is not great (it would be -; better to have a token DOT (actually SPACEDOT and DOT)) but it is -; the only way (that I have found) to have a good behaviour in the -; toplevel (not expecting tokens after a phrase). Drawbacks: 1/ to be -; complete, we should have STRINGDOT, RIGHTPARENDOT, and so on 2/ the -; parser rule with dot is right associative and we have to reverse -; the resulting tree (using the function leftify). -; This is a complicated issue: the behaviour of the OCaml toplevel -; is strange, anyway. For example, even without Camlp4, The OCaml -; toplevel accepts that: -; # let x = 32;; foo bar match let ) - -(definerec* - ((lexer kwt) - (parser - (((t (lexer0 kwt)) - (_ no_dot)) t))) - (no_dot - (parser - (((` '.')) ep - (Stdpp.raise_with_loc (values - (Reloc.shift_pos (- ep 1) Reloc.zero_loc) - (Reloc.shift_pos ep Reloc.zero_loc)) - (Stream.Error "bad dot"))) - (() ()))) - ((lexer0 kwt) - (parser bp - (((` (or '\t' '\n' '\r')) s) (lexer0 kwt s)) - (((` ' ') s) (after_space kwt s)) - (((` ';') (_ skip_to_eol) s) (lexer kwt s)) - (((` '(')) (values (values "" "(") (values bp (+ bp 1)))) - (((` ')') s) ep (values (values "" (rparen s)) (values bp ep))) - (((` '[')) (values (values "" "[") (values bp (+ bp 1)))) - (((` ']')) (values (values "" "]") (values bp (+ bp 1)))) - (((` '{')) (values (values "" "{") (values bp (+ bp 1)))) - (((` '}')) (values (values "" "}") (values bp (+ bp 1)))) - (((` '"') (s (string 0))) ep - (values (values "STRING" s) (values bp ep))) - (((` ''') (tok quote)) ep (values tok (values bp ep))) - (((` '<') (tok (less kwt))) ep (values tok (values bp ep))) - (((` '-') (tok (minus kwt))) ep (values tok (values bp ep))) - (((` '~') (tok tilde)) ep (values tok (values bp ep))) - (((` '?') (tok question)) ep (values tok (values bp ep))) - (((` '#') (tok (base_number kwt bp (Buff.store 0 '0')))) ep - (values tok (values bp ep))) - (((` (as (range '0' '9') c)) (tok (number (Buff.store 0 c)))) ep - (values tok (values bp ep))) - (((` (as (or '+' '*' '/') c)) (id (operator (Buff.store 0 c)))) ep - (values (identifier kwt (values id False)) (values bp ep))) - (((` x) (id (ident (Buff.store 0 x)))) ep - (values (identifier kwt id) (values bp ep))) - (() (values (values "EOI" "") (values bp (+ bp 1)))))) - (rparen - (parser - (((` '.')) ").") - ((_) ")"))) - ((after_space kwt) - (parser - (((` '.')) ep (values (values "" ".") (values (- ep 1) ep))) - (((x (lexer0 kwt))) x))) - (tilde - (parser - (((` (as (range 'a' 'z') c)) ((values s dot) (ident (Buff.store 0 c)))) - (values "TILDEIDENT" s)) - (() (values "LIDENT" "~")))) - (question - (parser - (((` (as (range 'a' 'z') c)) ((values s dot) (ident (Buff.store 0 c)))) - (values "QUESTIONIDENT" s)) - (() (values "LIDENT" "?")))) - ((minus kwt) - (parser - (((` '.')) (identifier kwt (values "-." False))) - (((` (as (range '0' '9') c)) - (n (number (Buff.store (Buff.store 0 '-') c)))) ep n) - (((id (ident (Buff.store 0 '-')))) (identifier kwt id)))) - ((less kwt) - (parser - (((` ':') (lab (label 0)) (? (` '<') "'<' expected") (q (quotation 0))) - (values "QUOT" (^ lab ":" q))) - (((id (ident (Buff.store 0 '<')))) (identifier kwt id)))) - ((label len) - (parser - (((` (as (or (range 'a' 'z') (range 'A' 'Z') '_') c)) s) - (label (Buff.store len c) s)) - (() (Buff.get len)))) - ((quotation len) - (parser - (((` '>') s) (quotation_greater len s)) - (((` x) s) (quotation (Buff.store len x) s)) - (() (failwith "quotation not terminated")))) - ((quotation_greater len) - (parser - (((` '>')) (Buff.get len)) - (((a (quotation (Buff.store len '>')))) a)))) - -(define (lexer_using kwt (values con prm)) - (match con - ((or "CHAR" "EOI" "INT" "FLOAT" "LIDENT" "LIDENTDOT" "QUESTIONIDENT" - "QUOT" "STRING" "TILDEIDENT" "UIDENT" "UIDENTDOT") - ()) - ("ANTIQUOT" ()) - ("" (try (Hashtbl.find kwt prm) (Not_found (Hashtbl.add kwt prm ())))) - (_ - (raise - (Token.Error - (^ "the constructor \"" con "\" is not recognized by Plexer")))))) - -(define (lexer_text (values con prm)) - (cond - ((= con "") (^ "'"prm "'")) - ((= prm "") con) - (else (^ con " \"" prm "\"")))) - -(define (lexer_gmake ()) - (let ((kwt (Hashtbl.create 89))) - {(Token.tok_func - (Token.lexer_func_of_parser - (lambda (s) - (let (((values r (values bp ep)) (lexer kwt s))) - (values r (values (Reloc.shift_pos bp Reloc.zero_loc) - (Reloc.shift_pos ep Reloc.zero_loc))))))) - (Token.tok_using (lexer_using kwt)) - (Token.tok_removing (lambda)) - (Token.tok_match Token.default_match) - (Token.tok_text lexer_text) - (Token.tok_comm None)})) - -; Building AST - -(type sexpr - (sum - (Sacc MLast.loc sexpr sexpr) - (Schar MLast.loc string) - (Sexpr MLast.loc (list sexpr)) - (Sint MLast.loc string) - (Sfloat MLast.loc string) - (Slid MLast.loc string) - (Slist MLast.loc (list sexpr)) - (Sqid MLast.loc string) - (Squot MLast.loc string string) - (Srec MLast.loc (list sexpr)) - (Sstring MLast.loc string) - (Stid MLast.loc string) - (Suid MLast.loc string))) - -(define loc_of_sexpr - (lambda_match - ((or (Sacc loc _ _) (Schar loc _) (Sexpr loc _) (Sint loc _) - (Sfloat loc _) (Slid loc _) (Slist loc _) (Sqid loc _) (Squot loc _ _) - (Srec loc _) (Sstring loc _) (Stid loc _) (Suid loc _)) - loc))) -(define (error_loc loc err) - (raise_with_loc loc (Stream.Error (^ err " expected")))) -(define (error se err) (error_loc (loc_of_sexpr se) err)) - -(define strm_n "strm__") -(define (peek_fun loc) <:expr< Stream.peek >>) -(define (junk_fun loc) <:expr< Stream.junk >>) - -(define assoc_left_parsed_op_list ["+" "*" "+." "*." "land" "lor" "lxor"]) -(define assoc_right_parsed_op_list ["and" "or" "^" "@"]) -(define and_by_couple_op_list ["=" "<>" "<" ">" "<=" ">=" "==" "!="]) - -(define (op_apply loc e1 e2) - (lambda_match - ("and" <:expr< $e1$ && $e2$ >>) - ("or" <:expr< $e1$ || $e2$ >>) - (x <:expr< $lid:x$ $e1$ $e2$ >>))) - -(define string_se - (lambda_match - ((Sstring loc s) s) - (se (error se "string")))) - -(define mod_ident_se - (lambda_match - ((Suid _ s) [(Pcaml.rename_id.val s)]) - ((Slid _ s) [(Pcaml.rename_id.val s)]) - (se (error se "mod_ident")))) - -(define (lident_expr loc s) - (if (&& (> (String.length s) 1) (= s.[0] '`')) - (let ((s (String.sub s 1 (- (String.length s) 1)))) - <:expr< ` $s$ >>) - <:expr< $lid:(Pcaml.rename_id.val s)$ >>)) - -(definerec* - (module_expr_se - (lambda_match - ((Sexpr loc [(Slid _ "functor") (Suid _ s) se1 se2]) - (let* ((s (Pcaml.rename_id.val s)) - (mt (module_type_se se1)) - (me (module_expr_se se2))) - <:module_expr< functor ($s$ : $mt$) -> $me$ >>)) - ((Sexpr loc [(Slid _ "struct") . sl]) - (let ((mel (List.map str_item_se sl))) - <:module_expr< struct $list:mel$ end >>)) - ((Sexpr loc [se1 se2]) - (let* ((me1 (module_expr_se se1)) - (me2 (module_expr_se se2))) - <:module_expr< $me1$ $me2$ >>)) - ((Suid loc s) <:module_expr< $uid:(Pcaml.rename_id.val s)$ >>) - (se (error se "module expr")))) - (module_type_se - (lambda_match - ((Sexpr loc [(Slid _ "functor") (Suid _ s) se1 se2]) - (let* ((s (Pcaml.rename_id.val s)) - (mt1 (module_type_se se1)) - (mt2 (module_type_se se2))) - <:module_type< functor ($s$ : $mt1$) -> $mt2$ >>)) - ((Sexpr loc [(Slid _ "sig") . sel]) - (let ((sil (List.map sig_item_se sel))) - <:module_type< sig $list:sil$ end >>)) - ((Sexpr loc [(Slid _ "with") se (Sexpr _ sel)]) - (let* ((mt (module_type_se se)) - (wcl (List.map with_constr_se sel))) - <:module_type< $mt$ with $list:wcl$ >>)) - ((Suid loc s) <:module_type< $uid:(Pcaml.rename_id.val s)$ >>) - (se (error se "module type")))) - (with_constr_se - (lambda_match - ((Sexpr loc [(Slid _ "type") se1 se2]) - (let* ((tn (mod_ident_se se1)) - (te (ctyp_se se2))) - (MLast.WcTyp loc tn [] te))) - (se (error se "with constr")))) - (sig_item_se - (lambda_match - ((Sexpr loc [(Slid _ "type") . sel]) - (let ((tdl (type_declaration_list_se sel))) - <:sig_item< type $list:tdl$ >>)) - ((Sexpr loc [(Slid _ "exception") (Suid _ c) . sel]) - (let* ((c (Pcaml.rename_id.val c)) - (tl (List.map ctyp_se sel))) - <:sig_item< exception $c$ of $list:tl$ >>)) - ((Sexpr loc [(Slid _ "value") (Slid _ s) se]) - (let* ((s (Pcaml.rename_id.val s)) - (t (ctyp_se se))) - <:sig_item< value $s$ : $t$ >>)) - ((Sexpr loc [(Slid _ "external") (Slid _ i) se . sel]) - (let* ((i (Pcaml.rename_id.val i)) - (pd (List.map string_se sel)) - (t (ctyp_se se))) - <:sig_item< external $i$ : $t$ = $list:pd$ >>)) - ((Sexpr loc [(Slid _ "module") (Suid _ s) se]) - (let* ((s (Pcaml.rename_id.val s)) - (mb (module_type_se se))) - <:sig_item< module $s$ : $mb$ >>)) - ((Sexpr loc [(Slid _ "moduletype") (Suid _ s) se]) - (let* ((s (Pcaml.rename_id.val s)) - (mt (module_type_se se))) - <:sig_item< module type $s$ = $mt$ >>)) - (se (error se "sig item")))) - ((str_item_se se) - (match se - ((Sexpr loc [(Slid _ "open") se]) - (let ((s (mod_ident_se se))) <:str_item< open $s$ >>)) - ((Sexpr loc [(Slid _ "type") . sel]) - (let ((tdl (type_declaration_list_se sel))) - <:str_item< type $list:tdl$ >>)) - ((Sexpr loc [(Slid _ "exception") (Suid _ c) . sel]) - (let* ((c (Pcaml.rename_id.val c)) - (tl (List.map ctyp_se sel))) - <:str_item< exception $c$ of $list:tl$ >>)) - ((Sexpr loc [(Slid _ (as (or "define" "definerec") r)) se . sel]) - (let* ((r (= r "definerec")) - ((values p e) (fun_binding_se se (begin_se loc sel)))) - <:str_item< value $opt:r$ $p$ = $e$ >>)) - ((Sexpr loc [(Slid _ (as (or "define*" "definerec*") r)) . sel]) - (let* ((r (= r "definerec*")) - (lbs (List.map let_binding_se sel))) - <:str_item< value $opt:r$ $list:lbs$ >>)) - ((Sexpr loc [(Slid _ "external") (Slid _ i) se . sel]) - (let* ((i (Pcaml.rename_id.val i)) - (pd (List.map string_se sel)) - (t (ctyp_se se))) - <:str_item< external $i$ : $t$ = $list:pd$ >>)) - ((Sexpr loc [(Slid _ "module") (Suid _ i) se]) - (let* ((i (Pcaml.rename_id.val i)) - (mb (module_binding_se se))) - <:str_item< module $i$ = $mb$ >>)) - ((Sexpr loc [(Slid _ "moduletype") (Suid _ s) se]) - (let* ((s (Pcaml.rename_id.val s)) - (mt (module_type_se se))) - <:str_item< module type $s$ = $mt$ >>)) - (_ - (let* ((loc (loc_of_sexpr se)) - (e (expr_se se))) - <:str_item< $exp:e$ >>)))) - ((module_binding_se se) (module_expr_se se)) - (expr_se - (lambda_match - ((Sacc loc se1 se2) - (let ((e1 (expr_se se1))) - (match se2 - ((Slist loc [se2]) - (let ((e2 (expr_se se2))) <:expr< $e1$ .[ $e2$ ] >>)) - ((Sexpr loc [se2]) - (let ((e2 (expr_se se2))) <:expr< $e1$ .( $e2$ ) >>)) - (_ (let ((e2 (expr_se se2))) <:expr< $e1$ . $e2$ >>))))) - ((Slid loc s) (lident_expr loc s)) - ((Suid loc s) <:expr< $uid:(Pcaml.rename_id.val s)$ >>) - ((Sint loc s) <:expr< $int:s$ >>) - ((Sfloat loc s) <:expr< $flo:s$ >>) - ((Schar loc s) <:expr< $chr:s$ >>) - ((Sstring loc s) <:expr< $str:s$ >>) - ((Stid loc s) <:expr< ~ $(Pcaml.rename_id.val s)$ >>) - ((Sqid loc s) <:expr< ? $(Pcaml.rename_id.val s)$ >>) - ((Sexpr loc []) <:expr< () >>) - ((when (Sexpr loc [(Slid _ s) e1 . (as [_ . _] sel)]) - (List.mem s assoc_left_parsed_op_list)) - (letrec - (((loop e1) - (lambda_match - ([] e1) - ([e2 . el] (loop (op_apply loc e1 e2 s) el))))) - (loop (expr_se e1) (List.map expr_se sel)))) - ((when (Sexpr loc [(Slid _ s) . (as [_ _ . _] sel)]) - (List.mem s assoc_right_parsed_op_list)) - (letrec - ((loop - (lambda_match - ([] - (assert False)) - ([e1] e1) - ([e1 . el] (let ((e2 (loop el))) (op_apply loc e1 e2 s)))))) - (loop (List.map expr_se sel)))) - ((when (Sexpr loc [(Slid _ s) . (as [_ _ . _] sel)]) - (List.mem s and_by_couple_op_list)) - (letrec - ((loop - (lambda_match - ((or [] [_]) (assert False)) - ([e1 e2] <:expr< $lid:s$ $e1$ $e2$ >>) - ([e1 . (as [e2 _ . _] el)] - (let* ((a1 (op_apply loc e1 e2 s)) - (a2 (loop el))) - <:expr< $a1$ && $a2$ >>))))) - (loop (List.map expr_se sel)))) - ((Sexpr loc [(Stid _ s) se]) - (let ((e (expr_se se))) <:expr< ~ $s$ : $e$ >>)) - ((Sexpr loc [(Slid _ "-") se]) - (let ((e (expr_se se))) <:expr< - $e$ >>)) - ((Sexpr loc [(Slid _ "if") se se1]) - (let* ((e (expr_se se)) - (e1 (expr_se se1))) - <:expr< if $e$ then $e1$ else () >>)) - ((Sexpr loc [(Slid _ "if") se se1 se2]) - (let* ((e (expr_se se)) - (e1 (expr_se se1)) - (e2 (expr_se se2))) - <:expr< if $e$ then $e1$ else $e2$ >>)) - ((Sexpr loc [(Slid _ "cond") . sel]) - (letrec - ((loop - (lambda_match - ([(Sexpr loc [(Slid _ "else") . sel])] (begin_se loc sel)) - ([(Sexpr loc [se1 . sel1]) . sel] - (let* ((e1 (expr_se se1)) - (e2 (begin_se loc sel1)) - (e3 (loop sel))) - <:expr< if $e1$ then $e2$ else $e3$ >>)) - ([] <:expr< () >>) - ([se . _] (error se "cond clause"))))) - (loop sel))) - ((Sexpr loc [(Slid _ "while") se . sel]) - (let* ((e (expr_se se)) - (el (List.map expr_se sel))) - <:expr< while $e$ do { $list:el$ } >>)) - ((Sexpr loc [(Slid _ "for") (Slid _ i) se1 se2 . sel]) - (let* ((i (Pcaml.rename_id.val i)) - (e1 (expr_se se1)) - (e2 (expr_se se2)) - (el (List.map expr_se sel))) - <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >>)) - ((Sexpr loc [(Slid loc1 "lambda")]) <:expr< fun [] >>) - ((Sexpr loc [(Slid loc1 "lambda") sep . sel]) - (let ((e (begin_se loc1 sel))) - (match (ipatt_opt_se sep) - ((Left p) <:expr< fun $p$ -> $e$ >>) - ((Right (values se sel)) - (List.fold_right - (lambda (se e) - (let ((p (ipatt_se se))) <:expr< fun $p$ -> $e$ >>)) - [se . sel] e))))) - ((Sexpr loc [(Slid _ "lambda_match") . sel]) - (let ((pel (List.map (match_case loc) sel))) - <:expr< fun [ $list:pel$ ] >>)) - ((Sexpr loc [(Slid _ (as (or "let" "letrec") r)) . sel]) - (match sel - ([(Sexpr _ sel1) . sel2] - (let* ((r (= r "letrec")) - (lbs (List.map let_binding_se sel1)) - (e (begin_se loc sel2))) - <:expr< let $opt:r$ $list:lbs$ in $e$ >>)) - ([(Slid _ n) (Sexpr _ sl) . sel] - (let* ((n (Pcaml.rename_id.val n)) - ((values pl el) - (List.fold_right - (lambda (se (values pl el)) - (match se - ((Sexpr _ [se1 se2]) - (values [(patt_se se1) . pl] - [(expr_se se2) . el])) - (se (error se "named let")))) - sl (values [] []))) - (e1 - (List.fold_right - (lambda (p e) <:expr< fun $p$ -> $e$ >>) - pl (begin_se loc sel))) - (e2 - (List.fold_left - (lambda (e1 e2) <:expr< $e1$ $e2$ >>) - <:expr< $lid:n$ >> el))) - <:expr< let rec $lid:n$ = $e1$ in $e2$ >>)) - ([se . _] (error se "let_binding")) - (_ (error_loc loc "let_binding")))) - ((Sexpr loc [(Slid _ "let*") . sel]) - (match sel - ([(Sexpr _ sel1) . sel2] - (List.fold_right - (lambda (se ek) - (let (((values p e) (let_binding_se se))) - <:expr< let $p$ = $e$ in $ek$ >>)) - sel1 (begin_se loc sel2))) - ([se . _] (error se "let_binding")) - (_ (error_loc loc "let_binding")))) - ((Sexpr loc [(Slid _ "match") se . sel]) - (let* ((e (expr_se se)) - (pel (List.map (match_case loc) sel))) - <:expr< match $e$ with [ $list:pel$ ] >>)) - ((Sexpr loc [(Slid _ "parser") . sel]) - (let ((e - (match sel - ([(as (Slid _ _) se) . sel] - (let* ((p (patt_se se)) - (pc (parser_cases_se loc sel))) - <:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >>)) - (_ (parser_cases_se loc sel))))) - <:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >>)) - ((Sexpr loc [(Slid _ "match_with_parser") se . sel]) - (let* ((me (expr_se se)) - ((values bpo sel) - (match sel - ([(as (Slid _ _) se) . sel] (values (Some (patt_se se)) sel)) - (_ (values None sel)))) - (pc (parser_cases_se loc sel)) - (e - (match bpo - ((Some bp) - <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>) - (None pc)))) - (match me - ((when <:expr< $lid:x$ >> (= x strm_n)) e) - (_ <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >>)))) - ((Sexpr loc [(Slid _ "try") se . sel]) - (let* ((e (expr_se se)) - (pel (List.map (match_case loc) sel))) - <:expr< try $e$ with [ $list:pel$ ] >>)) - ((Sexpr loc [(Slid _ "begin") . sel]) - (let ((el (List.map expr_se sel))) <:expr< do { $list:el$ } >>)) - ((Sexpr loc [(Slid _ ":=") se1 se2]) - (let* ((e1 (expr_se se1)) - (e2 (expr_se se2))) - <:expr< $e1$ := $e2$ >>)) - ((Sexpr loc [(Slid _ "values") . sel]) - (let ((el (List.map expr_se sel))) <:expr< ( $list:el$ ) >>)) - ((Srec loc [(Slid _ "with") se . sel]) - (let* ((e (expr_se se)) - (lel (List.map (label_expr_se loc) sel))) - <:expr< { ($e$) with $list:lel$ } >>)) - ((Srec loc sel) - (let ((lel (List.map (label_expr_se loc) sel))) - <:expr< { $list:lel$ } >>)) - ((Sexpr loc [(Slid _ ":") se1 se2]) - (let* ((e (expr_se se1)) (t (ctyp_se se2))) <:expr< ( $e$ : $t$ ) >>)) - ((Sexpr loc [se]) (let ((e (expr_se se))) <:expr< $e$ () >>)) - ((Sexpr loc [(Slid _ "assert") (Suid _ "False")]) - <:expr< assert False >>) - ((Sexpr loc [(Slid _ "assert") se]) - (let ((e (expr_se se))) <:expr< assert $e$ >>)) - ((Sexpr loc [(Slid _ "lazy") se]) - (let ((e (expr_se se))) <:expr< lazy $e$ >>)) - ((Sexpr loc [se . sel]) - (List.fold_left - (lambda (e se) (let ((e1 (expr_se se))) <:expr< $e$ $e1$ >>)) - (expr_se se) sel)) - ((Slist loc sel) - (letrec ((loop - (lambda_match - ([] <:expr< [] >>) - ([se1 (Slid _ ".") se2] - (let* ((e (expr_se se1)) - (el (expr_se se2))) - <:expr< [$e$ :: $el$] >>)) - ([se . sel] - (let* ((e (expr_se se)) - (el (loop sel))) - <:expr< [$e$ :: $el$] >>))))) - (loop sel))) - ((Squot loc typ txt) - (Pcaml.handle_expr_quotation loc (values typ txt))))) - ((begin_se loc) - (lambda_match - ([] <:expr< () >>) - ([se] (expr_se se)) - ((sel) - (let* ((el (List.map expr_se sel)) - (loc (values (fst (loc_of_sexpr (List.hd sel))) (snd loc)))) - <:expr< do { $list:el$ } >>)))) - (let_binding_se - (lambda_match - ((Sexpr loc [se . sel]) - (let ((e (begin_se loc sel))) - (match (ipatt_opt_se se) - ((Left p) (values p e)) - ((Right _) (fun_binding_se se e))))) - (se (error se "let_binding")))) - ((fun_binding_se se e) - (match se - ((Sexpr _ [(Slid _ "values") . _]) (values (ipatt_se se) e)) - ((Sexpr _ [(Slid loc s) . sel]) - (let* ((s (Pcaml.rename_id.val s)) - (e - (List.fold_right - (lambda (se e) - (let* ((loc - (values (fst (loc_of_sexpr se)) - (snd (MLast.loc_of_expr e)))) - (p (ipatt_se se))) - <:expr< fun $p$ -> $e$ >>)) - sel e)) - (p <:patt< $lid:s$ >>)) - (values p e))) - ((_) (values (ipatt_se se) e)))) - ((match_case loc) - (lambda_match - ((Sexpr loc [(Sexpr _ [(Slid _ "when") se sew]) . sel]) - (values (patt_se se) (Some (expr_se sew)) (begin_se loc sel))) - ((Sexpr loc [se . sel]) - (values (patt_se se) None (begin_se loc sel))) - (se (error se "match_case")))) - ((label_expr_se loc) - (lambda_match - ((Sexpr _ [se1 se2]) (values (patt_se se1) (expr_se se2))) - (se (error se "label_expr")))) - ((label_patt_se loc) - (lambda_match - ((Sexpr _ [se1 se2]) (values (patt_se se1) (patt_se se2))) - (se (error se "label_patt")))) - ((parser_cases_se loc) - (lambda_match - ([] <:expr< raise Stream.Failure >>) - ([(Sexpr loc [(Sexpr _ spsel) . act]) . sel] - (let* ((ekont (lambda _ (parser_cases_se loc sel))) - (act (match act - ([se] (expr_se se)) - ([sep se] - (let* ((p (patt_se sep)) - (e (expr_se se))) - <:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >>)) - (_ (error_loc loc "parser_case"))))) - (stream_pattern_se loc act ekont spsel))) - ([se . _] - (error se "parser_case")))) - ((stream_pattern_se loc act ekont) - (lambda_match - ([] act) - ([se . sel] - (let* ((ckont (lambda err <:expr< raise (Stream.Error $err$) >>)) - (skont (stream_pattern_se loc act ckont sel))) - (stream_pattern_component skont ekont <:expr< "" >> se))))) - ((stream_pattern_component skont ekont err) - (lambda_match - ((Sexpr loc [(Slid _ "`") se . wol]) - (let* ((wo (match wol - ([se] (Some (expr_se se))) - ([] None) - (_ (error_loc loc "stream_pattern_component")))) - (e (peek_fun loc)) - (p (patt_se se)) - (j (junk_fun loc)) - (k (ekont err))) - <:expr< match $e$ $lid:strm_n$ with - [ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ } - | _ -> $k$ ] >>)) - ((Sexpr loc [se1 se2]) - (let* ((p (patt_se se1)) - (e (let ((e (expr_se se2))) - <:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >>)) - (k (ekont err))) - <:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >>)) - ((Sexpr loc [(Slid _ "?") se1 se2]) - (stream_pattern_component skont ekont (expr_se se2) se1)) - ((Slid loc s) - (let ((s (Pcaml.rename_id.val s))) - <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >>)) - (se - (error se "stream_pattern_component")))) - (patt_se - (lambda_match - ((Sacc loc se1 se2) - (let* ((p1 (patt_se se1)) (p2 (patt_se se2))) <:patt< $p1$ . $p2$ >>)) - ((Slid loc "_") <:patt< _ >>) - ((Slid loc s) <:patt< $lid:(Pcaml.rename_id.val s)$ >>) - ((Suid loc s) <:patt< $uid:(Pcaml.rename_id.val s)$ >>) - ((Sint loc s) <:patt< $int:s$ >>) - ((Sfloat loc s) <:patt< $flo:s$ >>) - ((Schar loc s) <:patt< $chr:s$ >>) - ((Sstring loc s) <:patt< $str:s$ >>) - ((Stid loc _) (error_loc loc "patt")) - ((Sqid loc _) (error_loc loc "patt")) - ((Srec loc sel) - (let ((lpl (List.map (label_patt_se loc) sel))) - <:patt< { $list:lpl$ } >>)) - ((Sexpr loc [(Slid _ ":") se1 se2]) - (let* ((p (patt_se se1)) (t (ctyp_se se2))) <:patt< ($p$ : $t$) >>)) - ((Sexpr loc [(Slid _ "or") se . sel]) - (List.fold_left - (lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ | $p1$ >>)) - (patt_se se) sel)) - ((Sexpr loc [(Slid _ "range") se1 se2]) - (let* ((p1 (patt_se se1)) (p2 (patt_se se2))) <:patt< $p1$ .. $p2$ >>)) - ((Sexpr loc [(Slid _ "values") . sel]) - (let ((pl (List.map patt_se sel))) <:patt< ( $list:pl$ ) >>)) - ((Sexpr loc [(Slid _ "as") se1 se2]) - (let* ((p1 (patt_se se1)) - (p2 (patt_se se2))) - <:patt< ($p1$ as $p2$) >>)) - ((Sexpr loc [se . sel]) - (List.fold_left - (lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ $p1$ >>)) - (patt_se se) sel)) - ((Sexpr loc []) <:patt< () >>) - ((Slist loc sel) - (letrec ((loop - (lambda_match - ([] <:patt< [] >>) - ([se1 (Slid _ ".") se2] - (let* ((p (patt_se se1)) - (pl (patt_se se2))) - <:patt< [$p$ :: $pl$] >>)) - ([se . sel] - (let* ((p (patt_se se)) - (pl (loop sel))) - <:patt< [$p$ :: $pl$] >>))))) - (loop sel))) - ((Squot loc typ txt) - (Pcaml.handle_patt_quotation loc (values typ txt))))) - ((ipatt_se se) - (match (ipatt_opt_se se) - ((Left p) p) - ((Right (values se _)) (error se "ipatt")))) - (ipatt_opt_se - (lambda_match - ((Slid loc "_") (Left <:patt< _ >>)) - ((Slid loc s) (Left <:patt< $lid:(Pcaml.rename_id.val s)$ >>)) - ((Stid loc s) (Left <:patt< ~ $(Pcaml.rename_id.val s)$ >>)) - ((Sqid loc s) (Left <:patt< ? $(Pcaml.rename_id.val s)$ >>)) - ((Sexpr loc [(Sqid _ s) se]) - (let* ((s (Pcaml.rename_id.val s)) - (e (expr_se se))) - (Left <:patt< ? ( $lid:s$ = $e$ ) >>))) - ((Sexpr loc [(Slid _ ":") se1 se2]) - (let* ((p (ipatt_se se1)) (t (ctyp_se se2))) - (Left <:patt< ($p$ : $t$) >>))) - ((Sexpr loc [(Slid _ "values") . sel]) - (let ((pl (List.map ipatt_se sel))) (Left <:patt< ( $list:pl$ ) >>))) - ((Sexpr loc []) (Left <:patt< () >>)) - ((Sexpr loc [se . sel]) (Right (values se sel))) - (se (error se "ipatt")))) - (type_declaration_list_se - (lambda_match - ([se1 se2 . sel] - (let (((values n1 loc1 tpl) - (match se1 - ((Sexpr _ [(Slid loc n) . sel]) - (values n loc (List.map type_parameter_se sel))) - ((Slid loc n) - (values n loc [])) - ((se) - (error se "type declaration"))))) - [(values (values loc1 (Pcaml.rename_id.val n1)) tpl (ctyp_se se2) []) . - (type_declaration_list_se sel)])) - ([] []) - ([se . _] (error se "type_declaration")))) - (type_parameter_se - (lambda_match - ((when (Slid _ s) (and (>= (String.length s) 2) (= s.[0] '''))) - (values (String.sub s 1 (- (String.length s) 1)) (values False False))) - (se - (error se "type_parameter")))) - (ctyp_se - (lambda_match - ((Sexpr loc [(Slid _ "sum") . sel]) - (let ((cdl (List.map constructor_declaration_se sel))) - <:ctyp< [ $list:cdl$ ] >>)) - ((Srec loc sel) - (let ((ldl (List.map label_declaration_se sel))) - <:ctyp< { $list:ldl$ } >>)) - ((Sexpr loc [(Slid _ "->") . (as [_ _ . _] sel)]) - (letrec - ((loop - (lambda_match - ([] (assert False)) - ([se] (ctyp_se se)) - ([se . sel] - (let* ((t1 (ctyp_se se)) - (loc (values (fst (loc_of_sexpr se)) (snd loc))) - (t2 (loop sel))) - <:ctyp< $t1$ -> $t2$ >>))))) - (loop sel))) - ((Sexpr loc [(Slid _ "*") . sel]) - (let ((tl (List.map ctyp_se sel))) <:ctyp< ($list:tl$) >>)) - ((Sexpr loc [se . sel]) - (List.fold_left - (lambda (t se) (let ((t2 (ctyp_se se))) <:ctyp< $t$ $t2$ >>)) - (ctyp_se se) sel)) - ((Sacc loc se1 se2) - (let* ((t1 (ctyp_se se1)) (t2 (ctyp_se se2))) <:ctyp< $t1$ . $t2$ >>)) - ((Slid loc "_") <:ctyp< _ >>) - ((Slid loc s) - (if (= s.[0] ''') - (let ((s (String.sub s 1 (- (String.length s) 1)))) - <:ctyp< '$s$ >>) - <:ctyp< $lid:(Pcaml.rename_id.val s)$ >>)) - ((Suid loc s) <:ctyp< $uid:(Pcaml.rename_id.val s)$ >>) - (se (error se "ctyp")))) - (constructor_declaration_se - (lambda_match - ((Sexpr loc [(Suid _ ci) . sel]) - (values loc (Pcaml.rename_id.val ci) (List.map ctyp_se sel))) - (se - (error se "constructor_declaration")))) - (label_declaration_se - (lambda_match - ((Sexpr loc [(Slid _ lab) (Slid _ "mutable") se]) - (values loc (Pcaml.rename_id.val lab) True (ctyp_se se))) - ((Sexpr loc [(Slid _ lab) se]) - (values loc (Pcaml.rename_id.val lab) False (ctyp_se se))) - (se - (error se "label_declaration"))))) - -(define directive_se - (lambda_match - ((Sexpr _ [(Slid _ s)]) (values s None)) - ((Sexpr _ [(Slid _ s) se]) (let ((e (expr_se se))) (values s (Some e)))) - (se (error se "directive")))) - -; Parser - -(:= Pcaml.syntax_name.val "Scheme") -(:= Pcaml.no_constructors_arity.val False) - -(begin - (Grammar.Unsafe.gram_reinit gram (lexer_gmake ())) - (Grammar.Unsafe.clear_entry interf) - (Grammar.Unsafe.clear_entry implem) - (Grammar.Unsafe.clear_entry top_phrase) - (Grammar.Unsafe.clear_entry use_file) - (Grammar.Unsafe.clear_entry module_type) - (Grammar.Unsafe.clear_entry module_expr) - (Grammar.Unsafe.clear_entry sig_item) - (Grammar.Unsafe.clear_entry str_item) - (Grammar.Unsafe.clear_entry expr) - (Grammar.Unsafe.clear_entry patt) - (Grammar.Unsafe.clear_entry ctyp) - (Grammar.Unsafe.clear_entry let_binding) - (Grammar.Unsafe.clear_entry type_declaration) - (Grammar.Unsafe.clear_entry class_type) - (Grammar.Unsafe.clear_entry class_expr) - (Grammar.Unsafe.clear_entry class_sig_item) - (Grammar.Unsafe.clear_entry class_str_item)) - -(:= Pcaml.parse_interf.val (Grammar.Entry.parse interf)) -(:= Pcaml.parse_implem.val (Grammar.Entry.parse implem)) - -(define sexpr (Grammar.Entry.create gram "sexpr")) - -(definerec leftify - (lambda_match - ((Sacc loc1 se1 se2) - (match (leftify se2) - ((Sacc loc2 se2 se3) (Sacc loc1 (Sacc loc2 se1 se2) se3)) - (se2 (Sacc loc1 se1 se2)))) - (x x))) - -EXTEND - GLOBAL : implem interf top_phrase use_file str_item sig_item expr - patt sexpr / - implem : - [ [ "#" / se = sexpr -> - (let (((values n dp) (directive_se se))) - (values [(values <:str_item< # $n$ $opt:dp$ >> loc)] True)) - | si = str_item / x = SELF -> - (let* (((values sil stopped) x) - (loc (MLast.loc_of_str_item si))) - (values [(values si loc) . sil] stopped)) - | EOI -> (values [] False) ] ] - / - interf : - [ [ "#" / se = sexpr -> - (let (((values n dp) (directive_se se))) - (values [(values <:sig_item< # $n$ $opt:dp$ >> loc)] True)) - | si = sig_item / x = SELF -> - (let* (((values sil stopped) x) - (loc (MLast.loc_of_sig_item si))) - (values [(values si loc) . sil] stopped)) - | EOI -> (values [] False) ] ] - / - top_phrase : - [ [ "#" / se = sexpr -> - (let (((values n dp) (directive_se se))) - (Some <:str_item< # $n$ $opt:dp$ >>)) - | se = sexpr -> (Some (str_item_se se)) - | EOI -> None ] ] - / - use_file : - [ [ "#" / se = sexpr -> - (let (((values n dp) (directive_se se))) - (values [<:str_item< # $n$ $opt:dp$ >>] True)) - | si = str_item / x = SELF -> - (let (((values sil stopped) x)) (values [si . sil] stopped)) - | EOI -> (values [] False) ] ] - / - str_item : - [ [ se = sexpr -> (str_item_se se) - | e = expr -> <:str_item< $exp:e$ >> ] ] - / - sig_item : - [ [ se = sexpr -> (sig_item_se se) ] ] - / - expr : - [ "top" - [ se = sexpr -> (expr_se se) ] ] - / - patt : - [ [ se = sexpr -> (patt_se se) ] ] - / - sexpr : - [ [ se1 = sexpr_dot / se2 = sexpr -> (leftify (Sacc loc se1 se2)) ] - | [ "(" / sl = LIST0 sexpr / ")" -> (Sexpr loc sl) - | "(" / sl = LIST0 sexpr / ")." / se = sexpr -> - (leftify (Sacc loc (Sexpr loc sl) se)) - | "[" / sl = LIST0 sexpr / "]" -> (Slist loc sl) - | "{" / sl = LIST0 sexpr / "}" -> (Srec loc sl) - | a = pa_extend_keyword -> (Slid loc a) - | s = LIDENT -> (Slid loc s) - | s = UIDENT -> (Suid loc s) - | s = TILDEIDENT -> (Stid loc s) - | s = QUESTIONIDENT -> (Sqid loc s) - | s = INT -> (Sint loc s) - | s = FLOAT -> (Sfloat loc s) - | s = CHAR -> (Schar loc s) - | s = STRING -> (Sstring loc s) - | s = QUOT -> - (let* ((i (String.index s ':')) - (typ (String.sub s 0 i)) - (txt (String.sub s (+ i 1) (- (- (String.length s) i) 1)))) - (Squot loc typ txt)) ] ] - / - sexpr_dot : - [ [ s = LIDENTDOT -> (Slid loc s) - | s = UIDENTDOT -> (Suid loc s) ] ] - / - pa_extend_keyword : - [ [ "_" -> "_" - | "," -> "," - | "=" -> "=" - | ":" -> ":" - | "." -> "." - | "/" -> "/" ] ] - / -END diff --git a/camlp4/unmaintained/scheme/pr_scheme.ml b/camlp4/unmaintained/scheme/pr_scheme.ml deleted file mode 100644 index ccb00b1b..00000000 --- a/camlp4/unmaintained/scheme/pr_scheme.ml +++ /dev/null @@ -1,826 +0,0 @@ -(* pa_r.cmo q_MLast.cmo pa_extfun.cmo pr_dump.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU Library General Public License, with *) -(* the special exception on linking described in file *) -(* ../../../LICENSE. *) -(* *) -(***********************************************************************) -(* $Id: pr_scheme.ml,v 1.2.6.1 2005/12/19 16:49:53 verlyck Exp $ *) - -open Pcaml; -open Format; - -type printer_t 'a = - { pr_fun : mutable string -> next 'a; - pr_levels : mutable list (pr_level 'a) } -and pr_level 'a = - { pr_label : string; - pr_box : formatter -> (formatter -> unit) -> 'a -> unit; - pr_rules : mutable pr_rule 'a } -and pr_rule 'a = - Extfun.t 'a (formatter -> curr 'a -> next 'a -> string -> kont -> unit) -and curr 'a = formatter -> ('a * string * kont) -> unit -and next 'a = formatter -> ('a * string * kont) -> unit -and kont = formatter -> unit; - -value not_impl name x ppf k = - let desc = - if Obj.is_block (Obj.repr x) then - "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) - else "int_val = " ^ string_of_int (Obj.magic x) - in - fprintf ppf "%t" name desc k -; - -value pr_fun name pr lab = - loop False pr.pr_levels where rec loop app = - fun - [ [] -> fun ppf (x, dg, k) -> failwith ("unable to print " ^ name) - | [lev :: levl] -> - if app || lev.pr_label = lab then - let next = loop True levl in - let rec curr ppf (x, dg, k) = - Extfun.apply lev.pr_rules x ppf curr next dg k - in - fun ppf ((x, _, _) as n) -> lev.pr_box ppf (fun ppf -> curr ppf n) x - else loop app levl ] -; - -value rec find_pr_level lab = - fun - [ [] -> failwith ("level " ^ lab ^ " not found") - | [lev :: levl] -> - if lev.pr_label = lab then lev else find_pr_level lab levl ] -; - -value pr_constr_decl = {pr_fun = fun []; pr_levels = []}; -value constr_decl ppf (x, k) = pr_constr_decl.pr_fun "top" ppf (x, "", k); -pr_constr_decl.pr_fun := pr_fun "constr_decl" pr_constr_decl; - -value pr_ctyp = {pr_fun = fun []; pr_levels = []}; -pr_ctyp.pr_fun := pr_fun "ctyp" pr_ctyp; -value ctyp ppf (x, k) = pr_ctyp.pr_fun "top" ppf (x, "", k); - -value pr_expr = {pr_fun = fun []; pr_levels = []}; -pr_expr.pr_fun := pr_fun "expr" pr_expr; -value expr ppf (x, k) = pr_expr.pr_fun "top" ppf (x, "", k); - -value pr_label_decl = {pr_fun = fun []; pr_levels = []}; -value label_decl ppf (x, k) = pr_label_decl.pr_fun "top" ppf (x, "", k); -pr_label_decl.pr_fun := pr_fun "label_decl" pr_label_decl; - -value pr_let_binding = {pr_fun = fun []; pr_levels = []}; -pr_let_binding.pr_fun := pr_fun "let_binding" pr_let_binding; -value let_binding ppf (x, k) = pr_let_binding.pr_fun "top" ppf (x, "", k); - -value pr_match_assoc = {pr_fun = fun []; pr_levels = []}; -pr_match_assoc.pr_fun := pr_fun "match_assoc" pr_match_assoc; -value match_assoc ppf (x, k) = pr_match_assoc.pr_fun "top" ppf (x, "", k); - -value pr_mod_ident = {pr_fun = fun []; pr_levels = []}; -pr_mod_ident.pr_fun := pr_fun "mod_ident" pr_mod_ident; -value mod_ident ppf (x, k) = pr_mod_ident.pr_fun "top" ppf (x, "", k); - -value pr_module_binding = {pr_fun = fun []; pr_levels = []}; -pr_module_binding.pr_fun := pr_fun "module_binding" pr_module_binding; -value module_binding ppf (x, k) = - pr_module_binding.pr_fun "top" ppf (x, "", k); - -value pr_module_expr = {pr_fun = fun []; pr_levels = []}; -pr_module_expr.pr_fun := pr_fun "module_expr" pr_module_expr; -value module_expr ppf (x, k) = pr_module_expr.pr_fun "top" ppf (x, "", k); - -value pr_module_type = {pr_fun = fun []; pr_levels = []}; -pr_module_type.pr_fun := pr_fun "module_type" pr_module_type; -value module_type ppf (x, k) = pr_module_type.pr_fun "top" ppf (x, "", k); - -value pr_patt = {pr_fun = fun []; pr_levels = []}; -pr_patt.pr_fun := pr_fun "patt" pr_patt; -value patt ppf (x, k) = pr_patt.pr_fun "top" ppf (x, "", k); - -value pr_sig_item = {pr_fun = fun []; pr_levels = []}; -pr_sig_item.pr_fun := pr_fun "sig_item" pr_sig_item; -value sig_item ppf (x, k) = pr_sig_item.pr_fun "top" ppf (x, "", k); - -value pr_str_item = {pr_fun = fun []; pr_levels = []}; -pr_str_item.pr_fun := pr_fun "str_item" pr_str_item; -value str_item ppf (x, k) = pr_str_item.pr_fun "top" ppf (x, "", k); - -value pr_type_decl = {pr_fun = fun []; pr_levels = []}; -value type_decl ppf (x, k) = pr_type_decl.pr_fun "top" ppf (x, "", k); -pr_type_decl.pr_fun := pr_fun "type_decl" pr_type_decl; - -value pr_type_params = {pr_fun = fun []; pr_levels = []}; -value type_params ppf (x, k) = pr_type_params.pr_fun "top" ppf (x, "", k); -pr_type_params.pr_fun := pr_fun "type_params" pr_type_params; - -value pr_with_constr = {pr_fun = fun []; pr_levels = []}; -value with_constr ppf (x, k) = pr_with_constr.pr_fun "top" ppf (x, "", k); -pr_with_constr.pr_fun := pr_fun "with_constr" pr_with_constr; - -(* general functions *) - -value nok ppf = (); -value ks s k ppf = fprintf ppf "%s%t" s k; - -value rec list f ppf (l, k) = - match l with - [ [] -> k ppf - | [x] -> f ppf (x, k) - | [x :: l] -> fprintf ppf "%a@ %a" f (x, nok) (list f) (l, k) ] -; - -value rec listwb b f ppf (l, k) = - match l with - [ [] -> k ppf - | [x] -> f ppf ((b, x), k) - | [x :: l] -> fprintf ppf "%a@ %a" f ((b, x), nok) (listwb "" f) (l, k) ] -; - -(* specific functions *) - -value rec is_irrefut_patt = - fun - [ <:patt< $lid:_$ >> -> True - | <:patt< () >> -> True - | <:patt< _ >> -> True - | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y - | <:patt< { $list:fpl$ } >> -> - List.for_all (fun (_, p) -> is_irrefut_patt p) fpl - | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p - | <:patt< ($list:pl$) >> -> List.for_all is_irrefut_patt pl - | <:patt< ? $_$ : ( $p$ ) >> -> is_irrefut_patt p - | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p - | <:patt< ~ $_$ >> -> True - | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p - | _ -> False ] -; - -value expr_fun_args ge = Extfun.apply pr_expr_fun_args.val ge; - -pr_expr_fun_args.val := - extfun Extfun.empty with - [ <:expr< fun [$p$ -> $e$] >> as ge -> - if is_irrefut_patt p then - let (pl, e) = expr_fun_args e in - ([p :: pl], e) - else ([], ge) - | ge -> ([], ge) ]; - -value sequence ppf (e, k) = - match e with - [ <:expr< do { $list:el$ } >> -> - fprintf ppf "@[%a@]" (list expr) (el, k) - | _ -> expr ppf (e, k) ] -; - -value string ppf (s, k) = fprintf ppf "\"%s\"%t" s k; - -value int_repr s = - if String.length s > 2 && s.[0] = '0' then - match s.[1] with - [ 'b' | 'o' | 'x' | 'B' | 'O' | 'X' -> - "#" ^ String.sub s 1 (String.length s - 1) - | _ -> s ] - else s -; - -value assoc_left_parsed_op_list = ["+"; "*"; "land"; "lor"; "lxor"]; -value assoc_right_parsed_op_list = ["and"; "or"; "^"; "@"]; -value and_by_couple_op_list = ["="; "<>"; "<"; ">"; "<="; ">="; "=="; "!="]; - -(* extensible pretty print functions *) - -pr_constr_decl.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ (loc, c, []) -> - fun ppf curr next dg k -> fprintf ppf "(@[%s%t@]" c (ks ")" k) - | (loc, c, tl) -> - fun ppf curr next dg k -> - fprintf ppf "(@[%s@ %a@]" c (list ctyp) (tl, ks ")" k) ]}]; - -pr_ctyp.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ <:ctyp< [ $list:cdl$ ] >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[sum@ %a@]" (list constr_decl) (cdl, ks ")" k) - | <:ctyp< { $list:cdl$ } >> -> - fun ppf curr next dg k -> - fprintf ppf "{@[%a@]" (list label_decl) (cdl, ks "}" k) - | <:ctyp< ( $list:tl$ ) >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[* @[%a@]@]" (list ctyp) (tl, ks ")" k) - | <:ctyp< $t1$ -> $t2$ >> -> - fun ppf curr next dg k -> - let tl = - loop t2 where rec loop = - fun - [ <:ctyp< $t1$ -> $t2$ >> -> [t1 :: loop t2] - | t -> [t] ] - in - fprintf ppf "(@[-> @[%a@]@]" (list ctyp) - ([t1 :: tl], ks ")" k) - | <:ctyp< $t1$ $t2$ >> -> - fun ppf curr next dg k -> - let (t, tl) = - loop [t2] t1 where rec loop tl = - fun - [ <:ctyp< $t1$ $t2$ >> -> loop [t2 :: tl] t1 - | t1 -> (t1, tl) ] - in - fprintf ppf "(@[%a@ %a@]" ctyp (t, nok) (list ctyp) (tl, ks ")" k) - | <:ctyp< $t1$ . $t2$ >> -> - fun ppf curr next dg k -> - fprintf ppf "%a.%a" ctyp (t1, nok) ctyp (t2, k) - | <:ctyp< $lid:s$ >> | <:ctyp< $uid:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" s k - | <:ctyp< ' $s$ >> -> - fun ppf curr next dg k -> fprintf ppf "'%s%t" s k - | <:ctyp< _ >> -> - fun ppf curr next dg k -> fprintf ppf "_%t" k - | x -> - fun ppf curr next dg k -> not_impl "ctyp" x ppf k ]}]; - -pr_expr.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ <:expr< fun [] >> -> - fun ppf curr next dg k -> - fprintf ppf "(lambda%t" (ks ")" k) - | <:expr< fun $lid:s$ -> $e$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(lambda@ %s@;<1 1>%a" s expr (e, ks ")" k) - | <:expr< fun [ $list:pwel$ ] >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[lambda_match@ %a@]" (list match_assoc) - (pwel, ks ")" k) - | <:expr< match $e$ with [ $list:pwel$ ] >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[match@ %a@]@ %a@]" expr (e, nok) - (list match_assoc) (pwel, ks ")" k) - | <:expr< try $e$ with [ $list:pwel$ ] >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[try@ %a@]@ %a@]" expr (e, nok) - (list match_assoc) (pwel, ks ")" k) - | <:expr< let $p1$ = $e1$ in $e2$ >> -> - fun ppf curr next dg k -> - let (pel, e) = - loop [(p1, e1)] e2 where rec loop pel = - fun - [ <:expr< let $p1$ = $e1$ in $e2$ >> -> - loop [(p1, e1) :: pel] e2 - | e -> (List.rev pel, e) ] - in - let b = - match pel with - [ [_] -> "let" - | _ -> "let*" ] - in - fprintf ppf "(@[@[%s (@[%a@]@]@;<1 2>%a@]" b - (listwb "" let_binding) (pel, ks ")" nok) - sequence (e, ks ")" k) - | <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> - fun ppf curr next dg k -> - let b = if rf then "letrec" else "let" in - fprintf ppf "(@[%s@ (@[%a@]@ %a@]" b - (listwb "" let_binding) (pel, ks ")" nok) expr (e, ks ")" k) - | <:expr< if $e1$ then $e2$ else () >> -> - fun ppf curr next dg k -> - fprintf ppf "(if @[%a@;<1 0>%a@]" expr (e1, nok) - expr (e2, ks ")" k) - | <:expr< if $e1$ then $e2$ else $e3$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(if @[%a@ %a@ %a@]" expr (e1, nok) - expr (e2, nok) expr (e3, ks ")" k) - | <:expr< do { $list:el$ } >> -> - fun ppf curr next dg k -> - fprintf ppf "(begin@;<1 1>@[%a@]" (list expr) (el, ks ")" k) - | <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[for %s@ %a@ %a %a@]" i expr (e1, nok) - expr (e2, nok) (list expr) (el, ks ")" k) - | <:expr< ($e$ : $t$) >> -> - fun ppf curr next dg k -> - fprintf ppf "(:@ %a@ %a" expr (e, nok) ctyp (t, ks ")" k) - | <:expr< ($list:el$) >> -> - fun ppf curr next dg k -> - fprintf ppf "(values @[%a@]" (list expr) (el, ks ")" k) - | <:expr< { $list:fel$ } >> -> - fun ppf curr next dg k -> - let record_binding ppf ((p, e), k) = - fprintf ppf "(@[%a@ %a@]" patt (p, nok) expr (e, ks ")" k) - in - fprintf ppf "{@[%a@]" (list record_binding) (fel, ks "}" k) - | <:expr< { ($e$) with $list:fel$ } >> -> - fun ppf curr next dg k -> - let record_binding ppf ((p, e), k) = - fprintf ppf "(@[%a@ %a@]" patt (p, nok) expr (e, ks ")" k) - in - fprintf ppf "{@[@[with@ %a@]@ @[%a@]@]" expr (e, nok) - (list record_binding) (fel, ks "}" k) - | <:expr< $e1$ := $e2$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(:=@;<1 1>%a@;<1 1>%a" expr (e1, nok) - expr (e2, ks ")" k) - | <:expr< [$_$ :: $_$] >> as e -> - fun ppf curr next dg k -> - let (el, c) = - make_list e where rec make_list e = - match e with - [ <:expr< [$e$ :: $y$] >> -> - let (el, c) = make_list y in - ([e :: el], c) - | <:expr< [] >> -> ([], None) - | x -> ([], Some e) ] - in - match c with - [ None -> - fprintf ppf "[%a" (list expr) (el, ks "]" k) - | Some x -> - fprintf ppf "[%a@ %a" (list expr) (el, ks " ." nok) - expr (x, ks "]" k) ] - | <:expr< lazy ($x$) >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[lazy@ %a@]" expr (x, ks ")" k) - | <:expr< $lid:s$ $e1$ $e2$ >> - when List.mem s assoc_right_parsed_op_list -> - fun ppf curr next dg k -> - let el = - loop [e1] e2 where rec loop el = - fun - [ <:expr< $lid:s1$ $e1$ $e2$ >> when s1 = s -> - loop [e1 :: el] e2 - | e -> List.rev [e :: el] ] - in - fprintf ppf "(@[%s %a@]" s (list expr) (el, ks ")" k) - | <:expr< $e1$ $e2$ >> -> - fun ppf curr next dg k -> - let (f, el) = - loop [e2] e1 where rec loop el = - fun - [ <:expr< $e1$ $e2$ >> -> loop [e2 :: el] e1 - | e1 -> (e1, el) ] - in - fprintf ppf "(@[%a@ %a@]" expr (f, nok) (list expr) (el, ks ")" k) - | <:expr< ~ $s$ : ($e$) >> -> - fun ppf curr next dg k -> - fprintf ppf "(~%s@ %a" s expr (e, ks ")" k) - | <:expr< $e1$ .[ $e2$ ] >> -> - fun ppf curr next dg k -> - fprintf ppf "%a.[%a" expr (e1, nok) expr (e2, ks "]" k) - | <:expr< $e1$ .( $e2$ ) >> -> - fun ppf curr next dg k -> - fprintf ppf "%a.(%a" expr (e1, nok) expr (e2, ks ")" k) - | <:expr< $e1$ . $e2$ >> -> - fun ppf curr next dg k -> - fprintf ppf "%a.%a" expr (e1, nok) expr (e2, k) - | <:expr< $int:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" (int_repr s) k - | <:expr< $lid:s$ >> | <:expr< $uid:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" s k - | <:expr< ` $s$ >> -> - fun ppf curr next dg k -> fprintf ppf "`%s%t" s k - | <:expr< $str:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "\"%s\"%t" s k - | <:expr< $chr:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "'%s'%t" s k - | x -> - fun ppf curr next dg k -> not_impl "expr" x ppf k ]}]; - -pr_label_decl.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ (loc, f, m, t) -> - fun ppf curr next dg k -> - fprintf ppf "(@[%s%t@ %a@]" f - (fun ppf -> if m then fprintf ppf "@ mutable" else ()) - ctyp (t, ks ")" k) ]}]; - -pr_let_binding.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ (b, (p, e)) -> - fun ppf curr next dg k -> - let (pl, e) = expr_fun_args e in - match pl with - [ [] -> - fprintf ppf "(@[%s%s%a@ %a@]" b - (if b = "" then "" else " ") patt (p, nok) - sequence (e, ks ")" k) - | _ -> - fprintf ppf "(@[%s%s(%a)@ %a@]" b - (if b = "" then "" else " ") (list patt) ([p :: pl], nok) - sequence (e, ks ")" k) ] ]}]; - -pr_match_assoc.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ (p, we, e) -> - fun ppf curr next dg k -> - fprintf ppf "(@[%t@ %a@]" - (fun ppf -> - match we with - [ Some e -> - fprintf ppf "(when@ %a@ %a" patt (p, nok) - expr (e, ks ")" nok) - | None -> patt ppf (p, nok) ]) - sequence (e, ks ")" k) ]}]; - -pr_mod_ident.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ [s] -> - fun ppf curr next dg k -> - fprintf ppf "%s%t" s k - | [s :: sl] -> - fun ppf curr next dg k -> - fprintf ppf "%s.%a" s curr (sl, "", k) - | x -> - fun ppf curr next dg k -> not_impl "mod_ident" x ppf k ]}]; - -pr_module_binding.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ (b, s, me) -> - fun ppf curr next dg k -> - fprintf ppf "%s@ %s@ %a" b s module_expr (me, k) ]}]; - -pr_module_expr.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ <:module_expr< functor ($i$ : $mt$) -> $me$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[@[functor@ %s@]@ %a@]@ %a@]" - i module_type (mt, nok) module_expr (me, ks ")" k) - | <:module_expr< struct $list:sil$ end >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[struct@ @[%a@]@]" (list str_item) - (sil, ks ")" k) - | <:module_expr< $me1$ $me2$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[%a@ %a@]" module_expr (me1, nok) - module_expr (me2, ks ")" k) - | <:module_expr< $uid:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" s k - | x -> - fun ppf curr next dg k -> not_impl "module_expr" x ppf k ]}]; - -pr_module_type.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ <:module_type< functor ($i$ : $mt1$) -> $mt2$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[@[functor@ %s@]@ %a@]@ %a@]" - i module_type (mt1, nok) module_type (mt2, ks ")" k) - | <:module_type< sig $list:sil$ end >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[sig@ @[%a@]@]" (list sig_item) (sil, ks ")" k) - | <:module_type< $mt$ with $list:wcl$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[with@;<1 2>@[%a@ (%a@]@]" module_type (mt, nok) - (list with_constr) (wcl, ks "))" k) - | <:module_type< $uid:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" s k - | x -> - fun ppf curr next dg k -> not_impl "module_type" x ppf k ]}]; - -pr_patt.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ <:patt< $p1$ | $p2$ >> -> - fun ppf curr next dg k -> - let (f, pl) = - loop [p2] p1 where rec loop pl = - fun - [ <:patt< $p1$ | $p2$ >> -> loop [p2 :: pl] p1 - | p1 -> (p1, pl) ] - in - fprintf ppf "(@[or@ %a@ %a@]" patt (f, nok) (list patt) - (pl, ks ")" k) - | <:patt< ($p1$ as $p2$) >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[as@ %a@ %a@]" patt (p1, nok) patt (p2, ks ")" k) - | <:patt< $p1$ .. $p2$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[range@ %a@ %a@]" patt (p1, nok) patt (p2, ks ")" k) - | <:patt< [$_$ :: $_$] >> as p -> - fun ppf curr next dg k -> - let (pl, c) = - make_list p where rec make_list p = - match p with - [ <:patt< [$p$ :: $y$] >> -> - let (pl, c) = make_list y in - ([p :: pl], c) - | <:patt< [] >> -> ([], None) - | x -> ([], Some p) ] - in - match c with - [ None -> - fprintf ppf "[%a" (list patt) (pl, ks "]" k) - | Some x -> - fprintf ppf "[%a@ %a" (list patt) (pl, ks " ." nok) - patt (x, ks "]" k) ] - | <:patt< $p1$ $p2$ >> -> - fun ppf curr next dg k -> - let pl = - loop [p2] p1 where rec loop pl = - fun - [ <:patt< $p1$ $p2$ >> -> loop [p2 :: pl] p1 - | p1 -> [p1 :: pl] ] - in - fprintf ppf "(@[%a@]" (list patt) (pl, ks ")" k) - | <:patt< ($p$ : $t$) >> -> - fun ppf curr next dg k -> - fprintf ppf "(:@ %a@ %a" patt (p, nok) ctyp (t, ks ")" k) - | <:patt< ($list:pl$) >> -> - fun ppf curr next dg k -> - fprintf ppf "(values @[%a@]" (list patt) (pl, ks ")" k) - | <:patt< { $list:fpl$ } >> -> - fun ppf curr next dg k -> - let record_binding ppf ((p1, p2), k) = - fprintf ppf "(@[%a@ %a@]" patt (p1, nok) patt (p2, ks ")" k) - in - fprintf ppf "(@[{}@ %a@]" (list record_binding) (fpl, ks ")" k) - | <:patt< ? $x$ >> -> - fun ppf curr next dg k -> fprintf ppf "?%s%t" x k - | <:patt< ? ($lid:x$ = $e$) >> -> - fun ppf curr next dg k -> fprintf ppf "(?%s@ %a" x expr (e, ks ")" k) - | <:patt< $p1$ . $p2$ >> -> - fun ppf curr next dg k -> - fprintf ppf "%a.%a" patt (p1, nok) patt (p2, k) - | <:patt< $lid:s$ >> | <:patt< $uid:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" s k - | <:patt< $str:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "\"%s\"%t" s k - | <:patt< $chr:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "'%s'%t" s k - | <:patt< $int:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" (int_repr s) k - | <:patt< $flo:s$ >> -> - fun ppf curr next dg k -> fprintf ppf "%s%t" s k - | <:patt< _ >> -> - fun ppf curr next dg k -> fprintf ppf "_%t" k - | x -> - fun ppf curr next dg k -> not_impl "patt" x ppf k ]}]; - -pr_sig_item.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ <:sig_item< type $list:tdl$ >> -> - fun ppf curr next dg k -> - match tdl with - [ [td] -> fprintf ppf "(%a" type_decl (("type", td), ks ")" k) - | tdl -> - fprintf ppf "(@[type@ %a@]" (listwb "" type_decl) - (tdl, ks ")" k) ] - | <:sig_item< exception $c$ of $list:tl$ >> -> - fun ppf curr next dg k -> - match tl with - [ [] -> fprintf ppf "(@[exception@ %s%t@]" c (ks ")" k) - | tl -> - fprintf ppf "(@[@[exception@ %s@]@ %a@]" c - (list ctyp) (tl, ks ")" k) ] - | <:sig_item< value $i$ : $t$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[value %s@]@ %a@]" i ctyp (t, ks ")" k) - | <:sig_item< external $i$ : $t$ = $list:pd$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[external@ %s@]@ %a@ %a@]" i ctyp (t, nok) - (list string) (pd, ks ")" k) - | <:sig_item< module $s$ : $mt$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[module@ %s@]@ %a@]" s - module_type (mt, ks ")" k) - | <:sig_item< module type $s$ = $mt$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[moduletype@ %s@]@ %a@]" s - module_type (mt, ks ")" k) - | <:sig_item< declare $list:s$ end >> -> - fun ppf curr next dg k -> - if s = [] then fprintf ppf "; ..." - else fprintf ppf "%a" (list sig_item) (s, k) - | MLast.SgUse _ _ _ -> - fun ppf curr next dg k -> () - | x -> - fun ppf curr next dg k -> not_impl "sig_item" x ppf k ]}]; - -pr_str_item.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ <:str_item< open $i$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(open@ %a" mod_ident (i, ks ")" k) - | <:str_item< type $list:tdl$ >> -> - fun ppf curr next dg k -> - match tdl with - [ [td] -> fprintf ppf "(%a" type_decl (("type", td), ks ")" k) - | tdl -> - fprintf ppf "(@[type@ %a@]" (listwb "" type_decl) - (tdl, ks ")" k) ] - | <:str_item< exception $c$ of $list:tl$ >> -> - fun ppf curr next dg k -> - match tl with - [ [] -> fprintf ppf "(@[exception@ %s%t@]" c (ks ")" k) - | tl -> - fprintf ppf "(@[@[exception@ %s@]@ %a@]" c - (list ctyp) (tl, ks ")" k) ] - | <:str_item< value $opt:rf$ $list:pel$ >> -> - fun ppf curr next dg k -> - let b = if rf then "definerec" else "define" in - match pel with - [ [(p, e)] -> - fprintf ppf "%a" let_binding ((b, (p, e)), k) - | pel -> - fprintf ppf "(@[%s*@ %a@]" b (listwb "" let_binding) - (pel, ks ")" k) ] - | <:str_item< module $s$ = $me$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(%a" module_binding (("module", s, me), ks ")" k) - | <:str_item< module type $s$ = $mt$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[@[moduletype@ %s@]@ %a@]" s - module_type (mt, ks ")" k) - | <:str_item< external $i$ : $t$ = $list:pd$ >> -> - fun ppf curr next dg k -> - fprintf ppf "(@[external@ %s@ %a@ %a@]" i ctyp (t, nok) - (list string) (pd, ks ")" k) - | <:str_item< $exp:e$ >> -> - fun ppf curr next dg k -> - fprintf ppf "%a" expr (e, k) - | <:str_item< # $s$ $opt:x$ >> -> - fun ppf curr next dg k -> - match x with - [ Some e -> fprintf ppf "; # (%s %a" s expr (e, ks ")" k) - | None -> fprintf ppf "; # (%s%t" s (ks ")" k) ] - | <:str_item< declare $list:s$ end >> -> - fun ppf curr next dg k -> - if s = [] then fprintf ppf "; ..." - else fprintf ppf "%a" (list str_item) (s, k) - | MLast.StUse _ _ _ -> - fun ppf curr next dg k -> () - | x -> - fun ppf curr next dg k -> not_impl "str_item" x ppf k ]}]; - -pr_type_decl.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ (b, ((_, tn), tp, te, cl)) -> - fun ppf curr next dg k -> - fprintf ppf "%t%t@;<1 1>%a" - (fun ppf -> - if b <> "" then fprintf ppf "%s@ " b - else ()) - (fun ppf -> - match tp with - [ [] -> fprintf ppf "%s" tn - | tp -> fprintf ppf "(%s%a)" tn type_params (tp, nok) ]) - ctyp (te, k) ]}]; - -pr_type_params.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ [(s, vari) :: tpl] -> - fun ppf curr next dg k -> - fprintf ppf "@ '%s%a" s type_params (tpl, k) - | [] -> - fun ppf curr next dg k -> () ]}]; - -pr_with_constr.pr_levels := - [{pr_label = "top"; - pr_box ppf f x = fprintf ppf "@[%t@]" f; - pr_rules = - extfun Extfun.empty with - [ MLast.WcTyp _ m tp te -> - fun ppf curr next dg k -> - fprintf ppf "(type@ %t@;<1 1>%a" - (fun ppf -> - match tp with - [ [] -> fprintf ppf "%a" mod_ident (m, nok) - | tp -> - fprintf ppf "(%a@ %a)" mod_ident (m, nok) - type_params (tp, nok) ]) - ctyp (te, ks ")" k) - | x -> - fun ppf curr next dg k -> not_impl "with_constr" x ppf k ]}]; - -(* main *) - -value output_string_eval ppf s = - loop 0 where rec loop i = - if i == String.length s then () - else if i == String.length s - 1 then pp_print_char ppf s.[i] - else - match (s.[i], s.[i + 1]) with - [ ('\\', 'n') -> do { pp_print_char ppf '\n'; loop (i + 2) } - | (c, _) -> do { pp_print_char ppf c; loop (i + 1) } ] -; - -value sep = Pcaml.inter_phrases; - -value input_source ic len = - let buff = Buffer.create 20 in - try - let rec loop i = - if i >= len then Buffer.contents buff - else do { let c = input_char ic in Buffer.add_char buff c; loop (i + 1) } - in - loop 0 - with - [ End_of_file -> - let s = Buffer.contents buff in - if s = "" then - match sep.val with - [ Some s -> s - | None -> "\n" ] - else s ] -; - -value copy_source ppf (ic, first, bp, ep) = - match sep.val with - [ Some str -> - if first then () - else if ep == in_channel_length ic then pp_print_string ppf "\n" - else output_string_eval ppf str - | None -> - do { - seek_in ic bp; - let s = input_source ic (ep - bp) in pp_print_string ppf s - } ] -; - -value copy_to_end ppf (ic, first, bp) = - let ilen = in_channel_length ic in - if bp < ilen then copy_source ppf (ic, first, bp, ilen) - else pp_print_string ppf "\n" -; - -value apply_printer printer ast = - let ppf = std_formatter in - if Pcaml.input_file.val <> "-" && Pcaml.input_file.val <> "" then do { - let ic = open_in_bin Pcaml.input_file.val in - try - let (first, last_pos) = - List.fold_left - (fun (first, last_pos) (si, (bp, ep)) -> - do { - fprintf ppf "@[%a@]@?" copy_source (ic, first, last_pos.Lexing.pos_cnum, bp.Lexing.pos_cnum); - fprintf ppf "@[%a@]@?" printer (si, nok); - (False, ep) - }) - (True, Token.nowhere) ast - in - fprintf ppf "@[%a@]@?" copy_to_end (ic, first, last_pos.Lexing.pos_cnum) - with x -> - do { fprintf ppf "@."; close_in ic; raise x }; - close_in ic; - } - else failwith "not implemented" -; - -Pcaml.print_interf.val := apply_printer sig_item; -Pcaml.print_implem.val := apply_printer str_item; - -Pcaml.add_option "-l" (Arg.Int (fun x -> set_margin x)) - " Maximum line length for pretty printing."; - -Pcaml.add_option "-sep" (Arg.String (fun x -> sep.val := Some x)) - " Use this string between phrases instead of reading source."; diff --git a/camlp4/unmaintained/scheme/pr_schp_main.ml b/camlp4/unmaintained/scheme/pr_schp_main.ml deleted file mode 100644 index dc54aa92..00000000 --- a/camlp4/unmaintained/scheme/pr_schp_main.ml +++ /dev/null @@ -1,132 +0,0 @@ -(* pa_r.cmo q_MLast.cmo pa_extfun.cmo pr_dump.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU Library General Public License, with *) -(* the special exception on linking described in file *) -(* ../../../LICENSE. *) -(* *) -(***********************************************************************) -(* $Id: pr_schp_main.ml,v 1.2 2004/07/13 12:25:09 xleroy Exp $ *) - -open Format; -open Pcaml; -open Parserify; - -value nok = Pr_scheme.nok; -value ks = Pr_scheme.ks; -value patt = Pr_scheme.patt; -value expr = Pr_scheme.expr; -value find_pr_level = Pr_scheme.find_pr_level; -value pr_expr = Pr_scheme.pr_expr; -type printer_t 'a = Pr_scheme.printer_t 'a == - { pr_fun : mutable string -> Pr_scheme.next 'a; - pr_levels : mutable list (pr_level 'a) } -and pr_level 'a = Pr_scheme.pr_level 'a == - { pr_label : string; - pr_box : formatter -> (formatter -> unit) -> 'a -> unit; - pr_rules : mutable Pr_scheme.pr_rule 'a } -; - -(* extensions for rebuilding syntax of parsers *) - -value parser_cases ppf (spel, k) = - let rec parser_cases ppf (spel, k) = - match spel with - [ [] -> fprintf ppf "[: `HVbox [: b; k :] :]" - | [(sp, epo, e)] -> parser_case ppf (sp, epo, e, k) - | [(sp, epo, e) :: spel] -> - fprintf ppf "%a@ %a" parser_case (sp, epo, e, nok) - parser_cases (spel, k) ] - and parser_case ppf (sp, epo, e, k) = - fprintf ppf "(@[@[(%a)%t@]@ %a@]" stream_patt (sp, nok) - (fun ppf -> - match epo with - [ Some p -> fprintf ppf "@ %a" patt (p, nok) - | None -> () ]) - expr (e, ks ")" k) - and stream_patt ppf (sp, k) = - match sp with - [ [] -> k ppf - | [(spc, None)] -> fprintf ppf "%a" stream_patt_comp (spc, k) - | [(spc, Some e)] -> - fprintf ppf "(@[? %a@ %a@]" stream_patt_comp (spc, nok) - expr (e, ks ")" k) - | [(spc, None) :: spcl] -> - fprintf ppf "%a@ %a" stream_patt_comp (spc, nok) stream_patt (spcl, k) - | [(spc, Some e) :: spcl] -> - fprintf ppf "(@[? %a@ %a@]@ %a" stream_patt_comp (spc, nok) - expr (e, ks ")" nok) stream_patt (spcl, k) ] - and stream_patt_comp ppf (spc, k) = - match spc with - [ SPCterm (p, w) -> - match w with - [ Some e -> - fprintf ppf "(` %a@ %a" patt (p, nok) expr (e, ks ")" k) - | None -> fprintf ppf "(` %a" patt (p, ks ")" k) ] - | SPCnterm p e -> - fprintf ppf "(@[%a %a@]" patt (p, nok) expr (e, ks ")" k) - | SPCsterm p -> fprintf ppf "%a" patt (p, k) ] - in - parser_cases ppf (spel, k) -; - -value parser_body ppf (e, k) = - let (bp, e) = - match e with - [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) - | e -> (None, e) ] - in - match parser_of_expr e with - [ [] -> - fprintf ppf "(parser%t%t" - (fun ppf -> - match bp with - [ Some p -> fprintf ppf "@ %a" patt (p, nok) - | _ -> ()]) - (ks ")" k) - | spel -> - fprintf ppf "(@[@[parser%t@]@ @[%a@]@]" - (fun ppf -> - match bp with - [ Some p -> fprintf ppf "@ %a" patt (p, nok) - | _ -> ()]) - parser_cases (spel, ks ")" k) ] -; - -value pmatch ppf (e, k) = - let (me, e) = - match e with - [ <:expr< let (strm__ : Stream.t _) = $me$ in $e$ >> -> (me, e) - | _ -> failwith "Pr_schp_main.pmatch" ] - in - let (bp, e) = - match e with - [ <:expr< let $bp$ = Stream.count strm__ in $e$ >> -> (Some bp, e) - | e -> (None, e) ] - in - let spel = parser_of_expr e in - fprintf ppf "(@[@[match_with_parser@ %a@]%t@ @[%a@]@]" expr (me, nok) - (fun ppf -> - match bp with - [ Some p -> fprintf ppf "@ %a" patt (p, nok) - | _ -> () ]) - parser_cases (spel, ks ")" k) -; - -pr_expr_fun_args.val := - extfun pr_expr_fun_args.val with - [ <:expr< fun [(strm__ : $_$) -> $_$] >> as ge -> ([], ge) ]; - -let lev = find_pr_level "top" pr_expr.pr_levels in -lev.pr_rules := - extfun lev.pr_rules with - [ <:expr< fun (strm__ : $_$) -> $x$ >> -> - fun ppf curr next dg k -> fprintf ppf "%a" parser_body (x, k) - | <:expr< let (strm__ : Stream.t _) = $_$ in $_$ >> as e -> - fun ppf curr next dg k -> fprintf ppf "%a" pmatch (e, k) ]; diff --git a/camlp4/unmaintained/sml/.depend b/camlp4/unmaintained/sml/.depend deleted file mode 100644 index e69de29b..00000000 diff --git a/camlp4/unmaintained/sml/Makefile b/camlp4/unmaintained/sml/Makefile deleted file mode 100644 index ea3980be..00000000 --- a/camlp4/unmaintained/sml/Makefile +++ /dev/null @@ -1,68 +0,0 @@ -######################################################################### -# # -# Objective Caml # -# # -# Camlp4 # -# # -# Copyright 2004 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### -# -# Makefile for pa_sml -# M.Mauny -# - -include ../../config/Makefile.cnf - -OCAMLTOP=../../.. - -OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) -nostdlib -I $(OCAMLTOP)/stdlib -OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) -nostdlib -I $(OCAMLTOP)/stdlib - -P4INCLUDES=-I ../../meta -I ../../etc -I ../../lib -I ../../camlp4 -OCAMLINCLUDES=-I ../../meta -I ../../lib -I ../../camlp4 - -CAMLP4=camlp4$(EXE) -nolib -OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) - -SRC=pa_sml.ml -OBJS=$(SRC:.ml=.cmo) -OBJSX=$(SRC:.ml=.cmx) - -all: $(OBJS) smllib.cmo - -opt: $(OBJSX) smllib.cmx - -depend: - cp .depend .depend.bak - > .depend - for file in $(SRC); do \ - $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \ - sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \ - done - -clean: - rm -f *.cm* *.o *.bak .*.bak - - -.SUFFIXES: .cmx .cmo .cmi .ml .mli .sml - -.mli.cmi: - $(OCAMLC) $(OCAMLCFLAGS) -c $< - - -.sml.cmo: - $(OCAMLC) -I ../../../otherlibs/unix -pp "$(CAMLP4) ./pa_sml.cmo ../../meta/pr_dump.cmo -impl" -c -o $*.cmo -impl $< - -.sml.cmx: - $(OCAMLOPT) -I ../../../otherlibs/unix -pp "$(CAMLP4) ./pa_sml.cmo ../../meta/pr_dump.cmo -impl" -c -o $*.cmx -impl $< - -.ml.cmo: - $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< - -.ml.cmx: - $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< - -include .depend diff --git a/camlp4/unmaintained/sml/README b/camlp4/unmaintained/sml/README deleted file mode 100644 index 809d42f2..00000000 --- a/camlp4/unmaintained/sml/README +++ /dev/null @@ -1,15 +0,0 @@ -This is an application of or an extension for Camlp4. Although it is -currently distributed with OCaml/Camlp4, it may or may not be -actively maintained. - -It probably won't be part of future OCaml/Camlp4 distributions but be -accessible from the Camlp4 hump. If you are interested in developing -this package further and/or actively maintain it, please let us know -(caml@inria.fr) - -This package is distributed under the same license as the Objective -Caml Library (that is, LGPL with a special exception allowing both -static and dynamic link). - --- Michel Mauny - diff --git a/camlp4/unmaintained/sml/pa_sml.ml b/camlp4/unmaintained/sml/pa_sml.ml deleted file mode 100644 index c8d210ca..00000000 --- a/camlp4/unmaintained/sml/pa_sml.ml +++ /dev/null @@ -1,952 +0,0 @@ -(* pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *) -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU Library General Public License, with *) -(* the special exception on linking described in file *) -(* ../../../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id: pa_sml.ml,v 1.2 2004/07/13 12:25:09 xleroy Exp $ *) - -open Stdpp; -open Pcaml; - -value ocaml_records = ref False; - -Pcaml.no_constructors_arity.val := True; - -value lexer = Plexer.gmake (); - -do { - Grammar.Unsafe.gram_reinit gram lexer; - Grammar.Unsafe.clear_entry interf; - Grammar.Unsafe.clear_entry implem; - Grammar.Unsafe.clear_entry top_phrase; - Grammar.Unsafe.clear_entry use_file; - Grammar.Unsafe.clear_entry module_type; - Grammar.Unsafe.clear_entry module_expr; - Grammar.Unsafe.clear_entry sig_item; - Grammar.Unsafe.clear_entry str_item; - Grammar.Unsafe.clear_entry expr; - Grammar.Unsafe.clear_entry patt; - Grammar.Unsafe.clear_entry ctyp; - Grammar.Unsafe.clear_entry let_binding; -}; - -Pcaml.parse_interf.val := Grammar.Entry.parse interf; -Pcaml.parse_implem.val := Grammar.Entry.parse implem; - -value not_impl loc s = - raise_with_loc loc (Stream.Error ("not implemented feature [" ^ s ^ "]")) -; - -type altern 'a 'b = [ Left of 'a | Right of 'b ]; - -value get_seq = - fun - [ <:expr< do { $list:el$ } >> -> el - | e -> [e] ] -; - -value choose_tvar tpl = - let rec find_alpha v = - let s = String.make 1 v in - if List.mem_assoc s tpl then - if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1)) - else Some (String.make 1 v) - in - let rec make_n n = - let v = "a" ^ string_of_int n in - if List.mem_assoc v tpl then make_n (succ n) else v - in - match find_alpha 'a' with - [ Some x -> x - | None -> make_n 1 ] -; - -value mklistexp loc last = - loop True where rec loop top = - fun - [ [] -> - match last with - [ Some e -> e - | None -> <:expr< [] >> ] - | [e1 :: el] -> - let loc = if top then loc else (fst (MLast.loc_of_expr e1), snd loc) in - <:expr< [$e1$ :: $loop False el$] >> ] -; - -value mklistpat loc last = - loop True where rec loop top = - fun - [ [] -> - match last with - [ Some p -> p - | None -> <:patt< [] >> ] - | [p1 :: pl] -> - let loc = if top then loc else (fst (MLast.loc_of_patt p1), snd loc) in - <:patt< [$p1$ :: $loop False pl$] >> ] -; - -value expr_of_patt p = - let loc = MLast.loc_of_patt p in - match p with - [ <:patt< $lid:x$ >> -> <:expr< $lid:x$ >> - | _ -> Stdpp.raise_with_loc loc (Stream.Error "identifier expected") ] -; - -value apply_bind loc e bl = - let rec loop e = - fun - [ [] -> e - | [<:str_item< value $p1$ = $e1$ >> :: list] -> - loop_let e [(p1, e1)] list - | [<:str_item< value rec $p1$ = $e1$ >> :: list] -> - loop_letrec e [(p1, e1)] list - | [<:str_item< module $s$ = $me$ >> :: list] -> - let e = <:expr< let module $s$ = $me$ in $e$ >> in - loop e list - | [si :: list] -> - raise Exit ] - and loop_let e pel = - fun - [ [<:str_item< value $p1$ = $e1$ >> :: list] -> - loop_let e [(p1, e1) :: pel] list - | list -> - let e = <:expr< let $list:pel$ in $e$ >> in - loop e list ] - and loop_letrec e pel = - fun - [ [<:str_item< value rec $p1$ = $e1$ >> :: list] -> - loop_letrec e [(p1, e1) :: pel] list - | list -> - let e = <:expr< let rec $list:pel$ in $e$ >> in - loop e list ] - in - loop e (List.rev bl) -; - -value make_local loc sl1 sl2 = - try - let pl = - List.map - (fun - [ <:str_item< value $opt:_$ $p$ = $_$ >> -> p - | _ -> raise Exit ]) - sl2 - in - let e1 = - match List.map expr_of_patt pl with - [ [e] -> e - | el -> <:expr< ($list:el$) >> ] - in - let p1 = - match pl with - [ [p] -> p - | pl -> <:patt< ($list:pl$) >> ] - in - let e = apply_bind loc e1 sl2 in - let e = apply_bind loc e sl1 in - <:str_item< value $p1$ = $e$ >> - with - [ Exit -> - do { - Printf.eprintf "\ -*** Warning: a 'local' statement will be defined global because of bindings -which cannot be defined as first class values (modules, exceptions, ...)\n"; - flush stderr; - <:str_item< declare $list:sl1 @ sl2$ end >> - } ] -; - -value str_declare loc = - fun - [ [d] -> d - | dl -> <:str_item< declare $list:dl$ end >> ] -; - -value sig_declare loc = - fun - [ [d] -> d - | dl -> <:sig_item< declare $list:dl$ end >> ] -; - -value extract_label_types loc tn tal cdol = - let (cdl, aux) = - List.fold_right - (fun (loc, c, tl, aux_opt) (cdl, aux) -> - match aux_opt with - [ Some anon_record_type -> - let new_tn = tn ^ "_" ^ c in - let loc = MLast.loc_of_ctyp anon_record_type in - let aux_def = ((loc, new_tn), [], anon_record_type, []) in - let tl = [<:ctyp< $lid:new_tn$ >>] in - ([(loc, c, tl) :: cdl], [aux_def :: aux]) - | None -> ([(loc, c, tl) :: cdl], aux) ]) - cdol ([], []) - in - [((loc, tn), tal, <:ctyp< [ $list:cdl$ ] >>, []) :: aux] -; - -value function_of_clause_list loc xl = - let (fname, fname_loc, nbpat, l) = - List.fold_left - (fun (fname, fname_loc, nbpat, l) ((x1, loc), x2, x3, x4) -> - let (fname, fname_loc, nbpat) = - if fname = "" then (x1, loc, List.length x2) - else if x1 <> fname then - raise_with_loc loc - (Stream.Error ("'" ^ fname ^ "' expected")) - else if List.length x2 <> nbpat then - raise_with_loc loc - (Stream.Error "bad number of patterns in that clause") - else (fname, fname_loc, nbpat) - in - let x4 = - match x3 with - [ Some t -> <:expr< ($x4$ : $t$) >> - | _ -> x4 ] - in - let l = [(x2, x4) :: l] in - (fname, fname_loc, nbpat, l)) - ("", loc, 0, []) xl - in - let l = List.rev l in - let e = - match l with - [ [(pl, e)] -> - List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) pl e - | _ -> - if nbpat = 1 then - let pwel = - List.map - (fun (pl, e) -> (<:patt< $List.hd pl$ >>, None, e)) l - in - <:expr< fun [ $list:pwel$ ] >> - else - let sl = - loop 0 where rec loop n = - if n = nbpat then [] - else ["a" ^ string_of_int (n + 1) :: loop (n + 1)] - in - let e = - let el = List.map (fun s -> <:expr< $lid:s$ >>) sl in - let pwel = - List.map - (fun (pl, e) -> (<:patt< ($list:pl$) >>, None, e)) l - in - <:expr< match ($list:el$) with [ $list:pwel$ ] >> - in - List.fold_right (fun s e -> <:expr< fun $lid:s$ -> $e$ >>) sl e ] - in - (let loc = fname_loc in <:patt< $lid:fname$ >>, e) -; - -value record_expr loc x1 = - if ocaml_records.val then <:expr< { $list:x1$ } >> - else - let list1 = - List.map - (fun (l, v) -> - let id = - match l with - [ <:patt< $lid:l$ >> -> l - | _ -> "" ] - in - let loc = MLast.loc_of_expr v in - <:class_str_item< value $id$ = $v$ >>) - x1 - in - let list2 = - List.map - (fun (l, v) -> - let id = - match l with - [ <:patt< $lid:l$ >> -> l - | _ -> "" ] - in - let loc = MLast.loc_of_patt l in - <:class_str_item< method $id$ = $lid:id$ >>) - x1 - in - <:expr< - let module M = - struct - class a = object $list:list1 @ list2$ end; - end - in - new M.a - >> -; - -value record_match_assoc loc lpl e = - if ocaml_records.val then (<:patt< { $list:lpl$ } >>, e) - else - let pl = List.map (fun (_, p) -> p) lpl in - let e = - let el = - List.map - (fun (l, _) -> - let s = - match l with - [ <:patt< $lid:l$ >> -> l - | _ -> "" ] - in - let loc = MLast.loc_of_patt l in - <:expr< v # $lid:s$ >>) - lpl - in - let loc = MLast.loc_of_expr e in - <:expr< let v = $e$ in ($list:el$) >> - in - let p = <:patt< ($list:pl$) >> in - (p, e) -; - -value op = - Grammar.Entry.of_parser gram "op" - (parser [: `("", "op"); `(_, x) :] -> x) -; -lexer.Token.tok_using ("", "op"); - -value special x = - if String.length x >= 2 then - match x.[0] with - [ '+' | '<' | '^' -> True - | _ -> False ] - else False -; - -value idd = - let p = - parser - [ [: `("LIDENT", x) :] -> x - | [: `("UIDENT", x) :] -> x - | [: `("", "op"); `(_, x) :] -> x - | [: `("", x) when special x :] -> x ] - in - Grammar.Entry.of_parser Pcaml.gram "ID" p -; - -value uncap s = String.uncapitalize s; - -EXTEND - GLOBAL: implem interf top_phrase use_file sig_item str_item ctyp patt expr - module_type module_expr; - - implem: - [ [ x = interdec; EOI -> x ] ] - ; - interf: - [ [ x = LIST1 [ s = sig_item; OPT ";" -> (s, loc) ] -> (x, False) ] ] - ; - top_phrase: - [ [ ph = phrase; ";" -> Some ph - | EOI -> None ] ] - ; - use_file: - [ [ l = LIST0 phrase; EOI -> (l, False) ] ] - ; - phrase: - [ [ x = str_item -> x - | x = expr -> <:str_item< $exp:x$ >> - | "#"; n = LIDENT; dp = dir_param -> MLast.StDir loc n dp ] ] - ; - dir_param: - [ [ -> None - | e = expr -> Some e ] ] - ; - sdecs: - [ [ x = sdec; l = sdecs -> [x :: l] - | ";"; l = sdecs -> l - | -> [] ] ] - ; - - fsigb: [ [ -> not_impl loc "fsigb" ] ]; - fsigconstraint_op: [ [ -> not_impl loc "fsigconstraint_op" ] ]; - fct_exp: [ [ -> not_impl loc "fct_exp" ] ]; - exp_pa: [ [ -> not_impl loc "exp_pa" ] ]; - rvb: [ [ -> not_impl loc "rvb" ] ]; - tyvarseq: [ [ -> not_impl loc "tyvarseq" ] ]; - - tyvar_pc: - [ [ "'"; x1 = LIDENT -> [(x1, (False, False))] - | "'"; x1 = LIDENT; ","; l = tyvar_pc -> [(x1, (False, False)) :: l] ] ] - ; - id: - [ [ x1 = idd -> x1 - | "*" -> "*" ] ] - ; - ident: - [ [ x1 = idd -> x1 - | "*" -> "*" - | "=" -> "=" - | "<" -> "<" - | ">" -> ">" - | "<=" -> "<=" - | ">=" -> ">=" - | "^" -> "^" ] ] - ; - op_op: - [ [ x1 = op -> not_impl loc "op_op 1" - | -> () ] ] - ; - qid: - [ [ x1 = idd; "."; x2 = qid -> <:module_expr< $uid:x1$ . $x2$ >> - | x1 = idd -> <:module_expr< $uid:x1$ >> - | x1 = "*" -> <:module_expr< $uid:x1$ >> - | x1 = "=" -> <:module_expr< $uid:x1$ >> ] ] - ; - eqid: - [ [ x1 = UIDENT; "."; x2 = eqid -> <:expr< $uid:x1$ . $x2$ >> - | x1 = UIDENT -> <:expr< $uid:x1$ >> - | x1 = idd -> <:expr< $lid:x1$ >> - | x1 = "*" -> <:expr< $lid:x1$ >> - | x1 = "=" -> <:expr< $lid:x1$ >> ] ] - ; - sqid: - [ [ x1 = idd; "."; x2 = sqid -> [x1 :: x2] - | x1 = idd -> [x1] - | x1 = "*" -> [x1] - | x1 = "=" -> [x1] ] ] - ; - tycon: - [ [ LIDENT "real" -> <:ctyp< float >> - | x1 = idd; "."; x2 = tycon -> - let r = <:ctyp< $uid:x1$ . $x2$ >> in - loop r where rec loop = - fun - [ <:ctyp< $a$ . ($b$ . $c$) >> -> <:ctyp< $a$ . $b$ . $loop c$ >> - | x -> x ] - | x1 = idd -> <:ctyp< $lid:uncap x1$ >> ] ] - ; - selector: - [ [ x1 = id -> x1 - | x1 = INT -> not_impl loc "selector 1" ] ] - ; - tlabel: - [ [ x1 = selector; ":"; x2 = ctyp -> (loc, x1, False, x2) ] ] - ; - tuple_ty: - [ [ x1 = ctyp LEVEL "ty'"; "*"; x2 = tuple_ty -> [x1 :: x2] - | x1 = ctyp LEVEL "ty'" -> [x1] ] ] - ; - ctyp: - [ RIGHTA - [ x1 = ctyp; "->"; x2 = ctyp -> <:ctyp< $x1$ -> $x2$ >> ] - | [ x1 = ctyp; "*"; x2 = tuple_ty -> <:ctyp< ($list:[x1 :: x2]$) >> ] - | "ty'" - [ "'"; x1 = LIDENT -> <:ctyp< '$x1$ >> - | "'"; "'"; x1 = LIDENT -> <:ctyp< '$x1$ >> - | "{"; x1 = LIST1 tlabel SEP ","; "}" -> - if ocaml_records.val then <:ctyp< { $list:x1$ } >> - else - let list = List.map (fun (_, l, _, t) -> (l, t)) x1 in - <:ctyp< < $list:list$ > >> - | "{"; "}" -> not_impl loc "ty' 3" - | "("; x1 = ctyp; ","; x2 = LIST1 ctyp SEP ","; ")"; x3 = tycon -> - List.fold_left (fun t1 t2 -> <:ctyp< $t1$ $t2$ >>) x3 [x1 :: x2] - | "("; x1 = ctyp; ")" -> x1 - | x1 = ctyp; x2 = tycon -> <:ctyp< $x2$ $x1$ >> - | x1 = tycon -> x1 ] ] - ; - rule: - [ [ x1 = patt; "=>"; x2 = expr -> (x1, None, x2) ] ] - ; - elabel: - [ [ x1 = selector; "="; x2 = expr -> (<:patt< $lid:x1$ >>, x2) ] ] - ; - exp_ps: - [ [ x1 = expr -> x1 - | x1 = expr; ";"; x2 = exp_ps -> - <:expr< do { $list:[x1 :: get_seq x2]$ } >> ] ] - ; - expr: - [ [ "if"; x1 = expr; "then"; x2 = expr; "else"; x3 = expr -> - <:expr< if $x1$ then $x2$ else $x3$ >> - | "fn"; x1 = LIST1 rule SEP "|" -> <:expr< fun [$list:x1$] >> - | "case"; x1 = expr; "of"; x2 = LIST1 rule SEP "|" -> - <:expr< match $x1$ with [$list:x2$] >> - | "while"; x1 = expr; "do"; x2 = expr -> - <:expr< while $x1$ do { $x2$ } >> - | x1 = expr; "handle"; x2 = LIST1 rule SEP "|" -> - <:expr< try $x1$ with [$list:x2$] >> ] - | RIGHTA - [ "raise"; x1 = expr -> <:expr< raise $x1$ >> ] - | [ e1 = expr; ":="; e2 = expr -> <:expr< $e1$.val := $e2$ >> ] - | LEFTA - [ x1 = expr; "orelse"; x2 = expr -> <:expr< $x1$ || $x2$ >> ] - | LEFTA - [ x1 = expr; "andalso"; x2 = expr -> <:expr< $x1$ && $x2$ >> ] - | LEFTA - [ x1 = expr; ":"; x2 = ctyp -> <:expr< ($x1$ : $x2$) >> ] - | "4" NONA - [ x1 = expr; "<"; x2 = expr -> <:expr< $x1$ < $x2$ >> - | x1 = expr; ">"; x2 = expr -> <:expr< $x1$ > $x2$ >> - | x1 = expr; "<>"; x2 = expr -> <:expr< $x1$ <> $x2$ >> - | x1 = expr; "="; x2 = expr -> <:expr< $x1$ = $x2$ >> - | x1 = expr; ">="; x2 = expr -> <:expr< $x1$ >= $x2$ >> - | x1 = expr; "<="; x2 = expr -> <:expr< $x1$ <= $x2$ >> ] - | RIGHTA - [ x1 = expr; "^"; x2 = expr -> <:expr< $x1$ ^ $x2$ >> - | x1 = expr; "@"; x2 = expr -> <:expr< $x1$ @ $x2$ >> - | x1 = expr; "o"; x2 = expr -> <:expr< ooo $x1$ $x2$ >> ] - | "5" RIGHTA - [ x1 = expr; "::"; x2 = expr -> <:expr< [$x1$ :: $x2$] >> ] - | "6" LEFTA - [ x1 = expr; "+"; x2 = expr -> <:expr< $x1$ + $x2$ >> - | x1 = expr; "-"; x2 = expr -> <:expr< $x1$ - $x2$ >> ] - | "7" LEFTA - [ x1 = expr; "*"; x2 = expr -> <:expr< $x1$ * $x2$ >> - | x1 = expr; "/"; x2 = expr -> <:expr< $x1$ / $x2$ >> - | x1 = expr; "div"; x2 = expr -> <:expr< $x1$ / $x2$ >> - | x1 = expr; "mod"; x2 = expr -> <:expr< $x1$ mod $x2$ >> ] - | LEFTA - [ x1 = expr; x2 = expr -> <:expr< $x1$ $x2$ >> ] - | [ "#"; x1 = STRING -> <:expr< $chr:x1$ >> - | "#"; x1 = selector; x2 = expr -> - if ocaml_records.val then <:expr< $x2$ . $lid:x1$ >> - else <:expr< $x2$ # $lid:x1$ >> - | x1 = expr; "ocaml_record_access"; x2 = expr -> <:expr< $x1$ . $x2$ >> ] - | [ "!"; x1 = expr -> <:expr< $x1$ . val >> - | "~"; x1 = expr -> <:expr< - $x1$ >> ] - | [ x1 = LIDENT -> - match x1 with - [ "true" | "false" -> <:expr< $uid:String.capitalize x1$ >> - | "nil" -> <:expr< [] >> - | _ -> <:expr< $lid:x1$ >> ] - | x1 = UIDENT -> <:expr< $uid:x1$ >> - | x1 = UIDENT; "."; x2 = eqid -> <:expr< $uid:x1$ . $x2$ >> - | x1 = INT -> <:expr< $int:x1$ >> - | x1 = FLOAT -> <:expr< $flo:x1$ >> - | x1 = STRING -> <:expr< $str:x1$ >> - | "~"; x1 = INT -> <:expr< $int:"-"^x1$ >> - | i = op -> - if i = "::" then <:expr< fun (x, y) -> [x :: y] >> - else <:expr< fun (x, y) -> $lid:i$ x y >> - | "let"; x1 = ldecs; "in"; x2 = exp_ps; "end" -> - List.fold_right - (fun pel x2 -> - let loc = - match pel with - [ [(p, _) :: _] -> - (fst (MLast.loc_of_patt p), snd (MLast.loc_of_expr x2)) - | _ -> loc ] - in - match pel with - [ [(_, <:expr< fun [$list:_$] >>) :: _] -> - <:expr< let rec $list:pel$ in $x2$ >> - | _ -> - let pel = - List.map - (fun (p, e) -> - match p with - [ <:patt< { $list:lpl$ } >> -> - record_match_assoc (MLast.loc_of_patt p) lpl e - | _ -> (p, e) ]) - pel - in - <:expr< let $list:pel$ in $x2$ >> ]) - x1 x2 - | "{"; x1 = LIST1 elabel SEP ","; "}" -> record_expr loc x1 - | "["; "]" -> <:expr< [] >> - | "["; x1 = expr; "]" -> <:expr< [$x1$] >> - | "["; x1 = expr; ","; x2 = LIST1 SELF SEP ","; "]" -> - mklistexp loc None [x1 :: x2] - | "("; ")" -> <:expr< () >> - | "("; x1 = expr; ","; x2 = LIST1 SELF SEP ","; ")" -> - <:expr< ($list:[x1::x2]$) >> - | "("; x1 = expr; ";"; x2 = LIST1 SELF SEP ";"; ")" -> - <:expr< do { $list:[x1::x2]$ } >> - | "("; x1 = expr; ")" -> x1 ] ] - ; - fixity: - [ [ "infix" -> ("infix", None) - | "infix"; x1 = INT -> not_impl loc "fixity 2" - | "infixr" -> not_impl loc "fixity 3" - | "infixr"; x1 = INT -> ("infixr", Some x1) - | "nonfix" -> not_impl loc "fixity 5" ] ] - ; - patt: - [ [ x1 = patt; "as"; x2 = patt -> <:patt< ($x1$ as $x2$) >> ] - | LEFTA - [ x1 = patt; ":"; x2 = ctyp -> <:patt< ($x1$ : $x2$) >> ] - | RIGHTA - [ x1 = patt; "::"; x2 = patt -> <:patt< [$x1$ :: $x2$] >> ] - | [ x1 = patt; x2 = patt -> - match x1 with - [ <:patt< ref >> -> <:patt< {contents = $x2$} >> - | _ -> <:patt< $x1$ $x2$ >> ] ] - | "apat" - [ x1 = patt; "."; x2 = patt -> <:patt< $x1$ . $x2$ >> - | x1 = INT -> <:patt< $int:x1$ >> - | x1 = UIDENT -> <:patt< $uid:x1$ >> - | x1 = STRING -> <:patt< $str:x1$ >> - | "#"; x1 = STRING -> <:patt< $chr:x1$ >> - | "~"; x1 = INT -> <:patt< $int:"-"^x1$ >> - | LIDENT "nil" -> <:patt< [] >> - | LIDENT "false" -> <:patt< False >> - | LIDENT "true" -> <:patt< True >> - | x1 = id -> <:patt< $lid:x1$ >> - | x1 = op -> <:patt< $lid:x1$ >> - | "_" -> <:patt< _ >> - | "["; "]" -> <:patt< [] >> - | "["; x1 = patt; "]" -> <:patt< [$x1$] >> - | "["; x1 = patt; ","; x2 = LIST1 SELF SEP ","; "]" -> - mklistpat loc None [x1 :: x2] - | "{"; x1 = LIST1 plabel SEP ","; "}" -> <:patt< {$list:x1$} >> - | "("; ")" -> <:patt< () >> - | "("; x1 = patt; ","; x2 = LIST1 SELF SEP ","; ")" -> - <:patt< ($list:[x1::x2]$) >> - | "("; x1 = patt; ")" -> x1 ] ] - ; - plabel: - [ [ x1 = selector; "="; x2 = patt -> (<:patt< $lid:x1$ >>, x2) - | x1 = selector -> (<:patt< $lid:x1$ >>, <:patt< $lid:x1$ >>) ] ] - ; - vb: - [ [ "lazy"; x1 = patt; "="; x2 = expr -> not_impl loc "vb 1" - | x1 = patt; "="; x2 = expr -> (x1, x2) ] ] - ; - constrain: - [ [ -> None - | ":"; x1 = ctyp -> Some x1 ] ] - ; - fb: - [ [ xl = LIST1 clause SEP "|" -> function_of_clause_list loc xl - | "lazy"; x1 = LIST1 clause SEP "|" -> not_impl loc "fb 2" ] ] - ; - clause: - [ [ x1 = patt LEVEL "apat"; x2 = LIST1 (patt LEVEL "apat"); - x3 = constrain; "="; x4 = expr -> - let x1 = - match x1 with - [ <:patt< $lid:id$ >> -> (id, MLast.loc_of_patt x1) - | _ -> not_impl loc "clause 1" ] - in - (x1, x2, x3, x4) ] ] - ; - tb: - [ [ x1 = tyvars; x2 = idd; "="; x3 = ctyp -> - ((loc, uncap x2), x1, x3, []) - | x1 = tyvars; x2 = idd; "="; x3 = ctyp; "=="; x4 = dbrhs -> - let x4 = List.map (fun (loc, c, tl, _) -> (loc, c, tl)) x4 in - ((loc, uncap x2), x1, <:ctyp< $x3$ == [ $list:x4$ ] >>, []) ] ] - ; - tyvars: - [ [ "'"; x1 = LIDENT -> [(x1, (False, False))] - | "("; x1 = tyvar_pc; ")" -> x1 - | -> [] ] ] - ; - db1: - [ [ x1 = tyvars; x2 = ident; "="; x3 = dbrhs -> - let x2 = uncap x2 in - extract_label_types loc x2 x1 x3 - | "lazy"; x1 = tyvars; x2 = ident; "="; x3 = dbrhs -> - not_impl loc "db 2" ] ] - ; - db: - [ [ x1 = LIST1 db1 SEP "and" -> - List.fold_right (fun td tdl -> td @ tdl) x1 [] ] ] - ; - dbrhs: - [ [ x1 = LIST1 constr SEP "|" -> x1 - | "datatype"; x1 = tycon -> not_impl loc "dbrhs 2" ] ] - ; - constr: - [ [ x1 = op_op; x2 = ident -> (loc, x2, [], None) - | x1 = op_op; x2 = ident; "of"; x3 = ctyp -> - match x3 with - [ <:ctyp< {$list:_$} >> -> (loc, x2, [], Some x3) - | _ -> (loc, x2, [x3], None) ] ] ] - ; - eb: - [ [ x1 = op_op; x2 = ident -> (x2, [], []) - | x1 = op_op; x2 = ident; "of"; x3 = ctyp -> (x2, [x3], []) - | x1 = op_op; x2 = ident; "="; x3 = sqid -> (x2, [], x3) ] ] - ; - ldec1: - [ [ "val"; x1 = LIST1 vb SEP "and" -> x1 - | "fun"; x1 = LIST1 fb SEP "and" -> x1 ] ] - ; - ldecs: - [ [ -> [] - | x1 = ldec1; x2 = ldecs -> [x1 :: x2] - | ";"; x1 = ldecs -> x1 - | "local"; x1 = ldecs; "in"; x2 = ldecs; "end"; x3 = ldecs -> - not_impl loc "ldecs 4" ] ] - ; - spec_s: - [ [ -> [] - | x1 = spec; x2 = spec_s -> [x1 :: x2] - | ";"; x1 = spec_s -> x1 ] ] - ; - spec: - [ [ "structure"; x1 = LIST1 strspec SEP "and" -> sig_declare loc x1 - | "functor"; x1 = LIST1 fctspec SEP "and" -> sig_declare loc x1 - | "datatype"; x1 = db -> <:sig_item< type $list:x1$ >> - | "type"; x1 = LIST1 tyspec SEP "and" -> <:sig_item< type $list:x1$ >> - | "eqtype"; x1 = LIST1 tyspec SEP "and" -> <:sig_item< type $list:x1$ >> - | "val"; x1 = LIST1 valspec SEP "and" -> sig_declare loc x1 - | "exception"; x1 = LIST1 exnspec SEP "and" -> sig_declare loc x1 - | "sharing"; x1 = LIST1 sharespec SEP "and" -> <:sig_item< declare end >> - | "include"; x1 = module_type -> <:sig_item< include $x1$ >> ] ] - ; - sig_item: - [ [ x = spec -> x ] ] - ; - strspec: - [ [ x1 = ident; ":"; x2 = module_type; x3 = LIST0 sharing_def -> - let x2 = - List.fold_left - (fun mt sdl -> - List.fold_right - (fun spl mt -> - match spl with - [ Right ([m1], m2) -> - let (m1, m2) = - match m2 with - [ <:module_expr< $uid:x$ . $_$ >> -> - if x = x1 then (m2, m1) else (m1, m2) - | _ -> (m1, m2) ] - in - let m1 = - loop m1 where rec loop = - fun - [ <:module_expr< $uid:x$ >> -> x - | <:module_expr< $uid:x$ . $y$ >> -> loop y - | _ -> not_impl loc "strspec 2" ] - in - <:module_type< $mt$ with module $[m1]$ = $m2$ >> - | _ -> not_impl loc "strspec 1" ]) - sdl mt) - x2 x3 - in - <:sig_item< module $x1$ : $x2$ >> ] ] - ; - sharing_def: - [ [ "sharing"; x3 = LIST1 sharespec SEP "and" -> x3 ] ] - ; - fctspec: - [ [ x1 = ident; x2 = fsig -> <:sig_item< module $x1$ : $x2$ >> ] ] - ; - tyspec: - [ [ x1 = tyvars; x2 = idd -> - ((loc, uncap x2), x1, <:ctyp< '$choose_tvar x1$ >>, []) - | x1 = tyvars; x2 = idd; "="; x3 = ctyp -> - ((loc, uncap x2), x1, x3, []) ] ] - ; - valspec: - [ [ x1 = op_op; x2 = ident; ":"; x3 = ctyp -> - <:sig_item< value $x2$ : $x3$ >> ] ] - ; - exnspec: - [ [ x1 = ident -> <:sig_item< exception $x1$ >> - | x1 = ident; "of"; x2 = ctyp -> - <:sig_item< exception $x1$ of $x2$ >> ] ] - ; - sharespec: - [ [ "type"; x1 = patheqn -> Left x1 - | x1 = patheqn -> Right x1 ] ] - ; - patheqn: - [ [ l = patheqn1 -> l ] ] - ; - patheqn1: - [ [ (l, y) = patheqn1; "="; x = qid -> ([y :: l], x) - | x = qid -> ([], x) ] ] - ; - whspec: - [ [ "type"; x1 = tyvars; x2 = sqid; "="; x3 = ctyp -> - MLast.WcTyp loc x2 x1 x3 - | x1 = sqid; "="; x2 = qid -> MLast.WcMod loc x1 x2 ] ] - ; - module_type: - [ [ x1 = ident -> <:module_type< $uid:x1$ >> - | "sig"; x1 = spec_s; "end" -> <:module_type< sig $list:x1$ end >> - | x1 = module_type; "where"; x2 = LIST1 whspec SEP "and" -> - <:module_type< $x1$ with $list:x2$ >> ] ] - ; - sigconstraint_op: - [ [ -> None - | ":"; x1 = module_type -> Some x1 - | ":>"; x1 = module_type -> not_impl loc "sigconstraint_op 3" ] ] - ; - sigb: - [ [ x1 = ident; "="; x2 = module_type -> - <:str_item< module type $x1$ = $x2$ >> ] ] - ; - fsig: - [ [ ":"; x1 = ident -> not_impl loc "fsig 1" - | x1 = fparamList; ":"; x2 = module_type -> not_impl loc "fsig 2" ] ] - ; - module_expr: - [ [ x1 = qid -> x1 - | "struct"; x1 = strdecs; "end" -> <:module_expr< struct $list:x1$ end >> - | x1 = qid; x2 = arg_fct -> - match x2 with - [ Left [] -> x1 - | Left x2 -> <:module_expr< $x1$ (struct $list:x2$ end) >> - | Right x2 -> <:module_expr< $x1$ $x2$ >> ] - | "let"; x1 = strdecs; "in"; x2 = module_expr; "end" -> - not_impl loc "str 4" - | x1 = module_expr; ":"; x2 = module_type -> not_impl loc "str 5" - | x1 = module_expr; x2 = ":>"; x3 = module_type -> - not_impl loc "str 6" ] ] - ; - arg_fct: - [ [ "("; x1 = strdecs; ")"; x2 = arg_fct -> not_impl loc "arg_fct 1" - | "("; x1 = module_expr; ")"; x2 = arg_fct -> not_impl loc "arg_fct 2" - | "("; x1 = module_expr; ")" -> Right x1 - | "("; x2 = strdecs; ")" -> Left x2 ] ] - ; - strdecs: - [ [ x1 = str_item LEVEL "strdec"; x2 = strdecs -> [x1 :: x2] - | ";"; x1 = strdecs -> x1 - | -> [] ] ] - ; - str_item: - [ [ "signature"; x1 = LIST1 sigb SEP "and" -> str_declare loc x1 - | "funsig"; x1 = fsigb -> not_impl loc "sdec 3" ] - | "strdec" - [ "structure"; x1 = LIST1 strb SEP "and" -> str_declare loc x1 - | "functor"; x1 = LIST1 fctb SEP "and" -> str_declare loc x1 - | "local"; x1 = sdecs; "in"; x2 = sdecs; "end" -> - make_local loc x1 x2 ] - | [ "val"; x1 = LIST1 vb SEP "and" -> <:str_item< value $list:x1$ >> - | "val"; x1 = tyvarseq; x3 = LIST1 vb SEP "and" -> - not_impl loc "ldec 2" - | "val"; "rec"; x1 = rvb -> not_impl loc "ldec 3" - | "val"; "rec"; x1 = tyvarseq; x2 = rvb -> not_impl loc "ldec 4" - | "fun"; x1 = LIST1 fb SEP "and" -> <:str_item< value rec $list:x1$ >> - | "fun"; x1 = tyvarseq; x2 = fb -> not_impl loc "ldec 6" - | "type"; x1 = LIST1 tb SEP "and" -> <:str_item< type $list:x1$ >> - | "datatype"; x1 = db -> <:str_item< type $list:x1$ >> - | "datatype"; x1 = db; "withtype"; x2 = tb -> - <:str_item< type $list:x1 @ [x2]$ >> - | "abstype"; x1 = db; "with"; x2 = ldecs; "end" -> not_impl loc "ldec 10" - | "abstype"; x1 = db; "withtype"; x2 = tb; "with"; x3 = ldecs; "end" -> - not_impl loc "ldec 11" - | "exception"; x1 = LIST1 eb SEP "and" -> - let dl = - List.map - (fun (s, tl, eqn) -> - <:str_item< exception $s$ of $list:tl$ = $eqn$ >>) - x1 - in - str_declare loc dl - | "open"; x1 = LIST1 sqid -> - let dl = List.map (fun sl -> <:str_item< open $sl$ >>) x1 in - str_declare loc dl - | LIDENT "use"; s = STRING -> - <:str_item< #use $str:s$ >> - | x1 = fixity; list = LIST1 idd -> - match x1 with - [ ("infixr", Some n) -> - do { - List.iter - (fun s -> - EXTEND - expr: LEVEL $n$ - [ [ x1 = expr; $s$; x2 = expr -> - <:expr< $lid:s$ ($x1$, $x2$) >> ] ] - ; - END) - list; - str_declare loc [] - } - | ("infix", None) -> - do { - List.iter - (fun s -> - EXTEND - expr: LEVEL "4" - [ [ x1 = expr; $s$; x2 = expr -> - <:expr< $lid:s$ ($x1$, $x2$) >> ] ] - ; - clause: - [ [ x1 = patt LEVEL "apat"; $s$; - x2 = patt LEVEL "apat"; "="; x4 = expr -> - ((s, loc), [<:patt< ($x1$, $x2$) >>], - None, x4) ] ] - ; - END) - list; - str_declare loc [] - } - | _ -> not_impl loc "ldec 14" ] - | "overload"; x1 = ident; ":"; x2 = ctyp; "as"; x3 = exp_pa -> - not_impl loc "ldec 15" - | x = expr -> <:str_item< $exp:x$ >> ] ] - ; - sdec: - [ [ x = str_item -> x ] ] - ; - strb: - [ [ x1 = ident; x2 = sigconstraint_op; "="; x3 = module_expr -> - let x3 = - match x2 with - [ Some x2 -> <:module_expr< ($x3$ : $x2$) >> - | None -> x3 ] - in - <:str_item< module $x1$ = $x3$ >> ] ] - ; - fparam: - [ [ x1 = idd; ":"; x2 = module_type -> [<:sig_item< module $x1$ : $x2$ >>] - | x1 = spec_s -> x1 ] ] - ; - fparamList: - [ [ "("; x1 = fparam; ")" -> [x1] - | "("; x1 = fparam; ")"; x2 = fparamList -> [x1 :: x2] ] ] - ; - fctb: - [ [ x1 = ident; x2 = fparamList; x3 = sigconstraint_op; "="; - x4 = module_expr -> - let list = List.flatten x2 in - let x4 = - if list = [] then x4 - else - match x4 with - [ <:module_expr< struct $list:list$ end >> -> - let si = - let loc = (Token.nowhere, Token.nowhere) in - <:str_item< open AAA >> in - <:module_expr< struct $list:[si :: list]$ end >> - | _ -> not_impl loc "fctb 1" ] - in - let x4 = - match x3 with - [ Some x3 -> <:module_expr< ($x4$ : $x3$) >> - | None -> x4 ] - in - let x4 = - if list = [] then x4 - else - let mt = - let loc = - (fst (MLast.loc_of_sig_item (List.hd list)), - snd (MLast.loc_of_sig_item (List.hd (List.rev list)))) - in - <:module_type< sig $list:list$ end >> - in - <:module_expr< functor (AAA : $mt$) -> $x4$ >> - in - <:str_item< module $x1$ = $x4$ >> - | x1 = ident; x2 = fsigconstraint_op; "="; x3 = fct_exp -> - not_impl loc "fctb 2" ] ] - ; - interdec: - [ [ x = LIST1 [ s = str_item; OPT ";" -> (s, loc) ] -> (x, False) - | x = expr; OPT ";" -> not_impl loc "interdec 2" ] ] - ; -END; - -Pcaml.add_option "-records" (Arg.Set ocaml_records) - "Convert record into OCaml records, instead of objects"; diff --git a/camlp4/unmaintained/sml/smllib.sml b/camlp4/unmaintained/sml/smllib.sml deleted file mode 100644 index ea70fbf9..00000000 --- a/camlp4/unmaintained/sml/smllib.sml +++ /dev/null @@ -1,395 +0,0 @@ -(***********************************************************************) -(* *) -(* Camlp4 *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* Automatique. Distributed only by permission. *) -(* *) -(***********************************************************************) - -(* $Id: smllib.sml,v 1.2 2004/07/13 12:25:09 xleroy Exp $ *) - -datatype 'a option = SOME of 'a | NONE -exception Fail of string -exception Domain -exception Subscript -type 'a vector = 'a array - -structure OCaml = - struct - structure List = List - structure String = String - end - -structure Time = - struct - datatype time = TIME of { sec : int, usec : int } - fun toString _ = failwith "not implemented Time.toString" - fun now _ = failwith "not implemented Time.now" - end - -datatype cpu_timer = - CPUT of { gc : Time.time, sys : Time.time, usr : Time.time } - -datatype real_timer = - RealT of Time.time - -structure Char = - struct - val ord = Char.code - end - -structure General = - struct - datatype order = LESS | EQUAL | GREATER - end -type order = General.order == LESS | EQUAL | GREATER - -structure OS = - struct - exception SysErr - structure Path = - struct - fun dir s = - let val r = Filename.dirname s in - if r = "." then "" else r - end - val file = Filename.basename - fun ext s = - let fun loop i = - if i < 0 then NONE - else if String.get s i = #"." then - let val len = String.length s - i - 1 in - if len = 0 then NONE else SOME (String.sub s (i + 1) len) - end - else loop (i - 1) - in - loop (String.length s - 1) - end - fun splitDirFile s = - {dir = Filename.dirname s, - file = Filename.basename s} - fun joinDirFile x = - let val {dir,file} = x in Filename.concat dir file end - end - structure FileSys = - struct - datatype access_mode = A_READ | A_WRITE | A_EXEC - val chDir = Sys.chdir - fun isDir s = - (Unix.stat s) ocaml_record_access Unix.st_kind = Unix.S_DIR - handle Unix.Unix_error _ => raise SysErr - fun access (s, accs) = - let val st = Unix.stat s - val prm = st ocaml_record_access Unix.st_perm - val prm = - if st ocaml_record_access Unix.st_uid = Unix.getuid () then - lsr prm 6 - else if st ocaml_record_access Unix.st_uid = Unix.getgid () - then - lsr prm 3 - else prm - val rf = - if List.mem A_READ accs then land prm 4 <> 0 else true - val wf = - if List.mem A_WRITE accs then land prm 2 <> 0 else true - val xf = - if List.mem A_EXEC accs then land prm 1 <> 0 else true - in - rf andalso wf andalso xf - end - handle Unix.Unix_error (_, f, _) => - if f = "stat" then false else raise SysErr - end - structure Process = - struct - fun system s = (flush stdout; flush stderr; Sys.command s) - fun getEnv s = SOME (Sys.getenv s) handle Not_found => NONE - val success = 0 - end - end - -exception SysErr = OS.SysErr - -structure IO = - struct - exception Io of {cause:exn, function:string, name:string} - end - -structure TextIO = - struct - type instream = in_channel * char option option ref - type outstream = out_channel - type elem = char - type vector = string - fun openIn fname = - (open_in fname, ref NONE) handle exn => - raise IO.Io {cause = exn, function = "openIn", name = fname} - val openOut = open_out - fun closeIn (ic, ahc) = (ahc := SOME NONE; close_in ic) - val closeOut = close_out - val stdIn = (stdin, ref (NONE : char option option)) - fun endOfStream (ic, _) = pos_in ic = in_channel_length ic - fun inputLine (ic, ahc) = - case !ahc of - NONE => - (input_line ic ^ "\n" handle End_of_file => (ahc := SOME NONE; "")) - | SOME NONE => "" - | SOME (SOME c) => - (ahc := NONE; - if c = #"\n" then "\n" - else - String.make 1 c ^ input_line ic ^ "\n" handle - End_of_file => (ahc := SOME NONE; "")) - fun input1 (ic, ahc) = - case !ahc of - NONE => - (SOME (input_char ic) handle End_of_file => (ahc := SOME NONE; NONE)) - | SOME NONE => NONE - | SOME x => (ahc := NONE; x) - fun inputN (ins, n) = - let fun loop n = - if n <= 0 then "" - else - case input1 ins of - SOME c => String.make 1 c ^ loop (n - 1) - | NONE => "" - in - loop n - end - fun output (oc, v) = output_string oc v - fun inputAll ic = failwith "not implemented TextIO.inputAll" - fun lookahead (ic, ahc) = - case !ahc of - NONE => let val r = SOME (input_char ic) in ahc := SOME r; r end - | SOME x => x - fun print s = (print_string s; flush stdout) - end - -structure Timer = - struct - fun startRealTimer () = failwith "not implemented Timer.startRealTimer" - fun startCPUTimer () = failwith "not implemented Timer.startCPUTimer" - fun checkRealTimer _ = failwith "not implemented Timer.checkRealTimer" - fun checkCPUTimer _ = failwith "not implemented Timer.checkCPUTimer" - end - -structure Date = - struct - datatype month = - Jan | Feb | Mar | Apr | May | Jun | Jul | Sep | Oct | Nov | Dec - datatype wday = Sun | Mon | Tue | Wed | Thu | Fri | Sat - datatype date = - DATE of - {day : int, hour : int, isDst : bool option, minute : int, - month : month, offset : int option, second : int, wday : wday, - yday : int, year : int} - fun fmt _ _ = failwith "not implemented Date.fmt" - fun fromTimeLocal _ = failwith "not implemented Date.fromTimeLocal" - end - -structure Posix = - struct - structure ProcEnv = - struct - fun getenv s = SOME (Sys.getenv s) handle Not_found => NONE - end - end - -structure SMLofNJ = - struct - fun exportML s = failwith ("not implemented exportML " ^ s) - end - -fun null x = x = [] -fun explode s = - let fun loop i = - if i = String.length s then [] - else String.get s i :: loop (i + 1) - in - loop 0 - end - -val app = List.iter -fun implode [] = "" - | implode (c :: l) = String.make 1 c ^ implode l - -fun ooo f g x = f (g x) - -structure Array = - struct - fun array (len, v) = Array.create len v - fun sub _ = failwith "not implemented Array.sub" - fun update _ = failwith "not implemented Array.update" - (* for make the profiler work *) - val set = Array.set - val get = Array.get - end - -structure Vector = - struct - fun tabulate _ = failwith "not implemented Vector.tabulate" - fun sub _ = failwith "not implemented Vector.sub" - end - -structure Bool = - struct - val toString = string_of_bool - end - -structure String = - struct - val size = String.length - fun substring (s, beg, len) = - String.sub s beg len handle Invalid_argument _ => raise Subscript - val concat = String.concat "" - fun sub (s, i) = String.get s i - val str = String.make 1 - fun compare (s1, s2) = - if s1 < s2 then LESS - else if s1 > s2 then GREATER - else EQUAL - fun isPrefix s1 s2 = - let fun loop i1 i2 = - if i1 >= String.length s1 then true - else if i2 >= String.length s2 then false - else if String.get s1 i1 = String.get s2 i2 then loop (i1 + 1) (i2 + 1) - else false - in - loop 0 0 - end - fun tokens p s = - let fun loop tok i = - if i >= String.length s then - if tok = "" then [] else [tok] - else if p (String.get s i) then - if tok <> "" then tok :: loop "" (i + 1) - else loop "" (i + 1) - else loop (tok ^ String.make 1 (String.get s i)) (i + 1) - in - loop "" 0 - end - fun extract _ = failwith "not implemented String.extract" - end - -structure Substring = - struct - type substring = string * int * int - fun string (s : substring) = String.substring s - fun all s : substring = (s, 0, String.size s) - fun splitl f ((s, beg, len) : substring) : substring * substring = - let fun loop di = - if di = len then ((s, beg, len), (s, 0, 0)) - else if f (String.sub (s, beg + di)) then loop (di + 1) - else ((s, beg, di), (s, beg + di, len - di)) - in - loop 0 - end - fun getc (s, i, len) = - if len > 0 andalso i < String.size s then - SOME (String.sub (s, i), (s, i+1, len-1)) - else NONE - fun slice _ = failwith "not implemented: Substring.slice" - fun isEmpty (s, beg, len) = len = 0 - fun concat sl = String.concat (List.map string sl) - end -type substring = Substring.substring - -structure StringCvt = - struct - datatype radix = BIN | OCT | DEC | HEX - type ('a, 'b) reader = 'b -> ('a * 'b) option - end - -structure ListPair = - struct - fun zip (a1::l1, a2::l2) = (a1, a2) :: zip (l1, l2) - | zip _ = [] - val unzip = List.split - fun all f (x1 :: l1, x2 :: l2) = f (x1, x2) andalso all f (l1, l2) - | all _ _ = true - fun map f (a1::l1, a2::l2) = - let val r = f (a1, a2) in r :: map f (l1, l2) end - | map _ _ = [] - end - -structure ListMergeSort = - struct - fun uniqueSort cmp l = - List.sort - (fn x => fn y => - case cmp (x, y) of - LESS => ~1 - | EQUAL => 0 - | GREATER => 1) - l - end - -structure List = - struct - exception Empty - fun hd [] = raise Empty - | hd (x :: l) = x - fun tl [] = raise Empty - | tl (x :: l) = l - fun foldr f a l = - let fun loop a [] = a - | loop a (x :: l) = loop (f (x, a)) l - in - loop a (List.rev l) - end - fun foldl f a l = List.fold_left (fn a => fn x => f (x, a)) a l - val concat = List.flatten - val exists = List.exists - val filter = List.filter - val length = List.length - val map = List.map - val rev = List.rev - val all = List.for_all - fun find f [] = NONE - | find f (x :: l) = if f x then SOME x else find f l - fun last s = - case List.rev s of - [] => raise Empty - | x :: _ => x - fun take _ = failwith "not implemented: List.take" - fun partition _ = failwith "not implemented: List.partition" - fun mapPartial f [] = [] - | mapPartial f (x :: l) = - case f x of - NONE => mapPartial f l - | SOME y => y :: mapPartial f l - fun op @ l1 l2 = List.rev_append (List.rev l1) l2 - end - -structure Int = - struct - type int1 = int - type int = int1 - val toString = string_of_int - fun fromString s = SOME (int_of_string s) handle Failure _ => NONE - fun min (x, y) = if x < y then x else y - fun max (x, y) = if x > y then x else y - fun scan radix getc src = failwith "not impl: Int.scan" - end - -val foldr = List.foldr -val exists = List.exists -val size = String.size -val substring = String.substring -val concat = String.concat -val length = List.length -val op @ = List.op @ -val hd = List.hd -val tl = List.tl -val map = List.map -val rev = List.rev -val use_hook = ref (fn (s : string) => (failwith "no defined directive use" : unit)) -fun use s = !use_hook s -fun isSome (SOME _) = true - | isSome NONE = false -fun valOf (SOME x) = x - | valOf NONE = failwith "valOf" -val print = TextIO.print diff --git a/config/.cvsignore b/config/.cvsignore index eaf9ea55..df99fdc7 100644 --- a/config/.cvsignore +++ b/config/.cvsignore @@ -1,4 +1,5 @@ m.h s.h Makefile +config.sh diff --git a/config/Makefile-templ b/config/Makefile-templ index 359b8dd2..515c2ec5 100644 --- a/config/Makefile-templ +++ b/config/Makefile-templ @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile-templ,v 1.29 2004/06/19 16:17:31 xleroy Exp $ +# $Id: Makefile-templ,v 1.30 2006/08/18 14:52:19 xleroy Exp $ ### Compile-time configuration @@ -219,20 +219,6 @@ SHARPBANGSCRIPTS=true ### How to perform a partial link PARTIALLD=ld -r $(NATIVECCLINKOPTS) -PACKLD=$(PARTIALLD) - -### Path to the "objcopy" program from GNU binutils. -# You need a sufficiently recent version of the binutils so that -# the option --redefine-sym is supported by objcopy. -# Leave blank if you don't have "objcopy", but then "ocamlopt -pack" -# will not work -#BINUTILS_OBJCOPY=/usr/bin/objcopy - -### Path to the "nm" program from GNU binutils. -# Other versions of nm do *not* work for our purposes. -# Leave blank if you don't have GNU "nm", but then "ocamlopt -pack" -# will not work -#BINUTILS_NM=/usr/bin/nm ############# Configuration for the contributed libraries diff --git a/config/Makefile.mingw b/config/Makefile.mingw index f0ae0407..34db3c0f 100644 --- a/config/Makefile.mingw +++ b/config/Makefile.mingw @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile.mingw,v 1.13 2005/08/01 15:51:09 xleroy Exp $ +# $Id: Makefile.mingw,v 1.19 2007/03/01 14:48:53 xleroy Exp $ # Configuration for Windows, Mingw compiler @@ -31,6 +31,9 @@ STUBLIBDIR=$(LIBDIR)/stublibs ### Where to install the info files DISTRIB=$(PREFIX) +### Where to install the man pages +MANDIR=$(PREFIX)/man + ########## Toolchain and OS dependencies TOOLCHAIN=mingw @@ -41,6 +44,33 @@ S=s SO=s.o DO=d.o EXE=.exe +EXT_DLL=.dll +EXT_OBJ=.$(O) +EXT_LIB=.$(A) +EXT_ASM=.$(S) +MANEXT=1 +SHARPBANGSCRIPTS=false +PTHREAD_LINK= +X11_INCLUDES= +X11_LINK= +DBM_INCLUDES= +DBM_LINK= +BYTECCRPATH= +SUPPORTS_SHARED_LIBRARIES=true +SHAREDCCCOMPOPTS= +MKSHAREDLIBRPATH= +NATIVECCPROFOPTS= +NATIVECCRPATH= +ASFLAGS= +ASPP= +ASPPFLAGS= +ASPPPROFFLAGS= +PROFILING=noprof +DYNLINKOPTS= +DEBUGGER= +CC_PROFILE= +SYSTHREAD_SUPPORT=true +EXTRALIBS= ########## Configuration for the bytecode compiler @@ -63,16 +93,24 @@ NATIVECCLIBS= ### How to invoke the C preprocessor CPP=$(BYTECC) -E +### How to build an EXE +MKEXE=$(BYTECC) -o $(1) $(2) +#ml let mkexe out files opts = Printf.sprintf "%s -o %s %s %s" bytecc out opts files;; + ### How to build a DLL MKDLL=$(BYTECC) -shared -o $(1) -Wl,--out-implib,$(2) $(3) +#ml let mkdll out implib files opts = Printf.sprintf "%s -shared -o %s -Wl,--out-implib,%s %s %s" bytecc out implib files opts;; ### How to build a static library MKLIB=rm -f $(1); ar rcs $(1) $(2) +#ml let mklib out files opts = Printf.sprintf "rm -f %s && ar rcs %s %s %s" out opts out files;; ### Canonicalize the name of a system library SYSLIB=-l$(1) +#ml let syslib x = "-l"^x;; ### The ranlib command +RANLIB=ranlib RANLIBCMD=ranlib ############# Configuration for the native-code compiler @@ -97,7 +135,7 @@ NATIVECCLINKOPTS= ### Build partially-linked object file PARTIALLD=ld -r $(NATIVECCLINKOPTS) -PACKLD=$(PARTIALLD) +PACKLD=$(PARTIALLD) -o #there must be a space after this '-o' ############# Configuration for the contributed libraries @@ -108,11 +146,11 @@ BNG_ARCH=ia32 BNG_ASM_LEVEL=1 ### Configuration for LablTk -# Set TK_ROOT to the directory where you installed TCL/TK 8.3 +# Set TK_ROOT to the directory where you installed TCL/TK 8.4 # There must be no spaces or special characters in $(TK_ROOT) TK_ROOT=c:/tcl TK_DEFS=-I$(TK_ROOT)/include -TK_LINK=$(TK_ROOT)/lib/tk83.lib $(TK_ROOT)/lib/tcl83.lib +TK_LINK=$(TK_ROOT)/lib/tk84.lib $(TK_ROOT)/lib/tcl84.lib ############# Aliases for common commands diff --git a/config/Makefile.msvc b/config/Makefile.msvc index f5104211..e8aae0b3 100644 --- a/config/Makefile.msvc +++ b/config/Makefile.msvc @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile.msvc,v 1.14.2.2 2006/07/27 16:10:37 xleroy Exp $ +# $Id: Makefile.msvc,v 1.21 2007/03/01 14:20:33 xleroy Exp $ # Configuration for Windows, Visual C++ compiler @@ -31,6 +31,9 @@ STUBLIBDIR=$(LIBDIR)/stublibs ### Where to install the info files DISTRIB=$(PREFIX) +### Where to install the man pages +MANDIR=$(PREFIX)/man + ########## Toolchain and OS dependencies TOOLCHAIN=msvc @@ -41,6 +44,32 @@ S=asm SO=s.obj DO=d.obj EXE=.exe +EXT_DLL=.dll +EXT_OBJ=.$(O) +EXT_LIB=.$(A) +EXT_ASM=.$(S) +MANEXT=1 +SHARPBANGSCRIPTS=false +PTHREAD_LINK= +X11_INCLUDES= +X11_LINK= +DBM_INCLUDES= +DBM_LINK= +BYTECCRPATH= +SUPPORTS_SHARED_LIBRARIES=true +SHAREDCCCOMPOPTS= +NATIVECCPROFOPTS= +NATIVECCRPATH= +ASFLAGS= +ASPP= +ASPPFLAGS= +ASPPPROFFLAGS= +PROFILING=noprof +DYNLINKOPTS= +DEBUGGER= +CC_PROFILE= +SYSTHREAD_SUPPORT=true +EXTRALIBS= ########## Configuration for the bytecode compiler @@ -63,16 +92,29 @@ NATIVECCLIBS=advapi32.lib ### How to invoke the C preprocessor CPP=cl /nologo /EP +### How to merge a .manifest (if any) in a .exe or .dll +MERGEMANIFEST=test ! -f $(1).manifest || mt -nologo -outputresource:$(1) -manifest $(1).manifest && rm -f $(1).manifest +#ml let mergemanifest out = Printf.sprintf "test ! -f %s.manifest || mt -nologo -outputresource:%s -manifest %s.manifest && rm -f %s.manifest" out out out out;; + +### How to build an EXE +MKEXE=$(BYTECC) /Fe$(1) $(2) && ($(MERGEMANIFEST)) +#ml let mkexe out files opts = Printf.sprintf "%s /Fe%s %s %s && (%s)" bytecc out opts files (mergemanifest out);; + ### How to build a DLL -MKDLL=link /nologo /dll /out:$(1) /implib:$(2) $(3) +MKDLL=link /nologo /dll /out:$(1) /implib:$(2) $(3) && ($(MERGEMANIFEST)) +#ml let mkdll out implib files opts = Printf.sprintf "link /nologo /dll /out:%s /implib:%s %s %s && (%s)" out implib opts files (mergemanifest out);; ### How to build a static library MKLIB=link /lib /nologo /out:$(1) $(2) +#ml let mklib out files opts = Printf.sprintf "link /lib /nologo /out:%s %s %s" out opts files;; +MKSHAREDLIBRPATH= ### Canonicalize the name of a system library SYSLIB=$(1).lib +#ml let syslib x = x ^ ".lib";; ### The ranlib command +RANLIB= RANLIBCMD= ############# Configuration for the native-code compiler @@ -96,8 +138,8 @@ NATIVECCCOMPOPTS=/Ox /MT NATIVECCLINKOPTS=/MT ### Build partially-linked object file -PARTIALLD=lib /nologo -PACKLD=ld -r --oformat pe-i386 +PARTIALLD=link /lib /nologo +PACKLD=link /lib /nologo /out:# there must be no space after this '/out:' ############# Configuration for the contributed libraries @@ -115,7 +157,7 @@ TK_DEFS=-I$(TK_ROOT)/include # produced by OCaml, and is therefore required for binary distribution # of these libraries. However, $(TK_ROOT) must be added to the LIB # environment variable, as described in README.win32. -TK_LINK=tk83.lib tcl83.lib +TK_LINK=tk84.lib tcl84.lib # An alternative definition that avoids mucking with the LIB variable, # but hard-wires the Tcl/Tk location in the binaries # TK_LINK=$(TK_ROOT)/tk83.lib $(TK_ROOT)/tcl83.lib diff --git a/config/Makefile.msvc64 b/config/Makefile.msvc64 new file mode 100644 index 00000000..387447d1 --- /dev/null +++ b/config/Makefile.msvc64 @@ -0,0 +1,163 @@ +######################################################################### +# # +# Objective Caml # +# # +# Xavier Leroy, projet Cristal, INRIA Rocquencourt # +# # +# Copyright 1999 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the GNU Library General Public License, with # +# the special exception on linking described in file ../LICENSE. # +# # +######################################################################### + +# $Id: Makefile.msvc64,v 1.6 2007/03/01 09:50:58 xleroy Exp $ + +# Configuration for Windows, Visual C++ compiler + +######### General configuration + +PREFIX=C:/ocamlms64 + +### Where to install the binaries. +BINDIR=$(PREFIX)/bin + +### Where to install the standard library +LIBDIR=$(PREFIX)/lib + +### Where to install the stub DLLs +STUBLIBDIR=$(LIBDIR)/stublibs + +### Where to install the info files +DISTRIB=$(PREFIX) + +### Where to install the man pages +MANDIR=$(PREFIX)/man + +########## Toolchain and OS dependencies + +TOOLCHAIN=msvc +CCOMPTYPE=msvc +O=obj +A=lib +S=asm +SO=s.obj +DO=d.obj +DBGO=dbg.obj +EXE=.exe +EXT_DLL=.dll +EXT_OBJ=.$(O) +EXT_LIB=.$(A) +EXT_ASM=.$(S) +MANEXT=1 +SHARPBANGSCRIPTS=false +PTHREAD_LINK= +X11_INCLUDES= +X11_LINK= +DBM_INCLUDES= +DBM_LINK= +BYTECCRPATH= +SUPPORTS_SHARED_LIBRARIES=true +SHAREDCCCOMPOPTS= +NATIVECCPROFOPTS= +NATIVECCRPATH= +ASFLAGS= +ASPP= +ASPPFLAGS= +ASPPPROFFLAGS= +PROFILING=noprof +DYNLINKOPTS= +DEBUGGER= +CC_PROFILE= +SYSTHREAD_SUPPORT=true + +########## Configuration for the bytecode compiler + +### Which C compiler to use for the bytecode interpreter. +BYTECC=cl /nologo -D_CRT_SECURE_NO_DEPRECATE + +### Additional compile-time options for $(BYTECC). (For static linking.) +BYTECCCOMPOPTS=/Ox /MT + +### Additional compile-time options for $(BYTECC). (For debug version.) +BYTECCDBGCOMPOPTS=-DDEBUG /Zi /W3 /Wp64 + +### Additional link-time options for $(BYTECC). (For static linking.) +BYTECCLINKOPTS=/MT + +### Additional compile-time options for $(BYTECC). (For building a DLL.) +DLLCCCOMPOPTS=/Ox /MD -DCAML_DLL + +### Libraries needed +EXTRALIBS=bufferoverflowu.lib +BYTECCLIBS=advapi32.lib $(EXTRALIBS) +NATIVECCLIBS=advapi32.lib $(EXTRALIBS) + +### How to invoke the C preprocessor +CPP=cl /nologo /EP + +### How to merge a .manifest (if any) in a .exe or .dll +MERGEMANIFEST=test ! -f $(1).manifest || mt -nologo -outputresource:$(1) -manifest $(1).manifest && rm -f $(1).manifest +#ml let mergemanifest out = Printf.sprintf "test ! -f %s.manifest || mt -nologo -outputresource:%s -manifest %s.manifest && rm -f %s.manifest" out out out out;; + +### How to build an EXE +MKEXE=$(BYTECC) /Fe$(1) $(2) && ($(MERGEMANIFEST)) +#ml let mkexe out files opts = Printf.sprintf "%s /Fe%s %s %s && (%s)" bytecc out opts files (mergemanifest out);; + +### How to build a DLL +MKDLL=link /nologo /dll /machine:AMD64 /out:$(1) /implib:$(2) $(3) $(EXTRALIBS) && ($(MERGEMANIFEST)) +#ml let mkdll out implib files opts = Printf.sprintf "link /nologo /dll /machine:AMD64 /out:%s /implib:%s %s %s && (%s)" out implib opts files (mergemanifest out);; + +### How to build a static library +MKLIB=link /lib /nologo /machine:AMD64 /out:$(1) $(2) +#ml let mklib out files opts = Printf.sprintf "link /lib /nologo /machine:AMD64 /out:%s %s %s" out opts files;; +MKSHAREDLIBRPATH= + +### Canonicalize the name of a system library +SYSLIB=$(1).lib +#ml let syslib x = x ^ ".lib";; + +### The ranlib command +RANLIB= +RANLIBCMD= + +############# Configuration for the native-code compiler + +### Name of architecture for the native-code compiler +ARCH=amd64 + +### Name of architecture model for the native-code compiler. +MODEL=default + +### Name of operating system family for the native-code compiler. +SYSTEM=win64 + +### Which C compiler to use for the native-code compiler. +NATIVECC=cl /nologo + +### Additional compile-time options for $(NATIVECC). +NATIVECCCOMPOPTS=/Ox /MT + +### Additional link-time options for $(NATIVECC) +NATIVECCLINKOPTS=/MT + +### Build partially-linked object file +PARTIALLD=link /lib /nologo /machine:AMD64 +PACKLD=link /lib /nologo /machine:AMD64 /out:# there must be no space after this '/out:' + +############# Configuration for the contributed libraries + +OTHERLIBRARIES=win32unix systhreads str num win32graph dynlink bigarray + +### Name of the target architecture for the "num" library +BNG_ARCH=generic +BNG_ASM_LEVEL=0 + +### Configuration for LablTk (not supported) +TK_DEFS= +TK_LINK= + +############# Aliases for common commands + +MAKEREC=$(MAKE) -f Makefile.nt +MAKECMD=$(MAKE) diff --git a/config/auto-aux/.cvsignore b/config/auto-aux/.cvsignore new file mode 100644 index 00000000..cb1ca8a9 --- /dev/null +++ b/config/auto-aux/.cvsignore @@ -0,0 +1 @@ +camlp4_config.ml diff --git a/config/m-nt.h b/config/m-nt.h index ce59dd5e..f89fb863 100644 --- a/config/m-nt.h +++ b/config/m-nt.h @@ -11,18 +11,28 @@ /* */ /***********************************************************************/ -/* $Id: m-nt.h,v 1.11 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: m-nt.h,v 1.12 2006/05/09 16:01:26 xleroy Exp $ */ /* Machine configuration, Intel x86 processors, Win32, Visual C++ or Mingw compiler */ +#ifdef _WIN64 +#define ARCH_SIXTYFOUR +#else #undef ARCH_SIXTYFOUR +#endif #undef ARCH_BIG_ENDIAN #undef ARCH_ALIGN_DOUBLE + #define SIZEOF_INT 4 #define SIZEOF_LONG 4 +#ifdef _WIN64 +#define SIZEOF_PTR 8 +#else #define SIZEOF_PTR 4 +#endif #define SIZEOF_SHORT 2 + #ifdef __MINGW32__ #define ARCH_INT64_TYPE long long #define ARCH_UINT64_TYPE unsigned long long @@ -31,5 +41,6 @@ #define ARCH_UINT64_TYPE unsigned __int64 #endif #define ARCH_INT64_PRINTF_FORMAT "I64" + #undef NONSTANDARD_DIV_MOD diff --git a/configure b/configure index c4906c2b..15272f76 100755 --- a/configure +++ b/configure @@ -13,7 +13,7 @@ # # ######################################################################### -# $Id: configure,v 1.228.2.5 2006/03/30 10:00:19 doligez Exp $ +# $Id: configure,v 1.244.4.1 2007/03/06 16:02:09 xleroy Exp $ configure_options="$*" prefix=/usr/local @@ -39,6 +39,7 @@ verbose=no withcurses=yes withsharedlibs=yes gcc_warnings="-Wall" +partialld="ld -r" # Try to turn internationalization off, can cause config.guess to malfunction! unset LANG @@ -247,9 +248,11 @@ case "$bytecc,$host" in bytecccompopts="-fno-defer-pop $gcc_warnings -DSHRINKED_GNUC" mathlib="";; *,*-*-darwin*) - # Almost the same as rhapsody bytecccompopts="-fno-defer-pop -no-cpp-precomp $gcc_warnings" - mathlib="";; + mathlib="" + # Tell gcc that we can use 32-bit code addresses for threaded code + # even if we compile in 64-bit mode + echo "#define ARCH_CODE32" >> m.h;; *,*-*-beos*) bytecccompopts="-fno-defer-pop $gcc_warnings" # No -lm library @@ -325,9 +328,11 @@ echo "Checking the sizes of integers and pointers..." set `sh ./runtest sizes.c` case "$2,$3" in 4,4) echo "OK, this is a regular 32 bit architecture." - echo "#undef ARCH_SIXTYFOUR" >> m.h;; + echo "#undef ARCH_SIXTYFOUR" >> m.h + arch64=false;; *,8) echo "Wow! A 64 bit architecture!" - echo "#define ARCH_SIXTYFOUR" >> m.h;; + echo "#define ARCH_SIXTYFOUR" >> m.h + arch64=true;; *,*) echo "This architecture seems to be neither 32 bits nor 64 bits." echo "Objective Caml won't run on this architecture." exit 2;; @@ -536,8 +541,8 @@ if test $withsharedlibs = "yes"; then byteccrpath="-Wl,-rpath," mksharedlibrpath="-rpath " shared_libraries_supported=true;; - powerpc-apple-darwin*) - mksharedlib="cc -bundle -flat_namespace -undefined suppress -o" + *-apple-darwin*) + mksharedlib="$bytecc -bundle -flat_namespace -undefined suppress -o" bytecccompopts="$dl_defs $bytecccompopts" #sharedcccompopts="-fnocommon" dl_needs_underscore=true @@ -585,9 +590,10 @@ case "$host" in hppa*-*-linux*) arch=hppa; system=linux;; hppa*-*-gnu*) arch=hppa; system=gnu;; powerpc-*-linux*) arch=power; model=ppc; system=elf;; - powerpc-*-netbsd*) arch=power; model=ppc; system=bsd;; + powerpc-*-netbsd*) arch=power; model=ppc; system=elf;; powerpc-*-rhapsody*) arch=power; model=ppc; system=rhapsody;; - powerpc-*-darwin*) arch=power; model=ppc; system=rhapsody;; + powerpc-*-darwin*) arch=power; system=rhapsody + if $arch64; then model=ppc64; else model=ppc; fi;; arm*-*-linux*) arch=arm; system=linux;; arm*-*-gnu*) arch=arm; system=gnu;; ia64-*-linux*) arch=ia64; system=linux;; @@ -596,6 +602,7 @@ case "$host" in x86_64-*-linux*) arch=amd64; system=linux;; x86_64-*-gnu*) arch=amd64; system=gnu;; x86_64-*-freebsd*) arch=amd64; system=freebsd;; + x86_64-*-netbsd*) arch=amd64; system=netbsd;; x86_64-*-openbsd*) arch=amd64; system=openbsd;; esac @@ -621,8 +628,8 @@ case "$arch,$nativecc,$system,$host_type" in nativecclinkopts="-posix";; *,*,rhapsody,*darwin[1-5].*) nativecccompopts="$gcc_warnings -DSHRINKED_GNUC";; - *,*,rhapsody,*) - nativecccompopts="$gcc_warnings -DDARWIN_VERSION_6 $dl_defs";; + *,*,rhapsody,*) nativecccompopts="$gcc_warnings -DDARWIN_VERSION_6 $dl_defs" + if $arch64; then partialld="ld -r -arch ppc64"; fi;; *,gcc*,cygwin,*) nativecccompopts="$gcc_warnings -U_WIN32";; *,gcc*,*,*) nativecccompopts="$gcc_warnings";; esac @@ -653,7 +660,7 @@ case "$arch,$model,$system" in hppa,*,*) aspp="$cc"; asppflags='-traditional -c -DSYS_$(SYSTEM)';; power,*,elf) aspp='gcc'; asppflags='-c';; power,*,bsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; - power,*,rhapsody) ;; + power,*,rhapsody) aspp="$bytecc"; asppflags='-c';; arm,*,linux) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; arm,*,gnu) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; ia64,*,*) asflags=-xexplicit @@ -667,6 +674,7 @@ case "$arch,$model,$system" in i386,*,linux_elf) profiling='prof';; i386,*,gnu) profiling='prof';; i386,*,bsd_elf) profiling='prof';; + i386,*,macosx) profiling='prof';; sparc,*,solaris) profiling='prof' case "$nativecc" in gcc*) ;; *) cc_profile='-xpg';; esac;; @@ -978,7 +986,7 @@ elif sh ./hasgot $dllib -ldl dlopen; then echo "dlopen() found in -ldl." dllib="$dllib -ldl" else - shared_libraries_supported=no + shared_libraries_supported=false fi if $shared_libraries_supported; then @@ -1026,7 +1034,7 @@ fi # Determine if system stack overflows can be detected case "$arch,$system" in - i386,linux_elf|amd64,linux) + i386,linux_elf|amd64,linux|power,rhapsody|i386,macosx) echo "System stack overflow can be detected." echo "#define HAS_STACK_OVERFLOW_DETECTION" >> s.h;; *) @@ -1058,10 +1066,14 @@ systhread_support=false if test "$pthread_wanted" = "yes"; then case "$host" in - *-*-solaris*) pthread_link="-lpthread -lposix4";; - *-*-freebsd*) pthread_link="-pthread";; - *-*-openbsd*) pthread_link="-pthread";; - *) pthread_link="-lpthread";; + *-*-solaris*) pthread_link="-lpthread -lposix4" + pthread_caml_link="-cclib -lpthread -cclib -lposix4";; + *-*-freebsd*) pthread_link="-pthread" + pthread_caml_link="-cclib -pthread";; + *-*-openbsd*) pthread_link="-pthread" + pthread_caml_link="-cclib -pthread";; + *) pthread_link="-lpthread" + pthread_caml_link="-cclib -lpthread";; esac if ./hasgot -i pthread.h $pthread_link pthread_self; then echo "POSIX threads library supported." @@ -1079,7 +1091,6 @@ if test "$pthread_wanted" = "yes"; then nativecccompopts="$nativecccompopts -pthread";; esac echo "Options for linking with POSIX threads: $pthread_link" - echo "PTHREAD_LINK=$pthread_link" >> Makefile if sh ./hasgot $pthread_link sigwait; then echo "sigwait() found" echo "#define HAS_SIGWAIT" >> s.h @@ -1088,7 +1099,10 @@ if test "$pthread_wanted" = "yes"; then echo "POSIX threads not found." pthread_link="" fi +else + pthread_link="" fi +echo "PTHREAD_LINK=$pthread_caml_link" >> Makefile # Determine if the bytecode thread library is supported @@ -1232,9 +1246,9 @@ else else x11_include="-I$x11_include" fi - echo "X11_INCLUDES=$x11_include" >> Makefile - echo "X11_LINK=$x11_link" >> Makefile fi +echo "X11_INCLUDES=$x11_include" >> Makefile +echo "X11_LINK=$x11_link" >> Makefile # See if we can compile the dbm library @@ -1276,13 +1290,13 @@ else else dbm_include="-I$dbm_include" fi - echo "DBM_INCLUDES=$dbm_include" >> Makefile - echo "DBM_LINK=$dbm_link" >> Makefile if test "$use_gdbm_ndbm" = "yes"; then echo "#define DBM_USES_GDBM_NDBM" >> s.h fi otherlibraries="$otherlibraries dbm" fi +echo "DBM_INCLUDES=$dbm_include" >> Makefile +echo "DBM_LINK=$dbm_link" >> Makefile # Look for tcl/tk @@ -1312,7 +1326,8 @@ if test $has_tk = true; then "-I/usr/include/tcl8.3 -I/usr/include/tk8.3" \ "-I/usr/local/include/tcl8.2 -I/usr/local/include/tk8.2" \ "-I/usr/include/tcl8.2 -I/usr/include/tk8.2" \ - "-I/sw/include" + "-I/sw/include" \ + "-I/usr/pkg/include" do if test -z "$tcl_version"; then tk_defs="$tk_incs" tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c` @@ -1358,17 +1373,27 @@ if test $has_tk = true; then elif sh ./hasgot -L/sw/lib $tk_libs -ltcl$tclmaj.$tclmin $tkauxlibs \ Tcl_DoOneEvent then tk_libs="-L/sw/lib -ltk$tkmaj.$tkmin -ltcl$tclmaj.$tclmin $dllib" + elif sh ./hasgot -L/usr/pkg/lib $tk_libs $tk_x11_libs \ + -ltk$tkmaj$tkmin -ltcl$tclmaj$tclmin -lpthread $tkauxlibs \ + Tcl_DoOneEvent + then + tk_libs="-L/usr/pkg/lib $tk_libs $tk_x11_libs -ltk$tkmaj$tkmin -ltcl$tclmaj$tclmin -lpthread $tkauxlibs" else echo "Tcl library not found." has_tk=false fi fi + if test $has_tk = true; then if sh ./hasgot $tk_libs $tk_x11_libs $tkauxlibs Tk_SetGrid; then echo "Tcl/Tk libraries found." elif sh ./hasgot -L/sw/lib $tk_libs $tk_x11_libs $tkauxlibs Tk_SetGrid; then tk_libs="-L/sw/lib $tk_libs" echo "Tcl/Tk libraries found." + elif sh ./hasgot -L/usr/pkg/lib $tk_libs $tk_x11_libs $tkauxlibs \ + Tk_SetGrid; then + tk_libs="-L/usr/pkg/lib $tk_libs" + echo "Tcl/Tk libraries found." else echo "Tcl library found." echo "Tk library not found." @@ -1387,20 +1412,10 @@ if test $has_tk = true; then otherlibraries="$otherlibraries labltk" else echo "Configuration failed, LablTk will not be built." + echo "TK_DEFS=" >> Makefile + echo "TK_LINK=" >> Makefile fi -# Begin Camlp4 -( -cd ../../camlp4/config -EXE=$exe ./configure_batch -prefix "$prefix" -bindir "$bindir" -libdir "$libdir" -mandir "$mandir" -ocaml-top ../.. > /dev/null -) - -case $? in - 0) echo "Camlp4 correctly configured.";; - *) echo "Warning: Camlp4 configuration terminated with error code $?";; -esac -# End Camlp4 - # Final twiddling of compiler options to work around known bugs nativeccprofopts="$nativecccompopts" @@ -1422,8 +1437,22 @@ echo "BYTECCRPATH=$byteccrpath" >> Makefile echo "EXE=$exe" >> Makefile echo "SUPPORTS_SHARED_LIBRARIES=$shared_libraries_supported" >> Makefile echo "SHAREDCCCOMPOPTS=$sharedcccompopts" >> Makefile -echo "MKSHAREDLIB=$mksharedlib" >> Makefile echo "MKSHAREDLIBRPATH=$mksharedlibrpath" >> Makefile +cat >> Makefile <> Makefile echo "MODEL=$model" >> Makefile echo "SYSTEM=$system" >> Makefile @@ -1442,7 +1471,18 @@ echo "DYNLINKOPTS=$dllib" >> Makefile echo "OTHERLIBRARIES=$otherlibraries" >> Makefile echo "DEBUGGER=$debugger" >> Makefile echo "CC_PROFILE=$cc_profile" >> Makefile -echo "SYSTHREAD_SUPPORT=$systhread_support" >>Makefile +echo "SYSTHREAD_SUPPORT=$systhread_support" >> Makefile +echo "PARTIALLD=$partialld" >> Makefile +echo "DLLCCCOMPOPTS=" >> Makefile +echo "O=o" >> Makefile +echo "A=a" >> Makefile +echo "EXT_OBJ=.o" >> Makefile +echo "EXT_ASM=.s" >> Makefile +echo "EXT_LIB=.a" >> Makefile +echo "EXT_DLL=.so" >> Makefile +echo "EXTRALIBS=" >> Makefile +echo "CCOMPTYPE=cc" >> Makefile +echo "TOOLCHAIN=cc" >> Makefile rm -f tst hasgot.c rm -f ../m.h ../s.h ../Makefile diff --git a/debugger/.depend b/debugger/.depend index 07a35e54..328b77bd 100644 --- a/debugger/.depend +++ b/debugger/.depend @@ -9,7 +9,7 @@ events.cmi: ../bytecomp/instruct.cmi frames.cmi: primitives.cmi ../bytecomp/instruct.cmi input_handling.cmi: primitives.cmi lexer.cmi: parser.cmi -loadprinter.cmi: ../parsing/longident.cmi ../otherlibs/dynlink/dynlink.cmi +loadprinter.cmi: ../parsing/longident.cmi dynlink.cmi parser.cmi: parser_aux.cmi ../parsing/longident.cmi parser_aux.cmi: primitives.cmi ../parsing/longident.cmi pattern_matching.cmi: ../typing/typedtree.cmi parser_aux.cmi debugcom.cmi @@ -33,7 +33,7 @@ checkpoints.cmo: primitives.cmi int64ops.cmi debugcom.cmi checkpoints.cmi checkpoints.cmx: primitives.cmx int64ops.cmx debugcom.cmx checkpoints.cmi command_line.cmo: unix_tools.cmi ../otherlibs/unix/unix.cmi \ ../typing/types.cmi time_travel.cmi symbols.cmi source.cmi \ - show_source.cmi show_information.cmi program_management.cmi \ + show_source.cmi show_information.cmi question.cmi program_management.cmi \ program_loading.cmi printval.cmi primitives.cmi pos.cmi parser_aux.cmi \ parser.cmi parameters.cmi ../utils/misc.cmi ../parsing/location.cmi \ loadprinter.cmi lexer.cmi int64ops.cmi ../bytecomp/instruct.cmi \ @@ -42,7 +42,7 @@ command_line.cmo: unix_tools.cmi ../otherlibs/unix/unix.cmi \ checkpoints.cmi breakpoints.cmi command_line.cmi command_line.cmx: unix_tools.cmx ../otherlibs/unix/unix.cmx \ ../typing/types.cmx time_travel.cmx symbols.cmx source.cmx \ - show_source.cmx show_information.cmx program_management.cmx \ + show_source.cmx show_information.cmx question.cmx program_management.cmx \ program_loading.cmx printval.cmx primitives.cmx pos.cmx parser_aux.cmi \ parser.cmx parameters.cmx ../utils/misc.cmx ../parsing/location.cmx \ loadprinter.cmx lexer.cmx int64ops.cmx ../bytecomp/instruct.cmx \ @@ -55,6 +55,14 @@ debugcom.cmx: primitives.cmx ../utils/misc.cmx int64ops.cmx \ input_handling.cmx debugcom.cmi debugger_config.cmo: int64ops.cmi debugger_config.cmi debugger_config.cmx: int64ops.cmx debugger_config.cmi +dynlink.cmo: ../bytecomp/symtable.cmi ../bytecomp/opcodes.cmo \ + ../utils/misc.cmi ../bytecomp/meta.cmi ../bytecomp/dll.cmi \ + ../utils/consistbl.cmi ../utils/config.cmi ../bytecomp/cmo_format.cmi \ + dynlink.cmi +dynlink.cmx: ../bytecomp/symtable.cmx ../bytecomp/opcodes.cmx \ + ../utils/misc.cmx ../bytecomp/meta.cmx ../bytecomp/dll.cmx \ + ../utils/consistbl.cmx ../utils/config.cmx ../bytecomp/cmo_format.cmi \ + dynlink.cmi envaux.cmo: ../typing/types.cmi ../typing/printtyp.cmi ../typing/path.cmi \ ../typing/mtype.cmi ../utils/misc.cmi ../bytecomp/instruct.cmi \ ../typing/env.cmi envaux.cmi @@ -89,9 +97,9 @@ history.cmo: primitives.cmi ../utils/misc.cmi int64ops.cmi \ debugger_config.cmi checkpoints.cmi history.cmi history.cmx: primitives.cmx ../utils/misc.cmx int64ops.cmx \ debugger_config.cmx checkpoints.cmx history.cmi -input_handling.cmo: ../otherlibs/unix/unix.cmi primitives.cmi lexer.cmi \ +input_handling.cmo: ../otherlibs/unix/unix.cmi primitives.cmi \ input_handling.cmi -input_handling.cmx: ../otherlibs/unix/unix.cmx primitives.cmx lexer.cmx \ +input_handling.cmx: ../otherlibs/unix/unix.cmx primitives.cmx \ input_handling.cmi int64ops.cmo: int64ops.cmi int64ops.cmx: int64ops.cmi @@ -100,21 +108,21 @@ lexer.cmx: primitives.cmx parser.cmx lexer.cmi loadprinter.cmo: ../typing/types.cmi ../bytecomp/symtable.cmi printval.cmi \ ../typing/printtyp.cmi ../typing/path.cmi ../utils/misc.cmi \ ../parsing/longident.cmi ../typing/ident.cmi ../typing/env.cmi \ - ../otherlibs/dynlink/dynlink.cmi debugger_config.cmi ../typing/ctype.cmi \ - ../utils/config.cmi loadprinter.cmi + dynlink.cmi debugger_config.cmi ../typing/ctype.cmi ../utils/config.cmi \ + loadprinter.cmi loadprinter.cmx: ../typing/types.cmx ../bytecomp/symtable.cmx printval.cmx \ ../typing/printtyp.cmx ../typing/path.cmx ../utils/misc.cmx \ ../parsing/longident.cmx ../typing/ident.cmx ../typing/env.cmx \ - ../otherlibs/dynlink/dynlink.cmx debugger_config.cmx ../typing/ctype.cmx \ - ../utils/config.cmx loadprinter.cmi + dynlink.cmx debugger_config.cmx ../typing/ctype.cmx ../utils/config.cmx \ + loadprinter.cmi main.cmo: unix_tools.cmi ../otherlibs/unix/unix.cmi time_travel.cmi \ - show_information.cmi program_management.cmi primitives.cmi parameters.cmi \ - ../utils/misc.cmi input_handling.cmi frames.cmi exec.cmi \ + show_information.cmi question.cmi program_management.cmi primitives.cmi \ + parameters.cmi ../utils/misc.cmi input_handling.cmi frames.cmi exec.cmi \ ../typing/env.cmi debugger_config.cmi ../utils/config.cmi \ command_line.cmi checkpoints.cmi main.cmx: unix_tools.cmx ../otherlibs/unix/unix.cmx time_travel.cmx \ - show_information.cmx program_management.cmx primitives.cmx parameters.cmx \ - ../utils/misc.cmx input_handling.cmx frames.cmx exec.cmx \ + show_information.cmx question.cmx program_management.cmx primitives.cmx \ + parameters.cmx ../utils/misc.cmx input_handling.cmx frames.cmx exec.cmx \ ../typing/env.cmx debugger_config.cmx ../utils/config.cmx \ command_line.cmx checkpoints.cmx parameters.cmo: primitives.cmi ../utils/misc.cmi envaux.cmi \ @@ -152,23 +160,23 @@ program_loading.cmx: unix_tools.cmx ../otherlibs/unix/unix.cmx primitives.cmx \ parameters.cmx ../utils/misc.cmx input_handling.cmx debugger_config.cmx \ program_loading.cmi program_management.cmo: unix_tools.cmi ../otherlibs/unix/unix.cmi \ - time_travel.cmi symbols.cmi program_loading.cmi primitives.cmi \ - parameters.cmi ../utils/misc.cmi int64ops.cmi ../bytecomp/instruct.cmi \ - input_handling.cmi history.cmi debugger_config.cmi debugcom.cmi \ - breakpoints.cmi program_management.cmi + time_travel.cmi symbols.cmi question.cmi program_loading.cmi \ + primitives.cmi parameters.cmi ../utils/misc.cmi int64ops.cmi \ + ../bytecomp/instruct.cmi input_handling.cmi history.cmi \ + debugger_config.cmi debugcom.cmi breakpoints.cmi program_management.cmi program_management.cmx: unix_tools.cmx ../otherlibs/unix/unix.cmx \ - time_travel.cmx symbols.cmx program_loading.cmx primitives.cmx \ - parameters.cmx ../utils/misc.cmx int64ops.cmx ../bytecomp/instruct.cmx \ - input_handling.cmx history.cmx debugger_config.cmx debugcom.cmx \ - breakpoints.cmx program_management.cmi + time_travel.cmx symbols.cmx question.cmx program_loading.cmx \ + primitives.cmx parameters.cmx ../utils/misc.cmx int64ops.cmx \ + ../bytecomp/instruct.cmx input_handling.cmx history.cmx \ + debugger_config.cmx debugcom.cmx breakpoints.cmx program_management.cmi +question.cmo: primitives.cmi lexer.cmi input_handling.cmi question.cmi +question.cmx: primitives.cmx lexer.cmx input_handling.cmx question.cmi show_information.cmo: symbols.cmi show_source.cmi printval.cmi primitives.cmi \ - ../utils/misc.cmi ../parsing/location.cmi ../bytecomp/instruct.cmi \ - frames.cmi events.cmi debugcom.cmi checkpoints.cmi breakpoints.cmi \ - show_information.cmi + ../utils/misc.cmi ../bytecomp/instruct.cmi frames.cmi events.cmi \ + debugcom.cmi checkpoints.cmi breakpoints.cmi show_information.cmi show_information.cmx: symbols.cmx show_source.cmx printval.cmx primitives.cmx \ - ../utils/misc.cmx ../parsing/location.cmx ../bytecomp/instruct.cmx \ - frames.cmx events.cmx debugcom.cmx checkpoints.cmx breakpoints.cmx \ - show_information.cmi + ../utils/misc.cmx ../bytecomp/instruct.cmx frames.cmx events.cmx \ + debugcom.cmx checkpoints.cmx breakpoints.cmx show_information.cmi show_source.cmo: source.cmi primitives.cmi parameters.cmi ../utils/misc.cmi \ ../parsing/location.cmi ../bytecomp/instruct.cmi events.cmi \ debugger_config.cmi show_source.cmi @@ -183,14 +191,16 @@ symbols.cmo: ../bytecomp/symtable.cmi primitives.cmi ../bytecomp/instruct.cmi \ symbols.cmx: ../bytecomp/symtable.cmx primitives.cmx ../bytecomp/instruct.cmx \ events.cmx debugger_config.cmx debugcom.cmx checkpoints.cmx \ ../bytecomp/bytesections.cmx symbols.cmi -time_travel.cmo: trap_barrier.cmi symbols.cmi program_loading.cmi \ - primitives.cmi ../utils/misc.cmi int64ops.cmi ../bytecomp/instruct.cmi \ - input_handling.cmi exec.cmi events.cmi debugger_config.cmi debugcom.cmi \ - checkpoints.cmi breakpoints.cmi time_travel.cmi -time_travel.cmx: trap_barrier.cmx symbols.cmx program_loading.cmx \ - primitives.cmx ../utils/misc.cmx int64ops.cmx ../bytecomp/instruct.cmx \ - input_handling.cmx exec.cmx events.cmx debugger_config.cmx debugcom.cmx \ - checkpoints.cmx breakpoints.cmx time_travel.cmi +time_travel.cmo: trap_barrier.cmi symbols.cmi question.cmi \ + program_loading.cmi primitives.cmi ../utils/misc.cmi int64ops.cmi \ + ../bytecomp/instruct.cmi input_handling.cmi exec.cmi events.cmi \ + debugger_config.cmi debugcom.cmi checkpoints.cmi breakpoints.cmi \ + time_travel.cmi +time_travel.cmx: trap_barrier.cmx symbols.cmx question.cmx \ + program_loading.cmx primitives.cmx ../utils/misc.cmx int64ops.cmx \ + ../bytecomp/instruct.cmx input_handling.cmx exec.cmx events.cmx \ + debugger_config.cmx debugcom.cmx checkpoints.cmx breakpoints.cmx \ + time_travel.cmi trap_barrier.cmo: exec.cmi debugcom.cmi checkpoints.cmi trap_barrier.cmi trap_barrier.cmx: exec.cmx debugcom.cmx checkpoints.cmx trap_barrier.cmi unix_tools.cmo: ../otherlibs/unix/unix.cmi primitives.cmi ../utils/misc.cmi \ diff --git a/debugger/Makefile b/debugger/Makefile index 1e977391..35181ddf 100644 --- a/debugger/Makefile +++ b/debugger/Makefile @@ -10,7 +10,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.30 2005/08/25 15:35:16 doligez Exp $ +# $Id: Makefile,v 1.32 2006/12/09 13:49:10 ertai Exp $ include ../config/Makefile @@ -25,7 +25,7 @@ DEPFLAGS=$(INCLUDES) INCLUDES=\ -I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../toplevel \ - -I ../otherlibs/unix -I ../otherlibs/dynlink + -I ../otherlibs/unix OTHEROBJS=\ ../otherlibs/unix/unix.cma \ @@ -40,10 +40,11 @@ OTHEROBJS=\ ../bytecomp/runtimedef.cmo ../bytecomp/bytesections.cmo \ ../bytecomp/dll.cmo ../bytecomp/meta.cmo ../bytecomp/symtable.cmo \ ../bytecomp/opcodes.cmo \ - ../toplevel/genprintval.cmo \ - ../otherlibs/dynlink/dynlink.cmo + ../toplevel/genprintval.cmo + OBJS=\ + dynlink.cmo \ int64ops.cmo \ primitives.cmo \ unix_tools.cmo \ @@ -52,6 +53,7 @@ OBJS=\ parameters.cmo \ lexer.cmo \ input_handling.cmo \ + question.cmo \ debugcom.cmo \ exec.cmo \ source.cmo \ diff --git a/debugger/command_line.ml b/debugger/command_line.ml index 9f557de3..c77d1ce3 100644 --- a/debugger/command_line.ml +++ b/debugger/command_line.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: command_line.ml,v 1.23 2005/08/25 15:35:16 doligez Exp $ *) +(* $Id: command_line.ml,v 1.24 2006/12/09 13:49:10 ertai Exp $ *) (************************ Reading and executing commands ***************) @@ -28,6 +28,7 @@ open Parser open Parser_aux open Lexer open Input_handling +open Question open Debugcom open Program_loading open Program_management @@ -554,7 +555,7 @@ let instr_break ppf lexbuf = new_breakpoint (try let buffer = - try get_buffer module_name with + try get_buffer Lexing.dummy_pos module_name with | Not_found -> eprintf "No source file for %s.@." module_name; raise Toplevel @@ -632,11 +633,10 @@ let instr_backtrace ppf lexbuf = do_backtrace (print_frame 0 number) else begin let num_frames = stack_depth() in - if num_frames < 0 then begin + if num_frames < 0 then fprintf ppf - "(Encountered a function with no debugging information)"; - print_newline() - end else + "(Encountered a function with no debugging information)@." + else do_backtrace (print_frame (num_frames + number) max_int) end @@ -686,13 +686,14 @@ let instr_list ppf lexbuf = ("", -1) in let mdle = convert_module mo in + let pos = Lexing.dummy_pos in let beginning = match beg with | None when (mo <> None) || (point = -1) -> 1 | None -> let buffer = - try get_buffer mdle with + try get_buffer pos mdle with | Not_found -> error ("No source file for " ^ mdle ^ ".") in begin try @@ -708,10 +709,10 @@ let instr_list ppf lexbuf = | Some x -> x in if mdle = curr_mod then - show_listing mdle beginning en point + show_listing pos mdle beginning en point (current_event_is_before ()) else - show_listing mdle beginning en (-1) true + show_listing pos mdle beginning en (-1) true (** Variables. **) let raw_variable kill name = diff --git a/debugger/dynlink.ml b/debugger/dynlink.ml new file mode 100644 index 00000000..65e35ed5 --- /dev/null +++ b/debugger/dynlink.ml @@ -0,0 +1,252 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id: dynlink.ml,v 1.2 2006/09/28 21:36:38 xleroy Exp $ *) + +(* Dynamic loading of .cmo files *) + +(* This is a copy of ../otherlibs/dynlink/dynlink.ml that does not + use Dynlinkaux (the module that packs some of the compiler modules). *) + +open Cmo_format + +type linking_error = + Undefined_global of string + | Unavailable_primitive of string + | Uninitialized_global of string + +type error = + Not_a_bytecode_file of string + | Inconsistent_import of string + | Unavailable_unit of string + | Unsafe_file + | Linking_error of string * linking_error + | Corrupted_interface of string + | File_not_found of string + | Cannot_open_dll of string + +exception Error of error + +(* Management of interface CRCs *) + +let crc_interfaces = ref (Consistbl.create ()) +let allow_extension = ref true + +(* Check that the object file being loaded has been compiled against + the same interfaces as the program itself. In addition, check that + only authorized compilation units are referenced. *) + +let check_consistency file_name cu = + try + List.iter + (fun (name, crc) -> + if name = cu.cu_name then + Consistbl.set !crc_interfaces name crc file_name + else if !allow_extension then + Consistbl.check !crc_interfaces name crc file_name + else + Consistbl.check_noadd !crc_interfaces name crc file_name) + cu.cu_imports + with Consistbl.Inconsistency(name, user, auth) -> + raise(Error(Inconsistent_import name)) + | Consistbl.Not_available(name) -> + raise(Error(Unavailable_unit name)) + +(* Empty the crc_interfaces table *) + +let clear_available_units () = + Consistbl.clear !crc_interfaces; + allow_extension := false + +(* Allow only access to the units with the given names *) + +let allow_only names = + Consistbl.filter (fun name -> List.mem name names) !crc_interfaces; + allow_extension := false + +(* Prohibit access to the units with the given names *) + +let prohibit names = + Consistbl.filter (fun name -> not (List.mem name names)) !crc_interfaces; + allow_extension := false + +(* Initialize the crc_interfaces table with a list of units with fixed CRCs *) + +let add_available_units units = + List.iter (fun (unit, crc) -> Consistbl.set !crc_interfaces unit crc "") + units + +(* Default interface CRCs: those found in the current executable *) +let default_crcs = ref [] + +let default_available_units () = + clear_available_units(); + add_available_units !default_crcs; + allow_extension := true + +(* Initialize the linker tables and everything *) + +let init () = + default_crcs := Symtable.init_toplevel(); + default_available_units () + +(* Read the CRC of an interface from its .cmi file *) + +let digest_interface unit loadpath = + let filename = + let shortname = unit ^ ".cmi" in + try + Misc.find_in_path_uncap loadpath shortname + with Not_found -> + raise (Error(File_not_found shortname)) in + let ic = open_in_bin filename in + try + let buffer = String.create (String.length Config.cmi_magic_number) in + really_input ic buffer 0 (String.length Config.cmi_magic_number); + if buffer <> Config.cmi_magic_number then begin + close_in ic; + raise(Error(Corrupted_interface filename)) + end; + ignore (input_value ic); + let crc = + match input_value ic with + (_, crc) :: _ -> crc + | _ -> raise(Error(Corrupted_interface filename)) + in + close_in ic; + crc + with End_of_file | Failure _ -> + close_in ic; + raise(Error(Corrupted_interface filename)) + +(* Initialize the crc_interfaces table with a list of units. + Their CRCs are read from their interfaces. *) + +let add_interfaces units loadpath = + add_available_units + (List.map (fun unit -> (unit, digest_interface unit loadpath)) units) + +(* Check whether the object file being loaded was compiled in unsafe mode *) + +let unsafe_allowed = ref false + +let allow_unsafe_modules b = + unsafe_allowed := b + +let check_unsafe_module cu = + if (not !unsafe_allowed) && cu.cu_primitives <> [] + then raise(Error(Unsafe_file)) + +(* Load in-core and execute a bytecode object file *) + +let load_compunit ic file_name compunit = + check_consistency file_name compunit; + check_unsafe_module compunit; + seek_in ic compunit.cu_pos; + let code_size = compunit.cu_codesize + 8 in + let code = Meta.static_alloc code_size in + unsafe_really_input ic code 0 compunit.cu_codesize; + String.unsafe_set code compunit.cu_codesize (Char.chr Opcodes.opRETURN); + String.unsafe_set code (compunit.cu_codesize + 1) '\000'; + String.unsafe_set code (compunit.cu_codesize + 2) '\000'; + String.unsafe_set code (compunit.cu_codesize + 3) '\000'; + String.unsafe_set code (compunit.cu_codesize + 4) '\001'; + String.unsafe_set code (compunit.cu_codesize + 5) '\000'; + String.unsafe_set code (compunit.cu_codesize + 6) '\000'; + String.unsafe_set code (compunit.cu_codesize + 7) '\000'; + let initial_symtable = Symtable.current_state() in + begin try + Symtable.patch_object code compunit.cu_reloc; + Symtable.check_global_initialized compunit.cu_reloc; + Symtable.update_global_table() + with Symtable.Error error -> + let new_error = + match error with + Symtable.Undefined_global s -> Undefined_global s + | Symtable.Unavailable_primitive s -> Unavailable_primitive s + | Symtable.Uninitialized_global s -> Uninitialized_global s + | _ -> assert false in + raise(Error(Linking_error (file_name, new_error))) + end; + begin try + ignore((Meta.reify_bytecode code code_size) ()) + with exn -> + Symtable.restore_state initial_symtable; + raise exn + end + +let loadfile file_name = + let ic = open_in_bin file_name in + try + let buffer = String.create (String.length Config.cmo_magic_number) in + really_input ic buffer 0 (String.length Config.cmo_magic_number); + if buffer = Config.cmo_magic_number then begin + let compunit_pos = input_binary_int ic in (* Go to descriptor *) + seek_in ic compunit_pos; + load_compunit ic file_name (input_value ic : compilation_unit) + end else + if buffer = Config.cma_magic_number then begin + let toc_pos = input_binary_int ic in (* Go to table of contents *) + seek_in ic toc_pos; + let lib = (input_value ic : library) in + begin try + Dll.open_dlls Dll.For_execution + (List.map Dll.extract_dll_name lib.lib_dllibs) + with Failure reason -> + raise(Error(Cannot_open_dll reason)) + end; + List.iter (load_compunit ic file_name) lib.lib_units + end else + raise(Error(Not_a_bytecode_file file_name)); + close_in ic + with exc -> + close_in ic; raise exc + +let loadfile_private file_name = + let initial_symtable = Symtable.current_state() + and initial_crc = !crc_interfaces in + try + loadfile file_name; + Symtable.hide_additions initial_symtable; + crc_interfaces := initial_crc + with exn -> + Symtable.hide_additions initial_symtable; + crc_interfaces := initial_crc; + raise exn + +(* Error report *) + +let error_message = function + Not_a_bytecode_file name -> + name ^ " is not a bytecode object file" + | Inconsistent_import name -> + "interface mismatch on " ^ name + | Unavailable_unit name -> + "no implementation available for " ^ name + | Unsafe_file -> + "this object file uses unsafe features" + | Linking_error (name, Undefined_global s) -> + "error while linking " ^ name ^ ".\n" ^ + "Reference to undefined global `" ^ s ^ "'" + | Linking_error (name, Unavailable_primitive s) -> + "error while linking " ^ name ^ ".\n" ^ + "The external function `" ^ s ^ "' is not available" + | Linking_error (name, Uninitialized_global s) -> + "error while linking " ^ name ^ ".\n" ^ + "The module `" ^ s ^ "' is not yet initialized" + | Corrupted_interface name -> + "corrupted interface file " ^ name + | File_not_found name -> + "cannot find file " ^ name ^ " in search path" + | Cannot_open_dll reason -> + "error loading shared library: " ^ reason diff --git a/debugger/dynlink.mli b/debugger/dynlink.mli new file mode 100644 index 00000000..f349bf37 --- /dev/null +++ b/debugger/dynlink.mli @@ -0,0 +1,129 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id: dynlink.mli,v 1.1 2006/05/11 15:51:31 xleroy Exp $ *) + +(** Dynamic loading of bytecode object files. *) + +(** {6 Initialization} *) + +val init : unit -> unit +(** Initialize the [Dynlink] library. + Must be called before any other function in this module. *) + +(** {6 Dynamic loading of compiled bytecode files} *) + +val loadfile : string -> unit +(** Load the given bytecode object file ([.cmo] file) or + bytecode library file ([.cma] file), and link it with the running program. + All toplevel expressions in the loaded compilation units + are evaluated. No facilities are provided to + access value names defined by the unit. Therefore, the unit + must register itself its entry points with the main program, + e.g. by modifying tables of functions. *) + +val loadfile_private : string -> unit +(** Same as [loadfile], except that the compilation units just loaded + are hidden (cannot be referenced) from other modules dynamically + loaded afterwards. *) + +(** {6 Access control} *) + +val allow_only: string list -> unit +(** [allow_only units] restricts the compilation units that dynamically-linked + units can reference: it only allows references to the units named in + list [units]. References to any other compilation unit will cause + a [Unavailable_unit] error during [loadfile] or [loadfile_private]. + + Initially (just after calling [init]), all compilation units composing + the program currently running are available for reference from + dynamically-linked units. [allow_only] can be used to grant access + to some of them only, e.g. to the units that compose the API for + dynamically-linked code, and prevent access to all other units, + e.g. private, internal modules of the running program. *) + +val prohibit: string list -> unit +(** [prohibit units] prohibits dynamically-linked units from referencing + the units named in list [units]. This can be used to prevent + access to selected units, e.g. private, internal modules of + the running program. *) + +val default_available_units: unit -> unit +(** Reset the set of units that can be referenced from dynamically-linked + code to its default value, that is, all units composing the currently + running program. *) + +val allow_unsafe_modules : bool -> unit +(** Govern whether unsafe object files are allowed to be + dynamically linked. A compilation unit is ``unsafe'' if it contains + declarations of external functions, which can break type safety. + By default, dynamic linking of unsafe object files is + not allowed. *) + +(** {6 Deprecated, low-level API for access control} *) + +(** @deprecated The functions [add_interfaces], [add_available_units] + and [clear_available_units] should not be used in new programs, + since the default initialization of allowed units, along with the + [allow_only] and [prohibit] function, provides a better, safer + mechanism to control access to program units. The three functions + below are provided for backward compatibility only. *) + +val add_interfaces : string list -> string list -> unit +(** [add_interfaces units path] grants dynamically-linked object + files access to the compilation units named in list [units]. + The interfaces ([.cmi] files) for these units are searched in + [path] (a list of directory names). *) + +val add_available_units : (string * Digest.t) list -> unit +(** Same as {!Dynlink.add_interfaces}, but instead of searching [.cmi] files + to find the unit interfaces, uses the interface digests given + for each unit. This way, the [.cmi] interface files need not be + available at run-time. The digests can be extracted from [.cmi] + files using the [extract_crc] program installed in the + Objective Caml standard library directory. *) + +val clear_available_units : unit -> unit +(** Empty the list of compilation units accessible to dynamically-linked + programs. *) + +(** {6 Error reporting} *) + +type linking_error = + Undefined_global of string + | Unavailable_primitive of string + | Uninitialized_global of string + +type error = + Not_a_bytecode_file of string + | Inconsistent_import of string + | Unavailable_unit of string + | Unsafe_file + | Linking_error of string * linking_error + | Corrupted_interface of string + | File_not_found of string + | Cannot_open_dll of string + +exception Error of error +(** Errors in dynamic linking are reported by raising the [Error] + exception with a description of the error. *) + +val error_message : error -> string +(** Convert an error description to a printable message. *) + + +(**/**) + +(** {6 Internal functions} *) + +val digest_interface : string -> string list -> Digest.t diff --git a/debugger/input_handling.ml b/debugger/input_handling.ml index b32fccd1..1b87c6c2 100644 --- a/debugger/input_handling.ml +++ b/debugger/input_handling.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: input_handling.ml,v 1.4 1999/11/17 18:57:25 xleroy Exp $ *) +(* $Id: input_handling.ml,v 1.5 2006/12/09 13:49:10 ertai Exp $ *) (**************************** Input control ****************************) @@ -113,36 +113,3 @@ let resume_user_input () = end; add_file !user_channel exit_main_loop end - -(* Ask user a yes or no question. *) -let yes_or_no message = - if !interactif then - let old_prompt = !current_prompt in - try - current_prompt := message ^ " ? (y or n) "; - let answer = - let rec ask () = - resume_user_input (); - let line = - string_trim (Lexer.line (Lexing.from_function read_user_input)) - in - stop_user_input (); - match (if String.length line > 0 then line.[0] else ' ') with - 'y' -> true - | 'n' -> false - | _ -> - print_string "Please answer y or n."; - print_newline (); - ask () - in - ask () - in - current_prompt := old_prompt; - answer - with - x -> - current_prompt := old_prompt; - stop_user_input (); - raise x - else - false diff --git a/debugger/input_handling.mli b/debugger/input_handling.mli index 047e0aa8..e0b450eb 100644 --- a/debugger/input_handling.mli +++ b/debugger/input_handling.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: input_handling.mli,v 1.2 1999/11/17 18:57:25 xleroy Exp $ *) +(* $Id: input_handling.mli,v 1.3 2006/12/09 13:49:10 ertai Exp $ *) (***************************** Input control ***************************) @@ -58,6 +58,3 @@ val stop_user_input : unit -> unit (* Resume reading user input. *) val resume_user_input : unit -> unit - -(* Ask user a yes or no question. *) -val yes_or_no : string -> bool diff --git a/debugger/main.ml b/debugger/main.ml index 1451aa84..1c7e9349 100644 --- a/debugger/main.ml +++ b/debugger/main.ml @@ -11,11 +11,12 @@ (* *) (***********************************************************************) -(* $Id: main.ml,v 1.16.4.1 2005/11/29 12:17:27 doligez Exp $ *) +(* $Id: main.ml,v 1.19 2006/12/09 13:49:10 ertai Exp $ *) open Primitives open Misc open Input_handling +open Question open Command_line open Debugger_config open Checkpoints @@ -33,12 +34,14 @@ let rec loop ppf = if !loaded && (not (yes_or_no "The program is running. Quit anyway")) then loop ppf -let rec protect ppf loop = +let current_duration = ref (-1L) + +let rec protect ppf restart loop = try loop ppf with | End_of_file -> - protect ppf (function ppf -> + protect ppf restart (function ppf -> forget_process !current_checkpoint.c_fd !current_checkpoint.c_pid; @@ -46,12 +49,12 @@ let rec protect ppf loop = stop_user_input (); loop ppf) | Toplevel -> - protect ppf (function ppf -> + protect ppf restart (function ppf -> pp_print_flush ppf (); stop_user_input (); loop ppf) | Sys.Break -> - protect ppf (function ppf -> + protect ppf restart (function ppf -> fprintf ppf "Interrupted.@."; Exec.protect (function () -> stop_user_input (); @@ -61,18 +64,52 @@ let rec protect ppf loop = end); loop ppf) | Current_checkpoint_lost -> - protect ppf (function ppf -> + protect ppf restart (function ppf -> fprintf ppf "Trying to recover...@."; stop_user_input (); recover (); try_select_frame 0; show_current_event ppf; loop ppf) + | Current_checkpoint_lost_start_at (time, init_duration) -> + protect ppf restart (function ppf -> + let b = + if !current_duration = -1L then begin + let msg = sprintf "Restart from time %Ld and try to get closer of the problem" time in + stop_user_input (); + if yes_or_no msg then + (current_duration := init_duration; true) + else + false + end + else + true in + if b then + begin + go_to time; + current_duration := Int64.div !current_duration 10L; + if !current_duration > 0L then + while true do + step !current_duration + done + else begin + current_duration := -1L; + stop_user_input (); + show_current_event ppf; + restart ppf; + end + end + else + begin + recover (); + show_current_event ppf; + restart ppf + end) | x -> kill_program (); raise x -let toplevel_loop () = protect Format.std_formatter loop +let toplevel_loop () = protect Format.std_formatter loop loop (* Parsing of command-line arguments *) diff --git a/debugger/pos.ml b/debugger/pos.ml index bdc4fa20..5e1bc277 100644 --- a/debugger/pos.ml +++ b/debugger/pos.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: pos.ml,v 1.2 2005/08/25 15:35:16 doligez Exp $ *) +(* $Id: pos.ml,v 1.3 2006/12/09 13:49:10 ertai Exp $ *) open Instruct;; open Lexing;; @@ -26,9 +26,9 @@ let get_desc ev = (loc.loc_start.pos_cnum - loc.loc_start.pos_bol + 1) (loc.loc_end.pos_cnum - loc.loc_start.pos_bol + 1) else begin - let filename = source_of_module ev.ev_module in + let filename = source_of_module ev.ev_loc.loc_start ev.ev_module in try - let (start, line) = line_of_pos (get_buffer ev.ev_module) + let (start, line) = line_of_pos (get_buffer loc.loc_start ev.ev_module) loc.loc_start.pos_cnum in Printf.sprintf "file %s, line %d, characters %d-%d" diff --git a/debugger/program_management.ml b/debugger/program_management.ml index 5d5810d4..263a9935 100644 --- a/debugger/program_management.ml +++ b/debugger/program_management.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: program_management.ml,v 1.11 2002/11/02 22:36:42 doligez Exp $ *) +(* $Id: program_management.ml,v 1.12 2006/12/09 13:49:10 ertai Exp $ *) (* Manage the loading of the program *) @@ -24,6 +24,7 @@ open Instruct open Primitives open Parameters open Input_handling +open Question open Debugcom open Program_loading open Time_travel diff --git a/debugger/question.ml b/debugger/question.ml new file mode 100644 index 00000000..8b2d4598 --- /dev/null +++ b/debugger/question.ml @@ -0,0 +1,36 @@ +open Input_handling +open Primitives + +(* Ask user a yes or no question. *) +let yes_or_no message = + if !interactif then + let old_prompt = !current_prompt in + try + current_prompt := message ^ " ? (y or n) "; + let answer = + let rec ask () = + resume_user_input (); + let line = + string_trim (Lexer.line (Lexing.from_function read_user_input)) + in + stop_user_input (); + match (if String.length line > 0 then line.[0] else ' ') with + 'y' -> true + | 'n' -> false + | _ -> + print_string "Please answer y or n."; + print_newline (); + ask () + in + ask () + in + current_prompt := old_prompt; + answer + with + x -> + current_prompt := old_prompt; + stop_user_input (); + raise x + else + false + diff --git a/debugger/question.mli b/debugger/question.mli new file mode 100644 index 00000000..3a92dee6 --- /dev/null +++ b/debugger/question.mli @@ -0,0 +1,2 @@ +(* Ask user a yes or no question. *) +val yes_or_no : string -> bool diff --git a/debugger/show_source.ml b/debugger/show_source.ml index ea498577..aa1aa9cf 100644 --- a/debugger/show_source.ml +++ b/debugger/show_source.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: show_source.ml,v 1.13 2005/08/25 15:35:16 doligez Exp $ *) +(* $Id: show_source.ml,v 1.14 2006/12/09 13:49:10 ertai Exp $ *) open Debugger_config open Instruct @@ -46,7 +46,7 @@ let show_point ev selected = let before = (ev.ev_kind = Event_before) in if !emacs && selected then begin try - let source = source_of_module mdle in + let source = source_of_module ev.ev_loc.Location.loc_start mdle in printf "\026\026M%s:%i:%i" source ev.ev_loc.Location.loc_start.Lexing.pos_cnum ev.ev_loc.Location.loc_end.Lexing.pos_cnum; @@ -58,21 +58,22 @@ let show_point ev selected = end else begin try - let buffer = get_buffer mdle in - let point = (Events.get_pos ev).Lexing.pos_cnum in + let pos = Events.get_pos ev in + let buffer = get_buffer pos mdle in + let point = pos.Lexing.pos_cnum in let (start, line_number) = line_of_pos buffer point in ignore(print_line buffer line_number start point before) with Out_of_range -> (* line_of_pos *) prerr_endline "Position out of range." - | Not_found -> (* get_buffer *) + | Not_found -> (* Events.get_pos || get_buffer *) prerr_endline ("No source file for " ^ mdle ^ ".") end (* Display part of the source. *) -let show_listing mdle start stop point before = +let show_listing pos mdle start stop point before = try - let buffer = get_buffer mdle in + let buffer = get_buffer pos mdle in let rec aff (line_start, line_number) = if line_number <= stop then aff (print_line buffer line_number line_start point before + 1, line_number + 1) diff --git a/debugger/show_source.mli b/debugger/show_source.mli index 71a1c22a..c3760f7c 100644 --- a/debugger/show_source.mli +++ b/debugger/show_source.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: show_source.mli,v 1.4 2005/08/25 15:35:16 doligez Exp $ *) +(* $Id: show_source.mli,v 1.5 2006/12/09 13:49:10 ertai Exp $ *) (* Print the line containing the point *) val show_point : Instruct.debug_event -> bool -> unit;; @@ -20,4 +20,4 @@ val show_point : Instruct.debug_event -> bool -> unit;; val show_no_point : unit -> unit;; (* Display part of the source. *) -val show_listing : string -> int -> int -> int -> bool -> unit;; +val show_listing : Lexing.position -> string -> int -> int -> int -> bool -> unit;; diff --git a/debugger/source.ml b/debugger/source.ml index 9ea7e546..fec96b9f 100644 --- a/debugger/source.ml +++ b/debugger/source.ml @@ -11,17 +11,31 @@ (* *) (***********************************************************************) -(* $Id: source.ml,v 1.7 2002/06/07 07:35:38 xleroy Exp $ *) +(* $Id: source.ml,v 1.8 2006/12/09 13:49:10 ertai Exp $ *) (************************ Source management ****************************) open Misc open Primitives +let source_extensions = [".ml"] + (*** Conversion function. ***) -let source_of_module mdle = - find_in_path_uncap !Config.load_path (mdle ^ ".ml") +let source_of_module pos mdle = + let fname = pos.Lexing.pos_fname in + if fname = "" then + let rec loop = + function + | [] -> raise Not_found + | ext :: exts -> + try find_in_path_uncap !Config.load_path (mdle ^ ext) + with Not_found -> loop exts + in loop source_extensions + else if Filename.is_implicit fname then + find_in_path !Config.load_path fname + else + fname (*** Buffer cache ***) @@ -38,10 +52,10 @@ let buffer_list = let flush_buffer_list () = buffer_list := [] -let get_buffer mdle = +let get_buffer pos mdle = try List.assoc mdle !buffer_list with Not_found -> - let inchan = open_in_bin (source_of_module mdle) in + let inchan = open_in_bin (source_of_module pos mdle) in let (content, _) as buffer = (String.create (in_channel_length inchan), ref []) in diff --git a/debugger/source.mli b/debugger/source.mli index c85c3f6e..9cf01c04 100644 --- a/debugger/source.mli +++ b/debugger/source.mli @@ -11,13 +11,13 @@ (* *) (***********************************************************************) -(* $Id: source.mli,v 1.2 1999/11/17 18:57:28 xleroy Exp $ *) +(* $Id: source.mli,v 1.3 2006/12/09 13:49:10 ertai Exp $ *) (************************ Source management ****************************) (*** Conversion function. ***) -val source_of_module: string -> string +val source_of_module: Lexing.position -> string -> string (*** buffer cache ***) @@ -27,7 +27,7 @@ val buffer_max_count : int ref val flush_buffer_list : unit -> unit -val get_buffer : string -> buffer +val get_buffer : Lexing.position -> string -> buffer val buffer_content : buffer -> string val buffer_length : buffer -> int diff --git a/debugger/time_travel.ml b/debugger/time_travel.ml index 7c6e8d08..8917bd5e 100644 --- a/debugger/time_travel.ml +++ b/debugger/time_travel.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: time_travel.ml,v 1.19 2005/08/25 15:35:16 doligez Exp $ *) +(* $Id: time_travel.ml,v 1.21 2006/12/09 16:23:37 ertai Exp $ *) (**************************** Time travel ******************************) @@ -26,8 +26,10 @@ open Trap_barrier open Input_handling open Debugger_config open Program_loading +open Question exception Current_checkpoint_lost +exception Current_checkpoint_lost_start_at of int64 * int64 let remove_1st key list = let rec remove = @@ -385,16 +387,21 @@ let forget_process fd pid = find (function c -> c.c_pid = pid) (!current_checkpoint::!checkpoints) in Printf.eprintf "Lost connection with process %d" pid; - if checkpoint == !current_checkpoint then begin - Printf.eprintf " (active process)\n"; - match !current_checkpoint.c_state with - C_stopped -> - Printf.eprintf "at time %Ld" !current_checkpoint.c_time - | C_running duration -> - Printf.eprintf "between time %Ld and time %Ld" - !current_checkpoint.c_time - (!current_checkpoint.c_time ++ duration) - end; + let kont = + if checkpoint == !current_checkpoint then begin + Printf.eprintf " (active process)\n"; + match !current_checkpoint.c_state with + C_stopped -> + Printf.eprintf "at time %Ld" !current_checkpoint.c_time; + fun () -> raise Current_checkpoint_lost + | C_running duration -> + Printf.eprintf "between time %Ld and time %Ld" + !current_checkpoint.c_time + (!current_checkpoint.c_time ++ duration); + fun () -> raise (Current_checkpoint_lost_start_at + (!current_checkpoint.c_time, duration)) + end + else ignore in Printf.eprintf "\n"; flush stderr; Input_handling.remove_file fd; close_io checkpoint.c_fd; @@ -403,8 +410,7 @@ let forget_process fd pid = checkpoint.c_pid <- -1; (* Don't exist anymore *) if checkpoint.c_parent.c_pid > 0 then wait_child checkpoint.c_parent.c_fd; - if checkpoint == !current_checkpoint then - raise Current_checkpoint_lost + kont () (* Try to recover when the current checkpoint is lost. *) let recover () = diff --git a/debugger/time_travel.mli b/debugger/time_travel.mli index 2824c995..b37c99c9 100644 --- a/debugger/time_travel.mli +++ b/debugger/time_travel.mli @@ -11,13 +11,14 @@ (* *) (***********************************************************************) -(* $Id: time_travel.mli,v 1.5 2002/10/29 17:53:24 doligez Exp $ *) +(* $Id: time_travel.mli,v 1.6 2006/11/20 10:29:45 ertai Exp $ *) (**************************** Time travel ******************************) open Primitives exception Current_checkpoint_lost +exception Current_checkpoint_lost_start_at of int64 * int64 val new_checkpoint : int -> io_channel -> unit val set_file_descriptor : int -> io_channel -> bool diff --git a/driver/errors.ml b/driver/errors.ml index 8fbace82..c7d747fe 100644 --- a/driver/errors.ml +++ b/driver/errors.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: errors.ml,v 1.25.10.1 2005/11/09 15:58:47 doligez Exp $ *) +(* $Id: errors.ml,v 1.26 2006/01/04 16:55:49 doligez Exp $ *) (* WARNING: if you change something in this file, you must look at opterrors.ml to see if you need to make the same changes there. diff --git a/driver/main_args.ml b/driver/main_args.ml index e980946d..72b6172c 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: main_args.ml,v 1.47.2.2 2005/12/28 17:27:03 doligez Exp $ *) +(* $Id: main_args.ml,v 1.49 2006/04/05 02:28:13 garrigue Exp $ *) module Make_options (F : sig @@ -136,11 +136,11 @@ struct \032 E/e enable/disable fragile match\n\ \032 F/f enable/disable partially applied function\n\ \032 L/l enable/disable labels omitted in application\n\ - \032 M/m enable/disable overriden method\n\ + \032 M/m enable/disable overriden methods\n\ \032 P/p enable/disable partial match\n\ \032 S/s enable/disable non-unit statement\n\ \032 U/u enable/disable unused match case\n\ - \032 V/v enable/disable hidden instance variable\n\ + \032 V/v enable/disable overriden instance variables\n\ \032 Y/y enable/disable suspicious unused variables\n\ \032 Z/z enable/disable all other unused variables\n\ \032 X/x enable/disable all other warnings\n\ diff --git a/driver/opterrors.ml b/driver/opterrors.ml index d97760bc..8c9e44b0 100644 --- a/driver/opterrors.ml +++ b/driver/opterrors.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: opterrors.ml,v 1.18.10.1 2006/02/09 14:12:18 doligez Exp $ *) +(* $Id: opterrors.ml,v 1.19 2006/04/16 23:28:21 doligez Exp $ *) (* WARNING: if you change something in this file, you must look at errors.ml to see if you need to make the same changes there. diff --git a/driver/optmain.ml b/driver/optmain.ml index d155523f..dc08cede 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: optmain.ml,v 1.86.2.2 2005/12/28 17:27:03 doligez Exp $ *) +(* $Id: optmain.ml,v 1.89 2007/01/29 12:11:15 xleroy Exp $ *) open Config open Clflags @@ -114,6 +114,7 @@ let main () = "-for-pack", Arg.String (fun s -> for_package := Some s), " Generate code that can later be `packed' with\n\ \ ocamlopt -pack -o .cmx"; + "-g", Arg.Set debug, " Record debugging information for exception backtrace"; "-i", Arg.Unit (fun () -> print_types := true; compile_only := true), " Print inferred interface"; "-I", Arg.String(fun dir -> include_dirs := dir :: !include_dirs), @@ -173,7 +174,7 @@ let main () = \032 P/p enable/disable partial match\n\ \032 S/s enable/disable non-unit statement\n\ \032 U/u enable/disable unused match case\n\ - \032 V/v enable/disable hidden instance variables\n\ + \032 V/v enable/disable overriden instance variables\n\ \032 Y/y enable/disable suspicious unused variables\n\ \032 Z/z enable/disable all other unused variables\n\ \032 X/x enable/disable all other warnings\n\ diff --git a/emacs/caml-types.el b/emacs/caml-types.el index bc2f172d..e386083f 100644 --- a/emacs/caml-types.el +++ b/emacs/caml-types.el @@ -10,7 +10,7 @@ ;(* *) ;(***********************************************************************) -;(* $Id: caml-types.el,v 1.32 2005/08/13 20:59:37 doligez Exp $ *) +;(* $Id: caml-types.el,v 1.33 2007/02/09 13:31:15 doligez Exp $ *) ; An emacs-lisp complement to the "-dtypes" option of ocamlc and ocamlopt. @@ -45,7 +45,7 @@ Their format is: at least two space characters. - in each block, the two positions are respectively the start and the -- end of the range described by the block. + end of the range described by the block. - in a position, the filename is the name of the file, the first num is the line number, the second num is the offset of the beginning of the line, the third num is the offset of the position itself. diff --git a/lex/common.ml b/lex/common.ml index f56e7a86..cacea62d 100644 --- a/lex/common.ml +++ b/lex/common.ml @@ -122,26 +122,36 @@ let output_tag_access oc = function | Sum (a,i) -> fprintf oc "(%a + %d)" output_base_mem a i -let output_env oc env = +let output_env sourcefile ic oc tr env = let pref = ref "let" in match env with | [] -> () - | _ -> + | _ -> + (* Probably, we are better with variables sorted + in apparition order *) + let env = + List.sort + (fun ((_,p1),_) ((_,p2),_) -> + Pervasives.compare p1.start_pos p2.start_pos) + env in + List.iter - (fun (x,v) -> + (fun ((x,pos),v) -> + fprintf oc "%s\n" !pref ; + copy_chunk sourcefile ic oc tr pos false ; begin match v with | Ident_string (o,nstart,nend) -> fprintf oc - "\n %s %s = Lexing.sub_lexeme%s lexbuf %a %a" - !pref x (if o then "_opt" else "") + "= Lexing.sub_lexeme%s lexbuf %a %a" + (if o then "_opt" else "") output_tag_access nstart output_tag_access nend | Ident_char (o,nstart) -> fprintf oc - "\n %s %s = Lexing.sub_lexeme_char%s lexbuf %a" - !pref x (if o then "_opt" else "") + "= Lexing.sub_lexeme_char%s lexbuf %a" + (if o then "_opt" else "") output_tag_access nstart end ; - pref := "and") + pref := "\nand") env ; fprintf oc " in\n" diff --git a/lex/common.mli b/lex/common.mli index 4210d21d..e5742b45 100644 --- a/lex/common.mli +++ b/lex/common.mli @@ -19,7 +19,9 @@ val copy_chunk : val output_mem_access : out_channel -> int -> unit val output_memory_actions : string -> out_channel -> Lexgen.memory_action list -> unit -val output_env : out_channel -> (string * Lexgen.ident_info) list -> unit +val output_env : + string -> in_channel -> out_channel -> line_tracker -> + (Lexgen.ident * Lexgen.ident_info) list -> unit val output_args : out_channel -> string list -> unit val quiet_mode : bool ref;; diff --git a/lex/lexer.mll b/lex/lexer.mll index cb6add81..c039d917 100644 --- a/lex/lexer.mll +++ b/lex/lexer.mll @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: lexer.mll,v 1.21 2004/04/29 11:12:49 maranget Exp $ *) +(* $Id: lexer.mll,v 1.22 2006/01/04 16:55:49 doligez Exp $ *) (* The lexical analyzer for lexer definitions. Bootstrapped! *) @@ -29,7 +29,7 @@ exception Lexical_error of string * string * int * int let string_buff = Buffer.create 256 -let reset_string_buffer () = Buffer.clear string_buff +let reset_string_buffer () = Buffer.clear string_buff let store_string_char c = Buffer.add_char string_buff c @@ -62,7 +62,7 @@ let handle_lexical_error fn lexbuf = raise(Lexical_error(msg, file, line, column)) let get_input_name () = Sys.argv.(Array.length Sys.argv - 1) - + let warning lexbuf msg = let p = Lexing.lexeme_start_p lexbuf in Printf.eprintf "ocamllex warning:\nFile \"%s\", line %d, character %d: %s.\n" @@ -117,7 +117,7 @@ let backslash_escapes = ['\\' '"' '\'' 'n' 't' 'b' 'r'] rule main = parse - [' ' '\013' '\009' '\012' ] + + [' ' '\013' '\009' '\012' ] + { main lexbuf } | '\010' { incr_loc lexbuf 0; @@ -128,7 +128,7 @@ rule main = parse { update_loc lexbuf name (int_of_string num); main lexbuf } - | "(*" + | "(*" { comment_depth := 1; handle_lexical_error comment lexbuf; main lexbuf } @@ -143,16 +143,16 @@ rule main = parse | "let" -> Tlet | "as" -> Tas | s -> Tident s } - | '"' + | '"' { reset_string_buffer(); handle_lexical_error string lexbuf; Tstring(get_stored_string()) } -(* note: ''' is a valid character literall (by contrast with the compiler) *) - | "'" [^ '\\'] "'" +(* note: ''' is a valid character literal (by contrast with the compiler) *) + | "'" [^ '\\'] "'" { Tchar(Char.code(Lexing.lexeme_char lexbuf 1)) } - | "'" '\\' backslash_escapes "'" + | "'" '\\' backslash_escapes "'" { Tchar(Char.code(char_for_backslash (Lexing.lexeme_char lexbuf 2))) } - | "'" '\\' (['0'-'9'] as c) (['0'-'9'] as d) (['0'-'9'] as u)"'" + | "'" '\\' (['0'-'9'] as c) (['0'-'9'] as d) (['0'-'9'] as u)"'" { let v = decimal_code c d u in if v > 255 then raise_lexical_error lexbuf @@ -166,7 +166,7 @@ rule main = parse { raise_lexical_error lexbuf (Printf.sprintf "illegal escape sequence \\%c" c) } - | '{' + | '{' { let p = Lexing.lexeme_end_p lexbuf in let n1 = p.Lexing.pos_cnum and l1 = p.Lexing.pos_lnum @@ -196,7 +196,7 @@ rule main = parse (* String parsing comes from the compiler lexer *) and string = parse - '"' + '"' { () } | '\\' ("\010" | "\013" | "\013\010") ([' ' '\009'] * as spaces) { incr_loc lexbuf (String.length spaces); @@ -222,7 +222,7 @@ and string = parse store_string_char '\\' ; store_string_char c ; string lexbuf } - | eof + | eof { raise(Lexical_error("unterminated string", "", 0, 0)) } | '\010' { store_string_char '\010'; @@ -239,12 +239,12 @@ and string = parse *) and comment = parse - "(*" + "(*" { incr comment_depth; comment lexbuf } - | "*)" + | "*)" { decr comment_depth; if !comment_depth = 0 then () else comment lexbuf } - | '"' + | '"' { reset_string_buffer(); string lexbuf; reset_string_buffer(); @@ -252,22 +252,22 @@ and comment = parse | "'" { skip_char lexbuf ; comment lexbuf } - | eof + | eof { raise(Lexical_error("unterminated comment", "", 0, 0)) } | '\010' { incr_loc lexbuf 0; comment lexbuf } - | _ + | _ { comment lexbuf } and action = parse - '{' + '{' { incr brace_depth; action lexbuf } - | '}' + | '}' { decr brace_depth; if !brace_depth = 0 then Lexing.lexeme_start lexbuf else action lexbuf } - | '"' + | '"' { reset_string_buffer(); handle_lexical_error string lexbuf; reset_string_buffer(); @@ -275,16 +275,16 @@ and action = parse | "'" { skip_char lexbuf ; action lexbuf } - | "(*" + | "(*" { comment_depth := 1; comment lexbuf; action lexbuf } - | eof + | eof { raise (Lexical_error("unterminated action", "", 0, 0)) } | '\010' { incr_loc lexbuf 0; action lexbuf } - | _ + | _ { action lexbuf } and skip_char = parse @@ -298,4 +298,4 @@ and skip_char = parse | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "'" {()} (* A dieu va ! *) - | "" {()} + | "" {()} diff --git a/lex/lexgen.ml b/lex/lexgen.ml index d891f28f..efa7f749 100644 --- a/lex/lexgen.ml +++ b/lex/lexgen.ml @@ -12,7 +12,7 @@ (* *) (***********************************************************************) -(* $Id: lexgen.ml,v 1.17 2004/03/23 16:57:24 maranget Exp $ *) +(* $Id: lexgen.ml,v 1.20 2007/01/30 09:18:25 maranget Exp $ *) (* Compiling a lexer definition *) @@ -23,6 +23,8 @@ exception Memory_overflow (* Deep abstract syntax for regular expressions *) +type ident = string * Syntax.location + type tag_info = {id : string ; start : bool ; action : int} type regexp = @@ -39,7 +41,7 @@ type tag_addr = Sum of (tag_base * int) type ident_info = | Ident_string of bool * tag_addr * tag_addr | Ident_char of bool * tag_addr -type t_env = (string * ident_info) list +type t_env = (ident * ident_info) list type ('args,'action) lexer_entry = { lex_name: string; @@ -80,15 +82,20 @@ type ('args,'action) automata_entry = module Ints = Set.Make(struct type t = int let compare = compare end) -module Tags = Set.Make(struct type t = tag_info let compare = compare end) +let id_compare (id1,_) (id2,_) = String.compare id1 id2 + +let tag_compare t1 t2 = Pervasives.compare t1 t2 + +module Tags = Set.Make(struct type t = tag_info let compare = tag_compare end) module TagMap = - Map.Make (struct type t = tag_info let compare = compare end) + Map.Make (struct type t = tag_info let compare = tag_compare end) -module StringSet = - Set.Make (struct type t = string let compare = Pervasives.compare end) -module StringMap = - Map.Make (struct type t = string let compare = Pervasives.compare end) +module IdSet = + Set.Make (struct type t = ident let compare = id_compare end) + +module IdMap = + Map.Make (struct type t = ident let compare = id_compare end) (*********************) (* Variable cleaning *) @@ -98,10 +105,10 @@ module StringMap = let rec do_remove_nested to_remove = function | Bind (e,x) -> - if StringSet.mem x to_remove then + if IdSet.mem x to_remove then do_remove_nested to_remove e else - Bind (do_remove_nested (StringSet.add x to_remove) e, x) + Bind (do_remove_nested (IdSet.add x to_remove) e, x) | Epsilon|Eof|Characters _ as e -> e | Sequence (e1, e2) -> Sequence @@ -112,7 +119,7 @@ let rec do_remove_nested to_remove = function | Repetition e -> Repetition (do_remove_nested to_remove e) -let remove_nested_as e = do_remove_nested StringSet.empty e +let remove_nested_as e = do_remove_nested IdSet.empty e (*********************) (* Variable analysis *) @@ -128,36 +135,36 @@ let remove_nested_as e = do_remove_nested StringSet.empty e *) let stringset_delta s1 s2 = - StringSet.union - (StringSet.diff s1 s2) - (StringSet.diff s2 s1) + IdSet.union + (IdSet.diff s1 s2) + (IdSet.diff s2 s1) let rec find_all_vars = function | Characters _|Epsilon|Eof -> - StringSet.empty + IdSet.empty | Bind (e,x) -> - StringSet.add x (find_all_vars e) + IdSet.add x (find_all_vars e) | Sequence (e1,e2)|Alternative (e1,e2) -> - StringSet.union (find_all_vars e1) (find_all_vars e2) + IdSet.union (find_all_vars e1) (find_all_vars e2) | Repetition e -> find_all_vars e let rec do_find_opt = function - | Characters _|Epsilon|Eof -> StringSet.empty, StringSet.empty + | Characters _|Epsilon|Eof -> IdSet.empty, IdSet.empty | Bind (e,x) -> let opt,all = do_find_opt e in - opt, StringSet.add x all + opt, IdSet.add x all | Sequence (e1,e2) -> let opt1,all1 = do_find_opt e1 and opt2,all2 = do_find_opt e2 in - StringSet.union opt1 opt2, StringSet.union all1 all2 + IdSet.union opt1 opt2, IdSet.union all1 all2 | Alternative (e1,e2) -> let opt1,all1 = do_find_opt e1 and opt2,all2 = do_find_opt e2 in - StringSet.union - (StringSet.union opt1 opt2) + IdSet.union + (IdSet.union opt1 opt2) (stringset_delta all1 all2), - StringSet.union all1 all2 + IdSet.union all1 all2 | Repetition e -> let r = find_all_vars e in r,r @@ -175,26 +182,26 @@ let find_optional e = *) let rec do_find_double = function - | Characters _|Epsilon|Eof -> StringSet.empty, StringSet.empty + | Characters _|Epsilon|Eof -> IdSet.empty, IdSet.empty | Bind (e,x) -> let dbl,all = do_find_double e in - (if StringSet.mem x all then - StringSet.add x dbl + (if IdSet.mem x all then + IdSet.add x dbl else dbl), - StringSet.add x all + IdSet.add x all | Sequence (e1,e2) -> let dbl1, all1 = do_find_double e1 and dbl2, all2 = do_find_double e2 in - StringSet.union - (StringSet.inter all1 all2) - (StringSet.union dbl1 dbl2), - StringSet.union all1 all2 + IdSet.union + (IdSet.inter all1 all2) + (IdSet.union dbl1 dbl2), + IdSet.union all1 all2 | Alternative (e1,e2) -> let dbl1, all1 = do_find_double e1 and dbl2, all2 = do_find_double e2 in - StringSet.union dbl1 dbl2, - StringSet.union all1 all2 + IdSet.union dbl1 dbl2, + IdSet.union all1 all2 | Repetition e -> let r = find_all_vars e in r,r @@ -218,27 +225,27 @@ let add_some_some x y = match x,y with | _,_ -> None let rec do_find_chars sz = function - | Epsilon|Eof -> StringSet.empty, StringSet.empty, sz - | Characters _ -> StringSet.empty, StringSet.empty, add_some 1 sz + | Epsilon|Eof -> IdSet.empty, IdSet.empty, sz + | Characters _ -> IdSet.empty, IdSet.empty, add_some 1 sz | Bind (e,x) -> let c,s,e_sz = do_find_chars (Some 0) e in begin match e_sz with | Some 1 -> - StringSet.add x c,s,add_some 1 sz + IdSet.add x c,s,add_some 1 sz | _ -> - c, StringSet.add x s, add_some_some sz e_sz + c, IdSet.add x s, add_some_some sz e_sz end | Sequence (e1,e2) -> let c1,s1,sz1 = do_find_chars sz e1 in let c2,s2,sz2 = do_find_chars sz1 e2 in - StringSet.union c1 c2, - StringSet.union s1 s2, + IdSet.union c1 c2, + IdSet.union s1 s2, sz2 | Alternative (e1,e2) -> let c1,s1,sz1 = do_find_chars sz e1 and c2,s2,sz2 = do_find_chars sz e2 in - StringSet.union c1 c2, - StringSet.union s1 s2, + IdSet.union c1 c2, + IdSet.union s1 s2, (if sz1 = sz2 then sz1 else None) | Repetition e -> do_find_chars None e @@ -246,7 +253,7 @@ let rec do_find_chars sz = function let find_chars e = let c,s,_ = do_find_chars (Some 0) e in - StringSet.diff c s + IdSet.diff c s (*******************************) (* From shallow to deep syntax *) @@ -279,13 +286,13 @@ let rec encode_regexp char_vars act = function | Repetition r -> let r = encode_regexp char_vars act r in Star r - | Bind (r,x) -> + | Bind (r,((name,_) as x)) -> let r = encode_regexp char_vars act r in - if StringSet.mem x char_vars then - Seq (Tag {id=x ; start=true ; action=act},r) + if IdSet.mem x char_vars then + Seq (Tag {id=name ; start=true ; action=act},r) else - Seq (Tag {id=x ; start=true ; action=act}, - Seq (r, Tag {id=x ; start=false ; action=act})) + Seq (Tag {id=name ; start=true ; action=act}, + Seq (r, Tag {id=name ; start=false ; action=act})) (* Optimisation, @@ -317,6 +324,9 @@ let add_pos p i = match p with | Some (Sum (a,n)) -> Some (Sum (a,n+i)) | None -> None +let mem_name name id_set = + IdSet.exists (fun (id_name,_) -> name = id_name) id_set + let opt_regexp all_vars char_vars optional_vars double_vars r = (* From removed tags to their addresses *) @@ -340,7 +350,7 @@ let opt_regexp all_vars char_vars optional_vars double_vars r = let rec simple_forward pos r = match r with | Tag n -> - if StringSet.mem n.id double_vars then + if mem_name n.id double_vars then r,Some pos else begin Hashtbl.add env (n.id,n.start) (Sum (Start, pos)) ; @@ -383,7 +393,7 @@ let opt_regexp all_vars char_vars optional_vars double_vars r = let rec simple_backward pos r = match r with | Tag n -> - if StringSet.mem n.id double_vars then + if mem_name n.id double_vars then r,Some pos else begin Hashtbl.add env (n.id,n.start) (Sum (End, pos)) ; @@ -428,7 +438,7 @@ let opt_regexp all_vars char_vars optional_vars double_vars r = let rec alloc_exp pos r = match r with | Tag n -> - if StringSet.mem n.id double_vars then + if mem_name n.id double_vars then r,pos else begin match pos with | Some a -> @@ -456,17 +466,18 @@ let opt_regexp all_vars char_vars optional_vars double_vars r = let r,_ = alloc_exp None r in let m = - StringSet.fold - (fun x r -> + IdSet.fold + (fun ((name,_) as x) r -> + let v = - if StringSet.mem x char_vars then + if IdSet.mem x char_vars then Ident_char - (StringSet.mem x optional_vars, get_tag_addr (x,true)) + (IdSet.mem x optional_vars, get_tag_addr (name,true)) else Ident_string - (StringSet.mem x optional_vars, - get_tag_addr (x,true), - get_tag_addr (x,false)) in + (IdSet.mem x optional_vars, + get_tag_addr (name,true), + get_tag_addr (name,false)) in (x,v)::r) all_vars [] in m,r, !loc_count @@ -527,14 +538,14 @@ type t_transition = type transition = t_transition * Tags.t -let compare_trans (t1,tags1) (t2,tags2) = +let trans_compare (t1,tags1) (t2,tags2) = match Pervasives.compare t1 t2 with | 0 -> Tags.compare tags1 tags2 | r -> r module TransSet = - Set.Make(struct type t = transition let compare = compare end) + Set.Make(struct type t = transition let compare = trans_compare end) let rec nullable = function | Empty|Tag _ -> true @@ -1119,11 +1130,11 @@ let extract_tags l = (fun (act,m,_) -> envs.(act) <- List.fold_right - (fun (x,v) r -> match v with - | Ident_char (_,t) -> make_tag_entry x true act t r + (fun ((name,_),v) r -> match v with + | Ident_char (_,t) -> make_tag_entry name true act t r | Ident_string (_,t1,t2) -> - make_tag_entry x true act t1 - (make_tag_entry x false act t2 r)) + make_tag_entry name true act t1 + (make_tag_entry name false act t2 r)) m TagMap.empty) l ; envs diff --git a/lex/lexgen.mli b/lex/lexgen.mli index 3c713e9b..37e53b4c 100644 --- a/lex/lexgen.mli +++ b/lex/lexgen.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: lexgen.mli,v 1.5 2002/10/28 16:46:49 maranget Exp $ *) +(* $Id: lexgen.mli,v 1.6 2007/01/29 16:44:16 maranget Exp $ *) (* raised when there are too many bindings (>= 254 memory cells) *) @@ -35,6 +35,7 @@ and memory_action = and tag_action = SetTag of int * int | EraseTag of int +type ident = string * Syntax.location (* Representation of entry points *) type tag_base = Start | End | Mem of int @@ -42,7 +43,8 @@ type tag_addr = Sum of (tag_base * int) type ident_info = | Ident_string of bool * tag_addr * tag_addr | Ident_char of bool * tag_addr -type t_env = (string * ident_info) list + +type t_env = (ident * ident_info) list type ('args,'action) automata_entry = { auto_name: string; diff --git a/lex/output.ml b/lex/output.ml index 201e2c92..e37d1811 100644 --- a/lex/output.ml +++ b/lex/output.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: output.ml,v 1.25 2004/02/12 17:29:04 maranget Exp $ *) +(* $Id: output.ml,v 1.26 2007/01/29 16:44:16 maranget Exp $ *) (* Output the DFA tables and its entry points *) @@ -95,7 +95,7 @@ let output_entry sourcefile ic oc oci e = (fun (num, env, loc) -> fprintf oc " | "; fprintf oc "%d ->\n" num; - output_env oc env; + output_env sourcefile ic oc oci env; copy_chunk sourcefile ic oc oci loc true; fprintf oc "\n") e.auto_actions; diff --git a/lex/outputbis.ml b/lex/outputbis.ml index 4ea00a64..f8e9315d 100644 --- a/lex/outputbis.ml +++ b/lex/outputbis.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: outputbis.ml,v 1.5 2003/07/26 21:06:21 doligez Exp $ *) +(* $Id: outputbis.ml,v 1.6 2007/01/29 16:44:16 maranget Exp $ *) (* Output the DFA tables and its entry points *) @@ -168,7 +168,7 @@ let output_entry sourcefile ic oc tr e = (fun (num, env, loc) -> fprintf oc " | "; fprintf oc "%d ->\n" num; - output_env oc env ; + output_env sourcefile ic oc tr env ; copy_chunk sourcefile ic oc tr loc true; fprintf oc "\n") e.auto_actions; diff --git a/lex/parser.mly b/lex/parser.mly index c3f3d473..cbe5a1f1 100644 --- a/lex/parser.mly +++ b/lex/parser.mly @@ -10,7 +10,7 @@ /* */ /***********************************************************************/ -/* $Id: parser.mly,v 1.20 2004/04/29 11:12:49 maranget Exp $ */ +/* $Id: parser.mly,v 1.23 2007/01/29 16:44:16 maranget Exp $ */ /* The grammar for lexer definitions */ @@ -141,7 +141,7 @@ regexp: let s1 = as_cset $1 and s2 = as_cset $3 in Characters (Cset.diff s1 s2) - } + } | regexp Tor regexp { Alternative($1,$3) } | regexp regexp %prec CONCAT @@ -152,14 +152,22 @@ regexp: { try Hashtbl.find named_regexps $1 with Not_found -> - prerr_string "Reference to unbound regexp name `"; - prerr_string $1; - prerr_string "' at char "; - prerr_int (Parsing.symbol_start()); - prerr_newline(); + let p = Parsing.symbol_start_pos () in + Printf.eprintf "File \"%s\", line %d, character %d:\n\ + Reference to unbound regexp name `%s'.\n" + p.Lexing.pos_fname p.Lexing.pos_lnum + (p.Lexing.pos_cnum - p.Lexing.pos_bol) + $1; exit 2 } | regexp Tas ident - {Bind ($1, $3)} + {let p1 = Parsing.rhs_start_pos 3 + and p2 = Parsing.rhs_end_pos 3 in + let p = { + start_pos = p1.Lexing.pos_cnum ; + end_pos = p2.Lexing.pos_cnum ; + start_line = p1.Lexing.pos_lnum ; + start_col = p1.Lexing.pos_cnum - p1.Lexing.pos_bol ; } in + Bind ($1, ($3, p))} ; ident: @@ -182,4 +190,3 @@ char_class1: ; %% - diff --git a/lex/syntax.ml b/lex/syntax.ml index d2e70d99..2f491078 100644 --- a/lex/syntax.ml +++ b/lex/syntax.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: syntax.ml,v 1.8 2002/12/09 10:44:46 maranget Exp $ *) +(* $Id: syntax.ml,v 1.9 2007/01/29 16:44:16 maranget Exp $ *) (* This apparently useless implmentation file is in fact required by the pa_ocamllex syntax extension *) @@ -30,7 +30,7 @@ type regular_expression = | Sequence of regular_expression * regular_expression | Alternative of regular_expression * regular_expression | Repetition of regular_expression - | Bind of regular_expression * string + | Bind of regular_expression * (string * location) type ('arg,'action) entry = {name:string ; diff --git a/lex/syntax.mli b/lex/syntax.mli index c8063bdc..ab90f632 100644 --- a/lex/syntax.mli +++ b/lex/syntax.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: syntax.mli,v 1.8 2002/12/09 10:44:46 maranget Exp $ *) +(* $Id: syntax.mli,v 1.9 2007/01/29 16:44:16 maranget Exp $ *) (* The shallow abstract syntax *) @@ -27,7 +27,7 @@ type regular_expression = | Sequence of regular_expression * regular_expression | Alternative of regular_expression * regular_expression | Repetition of regular_expression - | Bind of regular_expression * string + | Bind of regular_expression * (string * location) type ('arg,'action) entry = {name:string ; diff --git a/man/ocamlc.m b/man/ocamlc.m index bc133e76..eec9cff9 100644 --- a/man/ocamlc.m +++ b/man/ocamlc.m @@ -205,7 +205,7 @@ redirect the standard output of the compiler to a .mli file, and edit that file to remove all declarations of unexported names. .TP -.BI \-I directory +.BI \-I \ directory Add the given directory to the list of directories searched for compiled interface files (.cmi) and compiled object code files (.cmo). By default, the current directory is searched first, then the diff --git a/myocamlbuild.ml b/myocamlbuild.ml new file mode 100644 index 00000000..d5c17192 --- /dev/null +++ b/myocamlbuild.ml @@ -0,0 +1,1079 @@ +open Ocamlbuild_plugin +open Command +open Arch +open Format + +module C = Myocamlbuild_config + +let windows = Sys.os_type = "Win32";; +if windows then tag_any ["windows"];; +let ccomptype = C.ccomptype +let () = if ccomptype <> "cc" then eprintf "ccomptype: %s@." ccomptype;; + +let fp_cat oc f = with_input_file ~bin:true f (fun ic -> copy_chan ic oc) + +(* Improve using the command module in Myocamlbuild_config + with the variant version (`S, `A...) *) +let mkdll out implib files opts = + let s = Command.string_of_command_spec in + Cmd(Sh(C.mkdll out (s implib) (s files) (s opts))) + +let mkexe out files opts = + let s = Command.string_of_command_spec in + Cmd(Sh(C.mkexe out (s files) (s opts))) + +let mklib out files opts = + let s = Command.string_of_command_spec in + Cmd(Sh(C.mklib out (s files) (s opts))) + +let syslib x = A(C.syslib x);; +let syscamllib x = + if ccomptype = "msvc" then A(Printf.sprintf "lib%s.lib" x) + else A("-l"^x) + +let mkobj obj file opts = + let obj = obj-.-C.o in + if ccomptype = "msvc" then + Seq[Cmd(S[Sh C.bytecc; Sh C.bytecccompopts; opts; A"-c"; Px file]); + mv (Pathname.basename (Pathname.update_extension C.o file)) obj] + else + Cmd(S[Sh C.bytecc; Sh C.bytecccompopts; opts; A"-c"; P file; A"-o"; Px obj]) + +let mkdynobj obj file opts = + let d_obj = obj-.-"d"-.-C.o in + if ccomptype = "msvc" then + Seq[Cmd(S[Sh C.bytecc; opts; Sh C.dllcccompopts; A"-c"; Px file]); + mv (Pathname.basename (Pathname.update_extension C.o file)) d_obj] + else + Cmd(S[Sh C.bytecc; opts; Sh C.dllcccompopts; A"-c"; P file; A"-o"; Px d_obj]) + +let mknatobj obj file opts = + let obj = obj-.-C.o in + if ccomptype = "msvc" then + Seq[Cmd(S[Sh C.nativecc; opts; A"-c"; Px file]); + mv (Pathname.basename (Pathname.update_extension C.o file)) obj] + else + Cmd(S[Sh C.nativecc; A"-O"; opts; + Sh C.nativecccompopts; A"-c"; P file; A"-o"; Px obj]) + +let add_exe a = + if not windows || Pathname.check_extension a "exe" then a + else a-.-"exe";; + +let add_exe_if_exists a = + if not windows || Pathname.check_extension a "exe" then a + else + let exe = a-.-"exe" in + if Pathname.exists exe then exe else a;; + +let convert_command_for_windows_shell spec = + if not windows then spec else + let rec self specs acc = + match specs with + | N :: specs -> self specs acc + | S[] :: specs -> self specs acc + | S[x] :: specs -> self (x :: specs) acc + | S specs :: specs' -> self (specs @ specs') acc + | (P(a) | A(a)) :: specs -> + let dirname = Pathname.dirname a in + let basename = Pathname.basename a in + let p = + if dirname = Pathname.current_dir_name then Sh(add_exe_if_exists basename) + else Sh(add_exe_if_exists (dirname ^ "\\" ^ basename)) in + if String.contains_string basename 0 "ocamlrun" = None then + List.rev (p :: acc) @ specs + else + self specs (p :: acc) + | [] | (Px _ | T _ | V _ | Sh _ | Quote _) :: _ -> + invalid_arg "convert_command_for_windows_shell: invalid atom in head position" + in S(self [spec] []) + +let convert_for_windows_shell solver () = + convert_command_for_windows_shell (solver ()) + +let ocamlrun = A"boot/ocamlrun" +let full_ocamlrun = P((Sys.getcwd ()) / "boot/ocamlrun") + +let boot_ocamlc = S[ocamlrun; A"boot/ocamlc"; A"-I"; A"boot"; A"-nostdlib"] + +let partial = bool_of_string (getenv ~default:"false" "OCAMLBUILD_PARTIAL");; + +let if_partial_dir dir = + if partial then ".."/dir else dir;; + +let unix_dir = + match Sys.os_type with + | "Win32" -> if_partial_dir "otherlibs/win32unix" + | _ -> if_partial_dir "otherlibs/unix";; + +let threads_dir = if_partial_dir "otherlibs/threads";; +let systhreads_dir = if_partial_dir "otherlibs/systhreads";; +let dynlink_dir = if_partial_dir "otherlibs/dynlink";; +let str_dir = if_partial_dir "otherlibs/str";; +let toplevel_dir = if_partial_dir "toplevel";; + +let ocamlc_solver = + let native_deps = ["ocamlc.opt"; "stdlib/stdlib.cmxa"; + "stdlib/std_exit.cmx"; "stdlib/std_exit"-.-C.o] in + let byte_deps = ["ocamlc"; "stdlib/stdlib.cma"; "stdlib/std_exit.cmo"] in + fun () -> + if List.for_all Pathname.exists native_deps then + S[A"./ocamlc.opt"; A"-nostdlib"] + else if List.for_all Pathname.exists byte_deps then + S[ocamlrun; A"./ocamlc"; A"-nostdlib"] + else boot_ocamlc;; + +Command.setup_virtual_command_solver "OCAMLC" ocamlc_solver;; +Command.setup_virtual_command_solver "OCAMLCWIN" (convert_for_windows_shell ocamlc_solver);; + +let ocamlopt_solver () = + S[if Pathname.exists "ocamlopt.opt" && Pathname.exists ("stdlib/stdlib.cmxa") + then A"./ocamlopt.opt" + else S[ocamlrun; A"./ocamlopt"]; + A"-nostdlib"];; + +Command.setup_virtual_command_solver "OCAMLOPT" ocamlopt_solver;; +Command.setup_virtual_command_solver "OCAMLOPTWIN" (convert_for_windows_shell ocamlopt_solver);; + +let ocamlc = V"OCAMLC";; +let ocamlopt = V"OCAMLOPT";; + +let ar = A"ar";; + +dispatch begin function +| Before_hygiene -> + if partial then + let patt = String.concat "," + ["asmcomp"; "bytecomp"; "debugger"; "driver"; + "lex"; "ocamldoc"; "otherlibs"; "parsing"; "stdlib"; "tools"; + "toplevel"; "typing"; "utils"] + in Ocamlbuild_pack.Configuration.parse_string + (sprintf "<{%s}/**>: not_hygienic, -traverse" patt) + +| After_options -> + begin + Options.ocamlrun := ocamlrun; + Options.ocamllex := S[ocamlrun; P"boot/ocamllex"]; + Options.ocamlyacc := if windows then P"./boot/ocamlyacc.exe" else P"boot/ocamlyacc"; + Options.ocamlmklib := S[ocamlrun; P"tools/ocamlmklib.byte"; A"-ocamlc"; Quote (V"OCAMLCWIN"); + A"-ocamlopt"; Quote (V"OCAMLOPTWIN")(* ; A"-v" *)]; + Options.ocamldep := S[ocamlrun; P"boot/ocamldep"]; + + Options.ext_obj := C.o; + Options.ext_lib := C.a; + Options.ext_dll := String.after C.ext_dll 1; + + Options.nostdlib := true; + Options.make_links := false; + if !Options.just_plugin then + Options.ocamlc := boot_ocamlc + else begin + Options.ocamlc := ocamlc; + Options.plugin := false; + Options.ocamlopt := ocamlopt; + end; + end +| After_rules -> + let module M = struct + + + +let hot_camlp4boot = "camlp4"/"boot"/"camlp4boot.byte";; +let cold_camlp4boot = "camlp4boot" (* The installed version *);; + +flag ["ocaml"; "ocamlyacc"] (A"-v");; + +flag ["ocaml"; "compile"; "warn_Ale"] (S[A"-w";A"Ale"; A"-warn-error";A"Ale"]);; +flag ["ocaml"; "compile"; "warn_Alezv"] (S[A"-w";A"Alezv"; A"-warn-error";A"Alezv"]);; + +non_dependency "otherlibs/threads/pervasives.ml" "Unix";; +non_dependency "otherlibs/threads/pervasives.ml" "String";; + +let add_extensions extensions modules = + List.fold_right begin fun x -> + List.fold_right begin fun ext acc -> + x-.-ext :: acc + end extensions + end modules [];; + +flag ["ocaml"; "pp"; "camlp4boot"] (convert_command_for_windows_shell (S[ocamlrun; P hot_camlp4boot]));; +flag ["ocaml"; "pp"; "camlp4boot"; "native"] (S[A"-D"; A"OPT"]);; +flag ["ocaml"; "pp"; "camlp4boot"; "ocamldep"] (S[A"-D"; A"OPT"]);; +let exn_tracer = Pathname.pwd/"camlp4"/"boot"/"Camlp4ExceptionTracer.cmo" in +if Pathname.exists exn_tracer then + flag ["ocaml"; "pp"; "camlp4boot"; "exntracer"] (P exn_tracer); + +use_lib "camlp4/mkcamlp4" "camlp4/camlp4lib";; +use_lib "toplevel/topstart" "toplevel/toplevellib";; +use_lib "otherlibs/dynlink/extract_crc" "otherlibs/dynlink/dynlink";; + +hide_package_contents "otherlibs/dynlink/dynlinkaux";; + +flag ["ocaml"; "link"; "file:driver/main.native"; "native"] begin + S[A"-ccopt"; A C.bytecclinkopts; A"-cclib"; A C.bytecclibs] +end;; + +dep ["ocaml"; "link"; "file:driver/main.native"; "native"] + ["asmrun/meta"-.-C.o; "asmrun/dynlink"-.-C.o];; + +dep ["ocaml"; "compile"; "native"] ["stdlib/libasmrun"-.-C.a];; + +flag ["ocaml"; "link"] (S[A"-I"; P "stdlib"]);; +flag ["ocaml"; "compile"; "include_unix"] (S[A"-I"; P unix_dir]);; +flag ["ocaml"; "compile"; "include_str"] (S[A"-I"; P str_dir]);; +flag ["ocaml"; "compile"; "include_dynlink"] (S[A"-I"; P dynlink_dir]);; +flag ["ocaml"; "compile"; "include_toplevel"] (S[A"-I"; P toplevel_dir]);; +flag ["ocaml"; "link"; "use_unix"] (S[A"-I"; P unix_dir]);; +flag ["ocaml"; "link"; "use_dynlink"] (S[A"-I"; P dynlink_dir]);; +flag ["ocaml"; "link"; "use_str"] (S[A"-I"; P str_dir]);; +flag ["ocaml"; "link"; "use_toplevel"] (S[A"-I"; P toplevel_dir]);; + +let setup_arch arch = + let annotated_arch = annotate arch in + let (_include_dirs_table, _for_pack_table) = mk_tables annotated_arch in + (* Format.eprintf "%a@." (Ocaml_arch.print_table (List.print pp_print_string)) include_dirs_table;; *) + iter_info begin fun i -> + Pathname.define_context i.current_path i.include_dirs + end annotated_arch;; + +let camlp4_arch = + dir "" [ + dir "stdlib" []; + dir "utils" []; + dir "parsing" []; + dir "camlp4" [ + dir "build" []; + dir_pack "Camlp4" [ + dir_pack "Struct" [ + dir_pack "Grammar" []; + ]; + dir_pack "Printers" []; + ]; + dir_pack "Camlp4Top" []; + ]; + ];; + +setup_arch camlp4_arch;; + +Pathname.define_context "" ["stdlib"];; +Pathname.define_context "utils" [Pathname.current_dir_name; "stdlib"];; +Pathname.define_context "camlp4" ["camlp4/build"; "utils"; "stdlib"];; +Pathname.define_context "camlp4/boot" ["camlp4/build"; "utils"; "parsing"; "camlp4"; "stdlib"];; +Pathname.define_context "camlp4/Camlp4Parsers" ["camlp4"; "camlp4/build"; "stdlib"];; +Pathname.define_context "camlp4/Camlp4Printers" ["camlp4"; "camlp4/build"; "stdlib"];; +Pathname.define_context "camlp4/Camlp4Filters" ["camlp4"; "camlp4/build"; "stdlib"];; +Pathname.define_context "camlp4/Camlp4Top" ["typing"; "stdlib"];; +Pathname.define_context "typing" ["typing"; "parsing"; "utils"; "stdlib"];; +Pathname.define_context "ocamldoc" ["typing"; "parsing"; "utils"; "tools"; "bytecomp"; "stdlib"];; +Pathname.define_context "bytecomp" ["bytecomp"; "parsing"; "typing"; "utils"; "stdlib"];; +Pathname.define_context "tools" ["tools"; (* "toplevel"; *) "parsing"; "utils"; "driver"; "bytecomp"; "asmcomp"; "typing"; "stdlib"];; +Pathname.define_context "toplevel" ["toplevel"; "parsing"; "typing"; "bytecomp"; "utils"; "driver"; "stdlib"];; +Pathname.define_context "driver" ["driver"; "asmcomp"; "bytecomp"; "typing"; "utils"; "parsing"; "stdlib"];; +Pathname.define_context "debugger" ["bytecomp"; "utils"; "typing"; "parsing"; "toplevel"; "stdlib"];; +Pathname.define_context "otherlibs/dynlink" ["otherlibs/dynlink"; "bytecomp"; "utils"; "typing"; "parsing"; "stdlib"];; +Pathname.define_context "asmcomp" ["asmcomp"; "bytecomp"; "parsing"; "typing"; "utils"; "stdlib"];; +Pathname.define_context "ocamlbuild" ["ocamlbuild"; "stdlib"; "."];; +Pathname.define_context "lex" ["lex"; "stdlib"];; + +List.iter (fun x -> let x = "otherlibs"/x in Pathname.define_context x [x; "stdlib"]) + ["bigarray"; "dbm"; "graph"; "num"; "str"; "systhreads"; "unix"; "win32graph"; "win32unix"];; + +(* The bootstrap standard library *) +copy_rule "The bootstrap standard library" "stdlib/%" "boot/%";; + +(* About the standard library *) +copy_rule "stdlib asmrun" ("asmrun/%"-.-C.a) ("stdlib/%"-.-C.a);; +copy_rule "stdlib byterun" ("byterun/%"-.-C.a) ("stdlib/%"-.-C.a);; + +(* The thread specific standard library *) +copy_rule "The thread specific standard library (mllib)" ~insert:`bottom "stdlib/%.mllib" "otherlibs/threads/%.mllib";; +copy_rule "The thread specific standard library (cmo)" ~insert:`bottom "stdlib/%.cmo" "otherlibs/threads/%.cmo";; +copy_rule "The thread specific standard library (cmi)" ~insert:`top "stdlib/%.cmi" "otherlibs/threads/%.cmi";; +copy_rule "The thread specific standard library (mli)" ~insert:`bottom "stdlib/%.mli" "otherlibs/threads/%.mli";; +copy_rule "The thread specific unix library (mli)" ~insert:`bottom "otherlibs/unix/%.mli" "otherlibs/threads/%.mli";; +copy_rule "The thread specific unix library (ml)" ~insert:`bottom "otherlibs/unix/%.ml" "otherlibs/threads/%.ml";; +copy_rule "The thread specific unix library (mllib)" ~insert:`bottom "otherlibs/unix/%.mllib" "otherlibs/threads/%.mllib";; + +(* Temporary rule, waiting for a full usage of ocamlbuild *) +copy_rule "Temporary rule, waiting for a full usage of ocamlbuild" "%.mlbuild" "%.ml";; + +if windows then + copy_rule "thread_win32.ml -> thread.ml" + "otherlibs/systhreads/thread_win32.ml" "otherlibs/systhreads/thread.ml" +else + copy_rule "thread_posix.ml -> thread.ml" + "otherlibs/systhreads/thread_posix.ml" "otherlibs/systhreads/thread.ml";; + +copy_rule "graph/graphics.ml -> win32graph/graphics.ml" "otherlibs/graph/graphics.ml" "otherlibs/win32graph/graphics.ml";; +copy_rule "graph/graphics.mli -> win32graph/graphics.mli" "otherlibs/graph/graphics.mli" "otherlibs/win32graph/graphics.mli";; + +rule "the ocaml toplevel" + ~prod:"ocaml" + ~deps:["stdlib/stdlib.mllib"; "toplevel/topstart.byte"; "toplevel/expunge.byte"] + begin fun _ _ -> + let modules = string_list_of_file "stdlib/stdlib.mllib" in + Cmd(S[ocamlrun; A"toplevel/expunge.byte"; A"toplevel/topstart.byte"; Px"ocaml"; + A"outcometree"; A"topdirs"; A"toploop"; atomize modules]) + end;; + +let copy_rule' ?insert src dst = copy_rule (sprintf "%s -> %s" src dst) ?insert src dst;; + +copy_rule' "driver/main.byte" "ocamlc";; +copy_rule' "driver/main.native" "ocamlc.opt";; +copy_rule' "driver/optmain.byte" "ocamlopt";; +copy_rule' "driver/optmain.native" "ocamlopt.opt";; +copy_rule' "lex/main.byte" "lex/ocamllex";; +copy_rule' "lex/main.native" "lex/ocamllex.opt";; +copy_rule' "debugger/main.byte" "debugger/ocamldebug";; +copy_rule' "ocamldoc/odoc.byte" "ocamldoc/ocamldoc";; +copy_rule' "ocamldoc/odoc_opt.native" "ocamldoc/ocamldoc.opt";; +copy_rule' "tools/ocamlmklib.byte" "tools/ocamlmklib";; +copy_rule' "otherlibs/dynlink/extract_crc.byte" "otherlibs/dynlink/extract_crc";; + +copy_rule' ~insert:`bottom "%" "%.exe";; + +ocaml_lib "stdlib/stdlib";; + +let stdlib_mllib_contents = + lazy (string_list_of_file "stdlib/stdlib.mllib");; + +let import_stdlib_contents build exts = + let l = + List.fold_right begin fun x -> + List.fold_right begin fun ext acc -> + ["stdlib"/(String.uncapitalize x)-.-ext] :: acc + end exts + end !*stdlib_mllib_contents [] + in + let res = build l in + List.iter Outcome.ignore_good res +;; + +rule "byte stdlib in partial mode" + ~prod:"byte_stdlib_partial_mode" + ~deps:["stdlib/stdlib.mllib"; "stdlib/stdlib.cma"; + "stdlib/std_exit.cmo"; "stdlib/libcamlrun"-.-C.a; + "stdlib/camlheader"; "stdlib/camlheader_ur"] + begin fun env build -> + let (_ : Command.t) = + Ocamlbuild_pack.Ocaml_compiler.byte_library_link_mllib + "stdlib/stdlib.mllib" "stdlib/stdlib.cma" env build + in + import_stdlib_contents build ["cmi"]; + touch "byte_stdlib_partial_mode" + end;; + +rule "native stdlib in partial mode" + ~prod:"native_stdlib_partial_mode" + ~deps:["stdlib/stdlib.mllib"; "stdlib/stdlib.cmxa"; + "stdlib/stdlib"-.-C.a; "stdlib/std_exit.cmx"; + "stdlib/std_exit"-.-C.o; "stdlib/libasmrun"-.-C.a; + "stdlib/camlheader"; "stdlib/camlheader_ur"] + begin fun env build -> + let (_ : Command.t) = + Ocamlbuild_pack.Ocaml_compiler.native_library_link_mllib + "stdlib/stdlib.mllib" "stdlib/stdlib.cmxa" env build + in + import_stdlib_contents build ["cmi"]; + touch "native_stdlib_partial_mode" + end;; + +rule "C files" + ~prod:("%"-.-C.o) + ~dep:"%.c" + ~insert:(`before "ocaml C stubs: c -> o") + begin fun env _ -> + let c = env "%.c" in + mkobj (env "%") c (T(tags_of_pathname c++"c"++"compile"++ccomptype)) + end;; + +rule "C files for windows dynamic libraries" + ~prod:("%.d"-.-C.o) + ~dep:"%.c" + ~insert:(`before "C files") + begin fun env _ -> + let c = env "%.c" in + mkdynobj (env "%") c (T(tags_of_pathname c++"c"++"compile"++"dll"++ccomptype)) + end;; + +(* ../ is because .h files are not dependencies so they are not imported in build dir *) +flag ["c"; "compile"; "otherlibs_bigarray"] (S[A"-I"; P"../otherlibs/bigarray"]);; +flag [(* "ocaml" or "c"; *) "ocamlmklib"; "otherlibs_graph"] (S[Sh C.x11_link]);; +flag ["c"; "compile"; "otherlibs_graph"] (S[Sh C.x11_includes; A"-I../otherlibs/graph"]);; +flag ["c"; "compile"; "otherlibs_win32graph"] (A"-I../otherlibs/win32graph");; +flag ["c"; "compile"; "otherlibs_dbm"] (Sh C.dbm_includes);; +flag [(* "ocaml" oc "c"; *) "ocamlmklib"; "otherlibs_dbm"] (S[A"-oc"; A"otherlibs/dbm/mldbm"; Sh C.dbm_link]);; +flag ["ocaml"; "ocamlmklib"; "otherlibs_threads"] (S[A"-oc"; A"otherlibs/threads/vmthreads"]);; +flag ["c"; "compile"; "otherlibs_num"] begin + S[A("-DBNG_ARCH_"^C.bng_arch); + A("-DBNG_ASM_LEVEL="^C.bng_asm_level); + A"-I"; P"../otherlibs/num"] +end;; +flag ["c"; "compile"; "otherlibs_win32unix"] (A"-I../otherlibs/win32unix");; +flag [(* "ocaml" or "c"; *) "ocamlmklib"; "otherlibs_win32unix"] (S[A"-cclib"; Quote (syslib "wsock32")]);; +flag ["c"; "link"; "dll"; "otherlibs_win32unix"] (syslib "wsock32");; +let flags = S[syslib "kernel32"; syslib "gdi32"; syslib "user32"] in +flag ["c"; "ocamlmklib"; "otherlibs_win32graph"] (S[A"-cclib"; Quote flags]); +flag ["c"; "link"; "dll"; "otherlibs_win32graph"] flags;; + +if windows then flag ["c"; "compile"; "otherlibs_bigarray"] (A"-DIN_OCAML_BIGARRAY");; + +if windows then flag ["ocamlmklib"] (A"-custom");; + +flag ["ocaml"; "pp"; "ocamldoc_sources"] begin + if windows then + S[A"grep"; A"-v"; A"DEBUG"] + else + A"../ocamldoc/remove_DEBUG" +end;; + +let ocamldoc = P"./ocamldoc/ocamldoc.opt" in +let stdlib_mlis = + List.fold_right + (fun x acc -> "stdlib"/(String.uncapitalize x)-.-"mli" :: acc) + (string_list_of_file "stdlib/stdlib.mllib") + ["otherlibs/unix/unix.mli"; "otherlibs/str/str.mli"; + "otherlibs/bigarray/bigarray.mli"; "otherlibs/num/num.mli"] in +rule "Standard library manual" + ~prod:"ocamldoc/stdlib_man/Pervasives.3o" + ~deps:stdlib_mlis + begin fun _ _ -> + Seq[Cmd(S[A"mkdir"; A"-p"; P"ocamldoc/stdlib_man"]); + Cmd(S[ocamldoc; A"-man"; A"-d"; P"ocamldoc/stdlib_man"; + A"-I"; P "stdlib"; A"-I"; P"otherlibs/unix"; A"-I"; P"otherlibs/num"; + A"-t"; A"Ocaml library"; A"-man-mini"; atomize stdlib_mlis])] + end;; + +flag ["ocaml"; "compile"; "bootstrap_thread"] + (S[A"-I"; P systhreads_dir; A"-I"; P threads_dir]);; + +flag ["ocaml"; "link"; "bootstrap_thread"] + (S[A"-I"; P systhreads_dir; A"-I"; P threads_dir]);; + +flag ["ocaml"; "compile"; "otherlibs_labltk"] (S[A"-I"; P unix_dir]);; + +flag ["c"; "compile"; "otherlibs_labltk"] (S[A"-Ibyterun"; Sh C.tk_defs; Sh C.sharedcccompopts]);; + +(* Sys threads *) + +rule "posix native systhreads" + ~prod:"otherlibs/systhreads/posix_n.o" + ~dep:"otherlibs/systhreads/posix.c" + ~insert:`top + begin fun _ _ -> + Cmd(S[Sh C.nativecc; A"-O"; A"-I../asmrun"; A"-I../byterun"; + Sh C.nativecccompopts; Sh C.sharedcccompopts; + A"-DNATIVE_CODE"; A("-DTARGET_"^C.arch); A("-DSYS_"^C.system); A"-c"; + A"otherlibs/systhreads/posix.c"; A"-o"; Px"otherlibs/systhreads/posix_n.o"]) + end;; + +rule "posix bytecode systhreads" + ~prod:"otherlibs/systhreads/posix_b.o" + ~dep:"otherlibs/systhreads/posix.c" + ~insert:`top + begin fun _ _ -> + Cmd(S[Sh C.bytecc; A"-O"; A"-I../byterun"; + Sh C.bytecccompopts; Sh C.sharedcccompopts; + A"-c"; A"otherlibs/systhreads/posix.c"; A"-o"; Px"otherlibs/systhreads/posix_b.o"]) + end;; + +rule "windows native systhreads" + ~prod:("otherlibs/systhreads/win32_n"-.-C.o) + ~dep:"otherlibs/systhreads/win32.c" + ~insert:`top + begin fun _ _ -> + mknatobj "otherlibs/systhreads/win32_n" + "otherlibs/systhreads/win32.c" + (S[A"-I../asmrun"; A"-I../byterun"; A"-DNATIVE_CODE"]) + end;; + +rule "windows bytecode static systhreads" + ~prod:("otherlibs/systhreads/win32_b"-.-C.o) + ~dep:"otherlibs/systhreads/win32.c" + ~insert:`top + begin fun _ _ -> + mkobj "otherlibs/systhreads/win32_b" "otherlibs/systhreads/win32.c" + ((*A"-O"; why ? *) A"-I../byterun") + end;; + +rule "windows bytecode dynamic systhreads" + ~prod:("otherlibs/systhreads/win32_b.d"-.-C.o) + ~dep:"otherlibs/systhreads/win32.c" + ~insert:`top + begin fun _ _ -> + mkdynobj "otherlibs/systhreads/win32_b" "otherlibs/systhreads/win32.c" + ((*A"-O"; why ? *) A"-I../byterun") + end;; + +if windows then begin + rule "windows libthreadsnat.a" + ~prod:("otherlibs/systhreads/libthreadsnat"-.-C.a) + ~dep:("otherlibs/systhreads/win32_n"-.-C.o) + ~insert:`top + begin fun _ _ -> + mklib ("otherlibs/systhreads/libthreadsnat"-.-C.a) (P("otherlibs/systhreads/win32_n"-.-C.o)) N + end +end else begin +(* Dynamic linking with -lpthread is risky on many platforms, so + do not create a shared object for libthreadsnat. *) +rule "libthreadsnat.a" + ~prod:"otherlibs/systhreads/libthreadsnat.a" + ~dep:"otherlibs/systhreads/posix_n.o" + ~insert:`top + begin fun _ _ -> + mklib "otherlibs/systhreads/libthreadsnat.a" (A"otherlibs/systhreads/posix_n.o") N + end; + +(* See remark above: force static linking of libthreadsnat.a *) +flag ["ocaml"; "link"; "library"; "otherlibs_systhreads"; "native"] begin + S[A"-cclib"; syscamllib "threadsnat"; (* A"-cclib"; syscamllib "unix"; seems to be useless and can be dangerous during bootstrap *) Sh C.pthread_link] +end; +end;; + +if windows then +copy_rule "systhreads/libthreads.clib is diffrent on windows" + ~insert:`top + ("otherlibs/systhreads/libthreadswin32"-.-C.a) + ("otherlibs/systhreads/libthreads"-.-C.a);; + +flag ["ocaml"; "ocamlmklib"; "otherlibs_systhreads"] (S[(* A"-cclib"; syscamllib "unix";; seems to be useless and can be dangerous during bootstrap *) Sh C.pthread_link]);; + + +flag ["c"; "compile"; "otherlibs"] begin + S[A"-I"; P"../byterun"; + A"-I"; P(".."/unix_dir); + Sh C.bytecccompopts; + Sh C.sharedcccompopts] +end;; + +flag ["c"; "compile"; "otherlibs"; "cc"] (A"-O");; +flag ["c"; "compile"; "otherlibs"; "mingw"] (A"-O");; + +(* The numeric opcodes *) +rule "The numeric opcodes" + ~prod:"bytecomp/opcodes.ml" + ~dep:"byterun/instruct.h" + ~insert:`top + begin fun _ _ -> + Cmd(Sh "sed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' byterun/instruct.h | \ + awk -f ../tools/make-opcodes > bytecomp/opcodes.ml") + end;; + +rule "tools/opnames.ml" + ~prod:"tools/opnames.ml" + ~dep:"byterun/instruct.h" + begin fun _ _ -> + Cmd(Sh"unset LC_ALL || : ; \ + unset LC_CTYPE || : ; \ + unset LC_COLLATE LANG || : ; \ + sed -e '/\\/\\*/d' \ + -e '/^#/d' \ + -e 's/enum \\(.*\\) {/let names_of_\\1 = [|/' \ + -e 's/};$/ |]/' \ + -e 's/\\([A-Z][A-Z_0-9a-z]*\\)/\"\\1\"/g' \ + -e 's/,/;/g' \ + byterun/instruct.h > tools/opnames.ml") + end;; + +(* The version number *) +rule "stdlib/sys.ml" + ~prod:"stdlib/sys.ml" + ~deps:["stdlib/sys.mlp"; "VERSION"] + begin fun _ _ -> + let version = with_input_file "VERSION" input_line in + Seq [rm_f "stdlib/sys.ml"; + Cmd (S[A"sed"; A"-e"; + A(sprintf "s,%%%%VERSION%%%%,%s," version); + Sh"<"; P"stdlib/sys.mlp"; Sh">"; Px"stdlib/sys.ml"]); + chmod (A"-w") "stdlib/sys.ml"] + end;; + +(* The predefined exceptions and primitives *) + +rule "camlheader" + ~prods:["stdlib/camlheader"; "stdlib/camlheader_ur"] + ~deps:["stdlib/header.c"; "stdlib/headernt.c"] + begin fun _ _ -> + if C.sharpbangscripts then + Cmd(Sh("echo '#!"^C.bindir^"/ocamlrun' > stdlib/camlheader && \ + echo '#!' | tr -d '\\012' > stdlib/camlheader_ur")) + else if windows then + Seq[mkexe "tmpheader.exe" (P"stdlib/headernt.c") (S[A"-I../byterun"; Sh C.extralibs]); + rm_f "camlheader.exe"; + mv "tmpheader.exe" "stdlib/camlheader"; + cp "stdlib/camlheader" "stdlib/camlheader_ur"] + else + let tmpheader = "tmpheader"^C.exe in + Cmd(S[Sh C.bytecc; Sh C.bytecccompopts; Sh C.bytecclinkopts; + A"-I"; A"../stdlib"; + A("-DRUNTIME_NAME='\""^C.bindir^"/ocamlrun\"'"); + A"stdlib/header.c"; A"-o"; Px tmpheader; Sh"&&"; + A"strip"; P tmpheader; Sh"&&"; + A"mv"; P tmpheader; A"stdlib/camlheader"; Sh"&&"; + A"cp"; A"stdlib/camlheader"; A"stdlib/camlheader_ur"]) + end;; + +rule "ocaml C stubs on windows: dlib & d.o* -> dll" + ~prod:"%.dll" + ~deps:["%.dlib"(*; "byterun/ocamlrun"-.-C.a*)] + ~insert:`top + begin fun env build -> + let dlib = env "%.dlib" in + let dll = env "%.dll" in + let objs = string_list_of_file dlib in + let include_dirs = Pathname.include_dirs_of (Pathname.dirname dll) in + let resluts = build begin + List.map begin fun d_o -> + List.map (fun dir -> dir / (Pathname.update_extension C.o d_o)) include_dirs + end objs + end in + let objs = List.map begin function + | Outcome.Good d_o -> d_o + | Outcome.Bad exn -> raise exn + end resluts in + mkdll dll (P("tmp"-.-C.a)) (S[atomize objs; P("byterun/ocamlrun"-.-C.a)]) + (T(tags_of_pathname dll++"dll"++"link"++"c")) + end;; + +copy_rule "win32unix use some unix files" "otherlibs/unix/%" "otherlibs/win32unix/%";; + +(* Temporary rule *) +rule "tools/ocamlmklib.ml" + ~prod:"tools/ocamlmklib.ml" + ~dep:"tools/ocamlmklib.mlp" + (fun _ _ -> cp "tools/ocamlmklib.mlp" "tools/ocamlmklib.ml");; + + +rule "bytecomp/runtimedef.ml" + ~prod:"bytecomp/runtimedef.ml" + ~deps:["byterun/primitives"; "byterun/fail.h"] + begin fun _ _ -> + Cmd(S[A"../build/mkruntimedef.sh";Sh">"; Px"bytecomp/runtimedef.ml"]) + end;; + +(* Choose the right machine-dependent files *) + +let mk_arch_rule ~src ~dst = + let prod = "asmcomp"/dst in + let dep = "asmcomp"/C.arch/src in + rule (sprintf "arch specific files %S%%" dst) ~prod ~dep begin + if windows then fun env _ -> cp (env dep) (env prod) + else fun env _ -> ln_s (env (C.arch/src)) (env prod) + end;; + +mk_arch_rule ~src:(if ccomptype = "msvc" then "proc_nt.ml" else "proc.ml") ~dst:"proc.ml";; +List.iter (fun x -> mk_arch_rule ~src:x ~dst:x) + ["arch.ml"; "reload.ml"; "scheduling.ml"; "selection.ml"];; + +let emit_mlp = "asmcomp"/C.arch/(if ccomptype = "msvc" then "emit_nt.mlp" else "emit.mlp") in +rule "emit.mlp" + ~prod:"asmcomp/emit.ml" + ~deps:[emit_mlp; "tools/cvt_emit.byte"] + begin fun _ _ -> + Cmd(S[ocamlrun; P"tools/cvt_emit.byte"; Sh "<"; P emit_mlp; + Sh">"; Px"asmcomp/emit.ml"]) + end;; + +let p4 = Pathname.concat "camlp4" +let pa = Pathname.concat (p4 "Camlp4Parsers") +let pr = Pathname.concat (p4 "Camlp4Printers") +let fi = Pathname.concat (p4 "Camlp4Filters") +let top = Pathname.concat (p4 "Camlp4Top") + +let pa_r = pa "Camlp4OCamlRevisedParser" +let pa_o = pa "Camlp4OCamlParser" +let pa_q = pa "Camlp4QuotationExpander" +let pa_qc = pa "Camlp4QuotationCommon" +let pa_rq = pa "Camlp4OCamlRevisedQuotationExpander" +let pa_oq = pa "Camlp4OCamlOriginalQuotationExpander" +let pa_rp = pa "Camlp4OCamlRevisedParserParser" +let pa_op = pa "Camlp4OCamlParserParser" +let pa_g = pa "Camlp4GrammarParser" +let pa_l = pa "Camlp4ListComprehension" +let pa_macro = pa "Camlp4MacroParser" +let pa_debug = pa "Camlp4DebugParser" + +let pr_dump = pr "Camlp4OCamlAstDumper" +let pr_r = pr "Camlp4OCamlRevisedPrinter" +let pr_o = pr "Camlp4OCamlPrinter" +let pr_a = pr "Camlp4AutoPrinter" +let fi_exc = fi "Camlp4ExceptionTracer" +let fi_tracer = fi "Camlp4Tracer" +let fi_meta = fi "MetaGenerator" +let camlp4_bin = p4 "Camlp4Bin" +let top_rprint = top "Rprint" +let top_top = top "Top" +let camlp4Profiler = p4 "Camlp4Profiler" + +let camlp4lib_cma = p4 "camlp4lib.cma" +let camlp4lib_cmxa = p4 "camlp4lib.cmxa" + +let special_modules = + if Sys.file_exists "./boot/Profiler.cmo" then [camlp4Profiler] else [] + +let mk_camlp4_top_lib name modules = + let name = "camlp4"/name in + let cma = name-.-"cma" in + let deps = special_modules @ modules @ [top_top] in + let cmos = add_extensions ["cmo"] deps in + rule cma + ~deps:(camlp4lib_cma::cmos) + ~prods:[cma] + ~insert:(`before "ocaml: mllib & cmo* -> cma") + begin fun _ _ -> + Cmd(S[ocamlc; A"-a"; T(tags_of_pathname cma++"ocaml"++"link"++"byte"); + P camlp4lib_cma; A"-linkall"; atomize cmos; A"-o"; Px cma]) + end;; + +let mk_camlp4_bin name ?unix:(link_unix=true) modules = + let name = "camlp4"/name in + let byte = name-.-"byte" in + let native = name-.-"native" in + let unix_cma, unix_cmxa, include_unix = + if link_unix then A"unix.cma", A"unix.cmxa", S[A"-I"; P unix_dir] else N,N,N in + let deps = special_modules @ modules @ [camlp4_bin] in + let cmos = add_extensions ["cmo"] deps in + let cmxs = add_extensions ["cmx"] deps in + rule byte + ~deps:(camlp4lib_cma::cmos) + ~prod:(add_exe byte) + ~insert:(`before "ocaml: cmo* -> byte") + begin fun _ _ -> + Cmd(S[ocamlc; include_unix; unix_cma; T(tags_of_pathname byte++"ocaml"++"link"++"byte"); + P camlp4lib_cma; A"-linkall"; atomize cmos; A"-o"; Px (add_exe byte)]) + end; + rule native + ~deps:(camlp4lib_cmxa::cmxs) + ~prod:(add_exe native) + ~insert:(`before "ocaml: cmx* & o* -> native") + begin fun _ _ -> + Cmd(S[ocamlopt; include_unix; unix_cmxa; T(tags_of_pathname native++"ocaml"++"link"++"native"); + P camlp4lib_cmxa; A"-linkall"; atomize cmxs; A"-o"; Px (add_exe native)]) + end;; + +let mk_camlp4 name ?unix modules bin_mods top_mods = + mk_camlp4_bin name ?unix (modules @ bin_mods); + mk_camlp4_top_lib name (modules @ top_mods);; + +copy_rule "camlp4: boot/Camlp4Ast.ml -> Camlp4/Struct/Camlp4Ast.ml" + ~insert:`top "camlp4/boot/Camlp4Ast.ml" "camlp4/Camlp4/Struct/Camlp4Ast.ml";; + +rule "camlp4: Camlp4/Struct/Lexer.ml -> boot/Lexer.ml" + ~prod:"camlp4/boot/Lexer.ml" + ~dep:"camlp4/Camlp4/Struct/Lexer.ml" + begin fun _ _ -> + Cmd(S[P"camlp4o"; P"camlp4/Camlp4/Struct/Lexer.ml"; + A"-printer"; A"r"; A"-o"; Px"camlp4/boot/Lexer.ml"]) + end;; + +module Camlp4deps = struct + let lexer = Genlex.make_lexer ["INCLUDE"; ";"; "="; ":"];; + + let rec parse strm = + match Stream.peek strm with + | None -> [] + | Some(Genlex.Kwd "INCLUDE") -> + Stream.junk strm; + begin match Stream.peek strm with + | Some(Genlex.String s) -> + Stream.junk strm; + s :: parse strm + | _ -> invalid_arg "Camlp4deps parse failure" + end + | Some _ -> + Stream.junk strm; + parse strm + + let parse_file file = + with_input_file file begin fun ic -> + let strm = Stream.of_channel ic in + parse (lexer strm) + end + + let build_deps build file = + let includes = parse_file file in + List.iter Outcome.ignore_good (build (List.map (fun i -> [i]) includes)); +end;; + +rule "camlp4: ml4 -> ml" + ~prod:"%.ml" + ~dep:"%.ml4" + begin fun env build -> + let ml4 = env "%.ml4" and ml = env "%.ml" in + Camlp4deps.build_deps build ml4; + Cmd(S[P cold_camlp4boot; A"-impl"; P ml4; A"-printer"; A"o"; + A"-D"; A"OPT"; A"-o"; Px ml]) + end;; + +rule "camlp4: mlast -> ml" + ~prod:"%.ml" + ~deps:["%.mlast"; "camlp4/Camlp4/Camlp4Ast.partial.ml"] + begin fun env _ -> + let mlast = env "%.mlast" and ml = env "%.ml" in + (* Camlp4deps.build_deps build mlast; too hard to lex *) + Cmd(S[P cold_camlp4boot; + A"-printer"; A"r"; + A"-filter"; A"map"; + A"-filter"; A"fold"; + A"-filter"; A"meta"; + A"-filter"; A"trash"; + A"-impl"; P mlast; + A"-o"; Px ml]) + end;; + +dep ["ocaml"; "compile"; "file:camlp4/Camlp4/Sig.ml"] + ["camlp4/Camlp4/Camlp4Ast.partial.ml"];; + +mk_camlp4_bin "camlp4" [];; +mk_camlp4 "camlp4boot" ~unix:false + [pa_r; pa_qc; pa_q; pa_rp; pa_g; pa_macro; pa_debug] [pr_dump] [top_rprint];; +mk_camlp4 "camlp4r" + [pa_r; pa_rp] [pr_a] [top_rprint];; +mk_camlp4 "camlp4rf" + [pa_r; pa_qc; pa_q; pa_rp; pa_g; pa_macro; pa_l] [pr_a] [top_rprint];; +mk_camlp4 "camlp4o" + [pa_r; pa_o; pa_rp; pa_op] [pr_a] [];; +mk_camlp4 "camlp4of" + [pa_r; pa_qc; pa_q; pa_o; pa_rp; pa_op; pa_g; pa_macro; pa_l] [pr_a] [];; +mk_camlp4 "camlp4oof" + [pa_r; pa_o; pa_rp; pa_op; pa_qc; pa_oq; pa_g; pa_macro; pa_l] [pr_a] [];; +mk_camlp4 "camlp4orf" + [pa_r; pa_o; pa_rp; pa_op; pa_qc; pa_rq; pa_g; pa_macro; pa_l] [pr_a] [];; + + +(* Labltk *) + +Pathname.define_context "otherlibs/labltk/support" ["otherlibs/labltk/support"; "stdlib"];; +Pathname.define_context "otherlibs/labltk/compiler" ["otherlibs/labltk/compiler"; "otherlibs/labltk/support"; "stdlib"];; +Pathname.define_context "otherlibs/labltk/labltk" ["otherlibs/labltk/labltk"; "otherlibs/labltk/support"; "stdlib"];; +Pathname.define_context "otherlibs/labltk/camltk" ["otherlibs/labltk/camltk"; "otherlibs/labltk/support"; "stdlib"];; +Pathname.define_context "otherlibs/labltk/lib" + ["otherlibs/labltk/labltk"; "otherlibs/labltk/camltk"; "otherlibs/labltk/support"; "stdlib"];; +Pathname.define_context "otherlibs/labltk/jpf" + ["otherlibs/labltk/jpf"; "otherlibs/labltk/labltk"; "otherlibs/labltk/support"; "stdlib"];; +Pathname.define_context "otherlibs/labltk/frx" + ["otherlibs/labltk/frx"; "otherlibs/labltk/camltk"; "otherlibs/labltk/support"; "stdlib"];; +Pathname.define_context "otherlibs/labltk/tkanim" + ["otherlibs/labltk/tkanim"; "otherlibs/labltk/camltk"; "otherlibs/labltk/support"; "stdlib"];; +Pathname.define_context "otherlibs/labltk/browser" + ["otherlibs/labltk/browser"; "otherlibs/labltk/labltk"; "otherlibs/labltk/support"; "parsing"; "utils"; "typing"; "stdlib"];; + +file_rule "otherlibs/labltk/compiler/copyright" + ~dep:"otherlibs/labltk/compiler/copyright" + ~prod:"otherlibs/labltk/compiler/copyright.ml" + ~cache:(fun _ -> "0.1") + begin fun _ oc -> + Printf.fprintf oc "let copyright = \"%a\";;\n\ + let write ~w = w copyright;;" + fp_cat "otherlibs/labltk/compiler/copyright" + end;; + +copy_rule "labltk tkcompiler" "otherlibs/labltk/compiler/maincompile.byte" "otherlibs/labltk/compiler/tkcompiler";; +copy_rule "labltk pp" "otherlibs/labltk/compiler/pp.byte" "otherlibs/labltk/compiler/pp";; +copy_rule "labltk ocamlbrowser" "otherlibs/labltk/browser/main.byte" "otherlibs/labltk/browser/ocamlbrowser";; + +let builtins = + let dir = "otherlibs/labltk/builtin" in + List.filter (fun f -> not (Pathname.is_directory f)) + (List.map (fun f -> dir/f) (Array.to_list (Pathname.readdir dir)));; + +let labltk_support = + ["support"; "rawwidget"; "widget"; "protocol"; "textvariable"; "timer"; "fileevent"; "camltkwrap"];; + +let labltk_generated_modules = + ["place"; "wm"; "imagephoto"; "canvas"; "button"; "text"; "label"; "scrollbar"; + "image"; "encoding"; "pixmap"; "palette"; "font"; "message"; "menu"; "entry"; + "listbox"; "focus"; "menubutton"; "pack"; "option"; "toplevel"; "frame"; + "dialog"; "imagebitmap"; "clipboard"; "radiobutton"; "tkwait"; "grab"; + "selection"; "scale"; "optionmenu"; "winfo"; "grid"; "checkbutton"; "bell"; "tkvars"];; + +let labltk_generated_files = + let dir = "otherlibs/labltk/labltk" in + List.fold_right (fun x acc -> dir/x-.-"ml" :: dir/x-.-"mli" :: acc) + labltk_generated_modules [] in + +rule "labltk/_tkgen.ml" + ~deps:(["otherlibs/labltk/Widgets.src"; "otherlibs/labltk/compiler/tkcompiler"] @ builtins) + ~prods:("otherlibs/labltk/labltk/_tkgen.ml" :: "otherlibs/labltk/labltk/labltk.ml" :: labltk_generated_files) + begin fun env _ -> + Cmd(S[A"cd"; A"otherlibs/labltk"; Sh"&&"; full_ocamlrun; + A"compiler/tkcompiler"; A"-outdir"; Px"labltk"]) + end;; + +let camltk_generated_modules = + ["cPlace"; "cResource"; "cWm"; "cImagephoto"; "cCanvas"; "cButton"; "cText"; "cLabel"; + "cScrollbar"; "cImage"; "cEncoding"; "cPixmap"; "cPalette"; "cFont"; "cMessage"; + "cMenu"; "cEntry"; "cListbox"; "cFocus"; "cMenubutton"; "cPack"; "cOption"; "cToplevel"; + "cFrame"; "cDialog"; "cImagebitmap"; "cClipboard"; "cRadiobutton"; "cTkwait"; "cGrab"; + "cSelection"; "cScale"; "cOptionmenu"; "cWinfo"; "cGrid"; "cCheckbutton"; "cBell"; "cTkvars"];; + +let camltk_generated_files = + let dir = "otherlibs/labltk/camltk" in + List.fold_right (fun x acc -> dir/x-.-"ml" :: dir/x-.-"mli" :: acc) + camltk_generated_modules [] in + +rule "camltk/_tkgen.ml" + ~deps:(["otherlibs/labltk/Widgets.src"; "otherlibs/labltk/compiler/tkcompiler"] @ builtins) + ~prods:("otherlibs/labltk/camltk/_tkgen.ml" :: "otherlibs/labltk/camltk/camltk.ml" :: camltk_generated_files) + begin fun env _ -> + Cmd(S[A"cd"; A"otherlibs/labltk"; Sh"&&"; full_ocamlrun; + A"compiler/tkcompiler"; A"-camltk"; A"-outdir"; Px"camltk"]) + end;; + +rule "tk.ml" + ~prod:"otherlibs/labltk/labltk/tk.ml" + ~deps:(["otherlibs/labltk/labltk/_tkgen.ml"; + "otherlibs/labltk/compiler/pp.byte"] + @ builtins) + begin fun _ _ -> + Seq[Cmd(Sh"\ + (echo 'open StdLabels'; \ + echo 'open Widget'; \ + echo 'open Protocol'; \ + echo 'open Support'; \ + echo 'open Textvariable'; \ + cat otherlibs/labltk/builtin/report.ml; \ + cat otherlibs/labltk/builtin/builtin_*.ml; \ + cat otherlibs/labltk/labltk/_tkgen.ml; \ + echo ; \ + echo ; \ + echo 'module Tkintf = struct'; \ + cat otherlibs/labltk/builtin/builtini_*.ml; \ + cat otherlibs/labltk/labltk/_tkigen.ml; \ + echo 'end (* module Tkintf *)'; \ + echo ; \ + echo ; \ + echo 'open Tkintf' ;\ + echo ; \ + echo ; \ + cat otherlibs/labltk/builtin/builtinf_*.ml; \ + cat otherlibs/labltk/labltk/_tkfgen.ml; \ + echo ; \ + ) > otherlibs/labltk/labltk/_tk.ml"); + Cmd(S[ocamlrun; P"otherlibs/labltk/compiler/pp.byte"; Sh"<"; P"otherlibs/labltk/labltk/_tk.ml"; + Sh">"; Px"otherlibs/labltk/labltk/tk.ml"]); + rm_f "otherlibs/labltk/labltk/_tk.ml"] + end;; + +rule "cTk.ml" + ~prod:"otherlibs/labltk/camltk/cTk.ml" + ~deps:(["otherlibs/labltk/camltk/_tkgen.ml"; + "otherlibs/labltk/compiler/pp.byte"] + @ builtins) + begin fun _ _ -> + Seq[Cmd(Sh"\ + (echo '##define CAMLTK'; \ + echo 'include Camltkwrap'; \ + echo 'open Widget'; \ + echo 'open Protocol'; \ + echo 'open Textvariable'; \ + echo ; \ + cat otherlibs/labltk/builtin/report.ml; \ + echo ; \ + cat otherlibs/labltk/builtin/builtin_*.ml; \ + echo ; \ + cat otherlibs/labltk/camltk/_tkgen.ml; \ + echo ; \ + echo ; \ + echo 'module Tkintf = struct'; \ + cat otherlibs/labltk/builtin/builtini_*.ml; \ + cat otherlibs/labltk/camltk/_tkigen.ml; \ + echo 'end (* module Tkintf *)'; \ + echo ; \ + echo ; \ + echo 'open Tkintf' ;\ + echo ; \ + echo ; \ + cat otherlibs/labltk/builtin/builtinf_*.ml; \ + cat otherlibs/labltk/camltk/_tkfgen.ml; \ + echo ; \ + ) > otherlibs/labltk/camltk/_cTk.ml"); + Cmd(S[ocamlrun; P"otherlibs/labltk/compiler/pp.byte"; Sh"<"; P"otherlibs/labltk/camltk/_cTk.ml"; + Sh">"; Px"otherlibs/labltk/camltk/cTk.ml"]); + rm_f "otherlibs/labltk/camltk/_cTk.ml"] + end;; + +let labltk_lib_contents = + labltk_support + @ "tk" + :: labltk_generated_modules + @ "cTk" + :: camltk_generated_modules;; + +let labltk_contents obj_ext = + List.map (fun x -> "otherlibs/labltk/support"/x-.-obj_ext) labltk_support + @ "otherlibs/labltk/labltk/tk"-.-obj_ext + :: List.map (fun x -> "otherlibs/labltk/labltk"/x-.-obj_ext) labltk_generated_modules + @ "otherlibs/labltk/camltk/cTk"-.-obj_ext + :: List.map (fun x -> "otherlibs/labltk/camltk"/x-.-obj_ext) camltk_generated_modules;; + +let labltk_cma_contents = labltk_contents "cmo" in +rule "labltk.cma" + ~prod:"otherlibs/labltk/lib/labltk.cma" + ~deps:labltk_cma_contents + (Ocamlbuild_pack.Ocaml_compiler.byte_library_link_modules + labltk_lib_contents "otherlibs/labltk/lib/labltk.cma");; + +let labltk_cmxa_contents = labltk_contents "cmx" in +rule "labltk.cmxa" + ~prod:"otherlibs/labltk/lib/labltk.cmxa" + ~deps:labltk_cmxa_contents + (Ocamlbuild_pack.Ocaml_compiler.native_library_link_modules + labltk_lib_contents "otherlibs/labltk/lib/labltk.cmxa");; + +rule "labltktop" + ~prod:(add_exe "otherlibs/labltk/lib/labltktop") + ~deps:["toplevel/toplevellib.cma"; "toplevel/topstart.cmo"; + "otherlibs/labltk/lib/labltk.cma"; "otherlibs/labltk/support/liblabltk"-.-C.a] + begin fun _ _ -> + Cmd(S[!Options.ocamlc; A"-verbose"; A"-linkall"; A"-o"; Px(add_exe "otherlibs/labltk/lib/labltktop"); + A"-I"; P"otherlibs/labltk/support"; A"-I"; P"toplevel"; P"toplevellib.cma"; + A"-I"; P"otherlibs/labltk/labltk"; A"-I"; P"otherlibs/labltk/camltk"; + A"-I"; P"otherlibs/labltk/lib"; P"labltk.cma"; A"-I"; P unix_dir; P"unix.cma"; + A"-I"; P"otherlibs/str"; A"-I"; P "stdlib"; P"str.cma"; P"topstart.cmo"]) + end;; + +let labltk_installdir = C.libdir/"labltk" in +file_rule "labltk" + ~prod:"otherlibs/labltk/lib/labltk" + ~cache:(fun _ -> labltk_installdir) + begin fun _ oc -> + Printf.fprintf oc + "#!/bin/sh\n\ + exec %s -I %s $*\n" (labltk_installdir/"labltktop") labltk_installdir + end;; + +use_lib "otherlibs/labltk/browser/main" "toplevel/toplevellib";; +use_lib "otherlibs/labltk/browser/main" "otherlibs/labltk/browser/jglib";; +use_lib "otherlibs/labltk/browser/main" "otherlibs/labltk/lib/labltk";; + +if windows then begin + + dep ["ocaml"; "link"; "program"; "ocamlbrowser"] ["otherlibs/labltk/browser/winmain"-.-C.o]; + flag ["ocaml"; "link"; "program"; "ocamlbrowser"] (S[A"-custom"; A"threads.cma"]); + + match ccomptype with + | "cc" -> flag ["ocaml"; "link"; "program"; "ocamlbrowser"] (S[A"-ccopt"; A"-Wl,--subsystem,windows"]) + | "msvc" -> flag ["ocaml"; "link"; "program"; "ocamlbrowser"] (S[A"-ccopt"; A"/link /subsystem:windows"]) + | _ -> assert false + +end;; + +let space_sep_strings s = Ocamlbuild_pack.Lexers.space_sep_strings (Lexing.from_string s);; + +flag [(* "ocaml" or "c"; *) "ocamlmklib"; "otherlibs_labltk"] + (if windows then begin + S(List.fold_right (fun s acc -> A"-cclib" :: A s :: acc) (space_sep_strings C.tk_link) []) + end else Sh C.tk_link);; + +flag ["ocaml"; "link"; "program"; "otherlibs_labltk"] (S[A"-I"; A"otherlibs/labltk/support"]);; + +flag ["c"; "compile"; "otherlibs_labltk"] (A"-Iotherlibs/labltk/support");; + +copy_rule "ocamlbrowser dummy module" + ("otherlibs/labltk/browser"/(if windows then "dummyWin.mli" else "dummyUnix.mli")) + "otherlibs/labltk/browser/dummy.mli";; + + end in () + | _ -> () +end diff --git a/myocamlbuild_config.mli b/myocamlbuild_config.mli new file mode 100644 index 00000000..506902ea --- /dev/null +++ b/myocamlbuild_config.mli @@ -0,0 +1,59 @@ +val prefix : string +val bindir : string +val libdir : string +val manext : string +val ranlib : string +val ranlibcmd : string +val sharpbangscripts : bool +val bng_arch : string +val bng_asm_level : string +val pthread_link : string +val x11_includes : string +val x11_link : string +val tk_link : string +val dbm_includes : string +val dbm_link : string +val bytecc : string +val bytecccompopts : string +val bytecclinkopts : string +val bytecclibs : string +val byteccrpath : string +val exe : string +val supports_shared_libraries : bool +val sharedcccompopts : string +val mksharedlibrpath : string +val arch : string +val model : string +val system : string +val nativecc : string +val nativecccompopts : string +val nativeccprofopts : string +val nativecclinkopts : string +val nativeccrpath : string +val nativecclibs : string +val dllcccompopts : string +val asflags : string +val aspp : string +val asppflags : string +val asppprofflags : string +val profiling : string +val dynlinkopts : string +val otherlibraries : string +val debugger : string +val cc_profile : string +val systhread_support : bool +val partialld : string +val syslib : string -> string +val mkexe : string -> string -> string -> string +val mkdll : string -> string -> string -> string -> string +val mklib : string -> string -> string -> string +val ext_lib : string +val ext_obj : string +val ext_asm : string +val ext_dll : string +val o : string +val a : string +val toolchain : string +val ccomptype : string +val extralibs : string +val tk_defs : string diff --git a/ocamlbuild/AUTHORS b/ocamlbuild/AUTHORS new file mode 100644 index 00000000..0b27a5b1 --- /dev/null +++ b/ocamlbuild/AUTHORS @@ -0,0 +1,2 @@ +Nicolas Pouillard +Berke Durak diff --git a/ocamlbuild/ChangeLog b/ocamlbuild/ChangeLog new file mode 100644 index 00000000..2992ecf0 --- /dev/null +++ b/ocamlbuild/ChangeLog @@ -0,0 +1,3539 @@ +2007-03-07 Nicolas Pouillard + + Handle specially archives files during an import. + + * shell.ml: Ditto. + +2007-03-07 Nicolas Pouillard + + Use cp -p in copy_rule, and fix some typos in the manual. + + * manual/manual.tex: Typos. + * rule.ml, + * rule.mli: Add cp_p and use it for copy_rule. + +2007-03-05 Nicolas Pouillard + + Relaxe executor on exception condition. + + Patch from Berke. + * executor.ml: Ignore Not_found and exceptional conditions. + * TODO: Add an entry (needs to better understand POSIX). + +2007-03-04 Nicolas Pouillard + + Split where in bindir and libdir. + + * ocamlbuild_where.mli: Ditto. + * ocaml_specific.ml: Update. + * options.ml: Use bindir. + * plugin.ml: Update. + * start.sh: Update. + +2007-03-04 Nicolas Pouillard + + Virtual solvers for ocaml tools. + + * options.ml: Setup virtual command solver for commands like ocamlc, + ocamlopt... This allow to have full pathname but let also failback to + classic search path. + * ocaml_compiler.ml: Add a tag to differentiate dependencies at link + time. + * ocamlbuild-presentation.rslide: Add an item as suggested by a friend. + +2007-03-02 Nicolas Pouillard + + Same thing for the second link function. + + * ocaml_compiler.ml: Ignore stdlib. + +2007-03-02 Nicolas Pouillard + + Move the stdlib hack. + + * ocaml_compiler.ml: Should works better. + +2007-03-02 Nicolas Pouillard + + Little fix about library linking. + + * ocaml_utils.ml: Avoid linking twice in some cases. + * ocaml_compiler.ml: Handle specially the OCaml stdlib. + +2007-03-01 Nicolas Pouillard + + Remove a rec. + + * glob.ml: Parse is not rec. + +2007-03-01 Nicolas Pouillard + + true: traverse and FAQ. + + * main.ml: Move the inital config upper to be loaded before the others + and hygiene. + * FAQ: New. + +2007-02-28 Nicolas Pouillard + + Improve the glob dir handling. + + * glob.ml: Extend the ast instead of parsing an extended string. + +2007-02-28 Nicolas Pouillard + + Ensure that the whole boolean expression is only valid in the directory. + + * glob.ml: Ditto. + +2007-02-28 Nicolas Pouillard + + Put -g on link only for programs. + + * ocaml_specific.ml: Ditto. + +2007-02-26 Berke Durak + + Added disclaimer to default rules table. + + * manual/manual.tex: . + +2007-02-26 Nicolas Pouillard + + Add the -documentation option. + + * main.ml: Implement it. + * flags.ml, + * flags.mli: Add get_flags. + * man/ocamlbuild.1: Update. + * signatures.mli, + * options.ml: Add show_documention. + * rule.ml, + * rule.mli: Add pretty_print. + +2007-02-26 Nicolas Pouillard + + Add the -dont-catch-errors option. + + * main.ml: Implement it. + * options.ml: Parse it. + * signatures.mli: Declare it. + * _tags: Use debug. + +2007-02-26 Nicolas Pouillard + + Deal with the camlp4 library name. + + * ocaml_specific.ml: Introduce use_old_camlp4 for the old one. + +2007-02-26 Nicolas Pouillard + + Minor `ocaml_lib' improvments. + + * signatures.mli: Declare and doc it. + * ocamlbuild_plugin.ml: Export it. + * ocaml_specific.ml, + * ocaml_specific.mli: Add some dirs to std libs. + Move the ocaml_lib implem to ... + * ocaml_utils.mli, + * ocaml_utils.ml: ... here. Improve it by adding the ~tag_name option. + * ocaml_compiler.ml: The hash now contains the tag. + * _tags: *.top use unix too. + +2007-02-22 Berke Durak + + Should use Log.eprintf for show_tags. + + * main.ml: . + +2007-02-22 Nicolas Pouillard + + ( & ), sanitize.sh, and the manual... + + * signatures.mli: Add ( & ). + + * hygiene.ml: Also clean the sanitize.sh script itself. + * my_std.ml: Add ( & ). + * manual/manual.tex: Some fixes and a section that I wrote but that's + needs reflexion about what solution we want to support. + +2007-02-22 Berke Durak + + Implemented fixes suggested by Commissar Leroy. + + * fda.ml: . + * hygiene.ml: . + * hygiene.mli: . + * man/ocamlbuild.1: . + * manual/manual.tex: . + * ocaml_specific.ml: . + * options.ml: . + * signatures.mli: . + +2007-02-20 Nicolas Pouillard + + Add -show-tags. + + * hygiene.ml: Rewrap the error message. + * main.ml: Do the show_tags job. Move one hook. + * ocaml_specific.ml: Add -g also in native code. + * options.ml, + * signatures.mli: Add the -show-tags option. + * tags.ml: Fix print. + * TODO: Add a done entry. + +2007-02-16 Nicolas Pouillard + + Relaxing plural options to spaces. + + * lexers.mli, + * lexers.mll: Add comma_or_blank_sep_strings. + * options.ml: Use it. + +2007-02-16 Nicolas Pouillard + + Add a plugin example. + + * manual/myocamlbuild.ml: New. + +2007-02-16 Nicolas Pouillard + + Typos. + + * ocamlbuild-presentation.rslide: . + * manual/trace.out: . + +2007-02-16 Berke Durak + + Fixed a few typos and sentences. + + * ocamlbuild-presentation.rslide: . + +2007-02-15 Nicolas Pouillard + + Little changes... + + * ocamlbuild-presentation.rslide: . + +2007-02-15 Nicolas Pouillard + + Slides almost done... + + * manual/trace.out: New. Of course you needed it. + * ocamlbuild-presentation.rslide: Ditto. + +2007-02-15 Berke Durak + + Improving slides. + + * ocamlbuild-presentation.rslide: . + +2007-02-15 Nicolas Pouillard + + Slides... + + * ocamlbuild-presentation.rslide: . + +2007-02-15 Nicolas Pouillard + + Working on slides... + + * ocamlbuild-presentation.rslide: . + +2007-02-15 Nicolas Pouillard + + More slides... + + * ocamlbuild-presentation.rslide: . + +2007-02-12 Nicolas Pouillard + + Keep include dirs uniq. + + * ocaml_compiler.ml: Ditto. + +2007-02-12 Nicolas Pouillard + + Keep include dirs uniq. + + * ocaml_compiler.ml: Ditto. + +2007-02-12 Nicolas Pouillard + + Add ocamlmktop support. + + * ocamlbuild.mltop: New. + * main.ml: Handle .top as binaries. + * ocaml_compiler.ml, + * ocaml_specific.ml, + * ocaml_compiler.mli: Add mktop functions and rules. + * options.ml, + * signatures.mli: Add an ocamlmktop option. + +2007-02-09 Berke Durak + + Was attempting to link with threads.cmxa in byte mode. + + * ocaml_specific.ml: . + +2007-02-09 Berke Durak + + Talking of sterilize.sh. + + * manual/manual.tex: . + +2007-02-09 Berke Durak + + Rewrote some parts, filled the abstract, moved rantings to the appendix. + + * manual/manual.tex: . + * .vcs: . + +2007-02-08 Nicolas Pouillard + + Add manual/manual.hva. + + * manual/manual.hva: New. + +2007-02-08 Nicolas Pouillard + + Changes done with Luc. + + * manual/manual.tex: . + * manual/Makefile: . + +2007-02-08 Nicolas Pouillard + + Fix a bug found by Luc in hevea. + + * ocaml_utils.ml, + * ocaml_utils.mli: Change keep_this_module into module_importance to + have a finer grain. + * ocaml_compiler.ml: Update to importance. + * ocamldep.ml, + * ocamldep.mli: We now try to also build stdlib modules but don't fail + if they don't exists. + * test/test5/stack.ml: New. + * test/test5/a.ml: A test case (from hevea). + * test/good-output: Update. + +2007-02-08 Nicolas Pouillard + + Ocamldoc, extension:* tag ... + + * ocaml_tools.mli, + * ocaml_tools.ml: The ocamldoc support now takes into account two modes + *d and -o. + * ocaml_specific.ml: Two more rules and many flags for some of the + standard behaviors. + * signatures.mli: Some comments. + * tools.ml: Add the extension:* tag. + * TODO: Update. + +2007-02-08 Berke Durak + + Hygiene generates sterilize.sh. + + * fda.ml: . + * fda.mli: . + * hygiene.ml: . + * hygiene.mli: . + * main.ml: . + * options.ml: . + * signatures.mli: . + +2007-02-07 Berke Durak + + Updated section on ocamldoc. + + * manual/manual.tex: . + +2007-02-07 Nicolas Pouillard + + Some minor manual and slides changes. + + * ocamlbuild-presentation.rslide, + * manual/manual.tex: Ditto. + +2007-02-07 Nicolas Pouillard + + Make links for the documentation. + + * main.ml: Handle doc. + * test/good-output: Update. + +2007-02-07 Berke Durak + + Added manual section for ocamldoc. + + * manual/manual.tex: . + * manual/Makefile: . + +2007-02-07 Berke Durak + + Fixed truncated display problem. + + * executor.ml: . + * .vcs: . + +2007-02-07 Nicolas Pouillard + + Fix the bootstrap. + + * start.sh: Swap lines. + * Makefile: -verbose. + +2007-02-07 Berke Durak + + TODO + Executor. + + * manual/manual.tex: . + * TODO: . + +2007-02-06 Nicolas Pouillard + + Make -a more static, to avoid some complications. + + * ocaml_utils.ml, + * ocaml_compiler.ml, + * ocaml_compiler.ml, + * ocaml_specific.ml: Ditto. + +2007-02-06 Nicolas Pouillard + + A fix. + + * ocaml_compiler.ml: Don't use these refs too early. + * ocamlbuild-presentation.rslide: . + +2007-02-05 Nicolas Pouillard + + Plugin signature. + + Somewhat a big patch, but that's just moving things around. + + * signatures.mli: Add TAGS, OUTCOME, MISC, OPTIONS, ARCH and PLUGIN. + * ocamlbuild_plugin.mli: New. + * ocamlbuild_plugin.ml: Conform to the sig. + + * command.ml, + * command.mli: Add a tags type. + * main.ml: Quit early if no targets. + * my_std.ml, + * my_std.mli: More things are in signatures. + * resource.ml, + * resource.mli: Remove the type t that was an Pathname.t alias. + * options.ml, + * options.mli: Add ext_lib, ext_obj, ext_dll. + * ocaml_compiler.ml: Update. + * ocaml_tools.ml: Update to Outcome. + * ocaml_specific.ml: Update. + * ocaml_utils.mli: Remove *ext_*. + * ocaml_arch.mli: Now in signatures. + * pathname.ml: Add readdir. + * slurp.ml: open Outcome. + * rule.ml, + * rule.mli, + * solver.ml, + * solver.mli: Update to Resource.t and Outcome.t. + * tags.mli: Now in Signatures. + * test/good-output: Update. + * test/test8/test.sh, + * test/test3/test.sh, + * test/test4/test.sh, + * test/test5/test.sh, + * test/test6/test.sh, + * test/test7/test.sh, + * test/test2/test.sh: Update to -verbose 0. + +2007-02-05 Berke Durak + + Continuing doc. + + * manual/manual.tex: . + * .: . + +2007-02-05 Berke Durak + + Described display line. + + * manual/manual.tex: . + +2007-02-05 Berke Durak + + Renamed -debug as -verbose. Authorized spaces etc. in flags. Continuing documentation. + + * lexers.mll: . + * manual/manual.tex: . + * options.ml: . + +2007-02-05 Berke Durak + + Added man page. + + * main.ml: . + * man: New. + * man/ocamlbuild.1: New. + * manual/manual.tex: . + * TODO: . + +2007-02-05 Nicolas Pouillard + + Update start.sh. + + * start.sh: Update. + +2007-02-05 Nicolas Pouillard + + Typo s/Orignal/Original/g. + +2007-02-05 Nicolas Pouillard + + Make signatures and std_signatures mliS. + + * signatures.ml: Remove. + * std_signatures.ml: Remove. + * signatures.mli: New. + * std_signatures.mli: New. + * Makefile: Update. + * lexers.mll: Allow any prefix: for tags. + +2007-02-04 Nicolas Pouillard + + The beginning of a presentation. + + * ocamlbuild-presentation.rslide: New. + +2007-02-04 Nicolas Pouillard + + Also add who is the original author of the file. + + * ocamlbuild.ml, + * ocamlbuild_plugin.ml, + * ocamlbuildlight.ml, + * ocamlbuild_where.mli, + * ocamlbuild.mli, + * ocamlbuildlight.mli, + * bool.ml, + * bool.mli, + * configuration.ml, + * configuration.mli, + * command.ml, + * command.mli, + * display.ml, + * discard_printf.ml, + * display.mli, + * discard_printf.mli, + * executor.ml, + * executor.mli, + * flags.ml, + * fda.ml, + * flags.mli, + * fda.mli, + * glob.ml, + * glob_ast.ml, + * glob_ast.mli, + * glob.mli, + * glob_lexer.mli, + * glob_lexer.mll, + * hygiene.ml, + * hooks.ml, + * hygiene.mli, + * hooks.mli, + * log.ml, + * lexers.mli, + * log.mli, + * lexers.mll, + * my_unix_with_unix.ml, + * main.ml, + * my_unix.ml, + * my_std.ml, + * my_unix_with_unix.mli, + * my_std.mli, + * my_unix.mli, + * main.mli, + * ocaml_utils.ml, + * ocaml_tools.ml, + * ocaml_arch.ml, + * ocaml_specific.ml, + * ocaml_compiler.ml, + * ocaml_dependencies.ml, + * ocaml_utils.mli, + * ocaml_specific.mli, + * ocaml_dependencies.mli, + * ocaml_tools.mli, + * ocaml_arch.mli, + * ocaml_compiler.mli, + * options.ml, + * options.mli, + * ocamldep.ml, + * ocamldep.mli, + * plugin.ml, + * ppcache.ml, + * pathname.ml, + * ppcache.mli, + * plugin.mli, + * pathname.mli, + * resource.ml, + * resource.mli, + * rule.ml, + * rule.mli, + * report.ml, + * report.mli, + * signatures.ml, + * slurp.ml, + * std_signatures.ml, + * solver.ml, + * shell.ml, + * shell.mli, + * slurp.mli, + * solver.mli, + * tags.ml, + * tools.ml, + * tags.mli, + * tools.mli: Ditto. + +2007-02-04 Nicolas Pouillard + + Add the header license. + + * ocamlbuildlight.ml, + * ocamlbuild.ml, + * ocamlbuild_plugin.ml, + * ocamlbuild_where.mli, + * ocamlbuild.mli, + * ocamlbuildlight.mli, + * bool.ml, + * bool.mli, + * configuration.ml, + * configuration.mli, + * command.ml, + * command.mli, + * discard_printf.ml, + * display.ml, + * display.mli, + * discard_printf.mli, + * executor.ml, + * executor.mli, + * fda.ml, + * flags.ml, + * flags.mli, + * fda.mli, + * glob.ml, + * glob_ast.ml, + * glob.mli, + * glob_ast.mli, + * glob_lexer.mli, + * glob_lexer.mll, + * hygiene.ml, + * hooks.ml, + * hygiene.mli, + * hooks.mli, + * log.ml, + * lexers.mli, + * log.mli, + * lexers.mll, + * my_unix.ml, + * main.ml, + * my_std.ml, + * my_unix_with_unix.ml, + * misc/opentracer.ml, + * my_std.mli, + * main.mli, + * my_unix.mli, + * my_unix_with_unix.mli, + * ocaml_arch.ml, + * ocaml_compiler.ml, + * ocaml_specific.ml, + * ocaml_tools.ml, + * ocaml_utils.ml, + * ocaml_dependencies.ml, + * ocaml_utils.mli, + * ocaml_tools.mli, + * ocaml_dependencies.mli, + * ocaml_compiler.mli, + * ocaml_specific.mli, + * ocaml_arch.mli, + * options.ml, + * options.mli, + * ocamldep.ml, + * ocamldep.mli, + * plugin.ml, + * pathname.ml, + * ppcache.ml, + * plugin.mli, + * ppcache.mli, + * pathname.mli, + * resource.ml, + * resource.mli, + * rule.ml, + * rule.mli, + * report.ml, + * report.mli, + * slurp.ml, + * std_signatures.ml, + * signatures.ml, + * solver.ml, + * shell.ml, + * shell.mli, + * slurp.mli, + * solver.mli, + * tools.ml, + * tags.ml, + * tags.mli, + * tools.mli: Ditto. + +2007-02-03 Nicolas Pouillard + + Fix a bug in copy_file. + + * my_std.ml: Also use the binary mode for the output channel. + +2007-02-03 Nicolas Pouillard + + Add nopervasives, and nolabels. + + * ocaml_specific.ml: Ditto. + +2007-02-03 Nicolas Pouillard + + Windows cannot use executor. + + * shell.ml: As in command.ml use executor only in non-windows and + non-degraded mode. + * rule.ml: Update two error messages. + +2007-02-02 Nicolas Pouillard + + Some minor things for the ocaml myocamlbuild for instance. + + * configuration.ml, + * configuration.mli: Add has_tag. + * my_std.ml, + * my_std.mli: Add getenv and copy_chan. + * ocaml_utils.ml, + * ocaml_utils.mli: Move some commands to rule. + * ocaml_specific.ml: Improve the menhir switching. + * options.ml, + * options.mli: Add -use-menhir and -menhir options. + * rule.ml, + * rule.mli: Add copy_rule and move some commands from ocaml_utils. + * signatures.ml: . + +2007-02-01 Nicolas Pouillard + + Move main sigs in signatures.ml and std_signatures.ml. + + * ocamlbuild_pack.mlpack: . + * ocamlbuildlib.mllib: . + * ocamlbuildlightlib.mllib: . + * ocamlbuild.odocl: . + * command.mli: . + * glob.mli: . + * log.mli: . + * my_unix_with_unix.ml: . + * my_std.ml: . + * my_std.mli: . + * ocaml_specific.ml: . + * pathname.mli: . + * std_signatures.ml: New. + * signatures.ml: New. + * start.sh: . + * tags.ml: . + * tags.mli: . + * test/test5/_tags: . + * Makefile: . + * _tags: . + +2007-02-01 Berke Durak + + Shell.run doesn't use execute_many in degraded mode. + + * shell.ml: . + +2007-02-01 Berke Durak + + cp, rm -rf and mv-like commands use Executor to better play with display. + + * display.ml: . + * my_unix.ml: . + * main.ml: . + * my_std.ml: . + * my_unix.mli: . + * shell.ml: . + * shell.mli: . + * start.sh: . + * _tags: . + +2007-02-01 Berke Durak + + Systematizing exit codes. + + * executor.ml: . + * main.ml: . + +2007-02-01 Berke Durak + + Added automatic file: tag, changed flag syntax. + + * lexers.mli: . + * lexers.mll: . + * main.ml: . + * ocamldep.ml: . + * ocamldep.mli: . + * tools.ml: . + +2007-01-31 Berke Durak + + Cleans up links to the _build directory. + + * main.ml: . + * options.ml: . + * options.mli: . + * pathname.ml: . + * pathname.mli: . + +2007-01-31 Nicolas Pouillard + + Restore the link to binary targets functionality. + + * main.ml: Make it separate from target running. + +2007-01-31 Nicolas Pouillard + + Add an hygiene hook pair. + + * ocamlbuild_plugin.ml, + * hooks.ml, + * hooks.mli, + * main.ml: Ditto. + +2007-01-31 Nicolas Pouillard + + The Killer feature about a fine grained dependency injection control. + + * rule.ml, + * rule.mli: Add build_deps_of_tags and call it automatically before + * ocaml_compiler.ml, + * ocaml_compiler.mli: Rework tags, to have them when callinng + build_deps_of_tags. + executing a command. + * ocaml_specific.ml, + * ocaml_specific.mli: Move the exception Exit_build_error to main and + remove the old dep function. + * ocamlbuild_plugin.ml: Export some new functions. + * test/test7/myocamlbuild.ml: Add a dep declaration. + * test/test7/cool_plugin.ml: New. + * test/test7/_tags: New. + * test/good-output: Update. + * flags.ml, + * command.ml, + * command.mli: Rename flags_of_tags as tag_handler. + * main.ml: Update error handling. + * TODO: Done. + +2007-01-30 Nicolas Pouillard + + Fix and improve the new link/deps system. + + * ocaml_dependencies.ml, + * ocaml_dependencies.mli: Some fixes and improvements. + * pathname.ml, + * pathname.mli: Add check_extension. + * ocaml_compiler.ml, + * ocaml_compiler.mli: Add support for hidden_packages and update. + +2007-01-30 Nicolas Pouillard + + Reverse the last 2 patches, since there is fact no name clash. + +2007-01-30 Nicolas Pouillard + + Shell -> Oshell second part. + + * ocamlbuild.odocl: Ditto. + * test/good-output: Update. + +2007-01-30 Nicolas Pouillard + + Rename the Shell module as Oshell to avoid a name clash with labltk. + + * shell.ml: Remove. + * shell.mli: Remove. + * oshell.ml: New. + * oshell.mli: New. + * ocamlbuild_pack.mlpack, + * command.ml, + * display.ml, + * main.ml, + * options.ml, + * ppcache.ml, + * pathname.ml, + * plugin.ml, + * resource.ml, + * start.sh: Update. + +2007-01-30 Nicolas Pouillard + + Fix 2 bugs. + + * test/test9/testglob.ml: More tests. + * glob_lexer.mll: Fix "/**". + * _tags: Restore my warnings. + * executor.ml: Use the unused variable. + +2007-01-30 Nicolas Pouillard + + Improve dprintf and update. + + * log.ml, log.mli: dprintf now wraps the message between "@[<2>" and "@]@.". + * command.ml, + * display.ml, + * fda.ml, + * main.ml, + * ocaml_dependencies.ml, + * ocaml_compiler.ml, + * ocaml_utils.ml, + * ocamldep.ml, + * pathname.ml, + * resource.ml, + * rule.ml, + * solver.ml: Update the dprintf usage. + +2007-01-30 Nicolas Pouillard + + Add the new dependency linking system (plz test it !). + + * ocamlbuild_pack.mlpack: Add a brand new module. + * ocaml_dependencies.ml: New. + * ocaml_dependencies.mli: New. + * ocaml_compiler.ml, + * ocaml_compiler.mli: Use this new module. + * resource.ml, + * resource.mli: Export a folding function on dependencies. + * TODO: Add something to do. + * start.sh: . + * main.ml: Update. + +2007-01-29 Nicolas Pouillard + + Executor exit codes. + + * executor.ml: Use the standard exit. + * main.ml: Some exit codes are reserved for Executor. + +2007-01-29 Berke Durak + + Executor returns finer-grained results. + + * executor.ml: . + * manual/manual.tex: . + +2007-01-29 Nicolas Pouillard + + Toward a working command execute feature :). + + * executor.ml, + * executor.mli: FIXME. + * command.ml, + * command.mli: Update to the new signature and merge the degraded mode + to avoid duplication. + * my_unix.ml, + * my_unix.mli, + * ocaml_utils.ml, + * ocamldep.ml, + * plugin.ml, + * resource.ml, + * rule.ml, + * solver.ml, + * test/good-output: Update. + +2007-01-29 Nicolas Pouillard + + Revert almost all of the 2 last patches. + + * command.ml: . + * command.mli: . + * executor.ml: . + * executor.mli: . + * my_unix.ml: . + * my_unix.mli: . + * ocaml_utils.ml: . + * ocaml_specific.ml: . + * ocamldep.ml: . + * plugin.ml: . + * resource.ml: . + * rule.ml: . + * solver.ml: . + +2007-01-29 Berke Durak + + Fixing before/after thunks. + + * command.ml: . + * command.mli: . + * ocaml_utils.ml: . + * ocamldep.ml: . + * plugin.ml: . + * resource.ml: . + * rule.ml: . + * solver.ml: . + * TODO: . + +2007-01-29 Berke Durak + + Adding before and after handlers to Executor. + + * command.ml: . + * executor.ml: . + * executor.mli: . + * my_unix.ml: . + * my_unix.mli: . + * manual/manual.tex: . + +2007-01-29 Berke Durak + + Fixed multi-dir globbing. + + * glob_lexer.mll: . + * manual/manual.tex: . + +2007-01-29 Nicolas Pouillard + + Add Rule.custom_rule and cleanup the ocamldep meta rule. + + * ocamldep.ml, + * ocamldep.mli: Make it a meta rule (or a rule generator). + * rule.ml, + * rule.mli: Add custom_rule. + * ocaml_specific.ml: Update to Ocamldep. + * test/good-output: Minor update. + +2007-01-29 Nicolas Pouillard + + MakefileS... + + * manual/Makefile: More things to remove (sometimes). + * Makefile: Use $(BUILDDIR) instead of _build. + +2007-01-26 Berke Durak + + Documenting glob expressions. + + * glob_lexer.mll: Added negative character classes. + * manual/manual.tex: . + +2007-01-26 Berke Durak + + Started documenting glob syntax. + + * manual/manual.tex: . + +2007-01-25 Nicolas Pouillard + + One other include dir fix. + + * main.ml: Ditto. + * test/test9/testglob.ml: Add a failing test (request for feature). + * test/good-output: Update. + +2007-01-25 Nicolas Pouillard + + Include dirs and Backtrace. + + * main.ml: Fix -I, and restore the backtrace. + * report.ml, + * report.mli: Fix the backtrace and rename analyze to + print_backtrace_analyze. + +2007-01-25 Berke Durak + + Added cross-directory globbing. + + * glob_ast.ml: . + * glob.ml: . + * glob_ast.mli: . + * glob_lexer.mll: . + * test/test9/testglob.ml: . + +2007-01-25 Nicolas Pouillard + + Inlcude dirs trought tags. + + * main.ml: Ditto. + * my_unix_with_unix.ml: Imrpove stat errors. + * my_std.ml, + * my_std.mli: . + * pathname.ml: bmla. + * slurp.ml, + * slurp.mli: Add force, fix bugs. + +2007-01-25 Berke Durak + + Fixed double display of error status. + + * command.ml: . + * display.ml: . + * display.mli: . + * log.ml: . + * log.mli: . + * main.ml: . + * my_std.ml: . + * my_std.mli: . + * plugin.ml: . + +2007-01-25 Berke Durak + + Stupid bug. + + * log.ml: . + * main.ml: . + * options.ml: . + +2007-01-25 Berke Durak + + Fixed interface, handling of -- with no argument. + + * ocamlbuild_plugin.mli: Remove. + * manual/manual.tex: . + * options.ml: . + +2007-01-25 Berke Durak + + Updated start.sh. + + * start.sh: . + +2007-01-25 Berke Durak + + Added .mlis. + + * ocamlbuild_plugin.mli: New. + * fda.mli: New. + * main.ml: . + * ocaml_specific.ml: . + * plugin.ml: . + * plugin.mli: New. + +2007-01-25 Nicolas Pouillard + + Cut down ocaml_specific in pieces. + + * ocaml_specific.ml, + * ocaml_specific.mli: Split. + * ocamlbuild_plugin.ml: Update. + * ocamlbuild_pack.mlpack: Add new modules. + * my_std.ml, + * my_std.mli: Add good_outcome. + * ocaml_utils.ml: New. + * ocaml_tools.ml: New. + * ocaml_compiler.ml: New. + * ocaml_utils.mli: New. + * ocaml_compiler.mli: New. + * ocaml_tools.mli: New. + * ocamldep.ml: New. + * ocamldep.mli: New. + * start.sh: Update. + * TODO: Move things done. + +2007-01-25 Berke Durak + + Fixer return codes and error message flushing issues. + + * display.ml: . + * log.ml: . + * log.mli: . + * main.ml: . + * report.ml: . + * report.mli: . + +2007-01-25 Nicolas Pouillard + + Add a warning. + + * ocaml_specific.ml: In -debug 1 mode there is a now a warning when + ocamlbuild skip a seliently a module, supposing that's an error of + ocamldep. + +2007-01-24 Nicolas Pouillard + + More hooks. + + * ocamlbuild_plugin.ml, + * hooks.ml, + * hooks.mli, + * main.ml: Add {Before,After}_rules. + +2007-01-24 Nicolas Pouillard + + Call these hooks. + + * main.ml: Call these hooks. + +2007-01-24 Nicolas Pouillard + + Add a first version of dispatch. + + * ocamlbuild_plugin.ml: Export dispatch and the hooks type. + * ocamlbuild_pack.mlpack: Add Hooks. + * hooks.ml: New. + * hooks.mli: New. + * ocaml_specific.mli: New line. + +2007-01-24 Berke Durak + + Mini slurp bug. + + * slurp.ml: . + * TODO: . + +2007-01-24 Nicolas Pouillard + + Fix few more things. + + * ocamlbuildlight.ml: . + * ocamlbuild_version.ml: Remove. + * ocamlbuild.ml: . + * ocamlbuild_pack.mlpack: . + * main.ml: . + * ocaml_specific.ml: . + * ocaml_specific.mli: . + * start.sh: . + * test/test2/toto.ml: . + * test/good-output: . + +2007-01-24 Berke Durak + + Read directories before files in Slurp. + + * slurp.ml: . + * TODO: . + +2007-01-24 Nicolas Pouillard + + Fix some bugs. + + * ocamlbuild_version.ml: Remove. + * ocamlbuild.ml, + * ocamlbuildlight.ml: Main is now in the pack. + * ocamlbuild_pack.mlpack: more things. + * ocaml_specific.ml: One fix and one comment. + * start.sh: Update. + +2007-01-24 Berke Durak + + Splitting ocaml_specific into multiple files. + + * ocamlbuildlight.ml: . + * ocamlbuild.ml: . + * ocamlbuild_version.ml: New. + * ocamlbuild.mli: . + * ocamlbuildlight.mli: . + * ocamlbuild_pack.mlpack: . + * command.ml: . + * fda.ml: New. + * hygiene.ml: . + * main.ml: New. + * my_std.ml: . + * my_std.mli: . + * main.mli: New. + * manual/manual.tex: . + * ocaml_specific.ml: . + * ocaml_specific.mli: . + * options.ml: . + * options.mli: . + * plugin.ml: New. + * rule.ml: . + * report.ml: . + * tools.ml: New. + * tools.mli: New. + * TODO: . + * _tags: . + +2007-01-24 Nicolas Pouillard + + Minor changes. + + * manual/manual.tex: Typo s/the the/the/g. + * ocaml_specific.ml, + * ocaml_specific.mli: Add some function to deal with linking of a + module list. Add a better lib declaration function. + * TODO: Update. + +2007-01-17 Nicolas Pouillard + + A new pathname operator and a bug fix. + + * pathname.ml, + * pathname.mli: add the ( -.- ) operator to add an extension to a + pathname. + * ocaml_specific.ml: Use that new operator. + * resource.ml: Fix a bug. + +2007-01-17 Berke Durak + + More examples. + + * examples/example3/epoch.ml: . + * examples/example3/make.sh: New. + * manual/manual.tex: . + * TODO: . + +2007-01-17 Nicolas Pouillard + + Infered mli's, and bug fixes. + + * my_unix.ml: Fix a bug. + * my_std.mli: Doc. + * manual/manual.tex: Use \verb. + * ocaml_arch.ml: Don't always overide the forpack_flags_of_pathname + function reference. + * ocaml_arch.mli: Remove the reference. + * ocaml_specific.ml: Update for forpack and add infered mli's. + * pathname.ml, + * pathname.mli: Add is_directory. + +2007-01-17 Berke Durak + + More examples. + + * examples/example3/epoch.ml: New. + * examples/example2/hello.ml: . + * examples/example2/greet.ml: New. + * examples/example3: New. + * examples/example2: New. + * manual/manual.tex: . + * TODO: . + +2007-01-17 Berke Durak + + Started examples. + + * examples/example1/hello.ml: New. + * examples/example1: New. + * examples: New. + * manual/manual.tex: . + * .vcs: . + * TODO: . + +2007-01-17 Berke Durak + + Wrote limitations and features. + + * manual/manual.tex: . + +2007-01-17 Berke Durak + + Wrote motivations. + + * manual/manual.tex: . + * _tags: . + +2007-01-17 Berke Durak + + Started manual. + + * manual/Makefile: New. + * manual/manual.tex: New. + * manual: New. + +2007-01-17 Nicolas Pouillard + + Bugs, menhir, path variables. + + * display.ml: Fix a bug. + * glob.mli: Fix a typo. + * lexers.mli, + * lexers.mll: Extend ocamldep_output lexer and meta_path lexer. + * my_std.ml, + * my_std.mli: Add memo and String.rev. + * ocaml_specific.ml, + * ocaml_specific.mli: Better rules for C lib linking and menhir rules. + * resource.ml, + * resource.mli: Handle naively some multiple variables. + * rule.ml, + * rule.mli: Update. + * start.sh: Update. + +2007-01-11 Nicolas Pouillard + + Integrate dprintf to the display. + + * display.ml, + * display.mli: Add dprintf and log_level. + * log.ml, + * log.mli: Add dprintf and level. + * debug.ml: Remove. + * debug.mli: Remove. + * options.ml: Update. + * command.ml, ocaml_specific.ml, my_std.ml, + * pathname.ml, ppcache.ml, resource.ml, + * rule.ml, report.ml, slurp.ml, solver.ml, + * configuration.ml, tags.ml: Update to Log. + * ocamlbuild.odocl: Add Log, remove Debug. + * ocamlbuild_pack.mlpack: Remove Debug. + * bool.ml: Remove the debug dependency. + +2007-01-10 Nicolas Pouillard + + Execute and windows... + + * command.ml: Test windows here. + * my_unix_with_unix.ml: Revert a little. + +2007-01-10 Nicolas Pouillard + + Don't use executor on windows. + + * my_unix_with_unix.ml: Since at least set_nonblock does not works on + windows. + +2007-01-10 Nicolas Pouillard + + Add the -no-log option and fix a log bug. + + * log.mli, + * log.ml: Log is now a lazy to have the good setup order. + * options.ml: Add the -no-log option. + +2007-01-10 Nicolas Pouillard + + Fix a bug with quoting of the nil string. + + * shell.ml: Quote the nil string. + +2007-01-09 Berke Durak + + Documented the interface of the glob module. + + * glob.mli: . + +2007-01-09 Berke Durak + + Continuing to document interfaces. + + * bool.mli: . + * debug.mli: . + * discard_printf.mli: . + * executor.mli: . + * hygiene.mli: . + * my_std.mli: . + * slurp.mli: . + * Makefile: . + +2007-01-09 Nicolas Pouillard + + Fix a bug with directory links to build dir. + + * ocaml_specific.ml, + * options.ml, + * options.mli: Keep the Slurp.entry instead of a set. + * pathname.ml: Clean the entry instead of the set, that more precise. + * Makefile: Add doc phonny rules. + +2007-01-09 Berke Durak + + Doc for Configuration. + + * ocamlbuild_plugin.ml: . + * bool.mli: . + * configuration.ml: . + * configuration.mli: . + * command.mli: . + * doc: New. + * glob.ml: . + * ocaml_specific.ml: . + * Makefile: . + +2007-01-09 Berke Durak + + Started documentation. + + * bool.mli: . + * command.ml: . + * command.mli: . + +2007-01-09 Nicolas Pouillard + + Export the doc. + + * Makefile: Use a link. + * _tags: Don't spend times in that dir. + +2007-01-09 Nicolas Pouillard + + Put the log file in the source dir and not when building plugin. + + * log.ml, + * log.mli: Use an optional. + * options.ml: Update. + * pathname.mli: Export in_source_dir. + * .vcs: Add _log. + +2007-01-09 Berke Durak + + Added doc target. + + * report.ml: . + * Makefile: . + * TODO: . + +2007-01-09 Berke Durak + + Writes tags to log file. + + * display.ml: . + +2007-01-09 Nicolas Pouillard + + Add the Log module. + + * ocamlbuild_pack.mlpack: Add Log. + * command.ml, + * command.mli: Use Log. + * log.ml: New. + * log.mli: New. + * options.ml: Use Log. + * start.sh: Update. + +2007-01-09 Berke Durak + + Added -log option. + + * command.ml: . + * command.mli: . + * display.ml: . + * display.mli: . + * executor.mli: . + * options.ml: . + * _tags: . + +2007-01-09 Nicolas Pouillard + + Make usable the ocamldoc support. + + * ocaml_specific.ml: Add rules for ocamldoc. + * ocamlbuild.odocl: New. + * test/test3/proj.odocl: New. + * test/good-output: Update. + * test/test3/test.sh: Add a odoc test. + +2007-01-09 Nicolas Pouillard + + Some cleanups. + + * ocamlbuild_plugin.ml: Add tag_file that simule one simple line in the + _tags file. + * ocaml_specific.ml, + * ocaml_specific.mli: Add ln_s, touch, chmod. + * pathname.ml, + * pathname.mli: Remove map_extension*, split_extension* and compiled + files hack skipping. + * rule.ml: Improve logging. + * solver.ml: Use another level. + +2007-01-07 Nicolas Pouillard + + Fix a bug with debug rules. + + * ocaml_specific.ml: Move %.cmi from prods to deps. + * test/good-output: Update. + +2007-01-07 Nicolas Pouillard + + Add debugging rules. + To get a ocamlbuild with debugging info you can + call `make debug' that will produce ocamlbuild.d.byte + and x.d.cmo files. + + * ocaml_specific.ml, + * ocaml_specific.mli: Add debugging rules, reorder warnings flag to + have 'A' and 'a' before others. + * Makefile: Add the debug target. + * _tags: Cleanup (remove the debug tag that was set by default). + +2007-01-07 Nicolas Pouillard + + Add profiling support directly in rules. + This means that you can now request for building a target such as + my_main.p.native or my_lib.p.cmxa, that will create %.p.cmx + intermediate files that do not interfer with non-profiling ones. + + * ocaml_specific.ml, + * ocaml_specific.mli: Add rules and functions for native link and + comilation in profiling mode. + * Makefile: Add a profile target (require a fixed ocamlopt w.r.t pack). + * _tags: Take care also of .p.cmx files. + * glob.ml: IS.print is equivalent to print_is. + * my_std.ml: Fix a bug. + +2007-01-07 Nicolas Pouillard + + Add some functions... + + * glob.ml: Extract is_suffix and is_prefix. + * my_std.ml, + * my_std.mli: Add String.{is_suffix,is_prefix,first_chars,last_chars} + and List.union. + * pathname.ml, + * pathname.mli: Add get_extensions, remove_extensions, + update_extensions, map_extensions that treat all extensions instead of + just the last. + * tags.ml, + * tags.mli: Add +++ and --- that treat optional tags. + +2007-01-06 Nicolas Pouillard + + Change the default display in degraded mode. + + * command.ml: Ditto. + +2007-01-06 Nicolas Pouillard + + Cleanup Makefile options. + + * Makefile: Ditto. + +2007-01-06 Nicolas Pouillard + + Add a simple opened files tracer. + + * misc/opentracer.ml: New. + Just support ktrace for now. A strace one will be appreciated the + interface to follow is quite simple anyway. + * misc: New. + +2007-01-06 Nicolas Pouillard + + Handle better commands without Px atom. + + * command.ml: Display the whole command if no Px is found. + * display.mli: No longer export these strings. + +2007-01-06 Nicolas Pouillard + + Handle myocamlbuild_config.mli. + + * ocaml_specific.ml: Add support for an interface to the config. + +2007-01-06 Berke Durak + + Improved language of explanations in Report. + + * report.ml: . + +2007-01-06 Nicolas Pouillard + + Factor and fix the plugin building. + + * ocamlbuildlight.mli: New. + * executor.ml: Call cleanup, add a fixme. + * ocaml_specific.ml: Factor and fix plugin stuffs. + * start.sh: Update. + * Makefile: Update. + * TODO: Update. + * _tags: No longer do favors to some modules. + +2007-01-05 Nicolas Pouillard + + Fix plugins. + + * ocamlbuildlib.mllib: Add missing modules. + * ocamlbuildlightlib.mllib: New. + * Makefile: Update. + +2007-01-05 Nicolas Pouillard + + Change the my_unix system. + + * ocamlbuildlight.ml: Just call the main. + * ocamlbuild.ml: Setup my_unix_with_unix. + * ocamlbuildlib.mllib: Remove executor and exit_codes for the lib. + * ocamlbuild_pack.mlpack: Remove my_std and my_unix. + * exit_codes.ml: Remove. Put them directly in executor. + * executor.ml: Add exitcodes. + * my_unix.ml: New. Default implem. + * my_unix_with_unix.ml: Extend the default implem. + * my_unix_without_unix.ml: Remove. + * my_unix.mli: Add the implem type and val. + * my_unix_with_unix.mli: New. + * ocaml_specific.ml, + * pathname.ml, + * slurp.ml, + * Makefile, + * command.ml, + * _tags: Update. + +2007-01-05 Nicolas Pouillard + + Don't use executor for the myocamlbuild call. + + * ocaml_specific.ml: Use sys_command directly. + +2007-01-05 Nicolas Pouillard + + Fix a stupid bug. + + * command.ml: That cause to have reversed sequences. + +2007-01-05 Nicolas Pouillard + + Some libs and ocamldoc changes. + + * ocaml_specific.ml, + * ocaml_specific.mli: Improve ocaml_lib_flag, add fews libs. + Fix ocamldoc support update tags, and use Px only once. + +2007-01-05 Berke Durak + + Started ocamldoc support. + + * ocaml_specific.ml: . + * options.ml: . + * options.mli: . + +2007-01-05 Berke Durak + + Pretend option didn't work. + + * command.ml: . + +2007-01-05 Berke Durak + + TODO + typo. + + * options.ml: . + * TODO: . + +2007-01-05 Nicolas Pouillard + + Really call executor all time. + + * command.ml, + * command.mli: Remove normalization. + And execute_many, it's now execute that do all the job. + In degraded mode it's execute_degraded. + * my_unix_without_unix.ml: Update. + * ocaml_specific.ml, + * resource.ml, + * rule.ml, + * solver.ml: Update to Command.execute type. + +2007-01-05 Berke Durak + + Isatty detection logic. + + * command.ml: . + * executor.ml: . + * my_unix_with_unix.ml: . + * my_unix_without_unix.ml: . + * my_unix.mli: . + +2007-01-05 Nicolas Pouillard + + Always call executor. + + * command.ml: Unless in degraded mode. + +2007-01-05 Berke Durak + + Removed debugging output, added period argument for ticker. + + * display.ml: . + * executor.ml: . + * executor.mli: . + * my_unix.mli: . + +2007-01-05 Berke Durak + + Somewhat slow but executor seems to work. + + * executor.ml: . + +2007-01-05 Berke Durak + + Added an Exit_codes module. Fixing Executor... + + * ocamlbuild.ml: . + * ocamlbuildlib.mllib: . + * executor.ml: . + * exit_codes.ml: New. + * solver.ml: . + +2007-01-05 Nicolas Pouillard + + Fix the max_jobs argument passing. + + * command.ml: Use an optional argument. + +2007-01-05 Nicolas Pouillard + + Subway changes... + + * my_unix_without_unix.ml, + * my_unix_with_unix.ml, + * my_unix.mli, + * command.ml: Call the new execute_many. + * executor.ml, + * executor.mli: Handle command sequences. + +2007-01-04 Berke Durak + + Added Display.update. + + * display.ml: . + * display.mli: . + * executor.ml: . + +2007-01-04 Berke Durak + + Added display function, indentation, language. + + * display.ml: . + * display.mli: . + * hygiene.ml: . + +2007-01-04 Berke Durak + + Fixing interface of Executor. + + * executor.ml: . + * executor.mli: . + * my_unix_with_unix.ml: . + +2007-01-04 Nicolas Pouillard + + Add attributes to entries. Add the -byte-plugin option. + + * slurp.ml, + * slurp.mli: Add an attribute field, add map, rename fold_pathnames to + fold and filter_on_names to filter. + * hygiene.ml, + * hygiene.mli: Perform hygiene only on entries with a true attribute. + * options.ml, + * options.mli: Add the native_plugin reference and the -byte-plugin + option. + * ocaml_specific.ml, + * ocaml_specific.mli: Exclude files tagged not_hygienic or precious + from hygiene. + +2007-01-04 Berke Durak + + Fixed pack issues. + + * ocamlbuild.ml: . + * executor.ml: . + * executor.mli: New. + * _tags: . + +2007-01-04 Berke Durak + + Started executor module. + + * executor.ml: New. + * hygiene.ml: . + * my_unix_with_unix.ml: . + +2007-01-04 Nicolas Pouillard + + Add virtual commands. + + * command.ml, + * command.mli: Add the V constructor for virtual commands that + will query a virtual command solver to use the best implementation + of that virtual command. + +2007-01-04 Nicolas Pouillard + + Mainly, prepare for parallel display. + + * ocamlbuild_plugin.ml: Export file_rule. + * command.ml, + * command.mli: Some cleanup and preparation. + * lexers.mll: Remove the dirty hack. + * my_std.ml, + * my_std.mli: Move search_in_path to Command and add ( @:= ). + * my_unix_with_unix.ml, + * my_unix_without_unix.ml, + * my_unix.mli: Change the execute_many_using_fork type. + * ocaml_specific.ml: Use the nopervasives tag for + pervasives dependencies. + * start.sh: Update. + * test/test8/myocamlbuild.ml: Update. + * test/good-output: Update. + * Makefile: Update. + +2007-01-03 Nicolas Pouillard + + I don't like microbes. + + * hygiene.ml: Reverse the bool. + +2007-01-03 Nicolas Pouillard + + Fix the stat problem. + + * ocaml_specific.ml: Use the filtered entry for source_dir_path_set. + +2007-01-03 Berke Durak + + Hygiene filters cleaned out microbes. + + * hygiene.ml: . + * hygiene.mli: . + * ocaml_specific.ml: . + * ocaml_specific.mli: . + * slurp.ml: . + * slurp.mli: . + +2007-01-03 Nicolas Pouillard + + Filename concat cleanup. + + * my_std.ml, + * my_std.mli: Add filename_concat. + * glob.ml, + * hygiene.ml, + * lexers.mll, + * pathname.ml, + * resource.ml, + * report.ml, + * solver.ml, + * slurp.ml, + * solver.mli: + Use filename_concat. + * flags.ml: FIXME. + +2007-01-03 Berke Durak + + Revert to old. + + * slurp.ml: . + +2007-01-03 Berke Durak + + Debugging tags for myocamlbuild.ml. + + * ocaml_specific.ml: . + * slurp.ml: . + +2007-01-02 Nicolas Pouillard + + Another atempt to fix the slurp bug and lazy. + + * slurp.ml: Ditto. + +2007-01-02 Nicolas Pouillard + + Fix slurp w.r.t lazyness: keep the cwd. + + * slurp.ml: Ditto. + +2007-01-02 Nicolas Pouillard + + My_unix, slurp in degraded mode, _tags in subdirs, fix the bug with -j... + + * ocamlbuild_version.mli: Remove. + * ocamlbuild_where.mli: New. + * display.mli: New. + * shell.ml: New. + * shell.mli: New. + * glob.ml, + * glob.mli, + * configuration.ml, + * lexers.mli, + * lexers.mll, + * configuration.mli: Honor _tags files in subdirs. + * my_unix_with_unix.ml, + * command.ml, + * command.mli, + * resource.ml, + * resource.mli, + * solver.ml: Fix the bug with the -j option. + * slurp.ml, + * slurp.mli: New degraded mode using the find command. + Use lazy values to avoid computing useless directories. + * options.ml, + * options.mli: Update -version and -where. + * pathname.ml, + * pathname.mli: Remove the init section. + * rule.ml, + * rule.mli: Add file_rule useful for rules that don't run a command but + just write a file. + * ocaml_specific.ml: Fix some plugin bugs. Remove -I to ocamldep. + Handle msvc .obj,.lib instead of .o,.a. + * my_unix_without_unix.ml: Make works link stuffs running the readlink + command. + * display.ml, + * hygiene.ml, + * my_std.ml, + * my_unix.mli, + * my_std.mli, + * start.sh, + * test/test5/test.sh, + * test/good-output, + * test/test6/test.sh, + * test/test7/test.sh, + * test/test4/test.sh, + * test/test8/test.sh, + * test/test3/test.sh, + * test/test2/test.sh, + * Makefile, + * _tags, + * ocamlbuild_pack.mlpack: Update. + +2007-01-02 Berke Durak + + Fixed ticker. + + * display.ml: . + +2006-12-21 Berke Durak + + Cosmetic. + + * command.ml: . + * display.ml: . + +2006-12-21 Berke Durak + + Computing display length. + + * display.ml: . + +2006-12-21 Nicolas Pouillard + + Add -classic-display. + + * command.ml, + * command.mli: Provide a way to use the classic display. + * options.ml: Add the -classic-display option. + * Makefile: Remove ppcache form the default. + +2006-12-21 Berke Durak + + Finish display only once ; display number of jobs cached. + + * command.ml: . + * display.ml: . + +2006-12-21 Nicolas Pouillard + + Oops fix a bug. + + * command.ml: Add begin .. end. + +2006-12-21 Nicolas Pouillard + + Some display fixes. + + * command.ml: Select the display mode and remove the assert false. + * display.ml: Change the print function to have a more compact one. + * start.sh: Update. + +2006-12-21 Berke Durak + + Error support in Display.finish. + + * display.ml: . + +2006-12-21 Berke Durak + + Support for cache. + + * display.ml: . + +2006-12-21 Nicolas Pouillard + + Integrate display mode. + + * ocamlbuild_pack.mlpack: Add display. + * command.mli: Add Px to indicate to highligth this pathname. + * command.ml: Support Px and call Display. + * display.ml: Fix minor bugs. + * ocaml_specific.ml: Declare some Px, and quiet ocamlyacc, ocamllex. + * options.ml: Add quiet to default tags. + * ppcache.ml: Detect more accuratly ocamlrun. + * pathname.ml: Improve concat. + * _tags: No profile. + +2006-12-21 Berke Durak + + Added pretend. + + * display.ml: . + +2006-12-21 Berke Durak + + Added ticker. + + * display.ml: . + +2006-12-21 Berke Durak + + Display module. + + * display.ml: . + * my_unix_with_unix.ml: . + * my_unix_without_unix.ml: . + * my_unix.mli: . + * test/test10/test.sh: New. + * test/test10: New. + * test/test10/dbdi: New. + +2006-12-21 Nicolas Pouillard + + Use a better init order, and fix a Filename.concat usage. + + * ocaml_specific.ml: The plugin should act before any initialization. + * ocaml_arch.ml: Use Pathname.(/). + +2006-12-21 Berke Durak + + Started user-friendly display module. + + * display.ml: New. + +2006-12-21 Nicolas Pouillard + + Fix init order. + + * ocaml_specific.ml: Config must be available for plugin building. + +2006-12-21 Nicolas Pouillard + + Some fixes. + + * command.ml: Quote if needed. + * my_std.mli: Comment String.contains_string. + * resource.ml: Remove a useless separator. + * test/good-output: Update. + +2006-12-21 Nicolas Pouillard + + Plugin config file and profile mode. + + * ocaml_specific.ml: Fix a bug due to the lazyness of &&. + * ocaml_specific.mli: Move some functions. + +2006-12-21 Berke Durak + + Now compiles patterns for fast matching. Removed regexp support. + + * glob_ast.ml: . + * glob.ml: . + * glob_lexer.mli: . + * glob_ast.mli: . + * glob_lexer.mll: . + * test/test9/testglob.ml: . + * test/test9/dbgl: New. + +2006-12-20 Berke Durak + + Pattern matching seems to start to work. + + * glob.ml: . + +2006-12-20 Berke Durak + + Started faster pattern matching code. + + * ocaml_specific.ml: . + * _tags: . + +2006-12-20 Berke Durak + + myocamlbuild is rebuilt only as needed. + + * hygiene.ml: . + * ocaml_specific.ml: . + * pathname.ml: . + * pathname.mli: . + * resource.ml: . + +2006-12-20 Nicolas Pouillard + + Some changes mainly for windows support. + + * command.ml, + * command.mli: Add the Quote constructor to help quoting building in + commands. + * my_unix_with_unix.ml, + * my_unix_without_unix.ml, + * glob.ml: Commented reslash mode. + * my_std.ml, + * my_std.mli: Some new functions. + * my_unix.mli: Export sys_command. + * ocaml_specific.ml, + * ocaml_specific.mli: Update and windows support. + * options.ml, + * options.mli: Remove the ocamlmklib option. + * ppcache.ml: Fix a bug. + * pathname.ml: Add more dirseps. Use a custom Filename.concat (for now). + * resource.ml, + * rule.ml, + * Makefile, + * _tags: Update. + +2006-12-15 Nicolas Pouillard + + Update start order. + + * start.sh: Ditto. + +2006-12-11 Berke Durak + + Added -custom, fixed paths for installation. + + * ocaml_specific.ml: . + * Makefile: . + +2006-12-11 Berke Durak + + Typo. + + * report.ml: . + +2006-12-08 Nicolas Pouillard + + Add a basic ocamlmklib support. + + * ocaml_specific.ml, + * ocaml_specific.mli: Use ocamlmklib to make libraries if enabled. + * options.ml, + * options.mli: Add -ocamlmklib and -use-ocamlmklib. + +2006-12-08 Nicolas Pouillard + + Export more references of options. + + * command.ml, + * command.mli: Add ?quiet to execute. + * ocaml_specific.ml, + * ocaml_specific.mli: Update to options. + * options.ml, + * options.mli: Move ocamlc, ocamlopt... to references on command specs. + * solver.ml: Update. + * Makefile: Use _ocamldistr to avoid hygiene. + * .vcs: Use _ocamldistr. + +2006-12-08 Nicolas Pouillard + + Ocaml distrib stuffs. + + * command.ml, + * command.mli: Add a normalization callback. + * ocaml_specific.ml, + * ocaml_specific.mli: Add a more complete interface. + * options.ml, + * options.mli: Add nostdlib. + * pathname.ml: Add mkdir -p to import in build. + * rule.ml, + * rule.mli: Call normalization of commands for digest. + * report.ml: Add ignore. + * start.sh: Add report.ml*. + * Makefile: Add distrib exportation (make a link). + * .vcs: Unmask ocamldistrib link. + +2006-12-07 Berke Durak + + Added TODO item. + + * .vcs: . + * TODO: . + +2006-12-07 Berke Durak + + Added TODO file. + + * TODO: New. + +2006-12-07 Berke Durak + + Very rudimentary report analysis. + + * report.ml: . + * _tags: . + +2006-12-07 Nicolas Pouillard + + Update tests to run ocamlbuild correctly. + + * test/test2/test.sh, + * test/test3/test.sh, + * test/test4/test.sh, + * test/test5/test.sh, + * test/test6/test.sh, + * test/test7/test.sh, + * test/test8/test.sh, + * test/test9/test.sh: Ditto. + * test/good-output: Update. + +2006-12-07 Nicolas Pouillard + + Make test9 independant. + + * test/test9/test.sh: Ditto. + +2006-12-07 Berke Durak + + Rewrote globbing engine, adding {,} ; moved reporting functions to Report. + + * ocamlbuild_pack.mlpack: . + * command.ml: . + * glob_ast.ml: . + * glob.ml: . + * glob_ast.mli: . + * glob_lexer.mll: . + * ocaml_specific.ml: . + * report.ml: New. + * report.mli: New. + * solver.ml: . + * solver.mli: . + * start.sh: . + * test/test9/testglob.ml: . + * test/test9/test.sh: . + * test/test3/test.sh: . + * _tags: . + +2006-12-07 Nicolas Pouillard + + Degraded mode... + + * ocamlbuildlight.ml: New. + * ocamlbuild_pack.mlpack: Include new modules. + * bool.ml: Fake dependency. + * configuration.ml: Adapt to the glob parser. + * command.ml: Export the fork usage. + * glob.ml: Use Str through My_unix. + * glob_lexer.mli: New. + * glob_lexer.mll: Add slashs to valid character patterns. + * lexers.mli, + * lexers.mll: Use the glob parser. + * my_std.ml: Use My_unix. + * my_unix_with_unix.ml: New. + * my_unix_without_unix.ml: New. + * my_unix.mli: New. + * my_std.mli: Add search_in_path and change lazy force to ( !* ). + * ocaml_specific.ml: Some updates. + * options.ml, + * options.mli: Add -ocamlrun. + * pathname.ml: Adapt to an optional slurp. + * ppcache.ml: Use search_in_path of my_std. + * resource.ml: Update to ( !* ). + * solver.ml: Export Unix errors reporting. + * slurp.ml, + * slurp.mli: Use My_unix. + * start.sh: Update. + * test/test9/testglob.ml: Test a constant. + * test/test5/_tags, + * test/test3/_tags, + * test/test4/_tags: Don't use regexp. + * test/good-output: Add test9. + * test/test9/test.sh: Remove the parent usage. + * Makefile: Add the light mode. + * .vcs: Update. + * _tags: Update. + +2006-12-06 Berke Durak + + Extra tests for globbing. + + * test/test9/testglob.ml: . + +2006-12-06 Berke Durak + + First draft of pattern matching. + + * glob_ast.ml: . + * glob.ml: . + * glob_ast.mli: . + * glob_lexer.mll: . + +2006-12-06 Berke Durak + + More hard-wired but common cases for globbing. + + * glob.ml: . + * test/test9/testglob.ml: . + +2006-12-06 Berke Durak + + Hidden interface in globber. + + * glob.mli: . + * test/test9/testglob.ml: . + +2006-12-06 Berke Durak + + Basic globbing works. + + * glob.ml: . + * glob.mli: . + * test/test9/testglob.ml: . + +2006-12-06 Berke Durak + + Improved interface. + + * glob.ml: . + * glob_ast.ml: New. + * glob_ast.mli: New. + * glob.mli: New. + * glob_lexer.mll: . + * test/test9/testglob.ml: . + * _tags: . + +2006-12-06 Berke Durak + + Added test9. + + * test/test9/testglob.ml: New. + * test/test9/parent: New. + * test/runtest.sh: . + * test/test9: New. + * test/test9/test.sh: New. + +2006-12-06 Berke Durak + + Parser seems to work. + + * glob.ml: . + * glob_lexer.mll: . + +2006-12-06 Berke Durak + + Removed eof_char. + + * glob.ml: . + * glob_lexer.mll: . + +2006-12-06 Berke Durak + + Interface seems to be OK. + + * glob.ml: . + * glob_lexer.mll: . + +2006-12-06 Berke Durak + + Adding files for the globbing module. + + * bool.ml: New. + * bool.mli: New. + * glob.ml: New. + * glob_lexer.mll: New. + * _tags: . + +2006-12-06 Berke Durak + + Replaced numeric escapes. + + * lexers.mll: . + +2006-12-05 Nicolas Pouillard + + Remove most of the Str usage by using ocamllex. + + * ocamlbuild_pack.mlpack: Remove Re, add Lexers. + * configuration.ml: Use Lexers. + * command.ml: Don't use Re. + * lexers.mli: New. + * lexers.mll: New. + * my_std.ml, + * my_std.mli: Add String.before and String.after. + * ocaml_specific.ml, + * ocaml_specific.mli: Use Lexers but also provide tags for warnings. + * resource.ml, + * rule.ml, + * options.ml, + * ppcache.ml, + * pathname.ml: Use Lexers. + * re.ml: Remove. + * re.mli: Remove. + * start.sh: Update. + * Makefile: Igonre _build... and gives -ml to ocamllex. + * _tags: Warnings for lexers. + +2006-12-05 Nicolas Pouillard + + Use Sys instead of Unix for readdir. + + * my_std.ml, + * my_std.mli: Supress a Unix usage. + +2006-12-05 Nicolas Pouillard + + Add an option to disable the link creation. + + * ocaml_specific.ml: Honor this option. + * options.ml: Declare it. + * options.mli: Define it. + +2006-12-05 Nicolas Pouillard + + Don't import compiled files... + + * pathname.ml: For the OCaml compilation itself I need to exclude some + dirs that contains compiled files but I want to use some of them with + ocamlbuild. + +2006-12-05 Nicolas Pouillard + + Support flags for ocamlyacc and ocamllex. + + * ocaml_specific.ml, + * options.ml, + * options.mli: Add these options. + +2006-12-04 Nicolas Pouillard + + Two fixes (hygiene and libraries)... + + * hygiene.ml: Exit 0 if sterilize removes some files (since source + files are cached in a rather persistent data structure I prefer let the + user start on a fresh setup). + * ocaml_specific.ml: Use the dirname if there is no directory named by + removing the extension. + +2006-12-04 Berke Durak + + Small bug in hygiene. + + * hygiene.ml: . + +2006-12-04 Nicolas Pouillard + + Add postition specifications to rules. + + * rule.ml, + * rule.mli: Add a way to specifie where to put a new rule + (top,bottom,before another,after another). + * flags.ml: Reorder. + * my_std.ml, + * my_std.mli: Add mv, fix an error handling. + * ocaml_specific.ml: Better error message for circular dependencies. + * ppcache.ml: Handle errors better. + +2006-11-29 Nicolas Pouillard + + Add a working multiple job support. + + * command.ml, + * command.mli: Add different versions of execute_many including a + version that use forks. + * options.ml, + * options.mli: Restore the -j option. + * solver.ml: Call Command.execute_many. + * test/runtest.sh: Pass $@ to sub tests. + * test/good-output: Update. + +2006-11-28 Nicolas Pouillard + + Fix the link order. + + * start.sh: Fix the link order. + +2006-11-28 Nicolas Pouillard + + One step toward multiple jobs: Add the support for suspended building. + + * resource.ml, + * resource.mli: Add the notion of suspended building. + This represent a resource that is fully ready for evaluation, it's just + a command and a function to apply after. + * rule.ml: Do not really execute rules that can be safely suspended. + * solver.ml: Play with suspended rules to collect as many as possible + to get closer to a pararllel execution. + +2006-11-27 Nicolas Pouillard + + Fix the makefile. + + * Makefile: Fix deps. + +2006-11-27 Nicolas Pouillard + + Activates more warnings, and prepare the -j feature. + + * hygiene.ml: Consolidates fragile patterns. + * my_std.ml: Likewise. + * ocaml_specific.ml: Mainly update to the new builder prototype. + * pathname.ml, + * pathname.mli: Kick a useless parameter. + * resource.ml: Remove dead code and update. + * rule.ml, + * rule.mli: The bulider now takes a list of resource lists, it will + try to make in parallel the first level of commands. + * solver.ml: Update to builder without parallelism. + * test/good-output: Update. + * Makefile: Warnings are now set to -w A -warn-error A. + +2006-11-26 Nicolas Pouillard + + Fix packages... again. + + * ocaml_specific.ml: Ditto. + +2006-11-26 Nicolas Pouillard + + Fix packages. + + * ocaml_specific.ml: Try to handle better packages during link. + * Makefile: Add the try_bootstrap rule. + +2006-11-26 Nicolas Pouillard + + Add -tag, -tags to options. + + * ocaml_specific.ml: Append default tags from options. + * options.ml, + * options.mli: Add -tag and -tags. + * tags.mli: Indent. + +2006-11-26 Nicolas Pouillard + + Fix a bug and update tests. + + * resource.ml: Use Hashtbl.replace of course instead of Hashtbl.add to + avoid a nasty bug. + * test/test7/test.sh, + * test/test8/test.sh, + * test/test2/test.sh, + * test/test6/test.sh, + * test/test4/test.sh, + * test/test5/test.sh, + * test/test3/test.sh: Extract program options to be sure that + the -nothing-should-be-rebuilt option is before the -- one. + * test/good-output: Update. + +2006-11-26 Nicolas Pouillard + + Use a hashtbl for digests. + + * resource.ml: Ditto. + * ocaml_specific.ml: Remove dead code. + +2006-11-26 Nicolas Pouillard + + Use lists instead of sets for rule deps & prods. + + * ocaml_specific.ml: Move the mli dep first. + * resource.ml, + * resource.mli: No more provide digest_resources but digest_resource. + * rule.ml, + * rule.mli: Use list instead of sets for deps and prods, since they are + not heavily updated and the order matter. + * solver.ml: Adapt. + * test/good-output: Yeah! + +2006-11-26 Nicolas Pouillard + + One more fix for libraries. + + * ocaml_specific.ml: Improve the link_exception handling. + * test/good-output: Update. + +2006-11-25 Nicolas Pouillard + + Fix the library linking. + + * ocaml_specific.ml: The test7 is specially made to check that feature. + +2006-11-25 Nicolas Pouillard + + Remove list_set. + + * ocamlbuild_pack.mlpack: Remove list_set + * list_set.ml: Remove. + * list_set.mli: Remove. + * start.sh: Remove list_set. + * test/good-output: Regen. + +2006-11-25 Nicolas Pouillard + + Fix the C rule when dirname = '.'. + + * ocaml_specific.ml: Don't move the output when it's useless. + +2006-11-25 Nicolas Pouillard + + Ignore ocamlbuild_version.ml. + +2006-11-25 Nicolas Pouillard + + New transitive closure. + + * ocamlbuild_version.ml: Remove. + * my_std.ml, + * my_std.mli: Add a debug mode for digests and run_and_read. + * ocaml_specific.ml: New transitive closure. + * pathname.ml, + * pathname.mli: Export also parent_dir_name and fix same_contents. + * resource.ml, + * resource.mli: Add dependencies. + * rule.ml: Adapt. + * test/good-output: Regen. + * Makefile: Improve install. + * .vcs: Ignore other _build dirs. + +2006-11-20 Nicolas Pouillard + + Rule definition shortcut and C files. + + * rule.ml, + * rule.mli: Allow to pass ~prod and ~dep when there is just one file. + * ocaml_specific.ml: Add a rule for C files and use the previous + shortcut. + +2006-11-18 Nicolas Pouillard + + No more extend Format. + + * command.ml, + * my_std.ml, + * my_std.mli: Put directly ksbprintf and sbprintf in My_std. + +2006-11-18 Nicolas Pouillard + + Clean up and consistent use of Pathname instead of Filename. + + * command.ml, + * my_std.ml, + * my_std.mli, + * ocaml_specific.ml, + * pathname.ml, + * ppcache.ml, + * pathname.mli, + * resource.ml: That's it. + +2006-11-18 Nicolas Pouillard + + Restore List_set. + + * ocamlbuild_pack.mlpack, + * list_set.ml, + * list_set.mli, + * resource.ml, + * start.sh: Ditto. + +2006-11-18 Nicolas Pouillard + + Remove List_set and List_map. + + * ocamlbuild_pack.mlpack: No more in the pack. + * list_set.ml: Remove. + * list_map.ml: Remove. + * list_map.mli: Remove. + * list_set.mli: Remove. + * resource.ml: Use a Set. + * start.sh: Adapt. + +2006-11-18 Nicolas Pouillard + + Huge speed up, worth updating. + + * resource.ml, + * resource.mli: Use a hash instead of map, remove the percent type. + * rule.ml, + * rule.mli: Remove the function for rule names. Use an exception to + choose matching rules. + +2006-11-18 Nicolas Pouillard + + Speedup rule calling. + + * rule.ml, + * rule.mli: No more call the code rule twice to compute the digest. + * ocaml_specific.ml, + * ocaml_specific.mli: Adapt to Rule. + * test/test8/myocamlbuild.ml: Use the exception. + * test/good-output: Update. + * boot: Update svn:ignore. + +2006-11-16 Nicolas Pouillard + + Remove phony resources and include dependencies. + + * ocaml_specific.ml, + * options.ml, + * options.mli, + * pathname.ml, + * pathname.mli, + * resource.ml, + * resource.mli, + * rule.ml, + * rule.mli, + * solver.ml, + * test/test8/myocamlbuild.ml: Simplify a lot the code. + +2006-11-16 Nicolas Pouillard + + Some improvements... + + * ocamlbuild.ml: . + * ocamlbuild_version.ml: New. + * ocamlbuild_plugin.ml: New. + * ocamlbuild_version.mli: New. + * ocamlbuildlib.mllib: . + * ocamlbuild.sh: Remove. + * ocamlbuild_pack.mlpack: New. + * boot: . + * ocaml_specific.ml: . + * ocaml_specific.mli: . + * options.ml: . + * options.mli: . + * rule.ml: . + * rule.mli: . + * start.sh: . + * test/test8/a.ml: New. + * test/test7/a2.ml: . + * test/test7/a3.ml: New. + * test/test8/myocamlbuild.ml: New. + * test/test7/myocamlbuild.ml: New. + * test/test8: New. + * test/test8/test.sh: New. + * test/runtest.sh: . + * test/test7/test.sh: . + * test/good-output: . + * Makefile: . + * _tags: . + +2006-11-15 Nicolas Pouillard + + Add support for libraries. + + * ocamlbuildlib.ml: Remove. + * ocamlbuildlib.mllib: New. + * ocaml_specific.ml: Rules and actions for libraries. + * rule.ml: Improve explanations. + * start.sh: Don't make ocamlbuildlib. + * test/test7/a.mli: New. + * test/runtest.sh: Add test7. + * test/test7/test.sh: Add reverts for a.ml. + * test/good-output: Update. + * Makefile: Remove junk lines. + +2006-11-14 Nicolas Pouillard + + Add a tests for libraries. + + * test/test7/e.ml: New. + * test/test7/d.ml: New. + * test/test7/a.ml: New. + * test/test7/b.ml: New. + * test/test7/a2.ml: New. + * test/test7/c.ml: New. + * test/test7/test.sh: New. + * test/test7/ablib.mllib: New. + * test/test7: New. + +2006-11-14 Nicolas Pouillard + + Simplify dependency rules. + + * ocaml_specific.ml: No more use bytelinkdeps... + * rule.ml, + * rule.mli: Add a dyndeps set. + * ocamlbuild.sh, + * pathname.ml, + * Makefile: Update. + +2006-11-14 Nicolas Pouillard + + Update tests... + + * test/test2/vivi3.ml: . + * test/good-output: . + +2006-11-10 Berke Durak + + Added -sterilize option. + + * hygiene.ml: ditto + * hygiene.mli: ditto + * ocaml_specific.ml: ditto + * options.ml: ditto + * options.mli: ditto + +2006-11-10 Nicolas Pouillard + + View the context dir in first. + + * pathname.ml: Ditto. + +2006-11-10 Berke Durak + + Added thread and profile tags. + + * ocaml_specific.ml: ditto. + +2006-11-10 Berke Durak + + Added law for leftover dependency files. + + * ocaml_specific.ml: ditto. + +2006-11-10 Nicolas Pouillard + + Reverse the ignore_auto default value. + + * options.ml: Add -no-skip, remove -ignore-auto, add -Is and -Xs. + * test/test2/test.sh, + * test/test5/test.sh, + * test/test6/test.sh, + * test/test4/test.sh, + * test/test3/test.sh, + * Makefile: Revert flags. + +2006-11-10 Berke Durak + + Added install target to Makefile. + + * Makefile: . + +2006-11-10 Nicolas Pouillard + + Deal with for-pack flags... + + * ocaml_arch.ml: Define a hook. + * ocaml_arch.mli: Declare it. + * ocaml_specific.ml: Use it. + * test/test6: Ignore main.byte. + +2006-11-09 Nicolas Pouillard + + Fix start.sh and remove dead code. + + * ocaml_specific.ml: Remove dead code about ignore_auto. + * start.sh: Swap two modules. + * test/test6/main.byte: Remove. + +2006-11-09 Nicolas Pouillard + + Pack now works great... + + * ocamlbuild.sh: Use ocamlopt. + * command.ml: Reset filesys cache. + * my_std.ml, + * my_std.mli: Add a filesys cache for + case sensitive file_exists and digest over files. + * ocaml_specific.ml: Work on link and packs. + * ppcache.ml: Exit 2 is for unix. + * pathname.ml, + * resource.ml, + * rule.ml, + * rule.mli, + * slurp.ml, + * solver.ml, + * solver.mli, + * test/test5: Update. + +2006-11-07 Nicolas Pouillard + + Too lazy to fill this up :). + + * ocamlbuild.sh, + * configuration.ml, + * command.ml, + * debug.ml, + * debug.mli, + * my_std.ml, + * my_std.mli, + * ocaml_specific.ml, + * ocaml_specific.mli, + * options.ml, + * options.mli, + * pathname.ml, + * ppcache.ml,ew. + * ppcache.mli,ew. + * pathname.mli, + * resource.ml, + * resource.mli, + * rule.ml, + * rule.mli, + * slurp.ml, + * solver.ml, + * solver.mli, + * slurp.mli, + * start.sh, + * tags.ml, + * test/test5/test.sh, + * test/test4/test.sh, + * test/test3/test.sh, + * test/good-output, + * test/test2/test.sh, + * test/test6/test.sh, + * Makefile, + * _tags: This too. + +2006-11-04 Nicolas Pouillard + + Some pack,dirs stuffs. + + * ocamlbuild.ml, + * ocamlbuildlib.ml,ew. + * ocamlbuild.sh,ew. + * configuration.ml, + * my_std.ml, + * my_std.mli, + * ocaml_arch.ml,ew. + * ocaml_specific.ml, + * ocaml_specific.mli, + * ocaml_arch.mli,ew. + * options.ml, + * options.mli, + * pathname.ml, + * pathname.mli, + * resource.ml, + * resource.mli, + * rule.ml, + * solver.ml, + * test/good-output, + * Makefile, + * _tags: That's it. + +2006-10-31 Nicolas Pouillard + + Remove the dirty thing about cmi's. + + * ocaml_specific.ml, + * ocaml_specific.mli: Moves of files are no more needed. + * test/good-output: Update. + +2006-10-31 Nicolas Pouillard + + Some renaming and cleanup... + + * ocamlbuild.ml, + * configuration.ml, + * configuration.mli, + * list_set.ml, + * ocaml_specific.ml, + * resource.ml, + * test/good-output, + * test/test6/test.sh: Do that. + +2006-10-31 Nicolas Pouillard + + Use the nothing-should-be-rebuilt for tests and update the output. + + * test/test2, + * test/test2/test.sh, + * test/test3/test.sh, + * test/test4/test.sh, + * test/test5/test.sh, + * test/test6/test.sh, + * test/good-output: Do that. + +2006-10-31 Nicolas Pouillard + + Add a mode usefull for tests. + + * options.ml, options.mli, rule.ml: + This new mode fails when something needs to be rebuilt. + +2006-10-31 Nicolas Pouillard + + Improve the ocaml rule set. + + * ocaml_specific.ml: Yipee! + +2006-10-31 Nicolas Pouillard + + Add scripts to run tests. + + * test/test2/vivi1.ml: New. + * test/test2/vivi2.ml: New. + * test/test2/vivi3.ml: New. + * test/test2/vivi.ml: . + * test/test4/test.sh: New. + * test/test5/test.sh: New. + * test/test2/test.sh: New. + * test/test6/test.sh: . + * test/good-output: New. + * test/test3/test.sh: New. + * test/runtest.sh: New. + +2006-10-31 Nicolas Pouillard + + Restore some recursivity for includes. + + * resource.ml, + * resource.mli: Remove the digest field. + * rule.ml: . + * test/test6/test.sh: . + +2006-10-30 Nicolas Pouillard + + Remove the arbitrary deep dependencies. + + * ocaml_specific.ml, + * ocaml_specific.mli: No more implicit transitives deps. + * resource.ml, + * resource.mli: Remove as many things as possible. + * rule.ml, + * rule.mli, + * solver.ml: Simplify. + * command.ml: Fix newlines and flush. + +2006-10-30 Nicolas Pouillard + + Separated preprocessing, total order over rules... + + * ocamlbuild.ml, + * my_std.ml, + * my_std.mli, + * ocaml_specific.ml, + * ocaml_specific.mli, + * options.ml, + * options.mli, + * pathname.ml, + * pathname.mli, + * resource.ml, + * resource.mli, + * rule.ml, + * rule.mli, + * solver.ml, + * test/test2/tutu.ml, + * tags.ml, + * test/test2/tyty.mli,ew. + * test/test6/test.sh, + * test/test6, + * test/test5/_tags, + * test/test5: Update. + +2006-10-27 Nicolas Pouillard + + Add options: -ocamlc,-ocamlopt,-ocamldep,-ocamlyacc,-ocamllex. + + * options.ml, + * options.mli: Declare them. + * ocaml_specific.ml: Use them. + +2006-10-27 Nicolas Pouillard + + Fix start.sh. + + * start.sh: Fix the output. + +2006-10-27 Nicolas Pouillard + + Regen start.sh. + + * start.sh: Regen. + +2006-10-27 Nicolas Pouillard + + Use the list based implems and fix many bugs. + + * ocamlbuild.ml: Rename some dependency files. + * boot: Ignore boot/ocamlbuild.byte.save.* files. + * command.ml: Fix command printing. + * my_std.ml, + * my_std.mli: Add List.equal, use the cp command in Shell.cp. + * ocaml_specific.ml, + * ocaml_specific.mli: Many things. + * pathname.ml, pathname.mli: Make compare obselete prefer equal. + * resource.ml, resource.mli: Add print_cache and use list based + sets and maps. + * Makefile: Add the bootstrap rule. + +2006-10-27 Nicolas Pouillard + + Add a test for fine-grained dependencies. + + * test/test6/main.ml: New. + * test/test6/d.ml: New. + * test/test6/b.ml: New. + * test/test6/a.ml: New. + * test/test6/main.mli: New. + * test/test6/a.mli: New. + * test/test6/d.mli: New. + * test/test6/b.mli: New. + * test/test6/b.mli.v2: New. + * test/test6/main.byte: New. + * test/test6/d.mli.v1: New. + * test/test6/test.sh: New. + * test/test6/d.mli.v2: New. + * test/test6/b.mli.v1: New. + * test/test6: New. + +2006-10-26 Nicolas Pouillard + + Dummy implementations for set and map using lists. + The main advantage is to only rely on the equal function that is simpler + to maintain correct in an imperative setting. + + * list_map.ml: New. + * list_set.ml: New. + * list_map.mli: New. + * list_set.mli: New. + +2006-10-24 Nicolas Pouillard + + Fixes and improvment. + + * ocamlbuild.ml, + * my_std.ml, + * my_std.mli, + * ocaml_specific.ml, + * ocaml_specific.mli, + * pathname.ml, + * resource.ml, + * rule.ml, + * rule.mli, + * solver.ml, + * solver.mli: The previous version was somwhat unstable. + +2006-10-24 Nicolas Pouillard + + Many things... + + * ocamlbuild.ml, + * command.ml, + * command.mli, + * ocaml_specific.ml, + * ocaml_specific.mli, + * options.ml, + * options.mli, + * resource.ml, + * resource.mli, + * rule.ml, + * rule.mli, + * solver.ml, + * solver.mli: + Simplify the whole solver by removing the value type. + Rule code now returns a resource set, that is injected as dependencies. + So rule code always returns unit. But can raise exceptions. + Add -ignore, and -ignore-auto options to workaround ocamldep + approximations without igonring errors. + * Makefile: Add backup and restore targets. + +2006-10-23 Nicolas Pouillard + + Compute digests of dependencies recursively. + + * ocamlbuild.ml, + * ocaml_specific.ml, + * options.ml, + * options.mli, + * resource.ml, + * resource.mli, + * rule.ml: Ditto. + +2006-10-23 Nicolas Pouillard + + One step toward a parallelisable system. + + * boot, + * command.ml, + * ocaml_specific.ml, + * ocaml_specific.mli, + * options.ml, + * options.mli, + * rule.ml, + * rule.mli, + * solver.ml: Update. + * value.ml: Remove. + * value.mli: Remove. + +2006-10-20 Nicolas Pouillard + + Add vcs config file to setup a good default setup. + + * .vcs: New. + +2006-10-20 Nicolas Pouillard + + Simplify the bootstrap by introducing a shell script. + + * boot/ocamlbuild.byte: Remove. Useless in distribution mode + but will be created, the first time. So the devel is not + disturbed. + * start.sh: New. + * Makefile: Remove the old one to use start.sh. + +2006-10-20 Nicolas Pouillard + + Take command line in account for the digest computation. + + * command.ml, + * command.mli, + * debug.ml, + * ocaml_specific.ml, + * ocaml_specific.mli, + * resource.ml, + * resource.mli, + * rule.ml, + * rule.mli, + * solver.ml, + * value.ml, + * value.mli: Update. + +2006-10-19 Nicolas Pouillard + + New pathname representation. + + * pathname.ml, pathname.mli: This new representation should + avoids "fix" problems. + +2006-10-17 Nicolas Pouillard + + Change the cache implem -> now really fast at link time. + + * ocamlbuild.ml, + * boot/ocamlbuild.byte, + * my_std.ml, + * ocaml_specific.ml, + * pathname.ml, + * resource.ml, + * resource.mli, + * solver.ml: By replacing various sets by a map of records and + remember that something has not changed, or cannot be built; + there is a real speedup. In particular to detect that the link is + not necessary to do. + +2006-10-17 Nicolas Pouillard + + Add a basic support for a digest based cache verification. + + * resource.ml, resource.mli: Add have_digest and store_digest. + * rule.ml: Use these digests but don't include the command for + now. + * test/test2/vivi.ml, test/test2/tata.mli: Dummy updates. + +2006-10-16 Nicolas Pouillard + + Split in many files. + + * ocamlbuild.ml: Splitted. + * boot/ocamlbuild.byte: Updated. + * configuration.ml: New. + * configuration.mli: New. + * command.ml: New. + * command.mli: New. + * debug.ml: New. + * debug.mli: New. + * flags.ml: New. + * flags.mli: New. + * my_std.ml: New. + * my_std.mli: New. + * ocaml_specific.ml: New. + * ocaml_specific.mli: New. + * options.ml: New. + * options.mli: New. + * pathname.ml: New. + * pathname.mli: New. + * re.ml: New. + * re.mli: New. + * resource.ml: New. + * resource.mli: New. + * rule.ml: New. + * rule.mli: New. + * solver.ml: New. + * solver.mli: New. + * test/test5/d.ml: New. + * tags.ml: New. + * test/test5/b.ml: New. + * test/test5/a.ml: New. + * tags.mli: New. + * test/test5/a.mli: New. + * test/test5/c.mlpack: New. + * test/test5/_tags: New. + * test/test5: New. + * value.ml: New. + * value.mli: New. + * Makefile: . + +2006-10-16 Berke Durak + + Various useful changes. + + * ocamlbuild.ml: Hygiene to true. + * slurp.ml: Remove debugging + * Makefile: Clean annot and object files. + +2006-10-15 Nicolas Pouillard + + Bootstrap it ;). + + * ocamlbuild.ml: Add support for -g, -dtypes, and -rectypes in + four lines. + * _tags: New. Specify how to build ocamlbuild itself. + * boot: New. + * boot/ocamlbuild.byte: New. A bytecode version needed to + bootstrap + * Makefile: By default make it a wrapper over ocamlbuild in boot. + +2006-10-15 Nicolas Pouillard + + Little fix... + + * ocamlbuild.ml: Don't assoc over pathnames since the default + compare is wrong and slow use the string repr. + +2006-10-15 Nicolas Pouillard + + Allow to control flags, and libraries by tags. + + * ocamlbuild.ml: In the _tags file you can add or remove flags + using a colon flag_name:flag_value. + * test/test2/vivi.ml, + * test/test3/f.ml, + * test/test4/b/bb.ml: Dummy updates. + * test/test3/_tags: New. + * test/test4/_tags: New. + +2006-10-15 Nicolas Pouillard + + Add a tag based flag system. + + * test/test2/vivi.ml: An example. + * test/test2/_tags: New. + * ocamlbuild.ml: Now a command can request for flags by giving a + set of tags these tags include file specific tags this allow to + tweak flags by just providing a _tags file. + +2006-10-15 Nicolas Pouillard + + Add -lib,-libs options remove -P. + + * ocamlbuild.ml: -P Is useless due to the fact that we now + have the same directory structure in the _build directory. + Add -lib,-libs that allows one to specify -lib unix without + its extension in order to request for native and byte + compilations. + +2006-10-15 Nicolas Pouillard + + Multi directories now works ;). + + * ocamlbuild.ml: Solve the whole problem by improving the + Pathname module. Pathnames are now symbolic values that + can include variable names. These variable names represent + still ambiguous pathnames /a/b/(c|d as x1)/e.ml but variables + can be shared, so discovering that /a/b/(c|d as x1)/e.ml is in + fact /a/b/c/e.ml will make /a/b/(c|d as x1)/e.cmo automatically + take this value /a/b/c/e.cmo cause it shares the x1 variable. + +2006-10-13 Nicolas Pouillard + + I prefer capitalized names. + + * AUTHORS + +2006-10-13 Berke Durak + + Added an AUTHORS file. + + * AUTHORS: New. + +2006-10-13 Nicolas Pouillard + + Add the vcs dir. + + * vcs: New. + * vcs/ocamlbuild.rb: New. + +2006-10-13 Nicolas Pouillard + + * ocamlbuild.ml: Restore dependencies. + +2006-10-13 Nicolas Pouillard + + Fix the makefile. + + * Makefile, discard_printf.ml: Ditto. + +2006-10-13 Nicolas Pouillard + + Improve the directory handling. + + * ocamlbuild.ml: Ditto, but there is still a problem with native. + * Makefile: Update. + +2006-10-11 Nicolas Pouillard + + Fix native dependencies. + + * ocamlbuild.ml: By default due to inlining the cmx dependencies + are needed to build a cmx. + * Makefile: Add native support. + +2006-10-11 Nicolas Pouillard + + Use phony for linkdeps. + + * ocamlbuild.ml: Ditto. + +2006-10-11 Nicolas Pouillard + + Fix exit on multiple targets. + + * ocamlbuild.ml: Ditto. + +2006-10-11 Nicolas Pouillard + + More flags -lflags,-lflag... + + * ocamlbuild.ml: Add plrual form options for those that use + comma separated lists. + +2006-10-11 Nicolas Pouillard + + Use phony resources for .cmo.linkdeps. + + * ocamlbuild.ml: Also restore the command running if "--" + is specified + +2006-10-11 Nicolas Pouillard + + Remove Include_string_list resources, add Phony resources. + + * ocamlbuild.ml: Also fix some rules. + +2006-10-11 Nicolas Pouillard + + Shift debug levels. + + * ocamlbuild.ml: Add -quiet. + +2006-10-11 Nicolas Pouillard + + Use str more intensively. + + * ocamlbuild.ml: Also clean up useless functions. + +2006-10-11 Nicolas Pouillard + + Fix link dependencies. + + * ocamlbuild.ml: Force to consider recursivly Include_ tagged + resources for their full contents. Alas it takes more time to + know if we need to recompute the link. + * test/test2/vivi.ml: Update. + +2006-10-10 Nicolas Pouillard + + Support multiple directories, it can compile the OCaml compiler :). + + * ocamlbuild.ml: Add directory handling but also start + the tags config files handling. + * Makefile: Use str.cma. + +2006-10-08 Nicolas Pouillard + + Add library support. + + * ocamlbuild.ml: Deduce basic set of tags form the target + extension. + +2006-10-08 Nicolas Pouillard + + More customisable flags, and cycle detection. + + * ocamlbuild.ml: Add some flags -lflag, -ppflag, -cflag, --. + Also add a detection mechanism for dependencies. + * discard_printf.ml, Makefile: Update. + diff --git a/ocamlbuild/FAQ b/ocamlbuild/FAQ new file mode 100644 index 00000000..b71516b9 --- /dev/null +++ b/ocamlbuild/FAQ @@ -0,0 +1,35 @@ +Q: I've a directory with examples and I want build all of them easily? + +R: + + You can use an .itarget file listing all products that you want. + + $ cat examples.itarget + examples/a.byte + examples/b.byte + + $ ocamlbuild examples.otarget + + You can also have a dynamic rule that read the examples directory: + + $ cat myocamlbuild.ml + open Ocamlbuild_plugin;; + + dispatch begin function + | After_rules -> + let examples = + Array.fold_right begin fun f acc -> + if Pathname.get_extension f = "ml" then + ("examples" / Pathname.update_extension "byte" f) :: acc + else + acc + end (Pathname.readdir "examples") [] + in + rule "All examples" + ~prod:"examples.otarget" + ~deps:examples + (fun _ _ -> Command.Nop) + | _ -> () + end + + $ ocamlbuild examples.otarget diff --git a/ocamlbuild/Makefile b/ocamlbuild/Makefile new file mode 100644 index 00000000..b8d780ad --- /dev/null +++ b/ocamlbuild/Makefile @@ -0,0 +1,96 @@ +.PHONY: all byte native profile debug ppcache doc + +ifndef INSTALL_PREFIX +INSTALL_PREFIX := /usr/local +endif + +ifndef INSTALL_LIB +INSTALL_LIB := $(INSTALL_PREFIX)/lib/ocamlbuild +endif + +ifndef INSTALL_BIN +INSTALL_BIN := $(INSTALL_PREFIX)/bin +endif + +ifndef BUILDDIR +BUILDDIR := "_build" +endif + +ifndef OCAMLBUILDCMD +OCAMLBUILDCMD := ./boot/ocamlbuild +endif + +ifdef O +OCAMLBUILD_OPTIONS := $(OCAMLBUILD_OPTIONS) $(O) +endif + +ifeq ($(wildcard ./boot/oc*build),./boot/ocamlbuild) +OCAMLBUILD=INSTALL_LIB=$(INSTALL_LIB) $(OCAMLBUILDCMD) -build-dir $(BUILDDIR) -no-links $(OCAMLBUILD_OPTIONS) +LIBS=ocamlbuildlib ocamlbuildlightlib +PROGRAMS=ocamlbuild ocamlbuildlight +BYTE=$(LIBS:=.cma) $(PROGRAMS:=.byte) +NATIVE=$(LIBS:=.cmxa) $(PROGRAMS:=.native) + +all: + $(OCAMLBUILD) $(BYTE) $(NATIVE) +byte: + $(OCAMLBUILD) $(BYTE) +profile: + $(OCAMLBUILD) $(LIBS:=.p.cmxa) $(PROGRAMS:=.p.native) +debug: + $(OCAMLBUILD) $(LIBS:=.d.cma) $(PROGRAMS:=.d.byte) +ppcache: + $(OCAMLBUILD) ppcache.byte ppcache.native +doc: + $(OCAMLBUILD) ocamlbuild.docdir/index.html + ln -sf $(BUILDDIR)/ocamlbuild.docdir doc +else +all byte native: ocamlbuild.byte.start + mkdir -p boot + cp ocamlbuild.byte.start boot/ocamlbuild + $(MAKE) $(MFLAGS) $(MAKECMDGOALS) + cp $(BUILDDIR)/ocamlbuild.native boot/ocamlbuild + $(MAKE) $(MFLAGS) $(MAKECMDGOALS) OCAMLBUILD_OPTIONS="-nothing-should-be-rebuilt -verbose -1" +endif + +ocamlbuild.byte.start: + ./start.sh + +promote: + cp $(BUILDDIR)/ocamlbuild.native boot/ocamlbuild + +clean: + rm -rf $(BUILDDIR) + +distclean: clean + rm -rf _log _start ocamlbuild.byte.start boot/ocamlbuild + +install: all + mkdir -p $(INSTALL_BIN) + mkdir -p $(INSTALL_LIB) + install $(BUILDDIR)/ocamlbuild.byte \ + $(BUILDDIR)/ocamlbuild.native \ + $(BUILDDIR)/ocamlbuildlight.byte \ + $(BUILDDIR)/ocamlbuildlight.native \ + $(INSTALL_BIN) + install $(BUILDDIR)/ocamlbuild.native $(INSTALL_BIN)/ocamlbuild + install $(BUILDDIR)/ocamlbuildlight.byte $(INSTALL_BIN)/ocamlbuildlight + install -m 644 \ + $(BUILDDIR)/ocamlbuildlib.cmxa \ + $(BUILDDIR)/ocamlbuildlib.a \ + $(BUILDDIR)/ocamlbuildlib.cma \ + $(BUILDDIR)/ocamlbuildlightlib.cmxa \ + $(BUILDDIR)/ocamlbuildlightlib.a \ + $(BUILDDIR)/ocamlbuildlightlib.cma \ + $(BUILDDIR)/ocamlbuild_pack.cmi \ + $(BUILDDIR)/ocamlbuild_pack.cmx \ + $(BUILDDIR)/ocamlbuild.cmi \ + $(BUILDDIR)/ocamlbuild_plugin.cmi \ + $(BUILDDIR)/ocamlbuild.cmx \ + $(BUILDDIR)/ocamlbuild.o \ + $(BUILDDIR)/ocamlbuild.cmo \ + $(BUILDDIR)/ocamlbuildlight.cmx \ + $(BUILDDIR)/ocamlbuildlight.o \ + $(BUILDDIR)/ocamlbuildlight.cmo $(INSTALL_LIB) + ranlib $(INSTALL_LIB)/ocamlbuildlib.a + ranlib $(INSTALL_LIB)/ocamlbuildlightlib.a diff --git a/ocamlbuild/TODO b/ocamlbuild/TODO new file mode 100644 index 00000000..3b634f6b --- /dev/null +++ b/ocamlbuild/TODO @@ -0,0 +1,34 @@ +To do: +* Executor: exceptional conditions and Not_found +* Fix report +* Design a nice, friendly, future-proof plugin (myocamlbuild) API +* Ocamlbuild should keep track of files removed from the source directory, e.g., +removing a .mli should be mirrored in the _build directory. + +Being done: +* Write doc + +Almost done: +* Fine control for hygiene using a glob pattern (command line option + tag) + => the command line option is todo. + -tag " or ..." "tag1, -tag2, ..." + +Won't fix: +* Config file for options => no since myocamlbuild is sufficent +* Optimize MD5 (Daemon ? Dnotify ?) : too much hassle for little gain + +Done: +* Fix uncaught exception handler to play well with the Display module +* Finish display before executing target +* Slurp: in a directory read files, before subdirs (to have _tags before foo/_tags) +* Add a -clean option +* Add ocamldoc rules (use .odoc extension) +* Add .inferred.mli target rules +* -- with no args does not call the executable +* Complain when used with -- and no target +* dep ["ocaml"; "link"; "use_foo"] ["foo/foo.o"] tags for adding targets +* Ensure that _build and _log are not created if not needed (with -help for + instance) +* Display: should display nothing (even when finish is called) when no real + event as occured. +* Have some option to draw tags/rules that applies on a target (it's -show-tags). diff --git a/ocamlbuild/_tags b/ocamlbuild/_tags new file mode 100644 index 00000000..66056bd6 --- /dev/null +++ b/ocamlbuild/_tags @@ -0,0 +1,13 @@ +# OCamlbuild tags file +true: debug +<*.ml> or <*.mli>: warn_A, warn_error_A, dtypes +"discard_printf.ml": rectypes +"ocamlbuildlib.cma" or "ocamlbuildlightlib.cma": linkall +<*.byte> or <*.native> or <*.top>: use_unix +"ocamlbuildlight.byte": -use_unix +<*.cmx>: for-pack(Ocamlbuild_pack) +<{ocamlbuild_{pack,plugin},my_unix_with_unix,ppcache,executor}{,.p}.cmx>: -for-pack(Ocamlbuild_pack) +"lexers.ml" or "glob_lexer.ml": -warn_A, -warn_error_A +"glob.ml": -warn_E, -warn_error_E, -warn_A, -warn_error_A +"doc": not_hygienic +"resource.ml": warn_error_e diff --git a/ocamlbuild/bool.ml b/ocamlbuild/bool.ml new file mode 100644 index 00000000..19cb9142 --- /dev/null +++ b/ocamlbuild/bool.ml @@ -0,0 +1,38 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: bool.ml,v 1.1 2007/02/07 08:59:13 ertai Exp $ *) +(* Original author: Berke Durak *) +(* Bool *) + +type 'a boolean = And of 'a boolean list | Or of 'a boolean list | Not of 'a boolean | Atom of 'a | True | False;; + +let rec eval f = function + | And l -> List.for_all (eval f) l + | Or l -> List.exists (eval f) l + | Not x -> not (eval f x) + | Atom a -> f a + | True -> true + | False -> false +;; +let rec iter f = function + | (And l|Or l) -> List.iter (iter f) l + | Not x -> iter f x + | Atom a -> f a + | True|False -> () +;; +let rec map f = function + | And l -> And(List.map (map f) l) + | Or l -> Or(List.map (map f) l) + | Not x -> Not(map f x) + | Atom a -> Atom(f a) + | (True|False) as b -> b +;; diff --git a/ocamlbuild/bool.mli b/ocamlbuild/bool.mli new file mode 100644 index 00000000..1f4a92e6 --- /dev/null +++ b/ocamlbuild/bool.mli @@ -0,0 +1,34 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: bool.mli,v 1.1 2007/02/07 08:59:13 ertai Exp $ *) +(* Original author: Berke Durak *) +(* Bool *) + +(** Provides a datatype for representing boolean formulas and evaluation, + iteration and map functions. *) + +(** Public type for generic boolean formulas. An empty conjunction [And[]] is true and + an empty disjunction [Or[]] is false. *) +type 'a boolean = + And of 'a boolean list + | Or of 'a boolean list + | Not of 'a boolean + | Atom of 'a + | True + | False + +val eval : ('a -> bool) -> 'a boolean -> bool +(** [eval g f] evaluates the boolean formula [f] using the values returned by [g] for the atoms. *) +val iter : ('a -> unit) -> 'a boolean -> unit +(** [iter g f] calls [g] over every atom of [f]. *) +val map : ('a -> 'b) -> 'a boolean -> 'b boolean +(** [map g f] replaces every atom of [f] by its image by [g]. *) diff --git a/ocamlbuild/command.ml b/ocamlbuild/command.ml new file mode 100644 index 00000000..22256e41 --- /dev/null +++ b/ocamlbuild/command.ml @@ -0,0 +1,295 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: command.ml,v 1.1 2007/02/07 08:59:13 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +(* Command *) + +open My_std +open Log + +type tags = Tags.t + +let jobs = ref 1 + +type t = +| Seq of t list +| Cmd of spec +| Nop +and spec = +| N (* nop or nil *) +| S of spec list +| A of string +| P of string (* Pathname.t *) +| Px of string (* Pathname.t *) +| Sh of string +| T of Tags.t +| V of string +| Quote of spec + +(*type v = [ `Seq of v list | `Cmd of vspec | `Nop ] +and vspec = + [ `N + | `S of vspec list + | `A of string + | `P of string (* Pathname.t *) + | `Px of string (* Pathname.t *) + | `Sh of string + | `Quote of vspec ] + +let rec spec_of_vspec = + function + | `N -> N + | `S vspecs -> S (List.map spec_of_vspec vspecs) + | `A s -> A s + | `P s -> P s + | `Px s -> Px s + | `Sh s -> Sh s + | `Quote vspec -> Quote (spec_of_vspec vspec) + +let rec vspec_of_spec = + function + | N -> `N + | S specs -> `S (List.map vspec_of_spec specs) + | A s -> `A s + | P s -> `P s + | Px s -> `Px s + | Sh s -> `Sh s + | T _ -> invalid_arg "vspec_of_spec: T not supported" + | Quote spec -> `Quote (vspec_of_spec spec) + +let rec t_of_v = + function + | `Nop -> Nop + | `Cmd vspec -> Cmd (spec_of_vspec vspec) + | `Seq cmds -> Seq (List.map t_of_v cmds) + +let rec v_of_t = + function + | Nop -> `Nop + | Cmd spec -> `Cmd (vspec_of_spec spec) + | Seq cmds -> `Seq (List.map v_of_t cmds)*) + +let no_tag_handler _ = failwith "no_tag_handler" + +let tag_handler = ref no_tag_handler + +(*** atomize *) +let atomize l = S(List.map (fun x -> A x) l) +let atomize_paths l = S(List.map (fun x -> P x) l) +(* ***) + +let env_path = lazy begin + let path_var = Sys.getenv "PATH" in + Lexers.colon_sep_strings (Lexing.from_string path_var) +end + +let virtual_solvers = Hashtbl.create 32 +let setup_virtual_command_solver virtual_command solver = + Hashtbl.replace virtual_solvers virtual_command solver +let virtual_solver virtual_command = + let solver = + try + Hashtbl.find virtual_solvers virtual_command + with Not_found -> + failwith (sbprintf "no solver for the virtual command %S \ + (setup one with Command.setup_virtual_command_solver)" + virtual_command) + in + try solver () + with Not_found -> + failwith (Printf.sprintf "the solver for the virtual command %S \ + has failed finding a valid command" virtual_command) + + +(* FIXME windows *) +let search_in_path cmd = + if Filename.is_implicit cmd then + let path = List.find begin fun path -> + if path = Filename.current_dir_name then sys_file_exists cmd + else sys_file_exists (filename_concat path cmd) + end !*env_path in + filename_concat path cmd + else cmd + +(*** string_of_command_spec{,_with_calls *) +let rec string_of_command_spec_with_calls call_with_tags call_with_target resolve_virtuals spec = + let self = string_of_command_spec_with_calls call_with_tags call_with_target resolve_virtuals in + let b = Buffer.create 256 in + let first = ref true in + let put_space () = + if !first then + first := false + else + Buffer.add_char b ' ' + in + let put_filename p = + Buffer.add_string b (Shell.quote_filename_if_needed p) + in + let rec do_spec = function + | N -> () + | A u -> put_space (); put_filename u + | Sh u -> put_space (); Buffer.add_string b u + | P p -> put_space (); put_filename p + | Px u -> put_space (); put_filename u; call_with_target u + | V v -> if resolve_virtuals then do_spec (virtual_solver v) + else (put_space (); Printf.bprintf b "" (Shell.quote_filename_if_needed v)) + | S l -> List.iter do_spec l + | T tags -> call_with_tags tags; do_spec (!tag_handler tags) + | Quote s -> put_space (); put_filename (self s) + in + do_spec spec; + Buffer.contents b + +let string_of_command_spec x = string_of_command_spec_with_calls ignore ignore false x + +let string_print_of_command_spec spec = + let rtags = ref Tags.empty in + let rtarget = ref "" in + let s = string_of_command_spec_with_calls ((:=) rtags) ((:=) rtarget) true spec in + let target = if !rtarget = "" then s else !rtarget in + (s, (fun quiet pretend () -> if not quiet then Log.event ~pretend s target !rtags)) +(* ***) + +let rec print f = + function + | Cmd spec -> Format.pp_print_string f (string_of_command_spec spec) + | Seq seq -> List.print print f seq + | Nop -> Format.pp_print_string f "nop" + +let to_string x = sbprintf "%a" print x + +let rec list_rev_iter f = + function + | [] -> () + | x :: xs -> list_rev_iter f xs; f x + +let spec_list_of_cmd cmd = + let rec loop acc = + function + | [] -> acc + | Nop :: xs -> loop acc xs + | Cmd spec :: xs -> loop (string_print_of_command_spec spec :: acc) xs + | Seq l :: xs -> loop (loop acc l) xs + in List.rev (loop [] [cmd]) + +let execute_many ?(quiet=false) ?(pretend=false) cmds = + let degraded = !*My_unix.is_degraded || Sys.os_type = "Win32" in + let jobs = !jobs in + if jobs < 0 then invalid_arg "jobs < 0"; + let max_jobs = if jobs = 0 then None else Some jobs in + + let ticker = Log.update in + let display = Log.display in + + if cmds = [] then + None + else + begin + let konts = + List.map + begin fun cmd -> + let specs = spec_list_of_cmd cmd in + List.map + begin fun (cmd, print) -> + (cmd, (print quiet pretend)) + end + specs + end + cmds + in + if pretend then + begin + List.iter + begin fun l -> + List.iter + begin fun (_, f) -> f () end + l + end + konts; + None + end + else + begin + reset_filesys_cache (); + if degraded then + let res, opt_exn = + List.fold_left begin fun (acc_res, acc_exn) cmds -> + match acc_exn with + | None -> + begin try + List.iter begin fun (cmd, print) -> + print (); + let rc = sys_command cmd in + if rc <> 0 then begin + if not quiet then + eprintf "Exit code %d while executing this \ + command:@\n%s" rc cmd; + raise (Exit_with_code rc) + end + end cmds; + true :: acc_res, None + with e -> false :: acc_res, Some e + end + | Some _ -> false :: acc_res, acc_exn + end ([], None) konts + in match opt_exn with + | Some(exn) -> Some(res, exn) + | None -> None + else + My_unix.execute_many ~ticker ?max_jobs ~display konts + end + end +;; + +let execute ?quiet ?pretend cmd = + match execute_many ?quiet ?pretend [cmd] with + | Some(_, exn) -> raise exn + | _ -> () + +let rec reduce x = + let rec self x acc = + match x with + | N -> acc + | A _ | Sh _ | P _ | Px _ | V _ -> x :: acc + | S l -> List.fold_right self l acc + | T tags -> self (!tag_handler tags) acc + | Quote s -> Quote (reduce s) :: acc in + match self x [] with + | [] -> N + | [x] -> x + | xs -> S xs + +let to_string_for_digest = to_string +(* +let to_string_for_digest x = + let rec cmd_of_spec = + function + | [] -> None + | N :: xs -> cmd_of_spec xs + | (A x | P x | P x) :: _ -> Some x + | Sh x :: _ -> + if Shell.is_simple_filename x then Some x + else None (* Sh"ocamlfind ocamlc" for example will not be digested. *) + | S specs1 :: specs2 -> cmd_of_spec (specs1 @ specs2) + | (T _ | Quote _) :: _ -> assert false in + let rec cmd_of_cmds = + function + | Nop | Seq [] -> None + | Cmd spec -> cmd_of_spec [spec] + | Seq (cmd :: _) -> cmd_of_cmds cmd in + let s = to_string x in + match cmd_of_cmds x with + | Some x -> + if sys_file_exists x then sprintf "(%S,%S)" s (Digest.file x) + else s + | None -> s +*) diff --git a/ocamlbuild/command.mli b/ocamlbuild/command.mli new file mode 100644 index 00000000..0a12f938 --- /dev/null +++ b/ocamlbuild/command.mli @@ -0,0 +1,30 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: command.mli,v 1.1 2007/02/07 08:59:13 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +(* Command *) + +(** Provides an abstract type for easily building complex shell commands without making + quotation mistakes. *) +include Signatures.COMMAND with type tags = Tags.t + +(** {6 For system use only, not for the casual user} *) + +(** Same as [to_string]. *) +val to_string_for_digest : t -> string + +(** Maximum number of parallel jobs. *) +val jobs : int ref + +(** Hook here the function that maps a set of tags to appropriate command + options. It also build the dependencies that matches the tags. *) +val tag_handler : (Tags.t -> spec) ref diff --git a/ocamlbuild/configuration.ml b/ocamlbuild/configuration.ml new file mode 100644 index 00000000..30370640 --- /dev/null +++ b/ocamlbuild/configuration.ml @@ -0,0 +1,63 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: configuration.ml,v 1.1 2007/02/07 08:59:13 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +open My_std +open Log +open Lexers + +type flag_list = (string * string) list + +type t = Lexers.conf + +let cache = Hashtbl.create 107 +let (configs, add_config) = + let configs = ref [] in + (fun () -> !configs), + (fun config -> configs := config :: !configs; Hashtbl.clear cache) + +let parse_string s = + let conf = Lexers.conf_lines None 1 (Printf.sprintf "string: %S" s) (Lexing.from_string s) in + add_config conf + +let parse_file ?dir file = + with_input_file file begin fun ic -> + let conf = Lexers.conf_lines dir 1 (Printf.sprintf "file: %S" file) (Lexing.from_channel ic) in + add_config conf + end + +let key_match = Glob.eval + +let apply_config s (config : t) init = + List.fold_left begin fun (tags, flags as acc) (key, v) -> + if key_match key s then + (List.fold_right Tags.add v.plus_tags (List.fold_right Tags.remove v.minus_tags tags), + List.fold_right Flags.add v.plus_flags (List.fold_right Flags.remove v.minus_flags flags)) + else acc + end init config + +let apply_configs s = + let (tags, flags) = + List.fold_right (apply_config s) (configs ()) (Tags.empty, []) + in (tags, Flags.to_spec flags) + +let tags_and_flags_of_filename s = + try Hashtbl.find cache s + with Not_found -> + let res = apply_configs s in + let () = Hashtbl.replace cache s res in + res + +let tags_of_filename x = fst (tags_and_flags_of_filename x) +let flags_of_filename x = snd (tags_and_flags_of_filename x) + +let has_tag tag = Tags.mem tag (tags_of_filename "") diff --git a/ocamlbuild/configuration.mli b/ocamlbuild/configuration.mli new file mode 100644 index 00000000..555d0370 --- /dev/null +++ b/ocamlbuild/configuration.mli @@ -0,0 +1,34 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: configuration.mli,v 1.1 2007/02/07 08:59:13 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +(* Configuration *) + +(** Handles the "_tags" file mechanism. *) + +type flag_list = (string * string) list + +(** Incorporate a newline-separated configuration string into the current configuration. + Will usually raising an [Invalid_arg] with an appropriately explicit message in case of error. *) +val parse_string : string -> unit + +(** [parse_file ?dir fn] incorporates the configuration file named [fn], prefixing its glob patterns + with [dir] if given. *) +val parse_file : ?dir:string -> string -> unit + +(** Return the set of tags that apply to a given filename under the current configuration. *) +val tags_of_filename : string -> Tags.t + +(** Return the set of flags that apply to a given filename under the current configuration. *) +val flags_of_filename : string -> Command.spec + +val has_tag : string -> bool diff --git a/ocamlbuild/discard_printf.ml b/ocamlbuild/discard_printf.ml new file mode 100644 index 00000000..5bcd8763 --- /dev/null +++ b/ocamlbuild/discard_printf.ml @@ -0,0 +1,16 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: discard_printf.ml,v 1.1 2007/02/07 08:59:13 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +let rec greedy _ = greedy + +let discard_printf _fmt = Obj.magic greedy diff --git a/ocamlbuild/discard_printf.mli b/ocamlbuild/discard_printf.mli new file mode 100644 index 00000000..737ebdb2 --- /dev/null +++ b/ocamlbuild/discard_printf.mli @@ -0,0 +1,19 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: discard_printf.mli,v 1.1 2007/02/07 08:59:13 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +(* Discard_printf *) + +(** This module compiled with [-rectypes] allows one to write functions + taking formatters as arguments. *) +open Format +val discard_printf: ('a, formatter, unit) format -> 'a diff --git a/ocamlbuild/display.ml b/ocamlbuild/display.ml new file mode 100644 index 00000000..82f9428f --- /dev/null +++ b/ocamlbuild/display.ml @@ -0,0 +1,385 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: display.ml,v 1.1 2007/02/07 08:59:13 ertai Exp $ *) +(* Original author: Berke Durak *) +(* Display *) +open My_std;; + +open My_unix;; + +let fp = Printf.fprintf;; + +(*** ANSI *) +module ANSI = + struct + let up oc n = fp oc "\027[%dA" n;; + let clear_to_eol oc () = fp oc "\027[K";; + let bol oc () = fp oc "\r";; + let get_columns () = + try + int_of_string (String.chomp (My_unix.run_and_read "tput cols")) + with + | Failure _ -> 80 + end +;; +(* ***) +(*** tagline_description *) +type tagline_description = (string * char) list;; +(* ***) +(*** sophisticated_display *) +type sophisticated_display = { + ds_channel : out_channel; (** Channel for writing *) + ds_start_time : float; (** When was compilation started *) + mutable ds_last_update : float; (** When was the display last updated *) + mutable ds_last_target : string; (** Last target built *) + mutable ds_last_cached : bool; (** Was the last target cached or really built ? *) + mutable ds_last_tags : Tags.t; (** Tags of the last command *) + mutable ds_changed : bool; (** Does the tag line need recomputing ? *) + ds_update_interval : float; (** Minimum interval between updates *) + ds_columns : int; (** Number of columns in dssplay *) + mutable ds_jobs : int; (** Number of jobs launched or cached *) + mutable ds_jobs_cached : int; (** Number of jobs cached *) + ds_tagline : string; (** Current tagline *) + mutable ds_seen_tags : Tags.t; (** Tags that we have encountered *) + ds_pathname_length : int; (** How much space for displaying pathnames ? *) + ds_tld : tagline_description; (** Description for the tagline *) +};; +(* ***) +(*** display_line, display *) +type display_line = +| Classic +| Sophisticated of sophisticated_display + +type display = { + di_log_level : int; + di_log_channel : (Format.formatter * out_channel) option; + di_channel : out_channel; + di_formatter : Format.formatter; + di_display_line : display_line; + mutable di_finished : bool; +} +;; +(* ***) +(*** various defaults *) +let default_update_interval = 0.05;; +let default_tagline_description = [ + "ocaml", 'O'; + "native", 'N'; + "byte", 'B'; + "program", 'P'; + "pp", 'R'; + "debug", 'D'; + "interf", 'I'; + "link", 'L'; +];; + +(* NOT including spaces *) +let countdown_chars = 8;; +let jobs_chars = 3;; +let jobs_cached_chars = 5;; +let dots = "...";; +let start_target = "STARTING";; +let finish_target = "FINISHED";; +let ticker_chars = 3;; +let ticker_period = 0.25;; +let ticker_animation = [| + "\\"; + "|"; + "/"; + "-"; +|];; +let cached = "*";; +let uncached = " ";; +let cache_chars = 1;; +(* ***) +(*** create_tagline *) +let create_tagline description = String.make (List.length description) '-';; +(* ***) +(*** create *) +let create + ?(channel=stdout) + ?(mode:[`Classic|`Sophisticated] = `Sophisticated) + ?columns:(_columns=75) + ?(description = default_tagline_description) + ?log_file + ?(log_level=1) + () + = + let log_channel = + match log_file with + | None -> None + | Some fn -> + let oc = open_out_gen [Open_text; Open_wronly; Open_creat; Open_trunc] 0o644 fn in + let f = Format.formatter_of_out_channel oc in + Format.fprintf f "*** Starting build.\n"; + Some (f, oc) + in + + let display_line = + match mode with + | `Classic -> Classic + | `Sophisticated -> + (* We assume Unix is not degraded. *) + let n = ANSI.get_columns () in + let tag_chars = List.length description in + Sophisticated + { ds_channel = stdout; + ds_start_time = gettimeofday (); + ds_last_update = 0.0; + ds_last_target = start_target; + ds_last_tags = Tags.empty; + ds_last_cached = false; + ds_changed = false; + ds_update_interval = default_update_interval; + ds_columns = n; + ds_jobs = 0; + ds_jobs_cached = 0; + ds_tagline = create_tagline description; + ds_seen_tags = Tags.empty; + ds_pathname_length = n - + (countdown_chars + 1 + jobs_chars + 1 + jobs_cached_chars + 1 + + cache_chars + 1 + tag_chars + 1 + ticker_chars + 2); + ds_tld = description } + in + { di_log_level = log_level; + di_log_channel = log_channel; + di_channel = channel; + di_formatter = Format.formatter_of_out_channel channel; + di_display_line = display_line; + di_finished = false } +;; +(* ***) +(*** print_time *) +let print_time oc t = + let t = int_of_float t in + let s = t mod 60 in + let m = (t / 60) mod 60 in + let h = t / 3600 in + fp oc "%02d:%02d:%02d" h m s +;; +(* ***) +(*** print_shortened_pathname *) +let print_shortened_pathname length oc u = + assert(length >= 3); + let m = String.length u in + if m <= length then + begin + output_string oc u; + fp oc "%*s" (length - m) "" + end + else + begin + let n = String.length dots in + let k = length - n in + output_string oc dots; + output oc u (m - k) k; + end +(* ***) +(*** Layout + +00000000001111111111222222222233333333334444444444555555555566666666667777777777 +01234567890123456789012345678901234567890123456789012345678901234567890123456789 +HH MM SS XXXX PATHNAME +00:12:31 32 ( 26) ...lp4Filters/Camlp4LocationStripper.cmo * OBn------------- +| | | | | \ tags +| | | \ last target built \ cached ? +| | | +| | \ number of jobs cached +| \ number of jobs +\ elapsed time +cmo mllib +***) +(*** redraw_sophisticated *) +let redraw_sophisticated ds = + let t = gettimeofday () in + let oc = ds.ds_channel in + let dt = t -. ds.ds_start_time in + ds.ds_last_update <- t; + fp oc "%a" ANSI.bol (); + let ticker_phase = (abs (int_of_float (ceil (dt /. ticker_period)))) mod (Array.length ticker_animation) in + let ticker = ticker_animation.(ticker_phase) in + fp oc "%a %-4d (%-4d) %a %s %s %s" + print_time dt + ds.ds_jobs + ds.ds_jobs_cached + (print_shortened_pathname ds.ds_pathname_length) ds.ds_last_target + (if ds.ds_last_cached then cached else uncached) + ds.ds_tagline + ticker; + fp oc "%a%!" ANSI.clear_to_eol () +;; +(* ***) +(*** redraw *) +let redraw = function + | Classic -> () + | Sophisticated ds -> redraw_sophisticated ds +;; +(* ***) +(*** finish_sophisticated *) +let finish_sophisticated ?(how=`Success) ds = + let t = gettimeofday () in + let oc = ds.ds_channel in + let dt = t -. ds.ds_start_time in + match how with + | `Success|`Error -> + fp oc "%a" ANSI.bol (); + fp oc "%s %d target%s (%d cached) in %a." + (if how = `Error then + "Compilation unsuccessful after building" + else + "Finished,") + ds.ds_jobs + (if ds.ds_jobs = 1 then "" else "s") + ds.ds_jobs_cached + print_time dt; + fp oc "%a\n%!" ANSI.clear_to_eol () + | `Quiet -> + fp oc "%a%a%!" ANSI.bol () ANSI.clear_to_eol (); +;; +(* ***) +(*** sophisticated_display *) +let sophisticated_display ds f = + fp ds.ds_channel "%a%a%!" ANSI.bol () ANSI.clear_to_eol (); + f ds.ds_channel +;; +(* ***) +(*** call_if *) +let call_if log_channel f = + match log_channel with + | None -> () + | Some x -> f x +;; +(* ***) +(*** display *) +let display di f = + call_if di.di_log_channel (fun (_, oc) -> f oc); + match di.di_display_line with + | Classic -> f di.di_channel + | Sophisticated ds -> sophisticated_display ds f +;; +(* ***) +(*** finish *) +let finish ?(how=`Success) di = + if not di.di_finished then begin + di.di_finished <- true; + call_if di.di_log_channel + begin fun (fmt, oc) -> + Format.fprintf fmt "# Compilation %ssuccessful.@." (if how = `Error then "un" else ""); + close_out oc + end; + match di.di_display_line with + | Classic -> () + | Sophisticated ds -> finish_sophisticated ~how ds + end +;; +(* ***) +(*** update_tagline_from_tags *) +let update_tagline_from_tags ds = + let tagline = ds.ds_tagline in + let tags = ds.ds_last_tags in + let rec loop i = function + | [] -> + for j = i to String.length tagline - 1 do + tagline.[j] <- '-' + done + | (tag, c) :: rest -> + if Tags.mem tag tags then + tagline.[i] <- Char.uppercase c + else + if Tags.mem tag ds.ds_seen_tags then + tagline.[i] <- Char.lowercase c + else + tagline.[i] <- '-'; + loop (i + 1) rest + in + loop 0 ds.ds_tld; +;; +(* ***) +(*** update_sophisticated *) +let update_sophisticated ds = + let t = gettimeofday () in + let dt = t -. ds.ds_last_update in + if dt > ds.ds_update_interval then + begin + if ds.ds_changed then + begin + update_tagline_from_tags ds; + ds.ds_changed <- false + end; + redraw_sophisticated ds + end + else + () +;; +(* ***) +(*** set_target_sophisticated *) +let set_target_sophisticated ds target tags cached = + ds.ds_changed <- true; + ds.ds_last_target <- target; + ds.ds_last_tags <- tags; + ds.ds_jobs <- 1 + ds.ds_jobs; + if cached then ds.ds_jobs_cached <- 1 + ds.ds_jobs_cached; + ds.ds_last_cached <- cached; + ds.ds_seen_tags <- Tags.union ds.ds_seen_tags ds.ds_last_tags; + update_sophisticated ds +;; + +let print_tags f tags = + let first = ref true in + Tags.iter begin fun tag -> + if !first then begin + first := false; + Format.fprintf f "%s" tag + end else Format.fprintf f ", %s" tag + end tags +;; +(* ***) +(*** update *) +let update di = + match di.di_display_line with + | Classic -> () + | Sophisticated ds -> update_sophisticated ds +;; +(* ***) +(*** event *) +let event di ?(pretend=false) command target tags = + call_if di.di_log_channel + (fun (fmt, _) -> + Format.fprintf fmt "# Target: %s, tags: { %a }\n" target print_tags tags; + Format.fprintf fmt "%s%s@." command (if pretend then " # cached" else "")); + match di.di_display_line with + | Classic -> + if pretend then + (if di.di_log_level >= 2 then Format.fprintf di.di_formatter "[cache hit] %s\n%!" command) + else + (if di.di_log_level >= 1 then Format.fprintf di.di_formatter "%s\n%!" command) + | Sophisticated ds -> + set_target_sophisticated ds target tags pretend; + update_sophisticated ds +;; +(* ***) +(*** dprintf *) +let dprintf ?(log_level=1) di fmt = + if log_level > di.di_log_level then Discard_printf.discard_printf fmt else + match di.di_display_line with + | Classic -> Format.fprintf di.di_formatter fmt + | Sophisticated _ -> + if log_level < 0 then + begin + display di ignore; + Format.fprintf di.di_formatter fmt + end + else + match di.di_log_channel with + | Some (f, _) -> Format.fprintf f fmt + | None -> Discard_printf.discard_printf fmt +(* ***) diff --git a/ocamlbuild/display.mli b/ocamlbuild/display.mli new file mode 100644 index 00000000..de47ca5a --- /dev/null +++ b/ocamlbuild/display.mli @@ -0,0 +1,33 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: display.mli,v 1.1 2007/02/07 08:59:13 ertai Exp $ *) +(* Original author: Berke Durak *) +(* Display *) + +type display +type tagline_description = (string * char) list + +val create : + ?channel:out_channel -> + ?mode:[ `Classic | `Sophisticated ] -> + ?columns:int -> + ?description:tagline_description -> + ?log_file:string -> + ?log_level:int -> + unit -> + display + +val finish : ?how:[`Success|`Error|`Quiet] -> display -> unit +val event : display -> ?pretend:bool -> string -> string -> Tags.t -> unit +val display : display -> (out_channel -> unit) -> unit +val update : display -> unit +val dprintf : ?log_level:int -> display -> ('a, Format.formatter, unit) format -> 'a diff --git a/ocamlbuild/examples/example1/hello.ml b/ocamlbuild/examples/example1/hello.ml new file mode 100644 index 00000000..c85cb66b --- /dev/null +++ b/ocamlbuild/examples/example1/hello.ml @@ -0,0 +1,5 @@ +let _ = + Printf.printf "Hello, %s ! My name is %s\n" + (if Array.length Sys.argv > 1 then Sys.argv.(1) else "stranger") + Sys.argv.(0) +;; diff --git a/ocamlbuild/examples/example2/greet.ml b/ocamlbuild/examples/example2/greet.ml new file mode 100644 index 00000000..ec808891 --- /dev/null +++ b/ocamlbuild/examples/example2/greet.ml @@ -0,0 +1,6 @@ +type how = Nicely | Badly;; + +let greet how who = + match how with Nicely -> Printf.printf "Hello, %s !\n" who + | Badly -> Printf.printf "Oh, here is that %s again.\n" who +;; diff --git a/ocamlbuild/examples/example2/hello.ml b/ocamlbuild/examples/example2/hello.ml new file mode 100644 index 00000000..b48806a3 --- /dev/null +++ b/ocamlbuild/examples/example2/hello.ml @@ -0,0 +1,14 @@ +open Greet + +let _ = + let name = + if Array.length Sys.argv > 1 then + Sys.argv.(1) + else + "stranger" + in + greet + (if name = "Caesar" then Nicely else Badly) + name; + Printf.printf "My name is %s\n" Sys.argv.(0) +;; diff --git a/ocamlbuild/examples/example3/epoch.ml b/ocamlbuild/examples/example3/epoch.ml new file mode 100644 index 00000000..ad95a039 --- /dev/null +++ b/ocamlbuild/examples/example3/epoch.ml @@ -0,0 +1,6 @@ +let _ = + let s = Num.num_of_string (Printf.sprintf "%.0f" (Unix.gettimeofday ())) in + let ps = Num.mult_num (Num.num_of_string "1000000000000") s in + Printf.printf "%s picoseconds have passed since January 1st, 1970.\n" + (Num.string_of_num ps) +;; diff --git a/ocamlbuild/examples/example3/make.sh b/ocamlbuild/examples/example3/make.sh new file mode 100755 index 00000000..3588a713 --- /dev/null +++ b/ocamlbuild/examples/example3/make.sh @@ -0,0 +1,32 @@ +#!/bin/sh + +set -e + +TARGET=epoch +FLAGS="-libs unix,nums" +OCAMLBUILD=ocamlbuild + +ocb() +{ + $OCAMLBUILD $FLAGS $* +} + +rule() { + case $1 in + clean) ocb -clean;; + native) ocb $TARGET.native;; + byte) ocb $TARGET.byte;; + all) ocb $TARGET.native $TARGET.byte;; + depend) echo "Not needed.";; + *) echo "Unknown action $1";; + esac; +} + +if [ $# -eq 0 ]; then + rule all +else + while [ $# -gt 0 ]; do + rule $1; + shift + done +fi diff --git a/ocamlbuild/executor.ml b/ocamlbuild/executor.ml new file mode 100644 index 00000000..5108d50c --- /dev/null +++ b/ocamlbuild/executor.ml @@ -0,0 +1,341 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: executor.ml,v 1.2.4.1 2007/03/05 15:11:23 pouillar Exp $ *) +(* Original author: Berke Durak *) +(* Executor *) + +open Unix;; + +module Exit_codes = struct + let rc_subcommand_failed = 10 + let rc_subcommand_got_signal = 11 + let rc_io_error = 12 + let rc_exceptional_condition = 13 +end;; + +type task = (string * (unit -> unit));; + +type job = { + job_id : int * int; + job_command : string; + job_next : (string * (unit -> unit)) list; + job_result : bool ref; (* Result of this sequence group *) + job_stdout : in_channel; + job_stdin : out_channel; + job_stderr : in_channel; + job_buffer : Buffer.t; + mutable job_dying : bool; +};; + +module JS = Set.Make(struct type t = job let compare = compare end);; +module FDM = Map.Make(struct type t = file_descr let compare = compare end);; + +let sf = Printf.sprintf;; +let fp = Printf.fprintf;; + +(*** print_unix_status *) +(* FIXME never called *) +let print_unix_status oc = function + | WEXITED x -> fp oc "exit %d" x + | WSIGNALED i -> fp oc "signal %d" i + | WSTOPPED i -> fp oc "stop %d" i +;; +(* ***) +(*** exit *) +let exit rc = + raise (Ocamlbuild_pack.My_std.Exit_with_code rc) +;; +(* ***) +(*** print_job_id *) +let print_job_id oc (x,y) = fp oc "%d.%d" x y;; +(* ***) +(*** output_lines *) +let output_lines prefix oc buffer = + let u = Buffer.contents buffer in + let m = String.length u in + let output_line i j = + output_string oc prefix; + output oc u i (j - i); + output_char oc '\n' + in + let rec loop i = + if i = m then + () + else + begin + try + let j = String.index_from u i '\n' in + output_line i j; + loop (j + 1) + with + | Not_found -> + output_line i m + end + in + loop 0 +;; +(* ***) +(*** execute *) +(* XXX: Add test for non reentrancy *) +let execute + ?(max_jobs=max_int) + ?(ticker=ignore) + ?(period=0.1) + ?(display=(fun f -> f Pervasives.stdout)) + (commands : task list list) + = + let batch_id = ref 0 in + let env = environment () in + let jobs = ref JS.empty in + let jobs_active = ref 0 in + let jobs_to_terminate = Queue.create () in + let commands_to_execute = Queue.create () in + let all_ok = ref true in + let results = + List.map (fun tasks -> + let result = ref false in + Queue.add (tasks, result) commands_to_execute; + result) + commands + in + let outputs = ref FDM.empty in + let doi = descr_of_in_channel in + let doo = descr_of_out_channel in + (*** compute_fds *) + let compute_fds = + let fds = ref ([], [], []) in + let prev_jobs = ref JS.empty in + fun () -> + if not (!prev_jobs == !jobs) then + begin + prev_jobs := !jobs; + fds := + JS.fold + begin fun job (rfds, wfds, xfds) -> + let ofd = doi job.job_stdout + and ifd = doo job.job_stdin + and efd = doi job.job_stderr + in + (ofd :: efd :: rfds, wfds, ofd :: ifd :: efd :: xfds) + end + !jobs + ([], [], []) + end; + !fds + in + (* ***) + (*** add_job *) + let add_job (cmd, action) rest result id = + (*display begin fun oc -> fp oc "Job %a is %s\n%!" print_job_id id cmd; end;*) + action (); + let (stdout', stdin', stderr') = open_process_full cmd env in + incr jobs_active; + set_nonblock (doi stdout'); + set_nonblock (doi stderr'); + let job = + { job_id = id; + job_command = cmd; + job_next = rest; + job_result = result; + job_stdout = stdout'; + job_stdin = stdin'; + job_stderr = stderr'; + job_buffer = Buffer.create 1024; + job_dying = false } + in + outputs := FDM.add (doi stdout') job (FDM.add (doi stderr') job !outputs); + jobs := JS.add job !jobs; + in + (* ***) + (*** add_some_jobs *) + let add_some_jobs () = + let (tasks, result) = Queue.take commands_to_execute in + match tasks with + | [] -> result := false + | task :: rest -> + let b_id = !batch_id in + incr batch_id; + add_job task rest result (b_id, 0) + in + (* ***) + (*** terminate *) + let terminate ?(continue=true) job = + if not job.job_dying then + begin + job.job_dying <- true; + Queue.add (job, continue) jobs_to_terminate + end + else + () + in + (* ***) + (*** add_more_jobs_if_possible *) + let add_more_jobs_if_possible () = + while !jobs_active < max_jobs && not (Queue.is_empty commands_to_execute) do + add_some_jobs () + done + in + (* ***) + (*** do_read *) + let do_read = + let u = String.create 4096 in + fun ?(loop=false) fd job -> + (*if job.job_dying then + () + else*) + try + let rec iteration () = + let m = + try + read fd u 0 (String.length u) + with + | Unix.Unix_error(_,_,_) -> 0 + in + if m = 0 then + if job.job_dying then + () + else + terminate job + else + begin + Buffer.add_substring job.job_buffer u 0 m; + if loop then + iteration () + else + () + end + in + iteration () + with + | x -> + display + begin fun oc -> + fp oc "Exception %s while reading output of command %S\n%!" job.job_command + (Printexc.to_string x); + end; + exit Exit_codes.rc_io_error + in + (* ***) + (*** process_jobs_to_terminate *) + let process_jobs_to_terminate () = + while not (Queue.is_empty jobs_to_terminate) do + ticker (); + let (job, continue) = Queue.take jobs_to_terminate in + + (*display begin fun oc -> fp oc "Terminating job %a\n%!" print_job_id job.job_id; end;*) + + decr jobs_active; + do_read ~loop:true (doi job.job_stdout) job; + do_read ~loop:true (doi job.job_stderr) job; + outputs := FDM.remove (doi job.job_stdout) (FDM.remove (doi job.job_stderr) !outputs); + jobs := JS.remove job !jobs; + let status = close_process_full (job.job_stdout, job.job_stdin, job.job_stderr) in + + let shown = ref false in + + let show_command () = + if !shown then + () + else + display + begin fun oc -> + shown := true; + fp oc "+ %s\n" job.job_command; + output_lines "" oc job.job_buffer + end + in + if Buffer.length job.job_buffer > 0 then show_command (); + begin + match status with + | Unix.WEXITED 0 -> + begin + if continue then + begin + match job.job_next with + | [] -> job.job_result := true + | task :: rest -> + let (b_id, s_id) = job.job_id in + add_job task rest job.job_result (b_id, s_id + 1) + end + else + all_ok := false; + end + | Unix.WEXITED rc -> + show_command (); + display (fun oc -> fp oc "Command exited with code %d.\n" rc); + all_ok := false; + exit Exit_codes.rc_subcommand_failed + | Unix.WSTOPPED s | Unix.WSIGNALED s -> + show_command (); + all_ok := false; + display (fun oc -> fp oc "Command got signal %d.\n" s); + exit Exit_codes.rc_subcommand_got_signal + end + done + in + (* ***) + (*** terminate_all_jobs *) + let terminate_all_jobs () = + JS.iter (terminate ~continue:false) !jobs + in + (* ***) + (*** loop *) + let rec loop () = + (*display (fun oc -> fp oc "Total %d jobs\n" !jobs_active);*) + process_jobs_to_terminate (); + add_more_jobs_if_possible (); + if JS.is_empty !jobs then + () + else + begin + let (rfds, wfds, xfds) = compute_fds () in + ticker (); + let (chrfds, chwfds, chxfds) = select rfds wfds xfds period in + List.iter + begin fun (fdlist, hook) -> + List.iter + begin fun fd -> + try + let job = FDM.find fd !outputs in + ticker (); + hook fd job + with + | Not_found -> () (* XXX *) + end + fdlist + end + [chrfds, do_read ~loop:false; + chwfds, (fun _ _ -> ()); + chxfds, + begin fun _ _job -> + (*display (fun oc -> fp oc "Exceptional condition on command %S\n%!" job.job_command); + exit Exit_codes.rc_exceptional_condition*) + () (* FIXME *) + end]; + loop () + end + in + try + loop (); + None + with + | x -> + begin + try + terminate_all_jobs () + with + | x' -> + display (fun oc -> fp oc "Extra exception %s\n%!" (Printexc.to_string x')) + end; + Some(List.map (!) results, x) +;; +(* ***) diff --git a/ocamlbuild/executor.mli b/ocamlbuild/executor.mli new file mode 100644 index 00000000..cb1a1c98 --- /dev/null +++ b/ocamlbuild/executor.mli @@ -0,0 +1,35 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: executor.mli,v 1.1 2007/02/07 08:59:13 ertai Exp $ *) +(* Original author: Berke Durak *) +(* Executor *) + +(** UNIX-specific module for running tasks in parallel and properly multiplexing their outputs. *) + +(** [execute ~ticker ~period ~display commands] will execute the commands in [commands] + in parallel, correctly multiplexing their outputs. A command is a pair [(cmd, action)] + where [cmd] is a shell command string, and [action] is a thunk that is to be called just + before [cmd] is about to be executed. If specified, it will call [ticker] at least every [period] + seconds. If specified, it will call [display f] when it wishes to print something; + [display] should then call [f] with then channel on which [f] should print. + Note that [f] must be idempotent as it may well be called twice, once for the log file, + once for the actual output. + If one of the commands fails, it will exit with an appropriate error code, + calling [cleanup] before. +*) +val execute : + ?max_jobs:int -> + ?ticker:(unit -> unit) -> + ?period:float -> + ?display:((out_channel -> unit) -> unit) -> + ((string * (unit -> unit)) list list) -> + (bool list * exn) option diff --git a/ocamlbuild/fda.ml b/ocamlbuild/fda.ml new file mode 100644 index 00000000..76a4c56d --- /dev/null +++ b/ocamlbuild/fda.ml @@ -0,0 +1,81 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: fda.ml,v 1.3 2007/02/22 15:56:23 ertai Exp $ *) +(* Original author: Berke Durak *) +(* FDA *) + +open Log +open Hygiene +;; + +exception Exit_hygiene_failed +;; + +let laws = + [ + { law_name = "Leftover Ocaml compilation files"; + law_rules = [Not ".cmo"; Not ".cmi"; Not ".cmx"; Not ".cma"; Not ".cmxa"]; + law_penalty = Fail }; + { law_name = "Leftover Ocaml type annotation files"; + law_rules = [Not ".annot"]; + law_penalty = Warn }; + { law_name = "Leftover object files"; + law_rules = [Not ".o"; Not ".a"; Not ".so"; Not ".obj"; Not ".lib"; Not ".dll"]; + law_penalty = Fail }; + { law_name = "Leftover ocamlyacc-generated files"; + law_rules = [Implies_not(".mly",".ml"); Implies_not(".mly",".mli")]; + law_penalty = Fail }; + { law_name = "Leftover ocamllex-generated files"; + law_rules = [Implies_not(".mll",".ml")]; + law_penalty = Fail }; + { law_name = "Leftover dependency files"; + law_rules = [Not ".ml.depends"; Not ".mli.depends"]; + law_penalty = Fail } + ] + +let inspect entry = + dprintf 5 "Doing sanity checks"; + let evil = ref false in + match Hygiene.check + ?sanitize: + begin + if !Options.sanitize then + Some(!Options.sanitization_script) + else + None + end + laws entry + with + | [] -> () + | stuff -> + List.iter + begin fun (law, msgs) -> + Printf.printf "%s: %s:\n" + (match law.law_penalty with + | Warn -> "Warning" + | Fail -> + if not !evil then + begin + Printf.printf "IMPORTANT: I cannot work with leftover compiled files.\n%!"; + evil := true + end; + "ERROR") + law.law_name; + List.iter + begin fun msg -> + Printf.printf " %s\n" msg + end + msgs + end + stuff; + if !evil then raise Exit_hygiene_failed; +;; diff --git a/ocamlbuild/fda.mli b/ocamlbuild/fda.mli new file mode 100644 index 00000000..97160345 --- /dev/null +++ b/ocamlbuild/fda.mli @@ -0,0 +1,18 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: fda.mli,v 1.2 2007/02/08 16:53:39 ertai Exp $ *) +(* Original author: Berke Durak *) +(* Fda *) + +exception Exit_hygiene_failed + +val inspect : bool Slurp.entry -> unit diff --git a/ocamlbuild/flags.ml b/ocamlbuild/flags.ml new file mode 100644 index 00000000..1696b323 --- /dev/null +++ b/ocamlbuild/flags.ml @@ -0,0 +1,45 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: flags.ml,v 1.2 2007/02/26 17:05:30 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +open Command +open Bool (* FIXME remove me *) +open Tags.Operators +let all_flags = ref [] + +let of_tags tags = + S begin + List.fold_left begin fun acc (xtags, xflags) -> + if Tags.does_match tags xtags then xflags :: acc + else acc + end [] !all_flags + end + +let () = Command.tag_handler := of_tags + +let of_tag_list x = of_tags (Tags.of_list x) + +let set_flags tags flags = + all_flags := (tags, flags) :: !all_flags + +let flag tags flags = set_flags (Tags.of_list tags) flags + +let add x xs = x :: xs +let remove me = List.filter (fun x -> me <> x) +let to_spec l = + S begin + List.fold_right begin fun (x, y) acc -> + A ("-"^x) :: A y :: acc + end l [] + end + +let get_flags () = !all_flags diff --git a/ocamlbuild/flags.mli b/ocamlbuild/flags.mli new file mode 100644 index 00000000..8901b709 --- /dev/null +++ b/ocamlbuild/flags.mli @@ -0,0 +1,23 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: flags.mli,v 1.2 2007/02/26 17:05:30 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +val of_tags : Tags.t -> Command.spec +val of_tag_list : Tags.elt list -> Command.spec +val flag : Tags.elt list -> Command.spec -> unit +val add : 'a -> 'a list -> 'a list +val remove : 'a -> 'a list -> 'a list +val to_spec : (string * string) list -> Command.spec + +(** For system use only *) + +val get_flags : unit -> (Tags.t * Command.spec) list diff --git a/ocamlbuild/glob.ml b/ocamlbuild/glob.ml new file mode 100644 index 00000000..ad446871 --- /dev/null +++ b/ocamlbuild/glob.ml @@ -0,0 +1,409 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: glob.ml,v 1.2 2007/03/01 14:40:11 pouillar Exp $ *) +(* Original author: Berke Durak *) +(* Glob *) +open My_std;; +open Bool;; +include Glob_ast;; +open Glob_lexer;; + +let sf = Printf.sprintf;; + +let brute_limit = 10;; + +(*** string_of_token *) +let string_of_token = function +| ATOM _ -> "ATOM" +| AND -> "AND" +| OR -> "OR" +| NOT -> "NOT" +| LPAR -> "LPAR" +| RPAR -> "RPAR" +| TRUE -> "TRUE" +| FALSE -> "FALSE" +| EOF -> "EOF" +;; +(* ***) +(*** match_character_class *) +let match_character_class cl c = + Bool.eval + begin function (c1,c2) -> + c1 <= c && c <= c2 + end + cl +;; +(* ***) +(*** NFA *) +module NFA = + struct + type transition = + | QCLASS of character_class + | QEPSILON + ;; + + module IS = Set.Make(struct type t = int let compare = compare let print = Format.pp_print_int end);; + module ISM = Map.Make(struct type t = IS.t let compare = IS.compare let print = IS.print end);; + + type machine = { + mc_qi : IS.t; + mc_table : (character_class * IS.t) list array; + mc_qf : int; + mc_power_table : (char, IS.t ISM.t) Hashtbl.t + } + + (*** build' *) + let build' p = + let count = ref 0 in + let transitions = ref [] in + let epsilons : (int * int) list ref = ref [] in + let state () = let id = !count in incr count; id in + let ( --> ) q1 t q2 = + match t with + | QEPSILON -> epsilons := (q1,q2) :: !epsilons; q1 + | QCLASS cl -> transitions := (q1,cl,q2) :: !transitions; q1 + in + (* Construit les transitions correspondant au motif donné et arrivant + * sur l'état qf. Retourne l'état d'origine. *) + let rec loop qf = function + | Epsilon -> qf + | Word u -> + let m = String.length u in + let q0 = state () in + let rec loop q i = + if i = m then + q0 + else + begin + let q' = + if i = m - 1 then + qf + else + state () + in + let _ = (q --> QCLASS(Atom(u.[i], u.[i]))) q' in + loop q' (i + 1) + end + in + loop q0 0 + | Class cl -> + let q1 = state () in + (q1 --> QCLASS cl) qf + | Star p -> + (* The fucking Kleene star *) + let q2 = state () in + let q1 = loop q2 p in (* q1 -{p}-> q2 *) + let _ = (q1 --> QEPSILON) qf in + let _ = (q2 --> QEPSILON) q1 in + let _ = (q2 --> QEPSILON) q1 in + q1 + | Concat(p1,p2) -> + let q12 = state () in + let q1 = loop q12 p1 in (* q1 -{p1}-> q12 *) + let q2 = loop qf p2 in (* q2 -{p2}-> qf *) + let _ = (q12 --> QEPSILON) q2 in + q1 + | Union pl -> + let qi = state () in + List.iter + begin fun p -> + let q = loop qf p in (* q -{p2}-> qf *) + let _ = (qi --> QEPSILON) q in (* qi -{}---> q *) + () + end + pl; + qi + in + let qf = state () in + let qi = loop qf p in + let m = !count in + + (* Compute epsilon closure *) + let graph = Array.make m IS.empty in + List.iter + begin fun (q,q') -> + graph.(q) <- IS.add q' graph.(q) + end + !epsilons; + + let closure = Array.make m IS.empty in + let rec transitive past = function + | [] -> past + | q :: future -> + let past' = IS.add q past in + let future' = + IS.fold + begin fun q' future' -> + (* q -{}--> q' *) + if IS.mem q' past' then + future' + else + q' :: future' + end + graph.(q) + future + in + transitive past' future' + in + for i = 0 to m - 1 do + closure.(i) <- transitive IS.empty [i] (* O(n^2), I know *) + done; + + (* Finally, build the table *) + let table = Array.make m [] in + List.iter + begin fun (q,t,q') -> + table.(q) <- (t, closure.(q')) :: table.(q) + end + !transitions; + + (graph, closure, + { mc_qi = closure.(qi); + mc_table = table; + mc_qf = qf; + mc_power_table = Hashtbl.create 37 }) + ;; + let build x = let (_,_, machine) = build' x in machine;; + (* ***) + (*** run *) + let run ?(trace=false) machine u = + let m = String.length u in + let apply qs c = + try + let t = Hashtbl.find machine.mc_power_table c in + ISM.find qs t + with + | Not_found -> + let qs' = + IS.fold + begin fun q qs' -> + List.fold_left + begin fun qs' (cl,qs'') -> + if match_character_class cl c then + IS.union qs' qs'' + else + qs' + end + qs' + machine.mc_table.(q) + end + qs + IS.empty + in + let t = + try + Hashtbl.find machine.mc_power_table c + with + | Not_found -> ISM.empty + in + Hashtbl.replace machine.mc_power_table c (ISM.add qs qs' t); + qs' + in + let rec loop qs i = + if IS.is_empty qs then + false + else + begin + if i = m then + IS.mem machine.mc_qf qs + else + begin + let c = u.[i] in + if trace then + begin + Printf.printf "%d %C {" i c; + IS.iter (fun q -> Printf.printf " %d" q) qs; + Printf.printf " }\n%!" + end; + let qs' = apply qs c in + loop qs' (i + 1) + end + end + in + loop machine.mc_qi 0 + ;; + (* ***) + end +;; +(* ***) +(*** Brute *) +module Brute = + struct + exception Succeed;; + exception Fail;; + exception Too_hard;; + + (*** match_pattern *) + let match_pattern counter p u = + let m = String.length u in + (** [loop i n p] returns [true] iff the word [u.(i .. i + n - 1)] is in the + ** language generated by the pattern [p]. + ** We must have 0 <= i and i + n <= m *) + let rec loop (i,n,p) = + assert (0 <= i && 0 <= n && i + n <= m); + incr counter; + if !counter >= brute_limit then raise Too_hard; + match p with + | Word v -> + String.length v = n && + begin + let rec check j = j = n or (v.[j] = u.[i + j] && check (j + 1)) + in + check 0 + end + | Epsilon -> n = 0 + | Star(Class True) -> true + | Star(Class cl) -> + let rec check k = + if k = n then + true + else + (match_character_class cl u.[i + k]) && check (k + 1) + in + check 0 + | Star p -> raise Too_hard + | Class cl -> n = 1 && match_character_class cl u.[i] + | Concat(p1,p2) -> + let rec scan j = + j <= n && ((loop (i,j,p1) && loop (i+j, n - j,p2)) || scan (j + 1)) + in + scan 0 + | Union pl -> List.exists (fun p' -> loop (i,n,p')) pl + in + loop (0,m,p) + ;; + (* ***) +end +;; +(* ***) +(*** fast_pattern, globber *) +type fast_pattern = +| Brute of int ref * pattern +| Machine of NFA.machine +;; + +type globber = fast_pattern ref atom Bool.boolean;; +(* ***) +(*** add_dir *) +let add_dir dir x = + match dir with + | None -> x + | Some(dir) -> + match x with + | Constant(s) -> + Constant(My_std.filename_concat dir s) + | Pattern(p) -> + Pattern(Concat(Word(My_std.filename_concat dir ""), p)) +;; +(* ***) +(*** add_ast_dir *) +let add_ast_dir dir x = + match dir with + | None -> x + | Some dir -> + let slash = Class(Atom('/','/')) in + let any = Class True in + let q = Union[Epsilon; Concat(slash, Star any)] in (* ( /** )? *) + And[Atom(Pattern(ref (Brute(ref 0, Concat(Word dir, q))))); x] +;; +(* ***) +(*** parse *) +let parse ?dir u = + let l = Lexing.from_string u in + let tok = ref None in + let f = + fun () -> + match !tok with + | None -> token l + | Some x -> + tok := None; + x + in + let g t = + match !tok with + | None -> tok := Some t + | Some t' -> + raise (Parse_error(sf "Trying to unput token %s while %s is active" (string_of_token t) (string_of_token t'))) + in + let read x = + let y = f () in + if x = y then + () + else + raise (Parse_error(sf "Unexpected token, expecting %s, got %s" (string_of_token x) (string_of_token y))) + in + let rec atomizer continuation = match f () with + | NOT -> atomizer (fun x -> continuation (Not x)) + | ATOM x -> + begin + let a = + match add_dir dir x with + | Constant u -> Constant u + | Pattern p -> Pattern(ref (Brute(ref 0, p))) + in + continuation (Atom a) + end + | TRUE -> continuation True + | FALSE -> continuation False + | LPAR -> + let y = parse_s () in + read RPAR; + continuation y + | t -> raise (Parse_error(sf "Unexpected token %s in atomizer" (string_of_token t))) + and parse_s1 x = match f () with + | OR -> let y = parse_s () in Or[x; y] + | AND -> parse_t x + | t -> g t; x + and parse_t1 x y = match f () with + | OR -> let z = parse_s () in Or[And[x;y]; z] + | AND -> parse_t (And[x;y]) + | t -> g t; And[x;y] + and parse_s () = atomizer parse_s1 + and parse_t x = atomizer (parse_t1 x) + in + let x = parse_s () in + read EOF; + add_ast_dir dir x +;; +(* ***) +(*** eval *) +let eval g u = + Bool.eval + begin function + | Constant v -> u = v + | Pattern kind -> + match !kind with + | Brute(count, p) -> + begin + let do_nfa () = + let m = NFA.build p in + kind := Machine m; + NFA.run m u + in + if !count >= brute_limit then + do_nfa () + else + try + Brute.match_pattern count p u + with + | Brute.Too_hard -> do_nfa () + end + | Machine m -> NFA.run m u + end + g +(* ***) +(*** Debug *) +(*let (Atom(Pattern x)) = parse "<{a,b}>";; +#install_printer IS.print;; +#install_printer ISM.print;; +let (graph, closure, machine) = build' x;;*) +(* ***) diff --git a/ocamlbuild/glob.mli b/ocamlbuild/glob.mli new file mode 100644 index 00000000..d4332fc6 --- /dev/null +++ b/ocamlbuild/glob.mli @@ -0,0 +1,18 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: glob.mli,v 1.1 2007/02/07 08:59:13 ertai Exp $ *) +(* Original author: Berke Durak *) +(* Glob *) + +(** A self-contained module implementing extended shell glob patterns who have an expressive power + equal to boolean combinations of regular expressions. *) +include Signatures.GLOB diff --git a/ocamlbuild/glob_ast.ml b/ocamlbuild/glob_ast.ml new file mode 100644 index 00000000..ff4a60d2 --- /dev/null +++ b/ocamlbuild/glob_ast.ml @@ -0,0 +1,31 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: glob_ast.ml,v 1.1 2007/02/07 08:59:13 ertai Exp $ *) +(* Original author: Berke Durak *) +(* Glob_ast *) + +exception Parse_error of string;; + +type pattern = +| Epsilon +| Star of pattern (* The fucking Kleene star *) +| Class of character_class +| Concat of pattern * pattern +| Union of pattern list +| Word of string +and character_class = (char * char) Bool.boolean +;; + +type 'pattern atom = +| Constant of string +| Pattern of 'pattern +;; diff --git a/ocamlbuild/glob_ast.mli b/ocamlbuild/glob_ast.mli new file mode 100644 index 00000000..15783d78 --- /dev/null +++ b/ocamlbuild/glob_ast.mli @@ -0,0 +1,25 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: glob_ast.mli,v 1.1 2007/02/07 08:59:13 ertai Exp $ *) +(* Original author: Berke Durak *) +(* Glob_ast *) + +exception Parse_error of string +type pattern = +| Epsilon +| Star of pattern +| Class of character_class +| Concat of pattern * pattern +| Union of pattern list +| Word of string +and character_class = (char * char) Bool.boolean +type 'pattern atom = Constant of string | Pattern of 'pattern diff --git a/ocamlbuild/glob_lexer.mli b/ocamlbuild/glob_lexer.mli new file mode 100644 index 00000000..eea41c22 --- /dev/null +++ b/ocamlbuild/glob_lexer.mli @@ -0,0 +1,27 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: glob_lexer.mli,v 1.1 2007/02/07 08:59:13 ertai Exp $ *) +(* Original author: Berke Durak *) +open Glob_ast + +type token = +| ATOM of pattern atom +| AND +| OR +| NOT +| LPAR +| RPAR +| TRUE +| FALSE +| EOF + +val token : Lexing.lexbuf -> token diff --git a/ocamlbuild/glob_lexer.mll b/ocamlbuild/glob_lexer.mll new file mode 100644 index 00000000..64b6b159 --- /dev/null +++ b/ocamlbuild/glob_lexer.mll @@ -0,0 +1,114 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: glob_lexer.mll,v 1.1 2007/02/07 08:59:13 ertai Exp $ *) +(* Original author: Berke Durak *) +(* Glob *) +{ +open Bool;; +open Glob_ast;; + +type token = +| ATOM of pattern atom +| AND +| OR +| NOT +| LPAR +| RPAR +| TRUE +| FALSE +| EOF +;; + +let sf = Printf.sprintf;; + +let concat_patterns p1 p2 = + match (p1,p2) with + | (Epsilon,_) -> p2 + | (_,Epsilon) -> p1 + | (_,_) -> Concat(p1,p2) +;; + +let slash = Class(Atom('/','/'));; +let not_slash = Class(Not(Atom('/','/')));; +let any = Class True;; +} + +let pattern_chars = ['a'-'z']|['A'-'Z']|'_'|'-'|['0'-'9']|'.' +let space_chars = [' ' '\t' '\n' '\r' '\012'] + +rule token = parse +| '<' { ATOM(Pattern(let (p,_) = parse_pattern ['>'] Epsilon lexbuf in p)) } +| '"' { ATOM(Constant(parse_string (Buffer.create 32) lexbuf)) } +| "and"|"AND"|"&" { AND } +| "or"|"OR"|"|" { OR } +| "not"|"NOT"|"~" { NOT } +| "true"|"1" { TRUE } +| "false"|"0" { FALSE } +| "(" { LPAR } +| ")" { RPAR } +| space_chars+ { token lexbuf } +| eof { EOF } + +and parse_pattern eof_chars p = parse +| (pattern_chars+ as u) { parse_pattern eof_chars (concat_patterns p (Word u)) lexbuf } +| '{' + { + let rec loop pl = + let (p',c) = parse_pattern ['}';','] Epsilon lexbuf in + let pl = p' :: pl in + if c = ',' then + loop pl + else + parse_pattern eof_chars (concat_patterns p (Union pl)) lexbuf + in + loop [] + } +| "[^" + { + let cl = Not(Or(parse_class [] lexbuf)) in + parse_pattern eof_chars (concat_patterns p (Class cl)) lexbuf + } +| '[' + { + let cl = Or(parse_class [] lexbuf) in + parse_pattern eof_chars (concat_patterns p (Class cl)) lexbuf + } +| "/**/" (* / | /\Sigma^*/ *) + { let q = Union[slash; Concat(slash, Concat(Star any, slash)) ] in + parse_pattern eof_chars (concat_patterns p q) lexbuf } +| "/**" (* \varepsilon | /\Sigma^* *) + { let q = Union[Epsilon; Concat(slash, Star any)] in + parse_pattern eof_chars (concat_patterns p q) lexbuf } +| "**/" (* \varepsilon | \Sigma^*/ *) + { let q = Union[Epsilon; Concat(Star any, slash)] in + parse_pattern eof_chars (concat_patterns p q) lexbuf } +| "**" { raise (Parse_error("Ambiguous ** pattern not allowed unless surrounded by one or more slashes")) } +| '*' { parse_pattern eof_chars (concat_patterns p (Star not_slash)) lexbuf } +| '/' { parse_pattern eof_chars (concat_patterns p slash) lexbuf } +| '?' { parse_pattern eof_chars (concat_patterns p (Class True)) lexbuf } +| _ as c + { if List.mem c eof_chars then + (p,c) + else + raise (Parse_error(sf "Unexpected character %C in glob pattern" c)) + } + +and parse_string b = parse +| "\"" { Buffer.contents b } +| "\\\"" { Buffer.add_char b '"'; parse_string b lexbuf } +| [^'"' '\\']+ as u { Buffer.add_string b u; parse_string b lexbuf } + +and parse_class cl = parse +| ']' { cl } +| "-]" { ((Atom('-','-'))::cl) } +| (_ as c1) '-' (_ as c2) { parse_class ((Atom(c1,c2))::cl) lexbuf } +| _ as c { parse_class ((Atom(c,c))::cl) lexbuf } diff --git a/ocamlbuild/hooks.ml b/ocamlbuild/hooks.ml new file mode 100644 index 00000000..0697ef47 --- /dev/null +++ b/ocamlbuild/hooks.ml @@ -0,0 +1,26 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: hooks.ml,v 1.1 2007/02/07 08:59:13 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +type message = + | Before_hygiene + | After_hygiene + | Before_options + | After_options + | Before_rules + | After_rules + +let hooks = ref ignore + +let setup_hooks f = hooks := f + +let call_hook m = !hooks m diff --git a/ocamlbuild/hooks.mli b/ocamlbuild/hooks.mli new file mode 100644 index 00000000..eb0f6b64 --- /dev/null +++ b/ocamlbuild/hooks.mli @@ -0,0 +1,23 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: hooks.mli,v 1.1 2007/02/07 08:59:13 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +type message = + | Before_hygiene + | After_hygiene + | Before_options + | After_options + | Before_rules + | After_rules + +val setup_hooks : (message -> unit) -> unit +val call_hook : message -> unit diff --git a/ocamlbuild/hygiene.ml b/ocamlbuild/hygiene.ml new file mode 100644 index 00000000..50e58055 --- /dev/null +++ b/ocamlbuild/hygiene.ml @@ -0,0 +1,165 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: hygiene.ml,v 1.4 2007/02/22 16:51:39 ertai Exp $ *) +(* Original author: Berke Durak *) +(* Hygiene *) +open My_std +open Slurp + +exception Exit_hygiene_violations + +type rule = +| Implies_not of pattern * pattern +| Not of pattern +and pattern = suffix +and suffix = string + +type penalty = Warn | Fail + +type law = { + law_name : string; + law_rules : rule list; + law_penalty : penalty +} + +let list_collect f l = + let rec loop result = function + | [] -> List.rev result + | x :: rest -> + match f x with + | None -> loop result rest + | Some y -> loop (y :: result) rest + in + loop [] l + +let list_none_for_all f l = + let rec loop = function + | [] -> None + | x :: rest -> + match f x with + | None -> loop rest + | y -> y + in + loop l + +let sf = Printf.sprintf + +module SS = Set.Make(String);; + +let check ?sanitize laws entry = + let penalties = ref [] in + let microbes = ref SS.empty in + let remove path name = + if sanitize <> None then + microbes := SS.add (filename_concat path name) !microbes + in + let check_rule = fun entries -> function + | Not suffix -> + list_collect + begin function + | File(path, name, _, true) -> + if Filename.check_suffix name suffix then + begin + remove path name; + Some(sf "File %s in %s has suffix %s" name path suffix) + end + else + None + | File _ | Dir _| Error _ | Nothing -> None + end + entries + | Implies_not(suffix1, suffix2) -> + list_collect + begin function + | File(path, name, _, true) -> + if Filename.check_suffix name suffix1 then + begin + let base = Filename.chop_suffix name suffix1 in + let name' = base ^ suffix2 in + if List.exists + begin function + | File(_, name'', _, true) -> name' = name'' + | File _ | Dir _ | Error _ | Nothing -> false + end + entries + then + begin + remove path name'; + Some(sf "Files %s and %s should not be together in %s" name name' path) + end + else + None + end + else + None + | File _ | Dir _ | Error _ | Nothing -> None + end + entries + in + let rec check_entry = function + | Dir(_,_,_,true,entries) -> + List.iter + begin fun law -> + match List.concat (List.map (check_rule !*entries) law.law_rules) with + | [] -> () + | explanations -> + penalties := (law, explanations) :: !penalties + end + laws; + List.iter check_entry !*entries + | Dir _ | File _ | Error _ | Nothing -> () + in + check_entry entry; + begin + let microbes = !microbes in + if not (SS.is_empty microbes) then + begin + match sanitize with + | None -> + Log.eprintf "sanitize: the following are files that should probably not be in your\n\ + source tree:\n"; + SS.iter + begin fun fn -> + Log.eprintf " %s" fn + end + microbes; + Log.eprintf "Remove them manually, don't use the -no-sanitize option, use -no-hygiene, or\n\ + define hygiene exceptions using the tags or plugin mechanism.\n"; + raise Exit_hygiene_violations + | Some fn -> + let m = SS.cardinal microbes in + Log.eprintf + "@[SANITIZE:@ a@ total@ of@ %d@ file%s@ that@ should@ probably\ + @ not@ be@ in@ your@ source@ tree@ has@ been@ found.\ + @ A@ script@ shell@ file@ %S@ is@ being@ created.\ + @ Check@ this@ script@ and@ run@ it@ to@ remove@ unwanted@ files\ + @ or@ use@ other@ options@ (such@ as@ defining@ hygiene@ exceptions\ + @ or@ using@ the@ -no-hygiene@ option).@]" + m (if m = 1 then "" else "s") fn; + let oc = open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o755 fn in + let fp = Printf.fprintf in + fp oc "#!/bin/sh\n\ + # File generated by ocamlbuild\n\ + \n"; + SS.iter + begin fun fn -> + fp oc "rm -f %s\n" (Shell.quote_filename_if_needed fn) + end + microbes; + (* Also clean itself *) + fp oc "# Also clean the script itself\n"; + fp oc "rm -f %s\n" (Shell.quote_filename_if_needed fn); + close_out oc + end; + !penalties + end +;; diff --git a/ocamlbuild/hygiene.mli b/ocamlbuild/hygiene.mli new file mode 100644 index 00000000..b1e18d99 --- /dev/null +++ b/ocamlbuild/hygiene.mli @@ -0,0 +1,46 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: hygiene.mli,v 1.3 2007/02/22 15:56:23 ertai Exp $ *) +(* Original author: Berke Durak *) +(* Hygiene *) + +(** Module for checking that the source tree is not polluted by object files. *) + +(** Sanity rules to abide. Not to be confused with compilation rules. *) +type rule = + Implies_not of pattern * pattern (** The rule [Implies_not(".mll",".ml")] is broken if there is a file [foo.mll] + together with a file [foo.ml] int the same directory. The second file can + get sanitized. *) +| Not of pattern (* No files with suffix [pattern] will be tolerated. *) + +(** Suffix matching is enough for the purpose of this module. *) +and pattern = suffix + +(** And a suffix is a string. *) +and suffix = string + +(** A warning is simply displayed. A failures stops the compilation. *) +type penalty = Warn | Fail + +(** This type is used to encode laws that will be checked by this module. *) +type law = { + law_name : string; (** The name of the law that will be printed when it is violated. *) + law_rules : rule list; (** Breaking any of these rules is breaking this law. *) + law_penalty : penalty; (** Breaking the law gives you either a warning or a failure. *) +} + +(** [check ~sanitize laws entry] will scan the directory tree [entry] for violation to the given [laws]. + Any warnings or errors will be printed on the [stdout]. If [sanitize] is [Some fn], a shell script will be written + into the file [fn] with commands to delete the offending files. The command will return a pair [(fatal, penalties)] + where [fatal] is [true] when serious hygiene violations have been spotted, and [penalties] is a list of laws and + messages describing the offenses. *) +val check : ?sanitize:string -> law list -> bool Slurp.entry -> (law * string list) list diff --git a/ocamlbuild/lexers.mli b/ocamlbuild/lexers.mli new file mode 100644 index 00000000..12f9bc9f --- /dev/null +++ b/ocamlbuild/lexers.mli @@ -0,0 +1,31 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: lexers.mli,v 1.2 2007/02/16 10:35:10 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +exception Error of string + +type conf_values = + { plus_tags : string list; + minus_tags : string list; + plus_flags : (string * string) list; + minus_flags : (string * string) list } + +type conf = (Glob.globber * conf_values) list + +val ocamldep_output : Lexing.lexbuf -> (string * string list) list +val space_sep_strings : Lexing.lexbuf -> string list +val blank_sep_strings : Lexing.lexbuf -> string list +val comma_sep_strings : Lexing.lexbuf -> string list +val comma_or_blank_sep_strings : Lexing.lexbuf -> string list +val colon_sep_strings : Lexing.lexbuf -> string list +val conf_lines : string option -> int -> string -> Lexing.lexbuf -> conf +val meta_path : Lexing.lexbuf -> (string * bool) list diff --git a/ocamlbuild/lexers.mll b/ocamlbuild/lexers.mll new file mode 100644 index 00000000..4f98a943 --- /dev/null +++ b/ocamlbuild/lexers.mll @@ -0,0 +1,127 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: lexers.mll,v 1.2 2007/02/16 10:35:10 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +{ +exception Error of string + +type conf_values = + { plus_tags : string list; + minus_tags : string list; + plus_flags : (string * string) list; + minus_flags : (string * string) list } + +type conf = (Glob.globber * conf_values) list + +let empty = { plus_flags = []; minus_flags = []; plus_tags = []; minus_tags = [] } + +} + +let newline = ('\n' | '\r' | "\r\n") +let space = [' ' '\t' '\012'] +let blank = newline | space +let not_blank = [^' ' '\t' '\012' '\n' '\r'] +let not_space_nor_comma = [^' ' '\t' '\012' ','] +let not_newline = [^ '\n' '\r' ] +let not_newline_nor_colon = [^ '\n' '\r' ':' ] +let normal_flag_value = [^ '(' ')' '\n' '\r'] +let normal = [^ ':' ',' '(' ')' ''' ' ' '\n' '\r'] +let tag = normal+ | ( normal+ ':' normal+ ) +let flag_name = normal+ +let flag_value = normal_flag_value+ + +rule ocamldep_output = parse + | ([^ ':' '\n' '\r' ]+ as k) ':' { let x = (k, space_sep_strings_nl lexbuf) in x :: ocamldep_output lexbuf } + | eof { [] } + | _ { raise (Error "Expecting colon followed by space-separated module name list") } + +and space_sep_strings_nl = parse + | space* (not_blank+ as word) { word :: space_sep_strings_nl lexbuf } + | space* newline { [] } + | _ { raise (Error "Expecting space-separated strings terminated with newline") } + +and space_sep_strings = parse + | space* (not_blank+ as word) { word :: space_sep_strings lexbuf } + | space* newline? eof { [] } + | _ { raise (Error "Expecting space-separated strings") } + +and blank_sep_strings = parse + | blank* '#' not_newline* newline { blank_sep_strings lexbuf } + | blank* (not_blank+ as word) { word :: blank_sep_strings lexbuf } + | blank* eof { [] } + | _ { raise (Error "Expecting blank-separated strings") } + +and comma_sep_strings = parse + | space* (not_space_nor_comma+ as word) space* eof { [word] } + | space* (not_space_nor_comma+ as word) { word :: comma_sep_strings_aux lexbuf } + | space* eof { [] } + | _ { raise (Error "Expecting comma-separated strings (1)") } +and comma_sep_strings_aux = parse + | space* ',' space* (not_space_nor_comma+ as word) { word :: comma_sep_strings_aux lexbuf } + | space* eof { [] } + | _ { raise (Error "Expecting comma-separated strings (2)") } + +and comma_or_blank_sep_strings = parse + | space* (not_space_nor_comma+ as word) space* eof { [word] } + | space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf } + | space* eof { [] } + | _ { raise (Error "Expecting (comma|blank)-separated strings (1)") } +and comma_or_blank_sep_strings_aux = parse + | space* ',' space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf } + | space* (not_space_nor_comma+ as word) { word :: comma_or_blank_sep_strings_aux lexbuf } + | space* eof { [] } + | _ { raise (Error "Expecting (comma|blank)-separated strings (2)") } + +and colon_sep_strings = parse + | ([^ ':']+ as word) eof { [word] } + | ([^ ':']+ as word) { word :: colon_sep_strings_aux lexbuf } + | eof { [] } + | _ { raise (Error "Expecting colon-separated strings (1)") } +and colon_sep_strings_aux = parse + | ':' ([^ ':']+ as word) { word :: colon_sep_strings_aux lexbuf } + | eof { [] } + | _ { raise (Error "Expecting colon-separated strings (2)") } + +and conf_lines dir pos err = parse + | space* '#' not_newline* newline { conf_lines dir (pos + 1) err lexbuf } + | space* newline { conf_lines dir (pos + 1) err lexbuf } + | space* eof { [] } + | space* (not_newline_nor_colon+ as k) space* ':' space* + { + let bexpr = Glob.parse ?dir k in + let v1 = conf_value pos err empty lexbuf in + let v2 = conf_values pos err v1 lexbuf in + let rest = conf_lines dir (pos + 1) err lexbuf in (bexpr, v2) :: rest + } + | _ { raise (Error(Printf.sprintf "Bad key in configuration line at line %d (from %s)" pos err)) } + +and conf_value pos err x = parse + | '-' (flag_name as t1) '(' (flag_value as t2) ')' { { (x) with minus_flags = (t1, t2) :: x.minus_flags } } + | '+'? (flag_name as t1) '(' (flag_value as t2) ')' { { (x) with plus_flags = (t1, t2) :: x.plus_flags } } + | '-' (tag as tag) { { (x) with minus_tags = tag :: x.minus_tags } } + | '+'? (tag as tag) { { (x) with plus_tags = tag :: x.plus_tags } } + | (_ | eof) { raise (Error(Printf.sprintf "Bad value in configuration line at line %d (from %s)" pos err)) } + +and conf_values pos err x = parse + | space* ',' space* { conf_values pos err (conf_value pos err x lexbuf) lexbuf } + | (newline | eof) { x } + | (_ | eof) { raise (Error(Printf.sprintf "Bad values in configuration line at line %d (from %s)" pos err)) } + +and meta_path = parse + | ([^ '%' ]+ as prefix) + { (prefix, false) :: meta_path lexbuf } + | "%(" ([ 'a'-'z' 'A'-'Z' '_' '-' '0'-'9' ]* as var) ')' + { (var, true) :: meta_path lexbuf } + | '%' + { ("", true) :: meta_path lexbuf } + | eof + { [] } diff --git a/ocamlbuild/log.ml b/ocamlbuild/log.ml new file mode 100644 index 00000000..7fe96005 --- /dev/null +++ b/ocamlbuild/log.ml @@ -0,0 +1,49 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: log.ml,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +open My_std + +module Debug = struct +let mode _ = true +end +include Debug + +let level = ref 1 + +let classic_display = ref false +let log_file = ref (lazy None) + +let internal_display = lazy begin + let mode = + if !classic_display || !*My_unix.is_degraded || !level <= 0 || not (My_unix.stdout_isatty ()) then + `Classic + else + `Sophisticated + in + Display.create ~mode ?log_file:!*(!log_file) ~log_level:!level () +end + +let raw_dprintf log_level = Display.dprintf ~log_level !*internal_display + +let dprintf log_level fmt = raw_dprintf log_level ("@[<2>"^^fmt^^"@]@.") +let eprintf fmt = dprintf (-1) fmt + +let update () = Display.update !*internal_display +let event ?pretend x = Display.event !*internal_display ?pretend x +let display x = Display.display !*internal_display x + +let finish ?how () = + if Lazy.lazy_is_val internal_display then + Display.finish ?how !*internal_display + +(*let () = My_unix.at_exit_once finish*) diff --git a/ocamlbuild/log.mli b/ocamlbuild/log.mli new file mode 100644 index 00000000..2139efbe --- /dev/null +++ b/ocamlbuild/log.mli @@ -0,0 +1,34 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: log.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +(* Log *) + +(** Module for modulating the logging output with the logging level. *) +include Signatures.LOG + +(** Turn it to true to have a classic display of commands. *) +val classic_display : bool ref + +(** The optional log file. *) +val log_file : string option Lazy.t ref + +(** See {Display.event}. *) +val event : ?pretend:bool -> string -> string -> Tags.t -> unit + +(**/**) + +val internal_display : Display.display Lazy.t +val finish : ?how:[`Success|`Error|`Quiet] -> unit -> unit +val display : (out_channel -> unit) -> unit +val update : unit -> unit +val mode : string -> bool diff --git a/ocamlbuild/main.ml b/ocamlbuild/main.ml new file mode 100644 index 00000000..2c54e9f2 --- /dev/null +++ b/ocamlbuild/main.ml @@ -0,0 +1,300 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: main.ml,v 1.8 2007/03/01 14:40:11 pouillar Exp $ *) +(* Original author: Berke Durak *) +open My_std +open Log +open Pathname.Operators +open Command +open Tools +open Ocaml_specific +open Format +;; + +exception Exit_build_error of string +exception Exit_silently + +let clean () = + Shell.rm_rf !Options.build_dir; + begin + match !Options.internal_log_file with + | None -> () + | Some fn -> Shell.rm_f fn + end; + let entry = + Slurp.map (fun _ _ _ -> true) + (Slurp.slurp Filename.current_dir_name) + in + Slurp.force (Pathname.clean_up_links entry); + raise Exit_silently +;; + +let show_tags () = + List.iter begin fun path -> + Log.eprintf "@[<2>Tags for %S:@ {. %a .}@]" path Tags.print (tags_of_pathname path) + end !Options.show_tags +;; + +let show_documentation () = + let rules = Rule.get_rules () in + let flags = Flags.get_flags () in + let pp fmt = Log.raw_dprintf (-1) fmt in + List.iter begin fun rule -> + pp "%a@\n@\n" Rule.pretty_print rule + end rules; + List.iter begin fun (tags, flag) -> + let sflag = Command.string_of_command_spec flag in + pp "@[<2>flag@ {. %a .}@ %S@]@\n@\n" Tags.print tags sflag + end flags; + pp "@." +;; + +let proceed () = + Hooks.call_hook Hooks.Before_options; + Options.init (); + if !Options.must_clean then clean (); + Hooks.call_hook Hooks.After_options; + Tools.default_tags := Tags.of_list !Options.tags; + Plugin.execute_plugin_if_needed (); + + if !Options.targets = [] + && !Options.show_tags = [] + && not !Options.show_documentation + then raise Exit_silently; + + let target_dirs = List.union [] (List.map Pathname.dirname !Options.targets) in + + Configuration.parse_string + "true: traverse + <**/*.ml> or <**/*.mli> or <**/*.mlpack> or <**/*.ml.depends>: ocaml + <**/*.byte>: ocaml, byte, program + <**/*.odoc>: ocaml, doc + <**/*.native>: ocaml, native, program + <**/*.cma>: ocaml, byte, library + <**/*.cmxa>: ocaml, native, library + <**/*.cmo>: ocaml, byte + <**/*.cmi>: ocaml, byte, native + <**/*.cmx>: ocaml, native + "; + + let newpwd = Sys.getcwd () in + Sys.chdir Pathname.pwd; + let entry_include_dirs = ref [] in + let entry = + Slurp.filter + begin fun path name _ -> + let dir = + if path = Filename.current_dir_name then + None + else + Some path + in + let path_name = path/name in + if name = "_tags" then + ignore (Configuration.parse_file ?dir path_name); + + (String.length name > 0 && name.[0] <> '_' && not (List.mem name !Options.exclude_dirs)) + && begin + if path_name <> Filename.current_dir_name && Pathname.is_directory path_name then + let tags = tags_of_pathname path_name in + if Tags.mem "include" tags + || List.mem path_name !Options.include_dirs then + (entry_include_dirs := path_name :: !entry_include_dirs; true) + else + Tags.mem "traverse" tags + || List.exists (Pathname.is_prefix path_name) !Options.include_dirs + || List.exists (Pathname.is_prefix path_name) target_dirs + else true + end + end + (Slurp.slurp Filename.current_dir_name) + in + Hooks.call_hook Hooks.Before_hygiene; + let hygiene_entry = + Slurp.map begin fun path name () -> + let tags = tags_of_pathname (path/name) in + not (Tags.mem "not_hygienic" tags) && not (Tags.mem "precious" tags) + end entry in + if !Options.hygiene then + Fda.inspect hygiene_entry + else + Slurp.force hygiene_entry; + let entry = hygiene_entry in + Hooks.call_hook Hooks.After_hygiene; + Options.include_dirs := Pathname.current_dir_name :: List.rev !entry_include_dirs; + dprintf 3 "include directories are:@ %a" print_string_list !Options.include_dirs; + Options.entry := Some entry; + + Hooks.call_hook Hooks.Before_rules; + Ocaml_specific.init (); + Hooks.call_hook Hooks.After_rules; + + Sys.chdir newpwd; + (*let () = dprintf 0 "source_dir_path_set:@ %a" StringSet.print source_dir_path_set*) + + if !Options.show_documentation then begin + show_documentation (); + raise Exit_silently + end; + Resource.Cache.init (); + + Sys.catch_break true; + + show_tags (); + + let targets = + List.map begin fun starget -> + let target = path_and_context_of_string starget in + let ext = Pathname.get_extension starget in + (target, starget, ext) + end !Options.targets in + + try + let targets = + List.map begin fun (target, starget, ext) -> + Shell.mkdir_p (Pathname.dirname starget); + let target = Solver.solve_target starget target in + (target, ext) + end targets in + + Log.finish (); + + Shell.chdir Pathname.pwd; + + let call spec = sys_command (Command.string_of_command_spec spec) in + + let cmds = + List.fold_right begin fun (target, ext) acc -> + let cmd = !Options.build_dir/target in + let link x = + if !Options.make_links then ignore (call (S [A"ln"; A"-sf"; P x; A Pathname.current_dir_name])) in + match ext with + | "byte" | "native" | "top" -> + link cmd; cmd :: acc + | "html" -> + link (Pathname.dirname cmd); acc + | _ -> + if !Options.program_to_execute then + eprintf "Warning: Won't execute %s whose extension is neither .byte nor .native" cmd; + acc + end targets [] in + + if !Options.program_to_execute then + begin + match List.rev cmds with + | [] -> raise (Exit_usage "Using -- requires one target"); + | cmd :: rest -> + if rest <> [] then dprintf 0 "Warning: Using -- only run the last target"; + let cmd_spec = S [P cmd; atomize !Options.program_args] in + dprintf 3 "Running the user command:@ %a" Pathname.print cmd; + raise (Exit_with_code (call cmd_spec)) (* Exit with the exit code of the called command *) + end + else + () + with + | Ocaml_dependencies.Circular_dependencies(seen, p) -> + raise + (Exit_build_error + (sbprintf "@[<2>Circular dependencies: %S already seen in@ %a@]@." p pp_l seen)) +;; + +module Exit_codes = + struct + let rc_ok = 0 + let rc_usage = 1 + let rc_failure = 2 + let rc_invalid_argument = 3 + let rc_system_error = 4 + let rc_hygiene = 1 + let rc_circularity = 5 + let rc_solver_failed = 6 + let rc_ocamldep_error = 7 + let rc_lexing_error = 8 + let rc_build_error = 9 + let rc_executor_reserved_1 = 10 (* Redefined in Executor *) + let rc_executor_reserved_2 = 11 + let rc_executor_reserved_3 = 12 + let rc_executor_reserved_4 = 13 + end + +open Exit_codes;; + +let main () = + let exit rc = + Log.finish ~how:(if rc <> 0 then `Error else `Success) (); + Pervasives.exit rc + in + try + proceed () + with e -> + if !Options.catch_errors then + try raise e with + | Exit_OK -> exit rc_ok + | Fda.Exit_hygiene_failed -> + Log.eprintf "Exiting due to hygiene violations."; + exit rc_hygiene + | Exit_usage u -> + Log.eprintf "Usage:@ %s." u; + exit rc_usage + | Exit_system_error msg -> + Log.eprintf "System error:@ %s." msg; + exit rc_system_error + | Exit_with_code rc -> + exit rc + | Exit_silently -> + Log.finish ~how:`Quiet (); + Pervasives.exit rc_ok + | Exit_silently_with_code rc -> + Log.finish ~how:`Quiet (); + Pervasives.exit rc + | Solver.Failed backtrace -> + Log.raw_dprintf (-1) "@[@[<2>Solver failed:@ %a@]@\n@[Backtrace:%a@]@]@." + Report.print_backtrace_analyze backtrace Report.print_backtrace backtrace; + exit rc_solver_failed + | Failure s -> + Log.eprintf "Failure:@ %s." s; + exit rc_failure + | Solver.Circular(r, rs) -> + Log.eprintf "Circular build detected@ (%a already seen in %a)" + Resource.print r (List.print Resource.print) rs; + exit rc_circularity + | Invalid_argument s -> + Log.eprintf + "INTERNAL ERROR: Invalid argument %s\n\ + This is likely to be a bug, please report this to the ocamlbuild\n\ + developers." s; + exit rc_invalid_argument + | Ocamldep.Error msg -> + Log.eprintf "Ocamldep error: %s" msg; + exit rc_ocamldep_error + | Lexers.Error msg -> + Log.eprintf "Lexical analysis error: %s" msg; + exit rc_lexing_error + | Arg.Bad msg -> + Log.eprintf "%s" msg; + exit rc_usage + | Exit_build_error msg -> + Log.eprintf "%s" msg; + exit rc_build_error + | Arg.Help msg -> + Log.eprintf "%s" msg; + exit rc_ok + | e -> + try + Log.eprintf "%a" My_unix.report_error e; + exit 100 + with + | e -> + Log.eprintf "Exception@ %s." (Printexc.to_string e); + exit 100 + else raise e +;; diff --git a/ocamlbuild/main.mli b/ocamlbuild/main.mli new file mode 100644 index 00000000..95e469a1 --- /dev/null +++ b/ocamlbuild/main.mli @@ -0,0 +1,14 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: main.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +val main : unit -> unit diff --git a/ocamlbuild/man/ocamlbuild.1 b/ocamlbuild/man/ocamlbuild.1 new file mode 100644 index 00000000..9077fdf0 --- /dev/null +++ b/ocamlbuild/man/ocamlbuild.1 @@ -0,0 +1,253 @@ +.TH OCAMLBUILD 1 + +.SH NAME +ocamlbuild \- The Objective Caml project compilation tool + + +.SH SYNOPSIS +.B ocamlbuild +[ +.B \-Is \ dir1,... +] +[ +.BI \-libs \ lib1,... +] +[ +.BI \-lflags \ flag1,... +] +[ +.BI \-pp \ flags +] +[ +.BI \-tags \ tag1,... +] +[ +.B \-j \ parallel-jobs +] +.I target.native +[ +.B \-\- arg1 arg2 ... +] + +.I (same options) + +.SH DESCRIPTION + +.BR ocamlbuild (1) +orchestrates the compilation process of your OCaml project. It is similar +in function to +.BR make (1) +except that it is tailor-made to automatically compile most OCaml projects +with very little user input. + +.BR ocamlbuild +should be invoked in the root of a clean project tree (e.g., with no leftover +compilation files). Given one or more targets to compile, it scans the required +subdirectories to gather information about the various files present, running +tools such as +.BR ocamldep (1) +to extract dependency information, and gathering optional files that fine-tune +its behaviour. +Target names are very significant. + +.SH TARGET NAMES +.BR ocamlbuild +uses a set of target naming conventions to select the kind of objects to +produce. Target names are of the form +.BR base.extension +where +.BR base +is usually the name of the underlying Ocaml module and +.BR extension +denotes the kind of object to produce from that file -- a byte code executable, +a native executable, documentation... +Of course extensions such as +.BR .cmo, +.BR .cma, +.BR .cmi... +map to their usual counterparts. Here is a list of the most important +.BR ocamlbuild \&-specific +extensions: + +.TP 2i +.B .native +Native code executable + +.TP 2i +.B .byte +Byte code executable + +.TP 2i +.B .inferred.mli +Interface inferred with +.BR ocamlc -i + +.TP 2i +.B .docdir/index.html +HTML documentation generated with +.BR ocamldoc + +.PP + +.SH OPTIONS + +The following command-line options are recognized by +.BR ocamlbuild (1). + +.TP +\fB\-version\fR +Display the version +.TP +\fB\-quiet\fR +Make as quiet as possible +.TP +\fB\-verbose\fR +Set the verbose level +.TP +\fB\-documentation\fR +Show rules and flags +.TP +\fB\-log\fR +Set log file +.TP +\fB\-no\-log\fR +No log file +.TP +\fB\-clean\fR +Remove build directory and other files, then exit +.TP +\fB\-I\fR +Add to include directories +.TP +\fB\-Is\fR +(same as above, but accepts a comma\-separated list) +.TP +\fB\-X\fR +Directory to ignore +.TP +\fB\-Xs\fR +(idem) +.TP +\fB\-lib\fR +Link to this ocaml library +.TP +\fB\-libs\fR +(idem) +.TP +\fB\-lflag\fR +Add to ocamlc link flags +.TP +\fB\-lflags\fR +(idem) +.TP +\fB\-cflag\fR +Add to ocamlc compile flags +.TP +\fB\-cflags\fR +(idem) +.TP +\fB\-yaccflag\fR +Add to ocamlyacc flags +.TP +\fB\-yaccflags\fR +(idem) +.TP +\fB\-lexflag\fR +Add to ocamllex flags +.TP +\fB\-lexflags\fR +(idem) +.TP +\fB\-ppflag\fR +Add to ocaml preprocessing flags +.TP +\fB\-pp\fR +(idem) +.TP +\fB\-tag\fR +Add to default tags +.TP +\fB\-tags\fR +(idem) +.TP +\fB\-ignore\fR +Don't try to build these modules +.TP +\fB\-no\-links\fR +Don't make links of produced final targets +.TP +\fB\-no\-skip\fR +Don't skip modules that are requested by ocamldep but cannot be built +.TP +\fB\-no\-hygiene\fR +Don't apply sanity\-check rules +.TP +\fB\-no\-plugin\fR +Don't build myocamlbuild.ml +.TP +\fB\-no\-stdlib\fR +Don't ignore stdlib modules +.TP +\fB\-just\-plugin\fR +Just build myocamlbuild.ml +.TP +\fB\-byte\-plugin\fR +Don't use a native plugin but bytecode +.TP +\fB\-no-sanitize\fR +Do not enforce sanity\-check rules +.TP +\fB\-nothing\-should\-be\-rebuilt\fR +Fail if something needs to be rebuilt +.TP +\fB\-classic\-display\fR +Display executed commands the old\-fashioned way +.TP +\fB\-j\fR +Allow N jobs at once (0 for unlimited) +.TP +\fB\-build\-dir\fR +Set build directory +.TP +\fB\-install\-dir\fR +Set the install directory +.TP +\fB\-where\fR +Display the install directory +.TP +\fB\-ocamlc\fR +Set the OCaml bytecode compiler +.TP +\fB\-ocamlopt\fR +Set the OCaml native compiler +.TP +\fB\-ocamldep\fR +Set the OCaml dependency tool +.TP +\fB\-ocamlyacc\fR +Set the ocamlyacc tool +.TP +\fB\-ocamllex\fR +Set the ocamllex tool +.TP +\fB\-ocamlrun\fR +Set the ocamlrun tool +.TP +\fB\-\-\fR +Stop argument processing, remaining arguments are given to the user program +.TP +\fB\-help\fR +Display the list of options +.TP +\fB\-\-help\fR +Display the list of options +.PP + +.SH SEE ALSO +The +.BR ocamlbuild +manual, +.BR ocaml (1), +.BR make (1). +.br +.I The Objective Caml user's manual, chapter "Batch compilation". diff --git a/ocamlbuild/misc/opentracer.ml b/ocamlbuild/misc/opentracer.ml new file mode 100644 index 00000000..77966a0d --- /dev/null +++ b/ocamlbuild/misc/opentracer.ml @@ -0,0 +1,101 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: opentracer.ml,v 1.1 2007/02/07 08:59:15 ertai Exp $ *) +open My_std + +module type TRACER = sig + (** Call the given command using the tracer, it returns the exit status. *) + val call : string -> string list -> StringSet.t * Unix.process_status +end + +module Ktrace = struct + let process_line line (wait_a_string, set) = + let strings = Lexers.space_sep_strings (Lexing.from_string line) in + if wait_a_string then + match strings with + | [_; _; "NAMI"; file] -> false, StringSet.add file set + | _ -> failwith (Printf.sprintf "unexpected ktrace output line (%S)" line) + else + match strings with + | [_; _; "CALL"; fct] -> + (String.length fct > 5 && String.sub fct 0 5 = "open("), set + | _ -> false, set + + let call cmd args = + let tmp = Filename.temp_file "ktrace" "out" in + match Unix.fork () with + | 0 -> Unix.execvp "ktrace" (Array.of_list("-d"::"-i"::"-t"::"nc"::"-f"::tmp::cmd::args)) + | pid -> + let _, st = Unix.waitpid [] pid in + let ic = Unix.open_process_in (Printf.sprintf "kdump -f %s" (Filename.quote tmp)) in + let close () = ignore (Unix.close_process_in ic); Sys.remove tmp in + let set = + try + let rec loop acc = + match try Some (input_line ic) with End_of_file -> None with + | Some line -> loop (process_line line acc) + | None -> acc in + let _, set = loop (false, StringSet.empty) in + close (); + set + with e -> (close (); raise e) + in set, st + +end + +module Driver (T : TRACER) = struct + let usage () = + Printf.eprintf "Usage: %s [-a ]* *\n%!" Sys.argv.(0); + exit 2 + + let main () = + let log = "opentracer.log" in + let oc = + if sys_file_exists log then + open_out_gen [Open_wronly;Open_append;Open_text] 0 log + else + let oc = open_out log in + let () = output_string oc "---\n" in + oc in + let rec loop acc = + function + | "-a" :: file :: rest -> loop (StringSet.add file acc) rest + | "-a" :: _ -> usage () + | "--" :: cmd :: args -> acc, cmd, args + | cmd :: args -> acc, cmd, args + | [] -> usage () in + let authorized_files, cmd, args = + loop StringSet.empty (List.tl (Array.to_list Sys.argv)) in + let opened_files, st = T.call cmd args in + let forbidden_files = StringSet.diff opened_files authorized_files in + + if not (StringSet.is_empty forbidden_files) then begin + Printf.fprintf oc "- cmd: %s\n args:\n%!" cmd; + let pp = Printf.fprintf oc " - %s\n%!" in + List.iter pp args; + Printf.fprintf oc " forbidden_files:\n%!"; + StringSet.iter pp forbidden_files; + end; + close_out oc; + match st with + | Unix.WEXITED st -> exit st + | Unix.WSIGNALED s | Unix.WSTOPPED s -> Unix.kill (Unix.getpid ()) s +end + +let main = + (* match os with *) + (* | "macos" -> *) + let module M = Driver(Ktrace) in M.main + (* | "linux" -> *) + (* let module M = Driver(Strace) in M.main *) + +let () = main () diff --git a/ocamlbuild/my_std.ml b/ocamlbuild/my_std.ml new file mode 100644 index 00000000..5bfeefd3 --- /dev/null +++ b/ocamlbuild/my_std.ml @@ -0,0 +1,361 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: my_std.ml,v 1.2 2007/02/22 16:51:39 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +open Format + +exception Exit_OK +exception Exit_usage of string +exception Exit_system_error of string +exception Exit_with_code of int +exception Exit_silently_with_code of int + +module Outcome = struct + type ('a,'b) t = + | Good of 'a + | Bad of 'b + + let ignore_good = + function + | Good _ -> () + | Bad e -> raise e + + let good = + function + | Good x -> x + | Bad exn -> raise exn + + let wrap f x = + try Good (f x) with e -> Bad e + +end + +let opt_print elt ppf = + function + | Some x -> fprintf ppf "@[<2>Some@ %a@]" elt x + | None -> pp_print_string ppf "None" + +open Format +let ksbprintf g fmt = + let buff = Buffer.create 42 in + let f = formatter_of_buffer buff in + kfprintf (fun f -> (pp_print_flush f (); g (Buffer.contents buff))) f fmt +let sbprintf fmt = ksbprintf (fun x -> x) fmt + +(** Some extensions of the standard library *) +module Set = struct + + module type OrderedTypePrintable = sig + include Set.OrderedType + val print : formatter -> t -> unit + end + + module type S = sig + include Set.S + val find : (elt -> bool) -> t -> elt + val map : (elt -> elt) -> t -> t + val of_list : elt list -> t + val print : formatter -> t -> unit + end + + module Make (M : OrderedTypePrintable) : S with type elt = M.t = struct + include Set.Make(M) + exception Found of elt + let find p set = + try + iter begin fun elt -> + if p elt then raise (Found elt) + end set; raise Not_found + with Found elt -> elt + let map f set = fold (fun x -> add (f x)) set empty + let of_list l = List.fold_right add l empty + let print f s = + let () = fprintf f "@[@[{.@ " in + let _ = + fold begin fun elt first -> + if not first then fprintf f ",@ "; + M.print f elt; + false + end s true in + fprintf f "@]@ .}@]" + end +end + +module List = struct + include List + let print pp_elt f ls = + fprintf f "@[<2>[@ "; + let _ = + fold_left begin fun first elt -> + if not first then fprintf f ";@ "; + pp_elt f elt; + false + end true ls in + fprintf f "@ ]@]" + + let filter_opt f xs = + List.fold_right begin fun x acc -> + match f x with + | Some x -> x :: acc + | None -> acc + end xs [] + + let union a b = + let rec self a b = + if a = [] then b else + match b with + | [] -> a + | x :: xs -> + if mem x a then self a xs + else self (x :: a) xs + in rev (self (rev a) b) +end + +module String = struct + include String + + let print f s = fprintf f "%S" s + + let chomp s = + let ls = length s in + if ls = 0 then s + else if s.[ls-1] = '\n' then sub s 0 (ls - 1) + else s + + let before s pos = sub s 0 pos + let after s pos = sub s pos (length s - pos) + let first_chars s n = sub s 0 n + let last_chars s n = sub s (length s - n) n + + let rec eq_sub_strings s1 p1 s2 p2 len = + if len > 0 then s1.[p1] = s2.[p2] && eq_sub_strings s1 (p1+1) s2 (p2+1) (len-1) + else true + + let rec contains_string s1 p1 s2 = + let ls1 = length s1 in + let ls2 = length s2 in + try let pos = index_from s1 p1 s2.[0] in + if ls1 - pos < ls2 then None + else if eq_sub_strings s1 pos s2 0 ls2 then + Some pos else contains_string s1 (pos + 1) s2 + with Not_found -> None + + let subst patt repl s = + let lpatt = length patt in + let lrepl = length repl in + let rec loop s from = + match contains_string s from patt with + | Some pos -> + loop (before s pos ^ repl ^ after s (pos + lpatt)) (pos + lrepl) + | None -> s + in loop s 0 + + let tr patt subst text = + let len = length text in + let text = copy text in + let rec loop pos = + if pos < len then begin + (if text.[pos] = patt then text.[pos] <- subst); + loop (pos + 1) + end + in loop 0; text + + (*** is_prefix : is v a prefix of u ? *) + let is_prefix u v = + let m = String.length u + and n = String.length v + in + m <= n && + let rec loop i = i = m or u.[i] = v.[i] && loop (i + 1) in + loop 0 + (* ***) + + (*** is_suffix : is v a suffix of u ? *) + let is_suffix u v = + let m = String.length u + and n = String.length v + in + n <= m && + let rec loop i = i = n or u.[m - 1 - i] = v.[n - 1 - i] && loop (i + 1) in + loop 0 + (* ***) + + let rev s = + let sl = String.length s in + let s' = String.create sl in + for i = 0 to sl - 1 do + s'.[i] <- s.[sl - i - 1] + done; + s';; +end + +module StringSet = Set.Make(String) + +let sys_readdir, reset_readdir_cache, reset_readdir_cache_for = + let cache = Hashtbl.create 103 in + let sys_readdir dir = + try Hashtbl.find cache dir with Not_found -> + let res = Outcome.wrap Sys.readdir dir in + (Hashtbl.add cache dir res; res) + and reset_readdir_cache () = + Hashtbl.clear cache + and reset_readdir_cache_for dir = + Hashtbl.remove cache dir in + (sys_readdir, reset_readdir_cache, reset_readdir_cache_for) + +let sys_file_exists x = + let dirname = Filename.dirname x in + let basename = Filename.basename x in + if basename = Filename.current_dir_name then true else + match sys_readdir dirname with + | Outcome.Bad _ -> false + | Outcome.Good a -> try Array.iter (fun x -> if x = basename then raise Exit) a; false with Exit -> true + +let sys_command = + match Sys.os_type with + | "Win32" -> fun cmd -> + let cmd = "bash -c "^Filename.quote cmd in + (* FIXME fix Filename.quote for windows *) + let cmd = String.subst "\"&\"\"&\"" "&&" cmd in + Sys.command cmd + | _ -> Sys.command + +(* FIXME warning fix and use Filename.concat *) +let filename_concat x y = + if x = Filename.current_dir_name || x = "" then y else + if y = "" && x.[String.length x - 1] = '/' then x + else x ^ "/" ^ y + +(* let reslash = + match Sys.os_type with + | "Win32" -> tr '\\' '/' + | _ -> (fun x -> x) *) + +open Format + +let invalid_arg' fmt = ksbprintf invalid_arg fmt + +let the = function Some x -> x | None -> invalid_arg "the: expect Some not None" + +let getenv ?default var = + try Sys.getenv var + with Not_found -> + match default with + | Some x -> x + | None -> failwith (sprintf "This command must have %S in his environment" var);; + +let with_input_file ?(bin=false) x f = + let ic = (if bin then open_in_bin else open_in) x in + try let res = f ic in close_in ic; res with e -> (close_in ic; raise e) + +let with_output_file ?(bin=false) x f = + reset_readdir_cache_for (Filename.dirname x); + let oc = (if bin then open_out_bin else open_out) x in + try let res = f oc in close_out oc; res with e -> (close_out oc; raise e) + +let read_file x = + with_input_file ~bin:true x begin fun ic -> + let len = in_channel_length ic in + let buf = String.create len in + let () = really_input ic buf 0 len in + buf + end + +let copy_chan ic oc = + let m = in_channel_length ic in + let m = (m lsr 12) lsl 12 in + let m = max 16384 (min 16777216 m) in + let buf = String.create m in + let rec loop () = + let len = input ic buf 0 m in + if len > 0 then begin + output oc buf 0 len; + loop () + end + in loop () + +let copy_file src dest = + reset_readdir_cache_for (Filename.dirname dest); + with_input_file ~bin:true src begin fun ic -> + with_output_file ~bin:true dest begin fun oc -> + copy_chan ic oc + end + end + +let ( !* ) = Lazy.force + +let ( @:= ) ref list = ref := !ref @ list + +let ( & ) f x = f x + +let print_string_list = List.print String.print + +module Digest = struct + include Digest +(* USEFUL FOR DIGEST DEBUGING + let digest_log_hash = Hashtbl.create 103;; + let digest_log = "digest.log";; + let digest_log_oc = open_out_gen [Open_append;Open_wronly;Open_text;Open_creat] 0o644 digest_log;; + let my_to_hex x = to_hex x ^ ";";; + if sys_file_exists digest_log then + with_input_file digest_log begin fun ic -> + try while true do + let l = input_line ic in + Scanf.sscanf l "%S: %S" (Hashtbl.replace digest_log_hash) + done with End_of_file -> () + end;; + let string s = + let res = my_to_hex (string s) in + if try let x = Hashtbl.find digest_log_hash res in s <> x with Not_found -> true then begin + Hashtbl.replace digest_log_hash res s; + Printf.fprintf digest_log_oc "%S: %S\n%!" res s + end; + res + let file f = my_to_hex (file f) + let to_hex x = x +*) + + let digest_cache = Hashtbl.create 103 + let reset_digest_cache () = Hashtbl.clear digest_cache + let reset_digest_cache_for file = Hashtbl.remove digest_cache file + let file f = + try Hashtbl.find digest_cache f + with Not_found -> + let res = file f in + (Hashtbl.add digest_cache f res; res) +end + +let reset_filesys_cache () = + Digest.reset_digest_cache (); + reset_readdir_cache () + +let reset_filesys_cache_for_file file = + Digest.reset_digest_cache_for file; + reset_readdir_cache_for (Filename.dirname file) + +let sys_remove x = + reset_filesys_cache_for_file x; + Sys.remove x + +let with_temp_file pre suf fct = + let tmp = Filename.temp_file pre suf in + (* Sys.remove is used instead of sys_remove since we know that the tempfile is not that important *) + try let res = fct tmp in Sys.remove tmp; res + with e -> (Sys.remove tmp; raise e) + +let memo f = + let cache = Hashtbl.create 103 in + fun x -> + try Hashtbl.find cache x + with Not_found -> + let res = f x in + (Hashtbl.add cache x res; res) diff --git a/ocamlbuild/my_std.mli b/ocamlbuild/my_std.mli new file mode 100644 index 00000000..790f7de6 --- /dev/null +++ b/ocamlbuild/my_std.mli @@ -0,0 +1,65 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: my_std.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +(* My_std *) + +(** Generic utility functions, and system-independent glue. *) + +exception Exit_OK +exception Exit_usage of string +exception Exit_system_error of string +exception Exit_with_code of int +exception Exit_silently_with_code of int + +module Outcome : Signatures.OUTCOME + +open Format + +val ksbprintf : (string -> 'a) -> ('b, formatter, unit, 'a) format4 -> 'b +val sbprintf : ('a, formatter, unit, string) format4 -> 'a + +module Set : sig + module type OrderedTypePrintable = Signatures.OrderedTypePrintable + module type S = Signatures.SET + module Make (M : OrderedTypePrintable) : S with type elt = M.t +end + +module List : Signatures.LIST + +module String : Signatures.STRING + +module Digest : sig + type t = string + val string : string -> t + val substring : string -> int -> int -> t + external channel : in_channel -> int -> t = "caml_md5_chan" + val file : string -> t + val output : out_channel -> t -> unit + val input : in_channel -> t + val to_hex : t -> string +end + +module StringSet : Set.S with type elt = String.t + +val sys_readdir : string -> (string array, exn) Outcome.t +val sys_remove : string -> unit +val reset_readdir_cache : unit -> unit +val reset_filesys_cache : unit -> unit +val reset_filesys_cache_for_file : string -> unit +val sys_file_exists : string -> bool +val sys_command : string -> int +val filename_concat : string -> string -> string + +val invalid_arg' : ('a, formatter, unit, 'b) format4 -> 'a + +include Signatures.MISC diff --git a/ocamlbuild/my_unix.ml b/ocamlbuild/my_unix.ml new file mode 100644 index 00000000..ef64b798 --- /dev/null +++ b/ocamlbuild/my_unix.ml @@ -0,0 +1,141 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: my_unix.ml,v 1.2 2007/02/26 16:36:33 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +open My_std +open Format + +type file_kind = +| FK_dir +| FK_file +| FK_link +| FK_other + +type stats = + { + stat_file_kind : file_kind; + stat_key : string + } + +type implem = + { + mutable is_degraded : bool; + mutable is_link : string -> bool; + mutable run_and_open : 'a . string -> (in_channel -> 'a) -> 'a; + mutable readlink : string -> string; + mutable execute_many : ?max_jobs:int -> + ?ticker:(unit -> unit) -> + ?period:float -> + ?display:((out_channel -> unit) -> unit) -> + ((string * (unit -> unit)) list list) -> + (bool list * exn) option; + mutable report_error : Format.formatter -> exn -> unit; + mutable at_exit_once : (unit -> unit) -> unit; + mutable gettimeofday : unit -> float; + mutable stdout_isatty : unit -> bool; + mutable stat : string -> stats; + mutable lstat : string -> stats; + } + +let is_degraded = true + +let stat f = + { stat_key = f; + stat_file_kind = + if Sys.file_exists f then + if Sys.is_directory f then + FK_dir + else + FK_file + else let _ = with_input_file f input_char in assert false } + +let run_and_open s kont = + with_temp_file "ocamlbuild" "out" begin fun tmp -> + let s = sprintf "%s > '%s'" s tmp in + let st = sys_command s in + if st <> 0 then failwith (Printf.sprintf "Error while running: %s" s); + with_input_file tmp kont + end + +exception Not_a_link +exception No_such_file +exception Link_to_directories_not_supported + +let readlinkcmd = + let cache = Hashtbl.create 32 in + fun x -> + try Hashtbl.find cache x + with Not_found -> + run_and_open (Printf.sprintf "readlink %s" (Filename.quote x)) begin fun ic -> + let y = String.chomp (input_line ic) in + Hashtbl.replace cache x y; y + end + +let rec readlink x = + if sys_file_exists x then + try + let y = readlinkcmd x in + if (lstat y).stat_file_kind = FK_dir then raise Link_to_directories_not_supported else y + with Failure(_) -> raise Not_a_link + else raise No_such_file + +and is_link x = + try ignore(readlink x); true with + | No_such_file | Not_a_link -> false + +and lstat x = + if is_link x then { stat_key = x; stat_file_kind = FK_link } else stat x + +let implem = + { + is_degraded = true; + + stat = stat; + lstat = lstat; + readlink = readlink; + is_link = is_link; + run_and_open = run_and_open; + + (* at_exit_once is at_exit in the degraded mode since fork is not accessible in this mode *) + at_exit_once = at_exit; + report_error = (fun _ -> raise); + gettimeofday = (fun () -> assert false); + stdout_isatty = (fun () -> false); + execute_many = (fun ?max_jobs:(_) ?ticker:(_) ?period:(_) ?display:(_) _ -> assert false) + } + +let is_degraded = lazy implem.is_degraded +let stat x = implem.stat x +let lstat x = implem.lstat x +let readlink x = implem.readlink x +let is_link x = implem.is_link x +let run_and_open x = implem.run_and_open x +let at_exit_once x = implem.at_exit_once x +let report_error x = implem.report_error x +let gettimeofday x = implem.gettimeofday x +let stdout_isatty x = implem.stdout_isatty x +let execute_many ?max_jobs = implem.execute_many ?max_jobs + +let run_and_read cmd = + let bufsiz = 2048 in + let buf = String.create bufsiz in + let totalbuf = Buffer.create 4096 in + implem.run_and_open cmd begin fun ic -> + let rec loop pos = + let len = input ic buf 0 bufsiz in + if len > 0 then begin + Buffer.add_substring totalbuf buf 0 len; + loop (pos + len) + end + in loop 0; Buffer.contents totalbuf + end + diff --git a/ocamlbuild/my_unix.mli b/ocamlbuild/my_unix.mli new file mode 100644 index 00000000..b07e0121 --- /dev/null +++ b/ocamlbuild/my_unix.mli @@ -0,0 +1,73 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: my_unix.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +type file_kind = +| FK_dir +| FK_file +| FK_link +| FK_other + +type stats = + { + stat_file_kind : file_kind; + stat_key : string + } + +val is_degraded : bool Lazy.t + +val is_link : string -> bool +val run_and_open : string -> (in_channel -> 'a) -> 'a +val readlink : string -> string +val run_and_read : string -> string + +(** See [Executor.execute] *) +val execute_many : + ?max_jobs:int -> + ?ticker:(unit -> unit) -> + ?period:float -> + ?display:((out_channel -> unit) -> unit) -> + ((string * (unit -> unit)) list list) -> + (bool list * exn) option + +val report_error : Format.formatter -> exn -> unit +val at_exit_once : (unit -> unit) -> unit + +val gettimeofday : unit -> float + +val stdout_isatty : unit -> bool + +val stat : string -> stats +val lstat : string -> stats + +(** internal usage only *) +type implem = + { + mutable is_degraded : bool; + mutable is_link : string -> bool; + mutable run_and_open : 'a . string -> (in_channel -> 'a) -> 'a; + mutable readlink : string -> string; + mutable execute_many : ?max_jobs:int -> + ?ticker:(unit -> unit) -> + ?period:float -> + ?display:((out_channel -> unit) -> unit) -> + ((string * (unit -> unit)) list list) -> + (bool list * exn) option; + mutable report_error : Format.formatter -> exn -> unit; + mutable at_exit_once : (unit -> unit) -> unit; + mutable gettimeofday : unit -> float; + mutable stdout_isatty : unit -> bool; + mutable stat : string -> stats; + mutable lstat : string -> stats; + } + +val implem : implem diff --git a/ocamlbuild/my_unix_with_unix.ml b/ocamlbuild/my_unix_with_unix.ml new file mode 100644 index 00000000..6dc800e6 --- /dev/null +++ b/ocamlbuild/my_unix_with_unix.ml @@ -0,0 +1,73 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: my_unix_with_unix.ml,v 1.1.4.1 2007/03/04 15:36:20 pouillar Exp $ *) +(* Original author: Nicolas Pouillard *) +open Format +open Ocamlbuild_pack +open My_unix + +let report_error f = + function + | Unix.Unix_error(err, fun_name, arg) -> + fprintf f "%s: %S failed" Sys.argv.(0) fun_name; + if String.length arg > 0 then + fprintf f " on %S" arg; + fprintf f ": %s" (Unix.error_message err) + | exn -> raise exn + +let mkstat unix_stat x = + let st = + try unix_stat x + with Unix.Unix_error _ as e -> raise (Sys_error (My_std.sbprintf "%a" report_error e)) + in + { stat_key = sprintf "(%d,%d)" st.Unix.st_dev st.Unix.st_ino; + stat_file_kind = + match st.Unix.st_kind with + | Unix.S_LNK -> FK_link + | Unix.S_DIR -> FK_dir + | Unix.S_CHR | Unix.S_BLK | Unix.S_FIFO | Unix.S_SOCK -> FK_other + | Unix.S_REG -> FK_file } + +let is_link s = (Unix.lstat s).Unix.st_kind = Unix.S_LNK + +let at_exit_once callback = + let pid = Unix.getpid () in + at_exit begin fun () -> + if pid = Unix.getpid () then callback () + end + +let run_and_open s kont = + let ic = Unix.open_process_in s in + let close () = + match Unix.close_process_in ic with + | Unix.WEXITED 0 -> () + | Unix.WEXITED _ | Unix.WSIGNALED _ | Unix.WSTOPPED _ -> + failwith (Printf.sprintf "Error while running: %s" s) in + try + let res = kont ic in close (); res + with e -> (close (); raise e) + +let stdout_isatty () = + Unix.isatty Unix.stdout + +let setup () = + implem.is_degraded <- false; + implem.stdout_isatty <- stdout_isatty; + implem.gettimeofday <- Unix.gettimeofday; + implem.report_error <- report_error; + implem.execute_many <- Executor.execute; + implem.readlink <- Unix.readlink; + implem.run_and_open <- run_and_open; + implem.at_exit_once <- at_exit_once; + implem.is_link <- is_link; + implem.stat <- mkstat Unix.stat; + implem.lstat <- mkstat Unix.lstat; diff --git a/ocamlbuild/my_unix_with_unix.mli b/ocamlbuild/my_unix_with_unix.mli new file mode 100644 index 00000000..819a5dd0 --- /dev/null +++ b/ocamlbuild/my_unix_with_unix.mli @@ -0,0 +1,14 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: my_unix_with_unix.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +val setup : unit -> unit diff --git a/ocamlbuild/ocaml_arch.ml b/ocamlbuild/ocaml_arch.ml new file mode 100644 index 00000000..a54ce156 --- /dev/null +++ b/ocamlbuild/ocaml_arch.ml @@ -0,0 +1,135 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: ocaml_arch.ml,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +open My_std +open Command +open Pathname.Operators + +type 'a arch = + | Arch_dir of string * 'a * 'a arch list + | Arch_dir_pack of string * 'a * 'a arch list + | Arch_file of string * 'a + +let dir name contents = Arch_dir(name, (), contents) +let dir_pack name contents = Arch_dir_pack(name, (), contents) +let file name = Arch_file(name, ()) + +type info = +{ + current_path : string; + include_dirs : string list; + for_pack : string; +} + +let join_pack parent base = + if parent = "" then base else parent ^ "." ^ base + +let annotate arch = + let rec self arch acc = + match arch with + | Arch_dir_pack(name, _, contents) -> + let acc = { (acc) with for_pack = join_pack acc.for_pack name } in + let (_, _, i, new_contents) = self_contents name contents acc in + ([], Arch_dir_pack(name, i, List.rev new_contents)) + | Arch_dir(name, _, contents) -> + let (current_path, include_dirs, i, new_contents) = self_contents name contents acc in + (current_path :: include_dirs, Arch_dir(name, i, List.rev new_contents)) + | Arch_file(name, _) -> + ([], Arch_file(name, acc)) + and self_contents name contents acc = + let current_path = acc.current_path/name in + let include_dirs = if current_path = "" then acc.include_dirs else current_path :: acc.include_dirs in + let i = { (acc) with current_path = current_path; include_dirs = include_dirs } in + let (include_dirs, new_contents) = + List.fold_left begin fun (include_dirs, new_contents) x -> + let j = { (i) with include_dirs = include_dirs @ i.include_dirs } in + let (include_dirs', x') = self x j in + (include_dirs @ include_dirs', x' :: new_contents) + end ([], []) contents in + (current_path, include_dirs, i, new_contents) in + let init = { current_path = ""; include_dirs = []; for_pack = "" } in + snd (self arch init) + +let rec print print_info f = + let rec print_contents f = + function + | [] -> () + | x :: xs -> Format.fprintf f "@ %a%a" (print print_info) x print_contents xs in + function + | Arch_dir(name, info, contents) -> + Format.fprintf f "@[dir %S%a%a@]" name print_info info print_contents contents + | Arch_dir_pack(name, info, contents) -> + Format.fprintf f "@[dir_pack %S%a%a@]" name print_info info print_contents contents + | Arch_file(name, info) -> + Format.fprintf f "@[<2>file %S%a@]" name print_info info + +let print_include_dirs = List.print String.print + +let print_info f i = + Format.fprintf f "@ @[{ @[<2>current_path =@ %S@];@\ + \ @[<2>include_dirs =@ %a@];@\ + \ @[<2>for_pack =@ %S@] }@]" + i.current_path print_include_dirs i.include_dirs i.for_pack + +let rec iter_info f = + function + | Arch_dir_pack(_, i, xs) | Arch_dir(_, i, xs) -> + f i; List.iter (iter_info f) xs + | Arch_file(_, i) -> f i + +let rec fold_info f arch acc = + match arch with + | Arch_dir_pack(_, i, xs) | Arch_dir(_, i, xs) -> + List.fold_right (fold_info f) xs (f i acc) + | Arch_file(_, i) -> f i acc + +module SS = Set.Make(String) + +let iter_include_dirs arch = + let set = fold_info (fun i -> List.fold_right SS.add i.include_dirs) arch SS.empty in + fun f -> SS.iter f set + +let forpack_flags_of_pathname = ref (fun _ -> N) + +let print_table print_value f table = + Format.fprintf f "@[{:@["; + Hashtbl.iter begin fun k v -> + if k <> "" then + Format.fprintf f "@ @[<2>%S =>@ %a@];" k print_value v; + end table; + Format.fprintf f "@]@ :}@]" + +let print_tables f (include_dirs_table, for_pack_table) = + Format.fprintf f "@[<2>@[<2>include_dirs_table:@ %a@];@ @[<2>for_pack_table: %a@]@]" + (print_table (List.print String.print)) include_dirs_table + (print_table String.print) for_pack_table + +let mk_tables arch = + let include_dirs_table = Hashtbl.create 17 + and for_pack_table = Hashtbl.create 17 in + iter_info begin fun i -> + Hashtbl.replace include_dirs_table i.current_path i.include_dirs; + Hashtbl.replace for_pack_table i.current_path i.for_pack + end arch; + let previous_forpack_flags_of_pathname = !forpack_flags_of_pathname in + forpack_flags_of_pathname := begin fun m -> + let m' = Pathname.dirname m in + try + let for_pack = Hashtbl.find for_pack_table m' in + if for_pack = "" then N else S[A"-for-pack"; A for_pack] + with Not_found -> previous_forpack_flags_of_pathname m + end; + (* Format.eprintf "@[<2>%a@]@." print_tables (include_dirs_table, for_pack_table); *) + (include_dirs_table, for_pack_table) + +let forpack_flags_of_pathname m = !forpack_flags_of_pathname m diff --git a/ocamlbuild/ocaml_arch.mli b/ocamlbuild/ocaml_arch.mli new file mode 100644 index 00000000..356bcf2c --- /dev/null +++ b/ocamlbuild/ocaml_arch.mli @@ -0,0 +1,16 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: ocaml_arch.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) + +include Signatures.ARCH +val forpack_flags_of_pathname : string -> Command.spec diff --git a/ocamlbuild/ocaml_compiler.ml b/ocamlbuild/ocaml_compiler.ml new file mode 100644 index 00000000..7a408bf4 --- /dev/null +++ b/ocamlbuild/ocaml_compiler.ml @@ -0,0 +1,336 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: ocaml_compiler.ml,v 1.5.2.2 2007/03/04 15:36:20 pouillar Exp $ *) +(* Original author: Nicolas Pouillard *) +open My_std +open Format +open Log +open Pathname.Operators +open Tools +open Command +open Rule +open Tags.Operators +open Ocaml_utils +open Rule.Common_commands +open Outcome + +let forpack_flags arg tags = + if Tags.mem "pack" tags then + Ocaml_arch.forpack_flags_of_pathname arg + else N + +let ocamlc_c tags arg out = + let tags = tags++"ocaml"++"byte" in + Cmd (S [!Options.ocamlc; A"-c"; T(tags++"compile"); + ocaml_ppflags tags; flags_of_pathname arg; + ocaml_include_flags arg; A"-o"; Px out; P arg]) + +let ocamlc_link flag tags deps out = + Cmd (S [!Options.ocamlc; flag; T tags; + atomize_paths deps; flags_of_pathname out; A"-o"; Px out]) + +let ocamlc_link_lib = ocamlc_link (A"-a") +let ocamlc_link_prog = ocamlc_link N + +let ocamlmklib tags deps out = + Cmd (S [!Options.ocamlmklib; T tags; + atomize_paths deps; flags_of_pathname out; A"-o"; Px (Pathname.remove_extensions out)]) + +let ocamlmktop tags deps out = + Cmd( S [!Options.ocamlmktop; T tags; + atomize_paths deps; flags_of_pathname out; A"-o"; Px out]) + +let byte_lib_linker tags = + if Tags.mem "ocamlmklib" tags then + ocamlmklib tags + else + ocamlc_link_lib tags + +let byte_lib_linker_tags tags = tags++"ocaml"++"link"++"byte"++"library" + +let ocamlc_p tags deps out = + Cmd (S [!Options.ocamlc; A"-pack"; T tags; + atomize_paths deps; flags_of_pathname out; A"-o"; Px out]) + +let ocamlopt_c tags arg out = + let tags = tags++"ocaml"++"native" in + Cmd (S [!Options.ocamlopt; A"-c"; Ocaml_arch.forpack_flags_of_pathname arg; + T(tags++"compile"); ocaml_ppflags tags; flags_of_pathname arg; + flags_of_pathname out; ocaml_include_flags arg; + A"-o"; Px out (* FIXME ocamlopt bug -o cannot be after the input file *); P arg]) + +let ocamlopt_link flag tags deps out = + Cmd (S [!Options.ocamlopt; flag; forpack_flags out tags; T tags; + atomize_paths deps; flags_of_pathname out; A"-o"; Px out]) + +let ocamlopt_link_lib = ocamlopt_link (A"-a") +let ocamlopt_link_prog = ocamlopt_link N + +let ocamlopt_p tags deps out = + let dirnames = List.union [] (List.map Pathname.dirname deps) in + let include_flags = List.fold_right ocaml_add_include_flag dirnames [] in + let cmi = cmi_of out and cmitmp = Pathname.update_extensions "cmitmp" out in + Seq[mv cmi cmitmp; + Cmd (S [!Options.ocamlopt; A"-pack"; forpack_flags out tags; T tags; S include_flags; + atomize_paths deps; flags_of_pathname out; (* FIXME: P (cmi_of out);*) A"-o"; Px out]); + cmp cmitmp cmi] + +let native_lib_linker tags = + if Tags.mem "ocamlmklib" tags then + ocamlmklib tags + else + ocamlopt_link_lib tags + +let native_lib_linker_tags tags = tags++"ocaml"++"link"++"native"++"library" + +let prepare_compile build ml = + let dir = Pathname.dirname ml in + let include_dirs = Pathname.include_dirs_of dir in + let modules = Ocamldep.module_dependencies_of ml in + let results = + build (List.map (fun (_, x) -> expand_module include_dirs x ["cmi"]) modules) in + List.iter2 begin fun (mandatory, name) res -> + match mandatory, res with + | _, Good _ -> () + | `mandatory, Bad exn -> + if !Options.ignore_auto then + dprintf 3 "Warning: Failed to build the module \ + %s requested by ocamldep" name + else raise exn + | `just_try, Bad _ -> () + end modules results + +let byte_compile_ocaml_interf mli cmi env build = + let mli = env mli and cmi = env cmi in + prepare_compile build mli; + ocamlc_c (tags_of_pathname mli++"interf") mli cmi + +let byte_compile_ocaml_implem ?tag ml cmo env build = + let ml = env ml and cmo = env cmo in + prepare_compile build ml; + ocamlc_c (tags_of_pathname ml++"implem"+++tag) ml cmo + +let cache_prepare_link = Hashtbl.create 107 +let rec prepare_link tag cmx extensions build = + let key = (tag, cmx, extensions) in + let dir = Pathname.dirname cmx in + let include_dirs = Pathname.include_dirs_of dir in + if Hashtbl.mem cache_prepare_link key then () else + let () = Hashtbl.add cache_prepare_link key true in + let modules = Ocamldep.module_dependencies_of (Pathname.update_extensions "ml" cmx) in + let modules' = List.map (fun (_, x) -> expand_module include_dirs x extensions) modules in + List.iter2 begin fun (mandatory, _) result -> + match mandatory, result with + | _, Good p -> prepare_link tag p extensions build + | `mandatory, Bad exn -> if not !Options.ignore_auto then raise exn + | `just_try, Bad _ -> () + end modules (build modules') + +let native_compile_ocaml_implem ?tag ?(cmx_ext="cmx") ml env build = + let ml = env ml in + let cmi = Pathname.update_extensions "cmi" ml in + let cmx = Pathname.update_extensions cmx_ext ml in + prepare_link cmx cmi [cmx_ext; "cmi"] build; + ocamlopt_c (tags_of_pathname ml++"implem"+++tag) ml cmx + +let libs_of_use_lib tags = + Tags.fold begin fun tag acc -> + try let libpath, extern = Hashtbl.find info_libraries tag in + if extern then acc else libpath :: acc + with Not_found -> acc + end tags [] + +let prepare_libs cma_ext a_ext out build = + let out_no_ext = Pathname.remove_extension out in + let libs1 = List.union (libraries_of out_no_ext) (libs_of_use_lib (tags_of_pathname out)) in + let () = dprintf 10 "prepare_libs: %S -> %a" out pp_l libs1 in + let libs = List.map (fun x -> x-.-cma_ext) libs1 in + let libs2 = List.map (fun lib -> [lib-.-a_ext]) libs1 in + List.iter ignore_good (build libs2); libs + +let library_index = Hashtbl.create 32 +let package_index = Hashtbl.create 32 +let hidden_packages = ref [] + +let hide_package_contents package = hidden_packages := package :: !hidden_packages + +module Ocaml_dependencies_input = struct + let fold_dependencies = Resource.Cache.fold_dependencies + let fold_libraries f = Hashtbl.fold f library_index + let fold_packages f = Hashtbl.fold f package_index +end +module Ocaml_dependencies = Ocaml_dependencies.Make(Ocaml_dependencies_input) + +let caml_transitive_closure = Ocaml_dependencies.caml_transitive_closure + +let link_gen cmX_ext cma_ext a_ext extensions linker tagger cmX out env build = + let cmX = env cmX and out = env out in + let tags = tagger (tags_of_pathname out) in + let dyndeps = Rule.build_deps_of_tags build (tags++"link_with") in + let cmi = Pathname.update_extensions "cmi" cmX in + prepare_link cmX cmi extensions build; + let libs = prepare_libs cma_ext a_ext out build in + let hidden_packages = List.map (fun x -> x-.-cmX_ext) !hidden_packages in + let deps = + caml_transitive_closure + ~caml_obj_ext:cmX_ext ~caml_lib_ext:cma_ext + ~used_libraries:libs ~hidden_packages (cmX :: dyndeps) in + let deps = (List.filter (fun l -> not (List.mem l deps)) libs) @ deps in + + (* Hack to avoid linking twice with the standard library. *) + let stdlib = "stdlib/stdlib"-.-cma_ext in + let is_not_stdlib x = x <> stdlib in + let deps = List.filter is_not_stdlib deps in + + if deps = [] then failwith "Link list cannot be empty"; + let () = dprintf 6 "link: %a -o %a" print_string_list deps Pathname.print out in + linker (tags++"dont_link_with") deps out + +let byte_link_gen = link_gen "cmo" "cma" "cma" ["cmo"; "cmi"] + +let byte_link = byte_link_gen ocamlc_link_prog + (fun tags -> tags++"ocaml"++"link"++"byte"++"program") + +let byte_library_link = byte_link_gen byte_lib_linker byte_lib_linker_tags + +let byte_debug_link_gen = + link_gen "d.cmo" "d.cma" "d.cma" ["d.cmo"; "cmi"] + +let byte_debug_link = byte_debug_link_gen ocamlc_link_prog + (fun tags -> tags++"ocaml"++"link"++"byte"++"debug"++"program") + +let byte_debug_library_link = byte_debug_link_gen byte_lib_linker + (fun tags -> byte_lib_linker_tags tags++"debug") + +let native_link_gen linker = + link_gen "cmx" "cmxa" !Options.ext_lib [!Options.ext_obj; "cmi"] linker + +let native_link x = native_link_gen ocamlopt_link_prog + (fun tags -> tags++"ocaml"++"link"++"native"++"program") x + +let native_library_link x = + native_link_gen native_lib_linker native_lib_linker_tags x + +let native_profile_link_gen linker = + link_gen "p.cmx" "p.cmxa" ("p" -.- !Options.ext_lib) ["p" -.- !Options.ext_obj; "cmi"] linker + +let native_profile_link x = native_profile_link_gen ocamlopt_link_prog + (fun tags -> tags++"ocaml"++"link"++"native"++"profile"++"program") x + +let native_profile_library_link x = native_profile_link_gen native_lib_linker + (fun tags -> native_lib_linker_tags tags++"profile") x + +let link_units table extensions cmX_ext cma_ext a_ext linker tagger contents_list cmX env build = + let cmX = env cmX in + let tags = tagger (tags_of_pathname cmX) in + let _ = Rule.build_deps_of_tags build tags in + let dir = + let dir1 = Pathname.remove_extensions cmX in + if Pathname.exists_in_source_dir dir1 then dir1 + else Pathname.dirname cmX in + let include_dirs = Pathname.include_dirs_of dir in + let extension_keys = List.map fst extensions in + let libs = prepare_libs cma_ext a_ext cmX build in + let results = + build begin + List.map begin fun module_name -> + expand_module include_dirs module_name extension_keys + end contents_list + end in + let module_paths = + List.map begin function + | Good p -> + let extension_values = List.assoc (Pathname.get_extensions p) extensions in + List.iter begin fun ext -> + List.iter ignore_good (build [[Pathname.update_extensions ext p]]) + end extension_values; p + | Bad exn -> raise exn + end results in + Hashtbl.replace table cmX module_paths; + let hidden_packages = List.map (fun x -> x-.-cmX_ext) !hidden_packages in + let deps = + caml_transitive_closure + ~caml_obj_ext:cmX_ext ~caml_lib_ext:cma_ext + ~hidden_packages ~pack_mode:true module_paths in + let full_contents = libs @ module_paths in + let deps = List.filter (fun x -> List.mem x full_contents) deps in + let deps = (List.filter (fun l -> not (List.mem l deps)) libs) @ deps in + + (* Hack to avoid linking twice with the standard library. *) + let stdlib = "stdlib/stdlib"-.-cma_ext in + let is_not_stdlib x = x <> stdlib in + let deps = List.filter is_not_stdlib deps in + + linker tags deps cmX + +let link_modules = link_units library_index +let pack_modules = link_units package_index + +let link_from_file link modules_file cmX env build = + let modules_file = env modules_file in + let contents_list = string_list_of_file modules_file in + link contents_list cmX env build + +let byte_library_link_modules = + link_modules [("cmo",[]); ("cmi",[])] "cmo" "cma" "cma" byte_lib_linker byte_lib_linker_tags + +let byte_library_link_mllib = link_from_file byte_library_link_modules + +let byte_toplevel_link_modules = + link_modules [("cmo",[]); ("cmi",[])] "cmo" "cma" "cma" ocamlmktop + (fun tags -> tags++"ocaml"++"link"++"byte"++"toplevel") + +let byte_toplevel_link_mltop = link_from_file byte_toplevel_link_modules + +let byte_debug_library_link_modules = + link_modules [("d.cmo",[]); ("cmi",[])] "d.cmo" "d.cma" "d.cma" byte_lib_linker + (fun tags -> byte_lib_linker_tags tags++"debug") + +let byte_debug_library_link_mllib = link_from_file byte_debug_library_link_modules + +let byte_pack_modules = + pack_modules [("cmo",["cmi"]); ("cmi",[])] "cmo" "cma" "cma" ocamlc_p + (fun tags -> tags++"ocaml"++"pack"++"byte") + +let byte_pack_mlpack = link_from_file byte_pack_modules + +let byte_debug_pack_modules = + pack_modules [("d.cmo",["cmi"]); ("cmi",[])] "d.cmo" "d.cma" "d.cma" ocamlc_p + (fun tags -> tags++"ocaml"++"pack"++"byte"++"debug") + +let byte_debug_pack_mlpack = link_from_file byte_debug_pack_modules + +let native_pack_modules x = + pack_modules [("cmx",["cmi"; !Options.ext_obj]); ("cmi",[])] "cmx" "cmxa" !Options.ext_lib ocamlopt_p + (fun tags -> tags++"ocaml"++"pack"++"native") x + +let native_pack_mlpack = link_from_file native_pack_modules + +let native_profile_pack_modules x = + pack_modules [("p.cmx",["cmi"; "p" -.- !Options.ext_obj]); ("cmi",[])] "p.cmx" "p.cmxa" + ("p" -.- !Options.ext_lib) ocamlopt_p + (fun tags -> tags++"ocaml"++"pack"++"native"++"profile") x + +let native_profile_pack_mlpack = link_from_file native_profile_pack_modules + +let native_library_link_modules x = + link_modules [("cmx",[!Options.ext_obj]); ("cmi",[])] "cmx" "cmxa" + !Options.ext_lib native_lib_linker native_lib_linker_tags x + +let native_library_link_mllib = link_from_file native_library_link_modules + +let native_profile_library_link_modules x = + link_modules [("p.cmx",["p" -.- !Options.ext_obj]); ("cmi",[])] "p.cmx" "p.cmxa" + ("p" -.- !Options.ext_lib) native_lib_linker + (fun tags -> native_lib_linker_tags tags++"profile") x + +let native_profile_library_link_mllib = link_from_file native_profile_library_link_modules diff --git a/ocamlbuild/ocaml_compiler.mli b/ocamlbuild/ocaml_compiler.mli new file mode 100644 index 00000000..06353766 --- /dev/null +++ b/ocamlbuild/ocaml_compiler.mli @@ -0,0 +1,84 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: ocaml_compiler.mli,v 1.2 2007/02/12 10:26:08 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) + +val forpack_flags : string -> Tags.t -> Command.spec +val ocamlc_c : Tags.t -> Pathname.t -> Pathname.t -> Command.t +val ocamlc_link_lib : Tags.t -> Pathname.t list -> Pathname.t -> Command.t +val ocamlc_link_prog : Tags.t -> Pathname.t list -> Pathname.t -> Command.t +val ocamlc_p : Tags.t -> Pathname.t list -> Pathname.t -> Command.t +val ocamlopt_c : Tags.t -> Pathname.t -> Pathname.t -> Command.t +val ocamlopt_link_lib : Tags.t -> Pathname.t list -> Pathname.t -> Command.t +val ocamlopt_link_prog : Tags.t -> Pathname.t list -> Pathname.t -> Command.t +val ocamlopt_p : Tags.t -> Pathname.t list -> Pathname.t -> Command.t +val ocamlmklib : Tags.t -> Pathname.t list -> Pathname.t -> Command.t +val ocamlmktop : Tags.t -> Pathname.t list -> Pathname.t -> Command.t +val prepare_compile : Rule.builder -> Pathname.t -> unit +val byte_compile_ocaml_interf : string -> string -> Rule.action +val byte_compile_ocaml_implem : ?tag:string -> string -> string -> Rule.action +val prepare_link : + Pathname.t -> Pathname.t -> + string list -> Rule.builder -> unit +val native_compile_ocaml_implem : ?tag:string -> ?cmx_ext:string -> string -> Rule.action +val prepare_libs : + string -> string -> Pathname.t -> + Rule.builder -> Pathname.t list +val link_gen : + string -> string -> string -> string list -> + (Tags.t -> Pathname.t list -> Pathname.t -> Command.t) -> + (Tags.t -> Tags.t) -> + string -> string -> Rule.action +val byte_link : string -> string -> Rule.action +val byte_library_link : string -> string -> Rule.action +val byte_debug_link : string -> string -> Rule.action +val byte_debug_library_link : string -> string -> Rule.action +val native_link : string -> string -> Rule.action +val native_library_link : string -> string -> Rule.action +val native_profile_link : string -> string -> Rule.action +val native_profile_library_link : string -> string -> Rule.action +val link_modules : + (Pathname.t * string list) list -> + string -> string -> + string -> (Tags.t -> Pathname.t list -> Pathname.t -> Command.t) -> + (Tags.t -> Tags.t) -> + string list -> string -> Rule.action +val pack_modules : + (Pathname.t * string list) list -> + string -> string -> + string -> (Tags.t -> Pathname.t list -> Pathname.t -> Command.t) -> + (Tags.t -> Tags.t) -> + string list -> string -> Rule.action +val byte_library_link_modules : string list -> string -> Rule.action +val byte_library_link_mllib : string -> string -> Rule.action +val byte_debug_library_link_modules : string list -> string -> Rule.action +val byte_debug_library_link_mllib : string -> string -> Rule.action +val byte_pack_modules : string list -> string -> Rule.action +val byte_pack_mlpack : string -> string -> Rule.action +val byte_debug_pack_modules : string list -> string -> Rule.action +val byte_debug_pack_mlpack : string -> string -> Rule.action +val byte_toplevel_link_modules : string list -> string -> Rule.action +val byte_toplevel_link_mltop : string -> string -> Rule.action +val native_pack_modules : string list -> string -> Rule.action +val native_pack_mlpack : string -> string -> Rule.action +val native_library_link_modules : string list -> string -> Rule.action +val native_library_link_mllib : string -> string -> Rule.action +val native_profile_pack_modules : string list -> string -> Rule.action +val native_profile_pack_mlpack : string -> string -> Rule.action +val native_profile_library_link_modules : string list -> string -> Rule.action +val native_profile_library_link_mllib : string -> string -> Rule.action + +(** [hide_package_contents pack_name] + Don't treat the given package as an open package. + So a module will not be replaced during linking by + this package even if it contains that module. *) +val hide_package_contents : string -> unit diff --git a/ocamlbuild/ocaml_dependencies.ml b/ocamlbuild/ocaml_dependencies.ml new file mode 100644 index 00000000..c002128d --- /dev/null +++ b/ocamlbuild/ocaml_dependencies.ml @@ -0,0 +1,219 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: ocaml_dependencies.ml,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +open My_std +open Log +open Tools +open Ocaml_utils + +let mydprintf fmt = dprintf 10 fmt + +exception Circular_dependencies of string list * string + +module type INPUT = sig + val fold_dependencies : (string -> string -> 'a -> 'a) -> 'a -> 'a + val fold_libraries : (string -> string list -> 'a -> 'a) -> 'a -> 'a + val fold_packages : (string -> string list -> 'a -> 'a) -> 'a -> 'a +end + +module Make (I : INPUT) = struct + open I + + module SMap = Map.Make(String) + + module Resources = Resource.Resources + + module Utils = struct + let add = SMap.add + + let empty = SMap.empty + + let find_all_set x acc = + try SMap.find x acc with Not_found -> Resources.empty + + let smap_add_set src dst acc = + SMap.add src (Resources.add dst (find_all_set src acc)) acc + + let print_smap pp f smap = + Format.fprintf f "@[{:@["; + SMap.iter begin fun k v -> + Format.fprintf f "@ @[<2>%S =>@ %a@];" k pp v + end smap; + Format.fprintf f "@]@,:}@]" + + let print_smap_list = print_smap pp_l + + let print_smap_set = print_smap Resources.print + + let print_lazy pp f l = pp f !*l + + let find_all_list x acc = + try SMap.find x acc with Not_found -> [] + + let find_all_rec xs map = + let visited = Hashtbl.create 32 in + let rec self x acc = + try + Hashtbl.find visited x; acc + with Not_found -> + Hashtbl.replace visited x (); + let acc = Resources.add x acc in + try Resources.fold self (SMap.find x map) acc + with Not_found -> acc + in List.fold_right self xs Resources.empty + + let mkindex fold filter = + fold begin fun name contents acc -> + if filter name then + List.fold_right begin fun elt acc -> + add elt (name :: (find_all_list elt acc)) acc + end contents acc + else + acc + end empty + + end + open Utils + + let caml_transitive_closure + ?(caml_obj_ext="cmo") + ?(caml_lib_ext="cma") + ?(pack_mode=false) + ?(used_libraries=[]) + ?(hidden_packages=[]) fns = + + let valid_link_exts = + if pack_mode then [caml_obj_ext; "cmi"] + else [caml_obj_ext; caml_lib_ext] in + + mydprintf "caml_transitive_closure@ ~caml_obj_ext:%S@ ~pack_mode:%b@ ~used_libraries:%a@ %a" + caml_obj_ext pack_mode pp_l used_libraries pp_l fns; + + let packages = fold_packages (fun name _ -> Resources.add name) Resources.empty in + mydprintf "packages:@ %a" Resources.print packages; + + let caml_obj_ext_of_cmi x = + if Filename.check_suffix x ".cmi" then + Pathname.update_extensions caml_obj_ext x + else x in + + let maybe_caml_obj_ext_of_cmi x = + if pack_mode then + if Filename.check_suffix x ".cmi" then + let caml_obj = Pathname.update_extensions caml_obj_ext x in + if Pathname.exists_in_build_dir caml_obj then + caml_obj + else + x + else + x + else + if Filename.check_suffix x ".cmi" then + Pathname.update_extensions caml_obj_ext x + else x in + + let not_linkable x = + not (List.exists (Pathname.check_extension x) valid_link_exts) in + + let dependency_map = + fold_dependencies begin fun x y acc -> + let x = maybe_caml_obj_ext_of_cmi x + and y = maybe_caml_obj_ext_of_cmi y in + if x = y || not_linkable x || not_linkable y then acc + else smap_add_set x y acc + end SMap.empty in + mydprintf "dependency_map:@ %a" print_smap_set dependency_map; + + let used_files = find_all_rec fns dependency_map in + mydprintf "used_files:@ %a" Resources.print used_files; + + let open_packages = + Resources.fold begin fun file acc -> + if Resources.mem file packages && not (List.mem file hidden_packages) + then file :: acc else acc + end used_files [] in + mydprintf "open_packages:@ %a" pp_l open_packages; + + let index_filter ext list x = + Pathname.check_extension x ext && List.mem x list in + + let lib_index = + lazy (mkindex fold_libraries (index_filter caml_lib_ext used_libraries)) in + mydprintf "lib_index:@ %a" (print_lazy print_smap_list) lib_index; + + let package_index = + lazy (mkindex fold_packages (index_filter caml_obj_ext open_packages)) in + + let rec resolve_packages x = + match find_all_list x !*package_index with + | [] -> x + | [x] -> resolve_packages x + | pkgs -> + failwith (sbprintf "the file %S is included in more than one active open package (%a)" + x pp_l pkgs) in + + let libs_of x = find_all_list x !*lib_index in + + let lib_of x = + match libs_of x with + | [] -> None + | [lib] -> Some(lib) + | libs -> + failwith (sbprintf "the file %S is included in more than one active library (%a)" + x pp_l libs) in + + let convert_dependency src dst acc = + let src = resolve_packages src in + let dst = resolve_packages dst in + let add_if_diff x y = if x = y then acc else smap_add_set x y acc in + match (lib_of src, lib_of dst) with + | None, None -> add_if_diff src dst + | Some(liba), Some(libb) -> add_if_diff liba libb + | Some(lib), None -> add_if_diff lib dst + | None, Some(lib) -> add_if_diff src lib in + + let dependencies = lazy begin + SMap.fold begin fun k -> + Resources.fold (convert_dependency k) + end dependency_map empty + end in + + mydprintf "dependencies:@ %a" (print_lazy print_smap_set) dependencies; + + let dependencies_of x = + try SMap.find x !*dependencies with Not_found -> Resources.empty in + + let needed = ref [] in + let seen = ref [] in + let rec aux fn = + if sys_file_exists fn && not (List.mem fn !needed) then begin + if List.mem fn !seen then raise (Circular_dependencies (!seen, fn)); + seen := fn :: !seen; + Resources.iter begin fun f -> + if sys_file_exists f then + if Filename.check_suffix f ".cmi" then + let f' = caml_obj_ext_of_cmi f in + if f' <> fn then + if sys_file_exists f' then aux f' + else if pack_mode then aux f else () + else () + else aux f + end (dependencies_of fn); + needed := fn :: !needed + end + in + List.iter aux fns; + mydprintf "caml_transitive_closure:@ %a ->@ %a" pp_l fns pp_l !needed; + List.rev !needed + +end diff --git a/ocamlbuild/ocaml_dependencies.mli b/ocamlbuild/ocaml_dependencies.mli new file mode 100644 index 00000000..89082327 --- /dev/null +++ b/ocamlbuild/ocaml_dependencies.mli @@ -0,0 +1,43 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: ocaml_dependencies.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +(** Ocaml dependencies *) + +exception Circular_dependencies of string list * string + +(** Give to this module a way to access libraries, packages, + and dependencies between files. *) +module type INPUT = sig + val fold_dependencies : (string -> string -> 'a -> 'a) -> 'a -> 'a + val fold_libraries : (string -> string list -> 'a -> 'a) -> 'a -> 'a + val fold_packages : (string -> string list -> 'a -> 'a) -> 'a -> 'a +end + +(** Wait an [INPUT] module and gives a function to compute the + transitive closure of caml file takeing in account libraries and packages. *) +module Make (I : INPUT) : sig + + (** [caml_transitive_closure] takes a list of root ocaml compiled files and returns + the list of files that must be given to a linker. Optionally you can change the + extension of caml object/library files (cmo/cma by default); use the pack mode + (false by default) to include only root files (just sort them); and gives the + list of used libraries (empty by default). *) + val caml_transitive_closure : + ?caml_obj_ext:string -> + ?caml_lib_ext:string -> + ?pack_mode:bool -> + ?used_libraries:string list -> + ?hidden_packages:string list -> + Pathname.t list -> Pathname.t list + +end diff --git a/ocamlbuild/ocaml_specific.ml b/ocamlbuild/ocaml_specific.ml new file mode 100644 index 00000000..99721c29 --- /dev/null +++ b/ocamlbuild/ocaml_specific.ml @@ -0,0 +1,396 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: ocaml_specific.ml,v 1.6.2.1 2007/03/04 16:13:53 pouillar Exp $ *) +(* Original author: Nicolas Pouillard *) +open My_std +open Format +open Log +open Pathname.Operators +open Tags.Operators +open Rule +open Tools +open Rule.Common_commands +open Outcome +open Command;; + +open Ocaml_utils + +module C_tools = struct + let link_C_library clib a libname env build = + let clib = env clib and a = env a and libname = env libname in + let objs = string_list_of_file clib in + let include_dirs = Pathname.include_dirs_of (Pathname.dirname a) in + let obj_of_o x = + if Filename.check_suffix x ".o" && !Options.ext_obj <> "o" then + Pathname.update_extension !Options.ext_obj x + else x in + let resluts = build (List.map (fun o -> List.map (fun dir -> dir / obj_of_o o) include_dirs) objs) in + let objs = List.map begin function + | Good o -> o + | Bad exn -> raise exn + end resluts in + Cmd(S[!Options.ocamlmklib; A"-o"; Px libname; T(tags_of_pathname a++"c"++"ocamlmklib"); atomize objs]);; +end + +open Flags +open Command +open Rule + +let init () = let module M = struct + +let ext_lib = !Options.ext_lib;; +let ext_obj = !Options.ext_obj;; +let ext_dll = !Options.ext_dll;; +let x_o = "%"-.-ext_obj;; +let x_a = "%"-.-ext_lib;; +let x_dll = "%"-.-ext_dll;; +let x_p_o = "%.p"-.-ext_obj;; +let x_p_a = "%.p"-.-ext_lib;; + +rule "target files" + ~dep:"%.itarget" + ~prod:"%.otarget" + begin fun env build -> + let itarget = env "%.itarget" and otarget = env "%.otarget" in + let dir = Pathname.dirname itarget in + List.iter ignore_good + (build (List.map (fun x -> [dir/x]) (string_list_of_file itarget))); + touch otarget + end;; + +rule "ocaml: mli -> cmi" + ~tags:["ocaml"] + ~prod:"%.cmi" + ~deps:["%.mli"; "%.mli.depends"] + (Ocaml_compiler.byte_compile_ocaml_interf "%.mli" "%.cmi");; + +rule "ocaml: mlpack & d.cmo* -> d.cmo & cmi" + ~tags:["ocaml"; "debug"; "byte"] + ~prods:["%.d.cmo"] + ~deps:["%.mlpack"; "%.cmi"] + (Ocaml_compiler.byte_debug_pack_mlpack "%.mlpack" "%.d.cmo");; + +rule "ocaml: mlpack & cmo* -> cmo & cmi" + ~tags:["ocaml"; "byte"] + ~prods:["%.cmo"; "%.cmi"] + ~dep:"%.mlpack" + (Ocaml_compiler.byte_pack_mlpack "%.mlpack" "%.cmo");; + +rule "ocaml: ml & cmi -> d.cmo" + ~tags:["ocaml"; "byte"] + ~prod:"%.d.cmo" + ~deps:["%.mli"(* This one is inserted to force this rule to be skiped when + a .ml is provided without a .mli *); "%.ml"; "%.ml.depends"; "%.cmi"] + (Ocaml_compiler.byte_compile_ocaml_implem ~tag:"debug" "%.ml" "%.d.cmo");; + +rule "ocaml: ml & cmi -> cmo" + ~tags:["ocaml"; "byte"] + ~prod:"%.cmo" + ~deps:["%.mli"(* This one is inserted to force this rule to be skiped when + a .ml is provided without a .mli *); "%.ml"; "%.ml.depends"; "%.cmi"] + (Ocaml_compiler.byte_compile_ocaml_implem "%.ml" "%.cmo");; + +rule "ocaml: mlpack & cmi & p.cmx* & p.o* -> p.cmx & p.o" + ~tags:["ocaml"; "profile"; "native"] + ~prods:["%.p.cmx"; x_p_o(* no cmi here you must make the byte version to have it *)] + ~deps:["%.mlpack"; "%.cmi"] + (Ocaml_compiler.native_profile_pack_mlpack "%.mlpack" "%.p.cmx");; + +rule "ocaml: mlpack & cmi & cmx* & o* -> cmx & o" + ~tags:["ocaml"; "native"] + ~prods:["%.cmx"; x_o(* no cmi here you must make the byte version to have it *)] + ~deps:["%.mlpack"; "%.cmi"] + (Ocaml_compiler.native_pack_mlpack "%.mlpack" "%.cmx");; + +rule "ocaml: ml & cmi -> p.cmx & p.o" + ~tags:["ocaml"; "native"; "profile"] + ~prods:["%.p.cmx"; x_p_o] + ~deps:["%.ml"; "%.ml.depends"; "%.cmi"] + (Ocaml_compiler.native_compile_ocaml_implem ~tag:"profile" ~cmx_ext:"p.cmx" "%.ml");; + +rule "ocaml: ml & cmi -> cmx & o" + ~tags:["ocaml"; "native"] + ~prods:["%.cmx"; x_o] + ~deps:["%.ml"; "%.ml.depends"; "%.cmi"] + (Ocaml_compiler.native_compile_ocaml_implem "%.ml");; + +rule "ocaml: ml -> d.cmo & cmi" + ~tags:["ocaml"; "debug"] + ~prods:["%.d.cmo"] + ~deps:["%.ml"; "%.ml.depends"; "%.cmi"] + (Ocaml_compiler.byte_compile_ocaml_implem ~tag:"debug" "%.ml" "%.d.cmo");; + +rule "ocaml: ml -> cmo & cmi" + ~tags:["ocaml"] + ~prods:["%.cmo"; "%.cmi"] + ~deps:["%.ml"; "%.ml.depends"] + (Ocaml_compiler.byte_compile_ocaml_implem "%.ml" "%.cmo");; + +rule "ocaml: d.cmo* -> d.byte" + ~tags:["ocaml"; "byte"; "debug"; "program"] + ~prod:"%.d.byte" + ~dep:"%.d.cmo" + (Ocaml_compiler.byte_debug_link "%.d.cmo" "%.d.byte");; + +rule "ocaml: cmo* -> byte" + ~tags:["ocaml"; "byte"; "program"] + ~prod:"%.byte" + ~dep:"%.cmo" + (Ocaml_compiler.byte_link "%.cmo" "%.byte");; + +rule "ocaml: p.cmx* & p.o* -> p.native" + ~tags:["ocaml"; "native"; "profile"; "program"] + ~prod:"%.p.native" + ~deps:["%.p.cmx"; x_p_o] + (Ocaml_compiler.native_profile_link "%.p.cmx" "%.p.native");; + +rule "ocaml: cmx* & o* -> native" + ~tags:["ocaml"; "native"; "program"] + ~prod:"%.native" + ~deps:["%.cmx"; x_o] + (Ocaml_compiler.native_link "%.cmx" "%.native");; + +rule "ocaml: mllib & d.cmo* -> d.cma" + ~tags:["ocaml"; "byte"; "debug"; "library"] + ~prod:"%.d.cma" + ~dep:"%.mllib" + (Ocaml_compiler.byte_debug_library_link_mllib "%.mllib" "%.d.cma");; + +rule "ocaml: mllib & cmo* -> cma" + ~tags:["ocaml"; "byte"; "library"] + ~prod:"%.cma" + ~dep:"%.mllib" + (Ocaml_compiler.byte_library_link_mllib "%.mllib" "%.cma");; + +rule "ocaml: d.cmo* -> d.cma" + ~tags:["ocaml"; "byte"; "debug"; "library"] + ~prod:"%.d.cma" + ~dep:"%.d.cmo" + (Ocaml_compiler.byte_debug_library_link "%.d.cmo" "%.d.cma");; + +rule "ocaml: cmo* -> cma" + ~tags:["ocaml"; "byte"; "library"] + ~prod:"%.cma" + ~dep:"%.cmo" + (Ocaml_compiler.byte_library_link "%.cmo" "%.cma");; + +rule "ocaml C stubs (short): clib & (o|obj)* -> (a|lib) & (so|dll)" + ~prods:["lib%(libname)"-.-ext_lib; "dll%(libname)"-.-ext_dll] + ~dep:"lib%(libname).clib" + (C_tools.link_C_library "lib%(libname).clib" ("lib%(libname)"-.-ext_lib) "%(libname)");; + +rule "ocaml C stubs: clib & (o|obj)* -> (a|lib) & (so|dll)" + ~prods:["%(path)/lib%(libname)"-.-ext_lib; "%(path)/dll%(libname)"-.-ext_dll] + ~dep:"%(path)/lib%(libname).clib" + (C_tools.link_C_library "%(path)/lib%(libname).clib" ("%(path)/lib%(libname)"-.-ext_lib) "%(path)/%(libname)");; + +rule "ocaml: mllib & p.cmx* & p.o* -> p.cmxa & p.a" + ~tags:["ocaml"; "native"; "profile"; "library"] + ~prods:["%.p.cmxa"; x_p_a] + ~dep:"%.mllib" + (Ocaml_compiler.native_profile_library_link_mllib "%.mllib" "%.p.cmxa");; + +rule "ocaml: mllib & cmx* & o* -> cmxa & a" + ~tags:["ocaml"; "native"; "library"] + ~prods:["%.cmxa"; x_a] + ~dep:"%.mllib" + (Ocaml_compiler.native_library_link_mllib "%.mllib" "%.cmxa");; + +rule "ocaml: p.cmx* & p.o* -> p.cmxa & p.a" + ~tags:["ocaml"; "native"; "profile"; "library"] + ~prods:["%.p.cmxa"; x_p_a] + ~deps:["%.p.cmx"; x_p_o] + (Ocaml_compiler.native_profile_library_link "%.p.cmx" "%.p.cmxa");; + +rule "ocaml: cmx* & o* -> cmxa & a" + ~tags:["ocaml"; "native"; "library"] + ~prods:["%.cmxa"; x_a] + ~deps:["%.cmx"; x_o] + (Ocaml_compiler.native_library_link "%.cmx" "%.cmxa");; + +Ocamldep.depends "ocaml dependencies ml" + ~prod:"%.ml.depends" + ~dep:"%.ml" ();; + +Ocamldep.depends "ocaml dependencies mli" + ~prod:"%.mli.depends" + ~dep:"%.mli" ();; + +rule "ocamllex" + ~tags:["ocaml"] (* FIXME "lexer" *) + ~prod:"%.ml" + ~dep:"%.mll" + (Ocaml_tools.ocamllex "%.mll");; + +rule "ocaml: mli -> odoc" + ~tags:["ocaml"; "doc"] + ~prod:"%.odoc" + ~deps:["%.mli"; "%.mli.depends"] + (Ocaml_tools.document_ocaml_interf "%.mli" "%.odoc");; + +rule "ocamldoc: document ocaml project odocl & *odoc -> docdir (html)" + ~prod:"%.docdir/index.html" + ~dep:"%.odocl" + (Ocaml_tools.document_ocaml_project + ~ocamldoc:Ocaml_tools.ocamldoc_l_dir "%.odocl" "%.docdir/index.html" "%.docdir");; + +rule "ocamldoc: document ocaml project odocl & *odoc -> docdir (man)" + ~prod:"%.docdir/man" + ~dep:"%.odocl" + (Ocaml_tools.document_ocaml_project + ~ocamldoc:Ocaml_tools.ocamldoc_l_dir "%.odocl" "%.docdir/man" "%.docdir");; + +rule "ocamldoc: document ocaml project odocl & *odoc -> man|latex|dot..." + ~prod:"%(dir).docdir/%(file)" + ~dep:"%(dir).odocl" + (Ocaml_tools.document_ocaml_project + ~ocamldoc:Ocaml_tools.ocamldoc_l_file "%(dir).odocl" "%(dir).docdir/%(file)" "%(dir).docdir");; + +(* To use menhir give the -use-menhir option at command line, + Or put true: use_menhir in your tag file. *) +if !Options.use_menhir || Configuration.has_tag "use_menhir" then begin + rule "ocaml: menhir" + ~prods:["%.ml"; "%.mli"] + ~deps:["%.mly"; "%.mly.depends"] + (Ocaml_tools.menhir "%.mly"); + + Ocamldep.depends "ocaml: menhir dependencies" + ~prod:"%.mly.depends" + ~dep:"%.mly" + ~ocamldep_command:Ocamldep.menhir_ocamldep_command (); +end else + rule "ocamlyacc" + ~tags:["ocaml"] (* FIXME "parser" *) + ~prods:["%.ml"; "%.mli"] + ~dep:"%.mly" + (Ocaml_tools.ocamlyacc "%.mly");; + +rule "ocaml C stubs: c -> o" + ~prod:x_o + ~dep:"%.c" + begin fun env _build -> + let c = env "%.c" in + let o = env x_o in + let cc = Cmd(S[!Options.ocamlc; T(tags_of_pathname c++"c"++"compile"); A"-c"; Px c]) in + if Pathname.dirname o = Pathname.current_dir_name then cc + else Seq[cc; mv (Pathname.basename o) o] + end;; + +rule "ocaml: ml & ml.depends & *cmi -> .inferred.mli" + ~prod:"%.inferred.mli" + ~deps:["%.ml"; "%.ml.depends"] + (Ocaml_tools.infer_interface "%.ml" "%.inferred.mli");; + +rule "ocaml: mltop -> top" + ~prod:"%.top" + ~dep:"%.mltop" + (Ocaml_compiler.byte_toplevel_link_mltop "%.mltop" "%.top");; + +flag ["ocaml"; "pp"] begin + S (List.fold_right (fun x acc -> Sh x :: acc) !Options.ocaml_ppflags []) +end;; + +flag ["ocaml"; "compile"] begin + atomize !Options.ocaml_cflags +end;; + +flag ["ocaml"; "link"] begin + atomize !Options.ocaml_lflags +end;; + +flag ["ocaml"; "ocamlyacc"] (atomize !Options.ocaml_yaccflags);; + +flag ["ocaml"; "ocamllex"] (atomize !Options.ocaml_lexflags);; + +flag ["ocaml"; "byte"; "link"] begin + S (List.map (fun x -> A (x^".cma")) !Options.ocaml_libs) +end;; + +flag ["ocaml"; "native"; "link"] begin + S (List.map (fun x -> A (x^".cmxa")) !Options.ocaml_libs) +end;; + +let camlp4_flags camlp4s = + List.iter begin fun camlp4 -> + flag ["ocaml"; "pp"; camlp4] (A camlp4) + end camlp4s;; + +camlp4_flags ["camlp4o"; "camlp4r"; "camlp4of"; "camlp4rf"; "camlp4orf"];; + +ocaml_lib ~extern:true ~native:false "dynlink";; +ocaml_lib ~extern:true "unix";; +ocaml_lib ~extern:true "str";; +ocaml_lib ~extern:true "bigarray";; +ocaml_lib ~extern:true "nums";; +ocaml_lib ~extern:true "dbm";; +ocaml_lib ~extern:true "graphics";; +ocaml_lib ~extern:true ~dir:"+labltk" "labltk";; +ocaml_lib ~extern:true ~dir:"+camlp4" ~tag_name:"use_camlp4" "camlp4lib";; +ocaml_lib ~extern:true ~dir:"+camlp4" ~tag_name:"use_old_camlp4" "camlp4";; +ocaml_lib ~extern:true ~dir:"+ocamldoc" "ocamldoc";; +ocaml_lib ~extern:true ~dir:"+ocamlbuild" "ocamlbuild";; + +flag ["ocaml"; "debug"; "compile"; "byte"] (A "-g");; +flag ["ocaml"; "debug"; "link"; "byte"; "program"] (A "-g");; +flag ["ocaml"; "debug"; "pack"; "byte"] (A "-g");; +flag ["ocaml"; "debug"; "compile"; "native"] (A "-g");; +flag ["ocaml"; "debug"; "link"; "native"; "program"] (A "-g");; +flag ["ocaml"; "debug"; "pack"; "native"] (A "-g");; +flag ["ocaml"; "dtypes"; "compile"] (A "-dtypes");; +flag ["ocaml"; "rectypes"; "compile"] (A "-rectypes");; +flag ["ocaml"; "linkall"; "link"] (A "-linkall");; +flag ["ocaml"; "link"; "profile"; "native"] (A "-p");; +flag ["ocaml"; "link"; "program"; "custom"; "byte"] (A "-custom");; +flag ["ocaml"; "compile"; "profile"; "native"] (A "-p");; +flag ["ocaml"; "compile"; "thread"] (A "-thread");; +flag ["ocaml"; "doc"; "thread"] (S[A"-I"; A"+threads"]);; +flag ["ocaml"; "link"; "thread"; "native"] (S[A "threads.cmxa"; A "-thread"]);; +flag ["ocaml"; "link"; "thread"; "byte"] (S[A "threads.cma"; A "-thread"]);; +flag ["ocaml"; "compile"; "nopervasives"] (A"-nopervasives");; +flag ["ocaml"; "compile"; "nolabels"] (A"-nolabels");; + +(*flag ["ocaml"; "ocamlyacc"; "quiet"] (A"-q");;*) +flag ["ocaml"; "ocamllex"; "quiet"] (A"-q");; + +let ocaml_warn_flag c = + flag ["ocaml"; "compile"; sprintf "warn_%c" (Char.uppercase c)] + (S[A"-w"; A (sprintf "%c" (Char.uppercase c))]); + flag ["ocaml"; "compile"; sprintf "warn_error_%c" (Char.uppercase c)] + (S[A"-warn-error"; A (sprintf "%c" (Char.uppercase c))]); + flag ["ocaml"; "compile"; sprintf "warn_%c" (Char.lowercase c)] + (S[A"-w"; A (sprintf "%c" (Char.lowercase c))]); + flag ["ocaml"; "compile"; sprintf "warn_error_%c" (Char.lowercase c)] + (S[A"-warn-error"; A (sprintf "%c" (Char.lowercase c))]);; + +List.iter ocaml_warn_flag ['A'; 'C'; 'D'; 'E'; 'F'; 'L'; 'M'; 'P'; 'S'; 'U'; 'V'; 'Y'; 'Z'; 'X'];; + +flag ["ocaml"; "doc"; "docdir"; "extension:html"] (A"-html");; +flag ["ocaml"; "doc"; "docdir"; "manpage"] (A"-man");; +flag ["ocaml"; "doc"; "docfile"; "extension:dot"] (A"-dot");; +flag ["ocaml"; "doc"; "docfile"; "extension:tex"] (A"-latex");; +flag ["ocaml"; "doc"; "docfile"; "extension:ltx"] (A"-latex");; +flag ["ocaml"; "doc"; "docfile"; "extension:texi"] (A"-texi");; + +(** Ocamlbuild plugin for it's own building *) +let install_lib = lazy (try Sys.getenv "INSTALL_LIB" with Not_found -> !*stdlib_dir/"ocamlbuild" (* not My_std.getenv since it's lazy*)) in +let install_bin = lazy (My_std.getenv ~default:"/usr/local/bin" "INSTALL_BIN") in +file_rule "ocamlbuild_where.ml" + ~prod:"%ocamlbuild_where.ml" + ~cache:(fun _ -> Printf.sprintf "lib:%S, bin:%S" !*install_lib !*install_bin) + begin fun _ oc -> + Printf.fprintf oc "let bindir = ref %S;;\n" !*install_bin; + Printf.fprintf oc "let libdir = ref %S;;\n" !*install_lib + end;; +ocaml_lib "ocamlbuildlib";; +ocaml_lib "ocamlbuildlightlib";; + +end in () diff --git a/ocamlbuild/ocaml_specific.mli b/ocamlbuild/ocaml_specific.mli new file mode 100644 index 00000000..be502625 --- /dev/null +++ b/ocamlbuild/ocaml_specific.mli @@ -0,0 +1,16 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: ocaml_specific.mli,v 1.2 2007/02/26 16:27:45 ertai Exp $ *) + +(* Original author: Nicolas Pouillard *) + +val init : unit -> unit diff --git a/ocamlbuild/ocaml_tools.ml b/ocamlbuild/ocaml_tools.ml new file mode 100644 index 00000000..b72fa688 --- /dev/null +++ b/ocamlbuild/ocaml_tools.ml @@ -0,0 +1,78 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: ocaml_tools.ml,v 1.2 2007/02/08 16:53:39 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +open My_std +open Pathname.Operators +open Tags.Operators +open Tools +open Command +open Ocaml_utils + +let ocamlyacc mly env _build = + let mly = env mly in + Cmd(S[!Options.ocamlyacc; T(tags_of_pathname mly++"ocaml"++"parser"++"ocamlyacc"); + flags_of_pathname mly; Px mly]) + +let ocamllex mll env _build = + let mll = env mll in + Cmd(S[!Options.ocamllex; T(tags_of_pathname mll++"ocaml"++"lexer"++"ocamllex"); + flags_of_pathname mll; Px mll]) + +let infer_interface ml mli env build = + let ml = env ml and mli = env mli in + Ocaml_compiler.prepare_compile build ml; + Cmd(S[!Options.ocamlc; ocaml_include_flags ml; A"-i"; + T(tags_of_pathname ml++"ocaml"++"infer_interface"); P ml; Sh">"; Px mli]) + +let menhir mly env build = + let mly = env mly in + Ocaml_compiler.prepare_compile build mly; + Cmd(S[!Options.ocamlyacc; T(tags_of_pathname mly++"ocaml"++"parser"++"menhir"); + A"--infer"; flags_of_pathname mly; Px mly]) + +let ocamldoc_c tags arg odoc = + let tags = tags++"ocaml" in + Cmd (S [!Options.ocamldoc; A"-dump"; Px odoc; T(tags++"doc"); + ocaml_ppflags tags; flags_of_pathname arg; + ocaml_include_flags arg; P arg]) + +let ocamldoc_l_dir tags deps _docout docdir = + Seq[Cmd (S[A"rm"; A"-rf"; Px docdir]); + Cmd (S[A"mkdir"; A"-p"; Px docdir]); + Cmd (S [!Options.ocamldoc; + S(List.map (fun a -> S[A"-load"; P a]) deps); + T(tags++"doc"++"docdir"); A"-d"; Px docdir])] + +let ocamldoc_l_file tags deps docout _docdir = + Seq[Cmd (S[A"rm"; A"-rf"; Px docout]); + Cmd (S[A"mkdir"; A"-p"; Px (Pathname.dirname docout)]); + Cmd (S [!Options.ocamldoc; + S(List.map (fun a -> S[A"-load"; P a]) deps); + T(tags++"doc"++"docfile"); A"-o"; Px docout])] + +let document_ocaml_interf mli odoc env build = + let mli = env mli and odoc = env odoc in + Ocaml_compiler.prepare_compile build mli; + ocamldoc_c (tags_of_pathname mli++"interf") mli odoc + +let document_ocaml_project ?(ocamldoc=ocamldoc_l_file) odocl docout docdir env build = + let odocl = env odocl and docout = env docout and docdir = env docdir in + let contents = string_list_of_file odocl in + let include_dirs = Pathname.include_dirs_of (Pathname.dirname odocl) in + let to_build = + List.map begin fun module_name -> + expand_module include_dirs module_name ["odoc"] + end contents in + let module_paths = List.map Outcome.good (build to_build) in + let tags = (Tags.union (tags_of_pathname docout) (tags_of_pathname docdir))++"ocaml" in + ocamldoc tags module_paths docout docdir diff --git a/ocamlbuild/ocaml_tools.mli b/ocamlbuild/ocaml_tools.mli new file mode 100644 index 00000000..b67d3e9e --- /dev/null +++ b/ocamlbuild/ocaml_tools.mli @@ -0,0 +1,26 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: ocaml_tools.mli,v 1.2 2007/02/08 16:53:39 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) + +val ocamldoc_c : Tags.t -> string -> string -> Command.t +val ocamldoc_l_dir : Tags.t -> string list -> string -> string -> Command.t +val ocamldoc_l_file : Tags.t -> string list -> string -> string -> Command.t + +val ocamlyacc : string -> Rule.action +val ocamllex : string -> Rule.action +val menhir : string -> Rule.action +val infer_interface : string -> string -> Rule.action +val document_ocaml_interf : string -> string -> Rule.action +val document_ocaml_project : + ?ocamldoc:(Tags.t -> string list -> string -> string -> Command.t) -> + string -> string -> string -> Rule.action diff --git a/ocamlbuild/ocaml_utils.ml b/ocamlbuild/ocaml_utils.ml new file mode 100644 index 00000000..0e71dc69 --- /dev/null +++ b/ocamlbuild/ocaml_utils.ml @@ -0,0 +1,112 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: ocaml_utils.ml,v 1.3.2.1 2007/03/02 17:10:27 pouillar Exp $ *) +(* Original author: Nicolas Pouillard *) +open My_std +open Format +open Log +open Pathname.Operators +open Tags.Operators +open Tools +open Flags +open Command;; + + +module S = Set.Make(String) + +let stdlib_dir = lazy begin + (* FIXME *) + let ocamlc_where = sprintf "%s/ocamlc.where" (Pathname.pwd / !Options.build_dir) in + let () = Command.execute ~quiet:true (Cmd(S[!Options.ocamlc; A"-where"; Sh">"; P ocamlc_where])) in + String.chomp (read_file ocamlc_where) +end + +let module_name_of_filename f = String.capitalize (Pathname.remove_extensions f) +let module_name_of_pathname x = + module_name_of_filename (Pathname.to_string (Pathname.basename x)) + +let ignore_stdlib x = + if !Options.nostdlib then false + else + let x' = !*stdlib_dir/((String.uncapitalize x)-.-"cmi") in + Pathname.exists x' + +let non_dependencies = ref [] +let non_dependency m1 m2 = non_dependencies := (m1, m2) :: !non_dependencies + +let module_importance modpath x = + if List.mem (modpath, x) !non_dependencies + || (List.mem x !Options.ignore_list) then begin + let () = dprintf 3 "This module (%s) is ignored by %s" x modpath in + `ignored + end + else if ignore_stdlib x then `just_try else `mandatory + +let expand_module include_dirs module_name exts = + List.fold_right begin fun include_dir -> + List.fold_right begin fun ext acc -> + let module_name_ext = module_name-.-ext in + include_dir/(String.uncapitalize module_name_ext) :: + include_dir/(String.capitalize module_name_ext) :: acc + end exts + end include_dirs [] + +let string_list_of_file file = + with_input_file file begin fun ic -> + Lexers.blank_sep_strings (Lexing.from_channel ic) + end +let print_path_list = Pathname.print_path_list + +let ocaml_ppflags tags = + let flags = Flags.of_tags (tags++"ocaml"++"pp") in + let reduced = Command.reduce flags in + if reduced = N then N else S[A"-pp"; Quote reduced] + +let ocaml_add_include_flag x acc = + if x = Pathname.current_dir_name then acc else A"-I" :: A x :: acc + +let ocaml_include_flags path = + S (List.fold_right ocaml_add_include_flag (Pathname.include_dirs_of (Pathname.dirname path)) []) + +let info_libraries = Hashtbl.create 103 + +let libraries = Hashtbl.create 103 +let libraries_of m = + try Hashtbl.find libraries m with Not_found -> [] +let use_lib m lib = Hashtbl.replace libraries m (lib :: libraries_of m) + +let ocaml_lib ?(extern=false) ?(byte=true) ?(native=true) ?dir ?tag_name libpath = + let add_dir x = + match dir with + | Some dir -> S[A"-I"; P dir; x] + | None -> x + in + let tag_name = + match tag_name with + | Some x -> x + | None -> "use_" ^ Pathname.basename libpath + in + Hashtbl.replace info_libraries tag_name (libpath, extern); + if extern then begin + if byte then + flag ["ocaml"; tag_name; "link"; "byte"] (add_dir (A (libpath^".cma"))); + if native then + flag ["ocaml"; tag_name; "link"; "native"] (add_dir (A (libpath^".cmxa"))); + end else begin + if not byte && not native then + invalid_arg "ocaml_lib: ~byte:false or ~native:false only works with ~extern:true"; + end; + match dir with + | None -> () + | Some dir -> flag ["ocaml"; tag_name; "compile"] (S[A"-I"; P dir]) + +let cmi_of = Pathname.update_extensions "cmi" diff --git a/ocamlbuild/ocaml_utils.mli b/ocamlbuild/ocaml_utils.mli new file mode 100644 index 00000000..20ba8a8f --- /dev/null +++ b/ocamlbuild/ocaml_utils.mli @@ -0,0 +1,39 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: ocaml_utils.mli,v 1.3 2007/02/26 16:27:45 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +val stdlib_dir : Pathname.t Lazy.t +val module_name_of_filename : Pathname.t -> string +val module_name_of_pathname : Pathname.t -> string +val ignore_stdlib : string -> bool +val non_dependency : string -> string -> unit +val expand_module : + Pathname.t list -> Pathname.t -> string list -> Pathname.t list +val string_list_of_file : string -> string list +val ocaml_ppflags : Tags.t -> Command.spec +val ocaml_include_flags : Pathname.t -> Command.spec +val libraries_of : Pathname.t -> Pathname.t list +val use_lib : Pathname.t -> Pathname.t -> unit +val cmi_of : Pathname.t -> Pathname.t +val ocaml_add_include_flag : string -> Command.spec list -> Command.spec list +val module_importance : string -> string -> [ `ignored | `mandatory | `just_try ] + +val info_libraries : (string, string * bool) Hashtbl.t + +val ocaml_lib : + ?extern:bool -> + ?byte:bool -> + ?native:bool -> + ?dir:Pathname.t -> + ?tag_name:string -> + Pathname.t -> unit + diff --git a/ocamlbuild/ocamlbuild-presentation.rslide b/ocamlbuild/ocamlbuild-presentation.rslide new file mode 100644 index 00000000..4dc529f8 --- /dev/null +++ b/ocamlbuild/ocamlbuild-presentation.rslide @@ -0,0 +1,329 @@ +documentclass :beamer, :t, :compress, :red +usepackage :inputenc, :utf8 + +words "**OCaml**", "**ocamlbuild**", "_Makefile_" + +title "ocamlbuild, a tool for automatic compilation of OCaml projects" +authors "Berke Durak", "Nicolas Pouillard" +institute do + > @@Berke.Durak@inria.fr@@ + hfill + > @@Nicolas.Pouillard@inria.fr@@ +end + +usetheme :JuanLesPins +usefonttheme :serif +beamer_header '\setbeamercolor*{titlelike}{parent=structure}' +at_begin_section do + slide "Outline" do + tableofcontents 'sectionstyle=show/shaded', + 'subsectionstyle=show/shaded/hide' + end +end +beamer_footline 50, 0 + +extend do + module ::Rslide::Tags + class CodeCaml < Code + end + class CodeTags < Code + end + end +end + +maketitle + +h1 "Introduction" + +slide "Why such a tool?", '<+->' do + * To make our OCaml life easier + * To stop writing poor MakefileS + * To have a tool that Just works™ +end + +slide "What does ocamlbuild handle?", '<+->' do + + box "Regular OCaml projects of arbitrary size" do + > Trivially handled using the command line options. + end + + box "Mostly regular OCaml projects with common exceptions" do + > Requires writing one tag file (__tags_) that declares those exceptions. + end + + box "Almost any project" do + > Accomplished by writing an ocamlbuild plugin. + end + +end + +slide "What does ocamlbuild provide?" do + list do + overlay 1,2 do + * Automated whole-project compilation + * Minimal recompilation + * Lots of useful targets (doc, debugging, profiling...) + * Supports multiple build directories + * Automatic and safe cleaning + * A source directory uncluttered by object files + * A portable tool shipped with OCaml + end + overlay 2 do + * Saves time and money! + end + end +end + +h1 "Regular OCaml projects" + +slide "What's a regular OCaml project?" do + box "It's a project that needs no exceptions from the standard rules:" do + * Has compilation units (_ml_ and _mli_ files) + * May have parsers and lexers (_mly_ and _mll_ files) + * May use packages, libraries and toplevels (_ml{pack,lib,top}_) + * May link with external libraries + * Has one main OCaml unit from which these units are reachable + end +end + +slide "How difficult is it to compile regular projects by hand?" do + box "OCaml has subtle compilation rules" do + * Interfaces (_.mli_) can be absent, yet buildable (_.mly_) + * Native and bytecode suffixes and settings differ + * Native packages are difficult to do (_-for-pack_) + * Linkage order must be correctly computed + * Include directories must be ordered + * _ocamldep_ gives partial information (too conservative) + end +end + +slide "How does ocamlbuild manage all that?" do + > It has a lot of hand-crafted Ocaml-specific compilation logic! + box "A dynamic exploration approach", '<2>' do + * Start from the given targets + * Attempt to discover dependencies using _ocamldep_ + * _ocamldep_ cannot always be trusted: backtrack if necessary + * Launch compilations and discover more dependencies + end +end + +slide "Demo..." do + box "Many projects can be compiled with a single command:" do + * Menhir: _ocamlbuild -lib unix back.native_ + * Hevea: _ocamlbuild latexmain.native_ + * Ergo: _ocamlbuild main.native_ + * Ocamlgraph: _ocamlbuild -cflags -for-pack,Ocamlgraph demo.native_ + * ... + end + box "To be fair..." do + > Some of these projects require that a _version.ml_ + or _stdlib.ml_ file be generated beforehand. + end +end + +h1 "Dealing with exceptions to standard rules" + +slide "What's an exception?" do + box "Files that need specific flags" do + * Warnings to be enabled or disabled + * Debugging (_-g_), profiling (_-p_), type annotation, + recursive types, _-linkall_, _-thread_, _-custom_... + end + list do + * Units that need external C libraries + * Binaries that need external OCaml libraries + * Directories that must be included or excluded + * Dependencies that cannot be discovered + end +end + +slide "_Make_ and exceptions" do + * The _make_ tool can't handle exceptions very well + * Needs exceptions to be encoded as specific rules + * This generally makes rules and exceptions tightly bound by variables + * This creates non-modular makefiles that don't *scale* +end + +slide "The tags, our way to specify exceptions", 'fragile=singleslide' do + list do + * The _tags file is made of lines + * Each line is made of a pattern and a list of signed tags + * A line adds or removes tags from matching files + * Patterns are boolean combinations of shell-like globbing expressions + end + code_tags do + : "funny.ml": rectypes + <**/*.ml*>: warn_A, warn_error_A, debug, dtypes + <**/*.cmx>: inline(9) + "foo.ml" or "bar.ml": warn_v, warn_error_v + "vendor.ml": -warn_A, -warn_error_A + : use_unix + "main.byte": use_dynlink, linkall + "test": not_hygienic + : precious + end +end + +slide "How tags and rules give commands", 'fragile=singleslide' do + box "Files are tagged using tagging rules" do + code_tags do + : "foo/bar.ml": rectypes + end + end + box "Rules then produce commands with *tagged holes*" do + code_caml do + : let tagged_hole = + tags_for(ml)++"ocaml"++"compile"++"byte" in + Cmd(S[A"ocamlc";A"-c";T tagged_hole;P ml;A"-o";P cmo]) + end + end + box "These holes are filled by command fragments (such as flags)" do + code_caml do + : flag ["ocaml"; "compile"; "byte"; "rectypes"] + (A"-rectypes") + end + end +end + +slide "Tags and dependencies", 'fragile=singleslide' do + box "One can define dependencies triggered by combinations of tags" do + code_caml do + : dep ["ocaml"; "link"; "byte"; "program"; "plugin:foo"] + ["plugin/pluginlib.cma"; "plugin/plugin_foo.cmo"] + end + end + box "By tagging files we make things happen" do + code_tags do + : "test.byte": plugin:foo + end + end +end + +h1 "Writing an ocamlbuild plugin" + +slide "Not a specific language, but plain OCaml code" do + * Plugins are compiled on the fly + * Dynamic configuration is feasible + box "With a plugin one can:" do + * Extend rules (add new ones, override old ones) + * Add flags and dependencies based on tags + * Tag files + * Change options + * Define the directory structure precisely + * Help _ocamldep_ + * Specify external libraries + end +end + +slide "A plugin example" do + > Let's read it in live... +end + +# slide "ocamlbuild scales" do +# > Indeed ocamlbuild is used as an experimental replacement in OCaml itself. +# end + +h1 "General features" + +slide "Parallel execution where applicable" do + * You select the maximum number of jobs (_-j N_) + * Rules know how to ask for parallel targets + * The system keeps things scheduled correctly + * Example: Separate compilation of byte code + * (Optimal scheduling would require a static graph) +end + +slide "A status bar for your visual comfort" do + * Compilation tools echo commands and their output + * This creates a long and boring output that scrolls too fast + * Here you can keep an eye on what is going on! + * It succinctly displays time, number of targets, and tags + * Command outputs are correctly multiplexed + * A trace of the commands executed is kept in a log file + * This log file can be used as the basis of a shell script + example do + invisible_join do + count = 0 + mod = 1 + File.read("manual/trace.out").each do |line| + count += 1 + next if count % mod != 0 + line.gsub!("\\", "|") + line.latex_encode! + line.gsub!(/( +)/) { "\\hspace{#{0.49 * $1.size}em}" } + line.chomp! + s = "\\only<#{count / mod}>{\\tt #{line}}%\n" + verbatim_text s + end + end + end +end + +slide "Hygiene and sterilization" do + * ocamlbuild has a Hygiene Squad (HS) that checks your source tree for cleanliness + box "It has preconceived but useful cleanliness notions", '<1->' do + * Files dirty by default: _.cmi_, _.cmo_, _.cma_, _.cmx_... + * _ocamllex_/_ocamlyacc_ files: _.ml_ *if* _.mll_, _.ml_&_.mli_ *if* _.mly_... + end + box "If unsatisfied, the HS produces a sterilization script", '<2->' do + * Read it carefully (or work with versioning) + * Run at your own risks + end + box "HS can be told of exceptions", '<3->' do + > Files or directories tagged as __not_hygienic__ or _precious_. + end +end + +slide "Some supported tools" do + box "_Menhir_ as an _ocamlyacc_ replacement", '<1->' do + * Enabled with the __use_menhir__ global tag or the __-use-menhir__ option + * Handles implicit dependencies using _--infer_ + end + box "_Ocamldoc_ to build your doc", '<2->' do + * Separated construction using (_-dump_/_-load_) + * Handles ??HTML??, ??LaTeX??, ??Man??, ??Dot??, ??TeXi?? + end + # box "_ocamlmklib_, _ocamlmktop_" do + # > Basic support using _.mllib_ and _.mltop_ files + # end + box "_Camlp4_ aware", '<3->' do + * Tags allow to setup any installed _Camlp4_ preprocessor + * Fine grained dependencies help a lot... + end +end + +h1 "Conclusion" + +slide "Resume" do + box "ocamlbuild can be used in three ways:", '<1->' do + * With only command-line options for fully regular projects + * With the __tags_ file for intermediate projects + * With a plugin for the most complex projects + end + box "ocamlbuild saves your time by:", '<2->' do + * Building your project gently + * Compiling only as necessary + * Running commands in parallel + * Keeping your house clean + * Letting you concentrate on your code! + end +end + +slide "Acknowledgments" do + box "For enlightening discussions about OCaml internals:", '<1->' do + * Xavier Leroy + * Damien Doligez + end + box "For his insights about OCaml dependencies:", '<2->' do + * Alain Frisch + end + box "For letting this happen:", '<3->' do + * Michel Mauny + end +end + +slide "Conclusion", '<+->' do + * ocamlbuild is not perfect but already damn useful + * It will be in 3.10, so feel free to use it + * Try it now! It's in the CVS! +end diff --git a/ocamlbuild/ocamlbuild.ml b/ocamlbuild/ocamlbuild.ml new file mode 100644 index 00000000..2805396d --- /dev/null +++ b/ocamlbuild/ocamlbuild.ml @@ -0,0 +1,15 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: ocamlbuild.ml,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +My_unix_with_unix.setup (); +Ocamlbuild_pack.Main.main () diff --git a/ocamlbuild/ocamlbuild.mli b/ocamlbuild/ocamlbuild.mli new file mode 100644 index 00000000..9cddf473 --- /dev/null +++ b/ocamlbuild/ocamlbuild.mli @@ -0,0 +1,15 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: ocamlbuild.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +(** Nothing to export for now *) + diff --git a/ocamlbuild/ocamlbuild.mltop b/ocamlbuild/ocamlbuild.mltop new file mode 100644 index 00000000..eb1598d6 --- /dev/null +++ b/ocamlbuild/ocamlbuild.mltop @@ -0,0 +1,4 @@ +Executor +My_unix_with_unix +Ocamlbuild_pack +Ocamlbuild_plugin diff --git a/ocamlbuild/ocamlbuild.odocl b/ocamlbuild/ocamlbuild.odocl new file mode 100644 index 00000000..d4374386 --- /dev/null +++ b/ocamlbuild/ocamlbuild.odocl @@ -0,0 +1,38 @@ +Log +My_unix +My_std +Std_signatures +Signatures +Shell +Display +Command +Configuration +Discard_printf +Flags +Hygiene +Options +Pathname +Report +Resource +Rule +Slurp +Solver +Tags +Tools +Fda +Ocaml_specific +Ocaml_arch +Ocamlbuild_where +Lexers +Glob +Bool +Glob_ast +Glob_lexer +Plugin +Main +Hooks +Ocaml_utils +Ocaml_tools +Ocaml_compiler +Ocamldep +Ocaml_dependencies diff --git a/ocamlbuild/ocamlbuild_pack.mlpack b/ocamlbuild/ocamlbuild_pack.mlpack new file mode 100644 index 00000000..d4374386 --- /dev/null +++ b/ocamlbuild/ocamlbuild_pack.mlpack @@ -0,0 +1,38 @@ +Log +My_unix +My_std +Std_signatures +Signatures +Shell +Display +Command +Configuration +Discard_printf +Flags +Hygiene +Options +Pathname +Report +Resource +Rule +Slurp +Solver +Tags +Tools +Fda +Ocaml_specific +Ocaml_arch +Ocamlbuild_where +Lexers +Glob +Bool +Glob_ast +Glob_lexer +Plugin +Main +Hooks +Ocaml_utils +Ocaml_tools +Ocaml_compiler +Ocamldep +Ocaml_dependencies diff --git a/ocamlbuild/ocamlbuild_plugin.ml b/ocamlbuild/ocamlbuild_plugin.ml new file mode 100644 index 00000000..38c400d9 --- /dev/null +++ b/ocamlbuild/ocamlbuild_plugin.ml @@ -0,0 +1,54 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: ocamlbuild_plugin.ml,v 1.2 2007/02/26 16:27:45 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) + +open Ocamlbuild_pack +include Ocamlbuild_pack.My_std +module Arch = Ocamlbuild_pack.Ocaml_arch +module Command = Ocamlbuild_pack.Command +module Pathname = Ocamlbuild_pack.Pathname +module Tags = Ocamlbuild_pack.Tags +include Pathname.Operators +include Tags.Operators +module Rule = Ocamlbuild_pack.Rule +module Options = Ocamlbuild_pack.Options +include Rule.Common_commands +type env = Pathname.t -> Pathname.t +type builder = Pathname.t list list -> (Pathname.t, exn) Ocamlbuild_pack.My_std.Outcome.t list +type action = env -> builder -> Command.t +let rule = Rule.rule +let dep = Rule.dep +let file_rule = Rule.file_rule +let copy_rule = Rule.copy_rule +let custom_rule = Rule.custom_rule +let ocaml_lib = Ocamlbuild_pack.Ocaml_utils.ocaml_lib +let flag = Ocamlbuild_pack.Flags.flag +let non_dependency = Ocamlbuild_pack.Ocaml_utils.non_dependency +let use_lib = Ocamlbuild_pack.Ocaml_utils.use_lib +let module_name_of_pathname = Ocamlbuild_pack.Ocaml_utils.module_name_of_pathname +let string_list_of_file = Ocamlbuild_pack.Ocaml_utils.string_list_of_file +let expand_module = Ocamlbuild_pack.Ocaml_utils.expand_module +let tags_of_pathname = Ocamlbuild_pack.Tools.tags_of_pathname +let hide_package_contents = Ocamlbuild_pack.Ocaml_compiler.hide_package_contents +let tag_file file tags = + Ocamlbuild_pack.Configuration.parse_string (Printf.sprintf "%S: %s" file (String.concat ", " tags));; +let tag_any tags = + Ocamlbuild_pack.Configuration.parse_string (Printf.sprintf "true: %s" (String.concat ", " tags));; +type hook = Ocamlbuild_pack.Hooks.message = + | Before_hygiene + | After_hygiene + | Before_options + | After_options + | Before_rules + | After_rules +let dispatch = Ocamlbuild_pack.Hooks.setup_hooks diff --git a/ocamlbuild/ocamlbuild_plugin.mli b/ocamlbuild/ocamlbuild_plugin.mli new file mode 100644 index 00000000..8e642f31 --- /dev/null +++ b/ocamlbuild/ocamlbuild_plugin.mli @@ -0,0 +1,5 @@ +include Ocamlbuild_pack.Signatures.PLUGIN + with module Pathname = Ocamlbuild_pack.Pathname + and module Outcome = Ocamlbuild_pack.My_std.Outcome + and module Tags = Ocamlbuild_pack.Tags + and module Command = Ocamlbuild_pack.Command diff --git a/ocamlbuild/ocamlbuild_where.mli b/ocamlbuild/ocamlbuild_where.mli new file mode 100644 index 00000000..13a7549f --- /dev/null +++ b/ocamlbuild/ocamlbuild_where.mli @@ -0,0 +1,17 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: ocamlbuild_where.mli,v 1.1.4.1 2007/03/04 16:13:53 pouillar Exp $ *) + +(* Original author: Nicolas Pouillard *) + +val bindir : string ref +val libdir : string ref diff --git a/ocamlbuild/ocamlbuildlib.mllib b/ocamlbuild/ocamlbuildlib.mllib new file mode 100644 index 00000000..eb1598d6 --- /dev/null +++ b/ocamlbuild/ocamlbuildlib.mllib @@ -0,0 +1,4 @@ +Executor +My_unix_with_unix +Ocamlbuild_pack +Ocamlbuild_plugin diff --git a/ocamlbuild/ocamlbuildlight.ml b/ocamlbuild/ocamlbuildlight.ml new file mode 100644 index 00000000..24eb35a3 --- /dev/null +++ b/ocamlbuild/ocamlbuildlight.ml @@ -0,0 +1,14 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: ocamlbuildlight.ml,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +Ocamlbuild_pack.Main.main ();; diff --git a/ocamlbuild/ocamlbuildlight.mli b/ocamlbuild/ocamlbuildlight.mli new file mode 100644 index 00000000..ae07af39 --- /dev/null +++ b/ocamlbuild/ocamlbuildlight.mli @@ -0,0 +1,14 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: ocamlbuildlight.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +(* Nothing *) diff --git a/ocamlbuild/ocamlbuildlightlib.mllib b/ocamlbuild/ocamlbuildlightlib.mllib new file mode 100644 index 00000000..dc38da3d --- /dev/null +++ b/ocamlbuild/ocamlbuildlightlib.mllib @@ -0,0 +1,2 @@ +Ocamlbuild_pack +Ocamlbuild_plugin diff --git a/ocamlbuild/ocamldep.ml b/ocamlbuild/ocamldep.ml new file mode 100644 index 00000000..7773b4ce --- /dev/null +++ b/ocamlbuild/ocamldep.ml @@ -0,0 +1,77 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: ocamldep.ml,v 1.2 2007/02/08 16:53:39 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +open My_std +open Log +open Command +open Tags.Operators +open Tools +open Ocaml_utils +open Pathname.Operators + +exception Error of string + +let ocamldep_command arg = + let tags = tags_of_pathname arg++"ocaml"++"ocamldep" in + S [!Options.ocamldep; T tags; ocaml_ppflags tags; + flags_of_pathname arg; A "-modules"] + +let menhir_ocamldep_command arg out = + let tags = tags_of_pathname arg++"ocaml"++"menhir_ocamldep" in + Cmd (S [!Options.ocamlyacc; T tags; A"--raw-depend"; + A"--ocamldep"; Quote (ocamldep_command arg); + P arg; Sh ">"; Px out]) + +let ocamldep_command arg out = + Cmd (S[ocamldep_command arg; P arg; Sh ">"; Px out]) + +let module_dependencies = Hashtbl.create 103 +let module_dependencies_of module_path = + try Hashtbl.find module_dependencies module_path with Not_found -> [] +let register_module_dependencies module_path deps = + let deps' = List.fold_right begin fun dep acc -> + match module_importance module_path dep with + | `ignored -> acc + | (`just_try | `mandatory) as importance -> (importance, dep) :: acc + end deps [] in + Hashtbl.replace module_dependencies module_path + (List.union (module_dependencies_of module_path) deps') + +let depends name ?tags ~prod ~dep ?insert ?(ocamldep_command=ocamldep_command) () = + Rule.custom_rule name ?tags ~prod ~dep ?insert + ~cache:(fun env -> Command.to_string (ocamldep_command (env dep) (env prod))) + begin fun env ~cached -> + let arg = env dep in + let out = env prod in + let cmd = ocamldep_command arg out in + let () = dprintf 6 "ocamldep: %a %a" Pathname.print arg Command.print cmd in + if not (Pathname.exists arg) then + raise (Error(sbprintf "Ocamldep.ocamldep: no input file (%a)" Pathname.print arg)) + else begin + Command.execute ~pretend:cached cmd; + with_input_file out begin fun ic -> + let ocamldep_output = + try Lexers.ocamldep_output (Lexing.from_channel ic) + with Lexers.Error msg -> raise (Error(Printf.sprintf "Ocamldep.ocamldep: bad output (%s)" msg)) in + let ocamldep_output = + List.fold_right begin fun (_, deps) acc -> + List.union deps acc + end ocamldep_output [] in + let ocamldep_output = + if !Options.nostdlib && not (Tags.mem "nopervasives" (tags_of_pathname arg)) then + "Pervasives" :: ocamldep_output + else ocamldep_output in + register_module_dependencies arg ocamldep_output + end + end + end diff --git a/ocamlbuild/ocamldep.mli b/ocamlbuild/ocamldep.mli new file mode 100644 index 00000000..791f518a --- /dev/null +++ b/ocamlbuild/ocamldep.mli @@ -0,0 +1,26 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: ocamldep.mli,v 1.2 2007/02/08 16:53:39 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +exception Error of string +val ocamldep_command : Pathname.t -> Pathname.t -> Command.t +val menhir_ocamldep_command : Pathname.t -> Pathname.t -> Command.t +val module_dependencies_of : Pathname.t -> ([ `mandatory | `just_try ] * string) list +val register_module_dependencies : Pathname.t -> string list -> unit +val depends : + string -> + ?tags:string list -> + prod:string -> + dep:string -> + ?insert:[`top | `before of string | `after of string | `bottom] -> + ?ocamldep_command:(Pathname.t -> Pathname.t -> Command.t) -> + unit -> unit diff --git a/ocamlbuild/options.ml b/ocamlbuild/options.ml new file mode 100644 index 00000000..602e0c3a --- /dev/null +++ b/ocamlbuild/options.ml @@ -0,0 +1,233 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: options.ml,v 1.7.2.2 2007/03/04 16:13:53 pouillar Exp $ *) +(* Original author: Nicolas Pouillard *) + +let version = "ocamlbuild 0.1";; + +type command_spec = Command.spec + +open My_std +open Arg +open Format +open Command + +let entry = ref None +let build_dir = ref "_build" +let include_dirs = ref [] +let exclude_dirs = ref [] +let nothing_should_be_rebuilt = ref false +let sanitize = ref true +let sanitization_script = ref "sanitize.sh" +let hygiene = ref true +let ignore_auto = ref true +let plugin = ref true +let just_plugin = ref false +let native_plugin = ref true +let make_links = ref true +let nostdlib = ref false +let use_menhir = ref false +let catch_errors = ref true + +let mk_virtual_solvers = + let dir = Ocamlbuild_where.bindir in + List.iter begin fun cmd -> + let opt = cmd ^ ".opt" in + let a_opt = A opt in + let a_cmd = A cmd in + let search_in_path = memo Command.search_in_path in + let solver () = + if sys_file_exists !dir then + let long = filename_concat !dir cmd in + let long_opt = long ^ ".opt" in + if sys_file_exists long_opt then A long_opt + else if sys_file_exists long then A long + else try let _ = search_in_path opt in a_opt + with Not_found -> a_cmd + else + try let _ = search_in_path opt in a_opt + with Not_found -> a_cmd + in Command.setup_virtual_command_solver (String.uppercase cmd) solver + end + +let () = + mk_virtual_solvers + ["ocamlc"; "ocamlopt"; "ocamldep"; "ocamldoc"; + "ocamlyacc"; "ocamllex"; "ocamlmklib"; "ocamlmktop"] +let ocamlc = ref (V"OCAMLC") +let ocamlopt = ref (V"OCAMLOPT") +let ocamldep = ref (V"OCAMLDEP") +let ocamldoc = ref (V"OCAMLDOC") +let ocamlyacc = ref (V"OCAMLYACC") +let ocamllex = ref (V"OCAMLLEX") +let ocamlmklib = ref (V"OCAMLMKLIB") +let ocamlmktop = ref (V"OCAMLMKTOP") +let ocamlrun = ref N +let program_to_execute = ref false +let must_clean = ref false +let show_documentation = ref false +let ext_lib = ref "a" +let ext_obj = ref "o" +let ext_dll = ref "so" + +let targets_internal = ref [] +let ocaml_libs_internal = ref [] +let ocaml_lflags_internal = ref [] +let ocaml_cflags_internal = ref [] +let ocaml_ppflags_internal = ref [] +let ocaml_yaccflags_internal = ref [] +let ocaml_lexflags_internal = ref [] +let program_args_internal = ref [] +let ignore_list_internal = ref [] +let tags_internal = ref [["quiet"]] +let show_tags_internal = ref [] + +let my_include_dirs = ref [[Filename.current_dir_name]] +let my_exclude_dirs = ref [[".svn"; "CVS"]] + +let pwd = Sys.getcwd () + +let internal_log_file = ref None +let set_log_file file = + internal_log_file := Some file; + Log.log_file := lazy begin + if !Log.level <= 0 + || ((!plugin || !just_plugin) + && sys_file_exists (filename_concat pwd "myocamlbuild.ml")) then + None + else Some(filename_concat pwd file) + end + +let () = set_log_file "_log" + +let dummy = "*invalid-dummy-string*";; (* Dummy string for delimiting the latest argument *) + +let add_to rxs x = + let xs = Lexers.comma_or_blank_sep_strings (Lexing.from_string x) in + rxs := xs :: !rxs +let add_to' rxs x = + if x <> dummy then + rxs := [x] :: !rxs + else + () +let set_cmd rcmd = String (fun s -> rcmd := Sh s) +let spec = + Arg.align + [ + "-version", Unit (fun () -> print_endline version; raise Exit_OK), " Display the version"; + "-quiet", Unit (fun () -> Log.level := 0), " Make as quiet as possible"; + "-verbose", Int (fun i -> Log.level := i + 2), " Set the verbosity level"; + "-documentation", Set show_documentation, " Show rules and flags"; + "-log", String set_log_file, " Set log file"; + "-no-log", Unit (fun () -> Log.log_file := lazy None), " No log file"; + "-clean", Set must_clean, " Remove build directory and other files, then exit"; + + "-I", String (add_to' my_include_dirs), " Add to include directories"; + "-Is", String (add_to my_include_dirs), " (same as above, but accepts a (comma or blank)-separated list)"; + "-X", String (add_to' my_exclude_dirs), " Directory to ignore"; + "-Xs", String (add_to my_exclude_dirs), " (idem)"; + + "-lib", String (add_to' ocaml_libs_internal), " Link to this ocaml library"; + "-libs", String (add_to ocaml_libs_internal), " (idem)"; + "-lflag", String (add_to' ocaml_lflags_internal), " Add to ocamlc link flags"; + "-lflags", String (add_to ocaml_lflags_internal), " (idem)"; + "-cflag", String (add_to' ocaml_cflags_internal), " Add to ocamlc compile flags"; + "-cflags", String (add_to ocaml_cflags_internal), " (idem)"; + "-yaccflag", String (add_to' ocaml_yaccflags_internal), " Add to ocamlyacc flags"; + "-yaccflags", String (add_to ocaml_yaccflags_internal), " (idem)"; + "-lexflag", String (add_to' ocaml_lexflags_internal), " Add to ocamllex flags"; + "-lexflags", String (add_to ocaml_lexflags_internal), " (idem)"; + "-ppflag", String (add_to' ocaml_ppflags_internal), " Add to ocaml preprocessing flags"; + "-pp", String (add_to ocaml_ppflags_internal), " (idem)"; + "-tag", String (add_to' tags_internal), " Add to default tags"; + "-tags", String (add_to tags_internal), " (idem)"; + "-show-tags", String (add_to' show_tags_internal), " Show tags that applies on that pathname"; + + "-ignore", String (add_to ignore_list_internal), " Don't try to build these modules"; + "-no-links", Clear make_links, " Don't make links of produced final targets"; + "-no-skip", Clear ignore_auto, " Don't skip modules that are requested by ocamldep but cannot be built"; + "-no-hygiene", Clear hygiene, " Don't apply sanity-check rules"; + "-no-plugin", Clear plugin, " Don't build myocamlbuild.ml"; + "-no-stdlib", Set nostdlib, " Don't ignore stdlib modules"; + "-dont-catch-errors", Clear catch_errors, " Don't catch and display exceptions (useful to display the call stack)"; + "-just-plugin", Set just_plugin, " Just build myocamlbuild.ml"; + "-byte-plugin", Clear native_plugin, " Don't use a native plugin but bytecode"; + "-sanitization-script", Set_string sanitization_script, " Change the file name for the generated sanitization script"; + "-no-sanitize", Clear sanitize, " Do not generate sanitization script"; + "-nothing-should-be-rebuilt", Set nothing_should_be_rebuilt, " Fail if something needs to be rebuilt"; + "-classic-display", Set Log.classic_display, " Display executed commands the old-fashioned way"; + "-use-menhir", Unit(fun () -> use_menhir := true; ocamlyacc := A"menhir"), + " Use menhir instead of ocamlyacc"; + + "-j", Set_int Command.jobs, " Allow N jobs at once (0 for unlimited)"; + + "-build-dir", Set_string build_dir, " Set build directory"; + "-install-lib-dir", Set_string Ocamlbuild_where.libdir, " Set the install library directory"; + "-install-bin-dir", Set_string Ocamlbuild_where.bindir, " Set the install binary directory"; + "-where", Unit (fun () -> print_endline !Ocamlbuild_where.libdir; raise Exit_OK), " Display the install library directory"; + + "-ocamlc", set_cmd ocamlc, " Set the OCaml bytecode compiler"; + "-ocamlopt", set_cmd ocamlopt, " Set the OCaml native compiler"; + "-ocamldep", set_cmd ocamldep, " Set the OCaml dependency tool"; + "-ocamlyacc", set_cmd ocamlyacc, " Set the ocamlyacc tool"; + "-menhir", set_cmd ocamlyacc, " Set the menhir tool (use it after -use-menhir)"; + "-ocamllex", set_cmd ocamllex, " Set the ocamllex tool"; + (* Not set since we perhaps want to replace ocamlmklib *) + (* "-ocamlmklib", set_cmd ocamlmklib, " Set the ocamlmklib tool"; *) + "-ocamlmktop", set_cmd ocamlmklib, " Set the ocamlmktop tool"; + "-ocamlrun", set_cmd ocamlrun, " Set the ocamlrun tool"; + + "--", Rest (fun x -> program_to_execute := true; add_to' program_args_internal x), + " Stop argument processing, remaining arguments are given to the user program"; + ] + +let targets = ref [] +let ocaml_libs = ref [] +let ocaml_lflags = ref [] +let ocaml_cflags = ref [] +let ocaml_ppflags = ref [] +let ocaml_yaccflags = ref [] +let ocaml_lexflags = ref [] +let program_args = ref [] +let ignore_list = ref [] +let tags = ref [] +let show_tags = ref [] + +let init () = + let anon_fun = add_to' targets_internal in + let usage_msg = sprintf "Usage %s [options] " Sys.argv.(0) in + let argv' = Array.concat [Sys.argv; [|dummy|]] in + parse_argv argv' spec anon_fun usage_msg; + Shell.mkdir_p !build_dir; + let reorder x y = x := (List.concat (List.rev !y)) in + reorder targets targets_internal; + reorder ocaml_libs ocaml_libs_internal; + reorder ocaml_cflags ocaml_cflags_internal; + reorder ocaml_lflags ocaml_lflags_internal; + reorder ocaml_ppflags ocaml_ppflags_internal; + reorder ocaml_yaccflags ocaml_yaccflags_internal; + reorder ocaml_lexflags ocaml_lexflags_internal; + reorder program_args program_args_internal; + reorder tags tags_internal; + reorder ignore_list ignore_list_internal; + reorder show_tags show_tags_internal; + + let dir_reorder my dir = + let d = !dir in + reorder dir my; + dir := List.filter sys_file_exists (!dir @ d) + in + dir_reorder my_include_dirs include_dirs; + dir_reorder my_exclude_dirs exclude_dirs; + + ignore_list := List.map String.capitalize !ignore_list +;; diff --git a/ocamlbuild/options.mli b/ocamlbuild/options.mli new file mode 100644 index 00000000..98550053 --- /dev/null +++ b/ocamlbuild/options.mli @@ -0,0 +1,18 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: options.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) + +include Signatures.OPTIONS with type command_spec = Command.spec + +val entry : bool Slurp.entry option ref +val init : unit -> unit diff --git a/ocamlbuild/pathname.ml b/ocamlbuild/pathname.ml new file mode 100644 index 00000000..af13359c --- /dev/null +++ b/ocamlbuild/pathname.ml @@ -0,0 +1,194 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: pathname.ml,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +open My_std +open Format +open Log + +type t = string + +include Filename + +let print_strings = List.print String.print + +let concat = filename_concat + +let compare = compare + +let print = pp_print_string + +let mk s = s + +let pwd = Sys.getcwd () + +let add_extension ext x = x ^ "." ^ ext + +let check_extension x ext = + let lx = String.length x and lext = String.length ext in + lx > lext + 1 && x.[lx - lext - 1] = '.' && String.is_suffix x ext + +module Operators = struct + let ( / ) = concat + let ( -.- ) file ext = add_extension ext file +end +open Operators + +let in_source_dir p = + if is_implicit p then pwd/p else invalid_arg (sprintf "in_source_dir: %S" p) + +let equal x y = x = y + +let to_string x = x + +let is_link = Shell.is_link +let readlink = Shell.readlink +let is_directory x = + try (My_unix.stat x).My_unix.stat_file_kind = My_unix.FK_dir + with Sys_error _ -> false +let readdir x = Outcome.good (sys_readdir x) + +let dir_seps = ['/';'\\'] (* FIXME add more *) +let parent x = concat parent_dir_name x + +(* [is_prefix x y] is [x] a pathname prefix of [y] *) +let is_prefix x y = + let lx = String.length x and ly = String.length y in + if lx = ly then x = (String.before y lx) + else if lx < ly then x = (String.before y lx) && List.mem y.[lx] dir_seps + else false + +let link_to_dir p dir = is_link p && is_prefix dir (readlink p) + +let remove_extension x = + try chop_extension x + with Invalid_argument _ -> x +let get_extension x = + try + let pos = String.rindex x '.' in + String.after x (pos + 1) + with Not_found -> "" +let update_extension ext x = + add_extension ext (chop_extension x) + +let chop_extensions x = + let dirname = dirname x and basename = basename x in + try + let pos = String.index basename '.' in + dirname / (String.before basename pos) + with Not_found -> invalid_arg "chop_extensions: no extensions" +let remove_extensions x = + try chop_extensions x + with Invalid_argument _ -> x +let get_extensions x = + let basename = basename x in + try + let pos = String.index basename '.' in + String.after basename (pos + 1) + with Not_found -> "" +let update_extensions ext x = + add_extension ext (chop_extensions x) + +let clean_up_links entry = + Slurp.filter begin fun path name _ -> + let pathname = in_source_dir (path/name) in + if link_to_dir pathname !Options.build_dir then + let z = readlink pathname in + (if not (Sys.file_exists z) then + Shell.rm pathname; false) + else true + end entry + +let clean_up_link_to_build () = + Options.entry := Some(clean_up_links (the !Options.entry)) + +let source_dir_path_set_without_links_to_build = + lazy begin + clean_up_link_to_build (); + Slurp.fold (fun path name _ -> StringSet.add (path/name)) + (the !Options.entry) StringSet.empty + end + +let exists_in_source_dir p = + if !*My_unix.is_degraded then sys_file_exists (in_source_dir p) + else StringSet.mem p !*source_dir_path_set_without_links_to_build + +let clean_links () = + if !*My_unix.is_degraded then + () + else + ignore (clean_up_link_to_build ()) + +let exists = sys_file_exists + +let copy = Shell.cp +let remove = Shell.rm +let try_remove x = if exists x then Shell.rm x +let read = read_file + +let with_input_file = with_input_file + +let with_output_file = with_output_file + +let print_path_list = List.print print + +let root = mk "__root__" + +let context_table = Hashtbl.create 107 + +let merge_include_dirs a b = + let rec aux a b = + match a, b with + | [], _ -> b + | _, [] -> a + | _, x::xs -> + if List.mem x a then aux a xs + else aux (x :: a) xs + in List.rev (aux (List.rev a) b) + +let define_context dir context = + let dir = if dir = "" then current_dir_name else dir in + try + let context = merge_include_dirs context (Hashtbl.find context_table dir) in + Hashtbl.replace context_table dir context + with Not_found -> + let context = merge_include_dirs context (!Options.include_dirs) in + Hashtbl.add context_table dir context + +let rec include_dirs_of dir = + try Hashtbl.find context_table dir + with Not_found -> dir :: List.filter (fun dir' -> dir <> dir') !Options.include_dirs + +(* +let include_dirs_of s = + let res = include_dirs_of s in + let () = dprintf 0 "include_dirs_of %S ->@ %a" s (List.print print) res + in res +*) + +let in_build_dir p = + if is_relative p then p + else + root/p (* XXX: Never reached *) + +let exists_in_build_dir p = exists (in_build_dir p) + +let same_contents x y = Digest.file x = Digest.file y + +let is_up_to_date b p = + let x = in_build_dir p in + if b then exists_in_source_dir p && exists x && same_contents x (in_source_dir p) + else not (exists_in_source_dir p) || exists x && same_contents x (in_source_dir p) + +let import_in_build_dir p = + let p_in_build_dir = in_build_dir p in + Shell.mkdir_p (dirname p); copy (in_source_dir p) p_in_build_dir diff --git a/ocamlbuild/pathname.mli b/ocamlbuild/pathname.mli new file mode 100644 index 00000000..76424019 --- /dev/null +++ b/ocamlbuild/pathname.mli @@ -0,0 +1,22 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: pathname.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +include Signatures.PATHNAME + +val is_up_to_date : bool -> t -> bool +val clean_up_links : bool Slurp.entry -> bool Slurp.entry +val exists_in_source_dir : t -> bool +val exists_in_build_dir : t -> bool +val import_in_build_dir : t -> unit +val in_build_dir : t -> t +val in_source_dir : t -> t diff --git a/ocamlbuild/plugin.ml b/ocamlbuild/plugin.ml new file mode 100644 index 00000000..198c1ecc --- /dev/null +++ b/ocamlbuild/plugin.ml @@ -0,0 +1,111 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: plugin.ml,v 1.1.4.1 2007/03/04 16:13:53 pouillar Exp $ *) +(* Original author: Nicolas Pouillard *) +open My_std +open Format +open Log +open Pathname.Operators +open Tags.Operators +open Rule +open Tools +open Command +;; + +module Make(U:sig end) = + struct + let plugin = "myocamlbuild" + let plugin_file = plugin^".ml" + let plugin_config_file = plugin^"_config.ml" + let plugin_config_file_interface = plugin^"_config.mli" + + let we_have_a_config_file = sys_file_exists plugin_config_file + let we_need_a_plugin = !Options.plugin && sys_file_exists plugin_file + let we_have_a_plugin = sys_file_exists (!Options.build_dir/plugin) + let we_have_a_config_file_interface = sys_file_exists plugin_config_file_interface + + let up_to_date_or_copy fn = + let fn' = !Options.build_dir/fn in + Pathname.exists fn && + begin + Pathname.exists fn' && Pathname.same_contents fn fn' || + begin + Shell.cp fn fn'; + false + end + end + + let profiling = Tags.mem "profile" (tags_of_pathname plugin_file) + + let debugging = Tags.mem "debug" (tags_of_pathname plugin_file) + + let rebuild_plugin_if_needed () = + let a = up_to_date_or_copy plugin_file in + let b = (not we_have_a_config_file) or up_to_date_or_copy plugin_config_file in + let c = (not we_have_a_config_file_interface) or up_to_date_or_copy plugin_config_file_interface in + if a && b && c && we_have_a_plugin then + () (* Up to date *) + (* FIXME: remove ocamlbuild_config.ml in _build/ if removed in parent *) + else begin + let plugin_config = + if we_have_a_config_file then + if we_have_a_config_file_interface then + S[P plugin_config_file_interface; P plugin_config_file] + else P plugin_config_file + else N in + let cma, cmo, more_options, compiler = + if !Options.native_plugin then + "cmxa", "cmx", (if profiling then A"-p" else N), !Options.ocamlopt + else + "cma", "cmo", (if debugging then A"-g" else N), !Options.ocamlc + in + let ocamlbuildlib, ocamlbuild, libs = + if (not !Options.native_plugin) && !*My_unix.is_degraded then + "ocamlbuildlightlib", "ocamlbuildlight", N + else + "ocamlbuildlib", "ocamlbuild", A("unix"-.-cma) + in + let ocamlbuildlib = ocamlbuildlib-.-cma in + let ocamlbuild = ocamlbuild-.-cmo in + let dir = !Ocamlbuild_where.libdir in + if not (sys_file_exists (dir/ocamlbuildlib)) then + failwith (sprintf "Cannot found %S in ocamlbuild -where directory" ocamlbuildlib); + let dir = if Pathname.is_implicit dir then Pathname.pwd/dir else dir in + let cmd = + Cmd(S[compiler; A"-I"; P dir; libs; more_options; + P(dir/ocamlbuildlib); plugin_config; P plugin_file; + P(dir/ocamlbuild); A"-o"; Px plugin]) + in + Shell.chdir !Options.build_dir; + Shell.rm_f plugin; + Command.execute cmd + end + + let execute_plugin_if_needed () = + if we_need_a_plugin then + begin + rebuild_plugin_if_needed (); + Shell.chdir Pathname.pwd; + if not !Options.just_plugin then + let spec = S[!Options.ocamlrun; P(!Options.build_dir/plugin); + A"-no-plugin"; atomize (List.tl (Array.to_list Sys.argv))] in + raise (Exit_silently_with_code (sys_command (Command.string_of_command_spec spec))) + end + else + () + end +;; + +let execute_plugin_if_needed () = + let module P = Make(struct end) in + P.execute_plugin_if_needed () +;; diff --git a/ocamlbuild/plugin.mli b/ocamlbuild/plugin.mli new file mode 100644 index 00000000..e5494f6b --- /dev/null +++ b/ocamlbuild/plugin.mli @@ -0,0 +1,16 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: plugin.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +(* Plugin *) + +val execute_plugin_if_needed : unit -> unit diff --git a/ocamlbuild/ppcache.ml b/ocamlbuild/ppcache.ml new file mode 100644 index 00000000..770d4588 --- /dev/null +++ b/ocamlbuild/ppcache.ml @@ -0,0 +1,88 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: ppcache.ml,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +open My_std +open Command +open Pathname.Operators +let () = Log.level := -1000 + +let usage () = + Format.eprintf "Usage: %s @." Sys.argv.(0); + exit 4 + +let () = if Array.length Sys.argv < 2 then usage () + +let args = List.tl (Array.to_list Sys.argv) + +let buf = Buffer.create 2048 + +let digest_file file = + Buffer.add_string buf (Digest.file file) +let digest_string string = + Buffer.add_string buf (Digest.string string) + +let search_in_path x = + if Sys.file_exists x then x else + try search_in_path x + with Not_found -> (Format.eprintf "Command not found %s@." x; exit 3) + +let cmd = + match args with + | ocamlrun :: x :: _ when String.contains_string ocamlrun 0 "ocamlrun" <> None -> + digest_file (search_in_path ocamlrun); x + | x :: _ -> x + | _ -> usage () + +let output = ref "" + +let () = digest_file (search_in_path cmd) + +let rec loop = + function + | [] -> Digest.string (Buffer.contents buf) + | ("-impl"|"-intf") :: x :: xs -> + digest_string x; digest_file x; loop xs + | "-o" :: x :: xs -> + output := x; loop xs + | x :: xs -> + let ext = Pathname.get_extension x in + digest_string x; + (match ext with + | "cmo" | "cma" | "ml" | "mli" -> digest_file x + | _ -> ()); + loop xs + +let digest = loop args;; + +let cache_dir = "/tmp/ppcache";; (* FIXME *) + +let () = Shell.mkdir_p cache_dir;; + +let path = cache_dir/(Digest.to_hex digest);; + +if sys_file_exists path then + if !output = "" then + print_string (read_file path) + else + Shell.cp path !output +else + let cmd = atomize args in + if !output = "" then begin + let tmp = path^".tmp" in + Command.execute (Cmd(S[cmd; Sh ">"; A tmp])); + Shell.mv tmp path; + print_string (read_file path) + end else begin + Command.execute (Cmd cmd); + Shell.cp !output path + end diff --git a/ocamlbuild/ppcache.mli b/ocamlbuild/ppcache.mli new file mode 100644 index 00000000..5cd30f2d --- /dev/null +++ b/ocamlbuild/ppcache.mli @@ -0,0 +1,14 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: ppcache.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +(* nothing to export *) diff --git a/ocamlbuild/report.ml b/ocamlbuild/report.ml new file mode 100644 index 00000000..9ec17731 --- /dev/null +++ b/ocamlbuild/report.ml @@ -0,0 +1,61 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: report.ml,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Berke Durak *) +(* Report *) + +open My_std +open Log +open Format +open Solver + +let sources_glob = Glob.parse "<*.ml> or <*.mli> or <*.c> or <*.h>";; + +let rec analyze f bt = + match bt with + | Leaf r -> + fprintf f "Ocamlbuild knows of no rules that apply to a target named %a. \ + This can happen if you ask Ocamlbuild to build a target with the \ + wrong extension (e.g. .opt instead of .native) or if the source \ + files live in directories that have not been specified as \ + include directories." + Resource.print r; + false + | Depth(r, bt) -> + if Glob.eval sources_glob r then + begin + fprintf f "Ocamlbuild cannot find or build %a. A file with such a name would \ + usually be a source file. I suspect you have given a wrong target \ + name to Ocamlbuild." + Resource.print r; + false + end + else + analyze f bt + | Choice bl -> List.for_all (analyze f) bl + | Target(_, bt) -> analyze f bt + +let rec print_backtrace f = + function + | Target (name, backtrace) -> + fprintf f "@\n- @[<2>Failed to build the target %s%a@]" name print_backtrace backtrace + | Leaf r -> + fprintf f "@\n- @[<2>Building %a@]" Resource.print r + | Depth (r, backtrace) -> + fprintf f "@\n- @[Building %a:%a@]" Resource.print r print_backtrace backtrace + | Choice [backtrace] -> print_backtrace f backtrace + | Choice backtraces -> + fprintf f "@\n- @[Failed to build all of these:"; + List.iter (print_backtrace f) backtraces; + fprintf f "@]" + +let print_backtrace_analyze f bt = ignore (analyze f bt) diff --git a/ocamlbuild/report.mli b/ocamlbuild/report.mli new file mode 100644 index 00000000..a0385f9a --- /dev/null +++ b/ocamlbuild/report.mli @@ -0,0 +1,18 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: report.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Berke Durak *) +(* Report *) + +val print_backtrace_analyze : Format.formatter -> Solver.backtrace -> unit + +val print_backtrace : Format.formatter -> Solver.backtrace -> unit diff --git a/ocamlbuild/resource.ml b/ocamlbuild/resource.ml new file mode 100644 index 00000000..1755d5aa --- /dev/null +++ b/ocamlbuild/resource.ml @@ -0,0 +1,324 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: resource.ml,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +open My_std +open Format +open Log + +module Resources = Set.Make(Pathname) + +let print = Pathname.print + +let equal = (=) +let compare = compare + +module Cache = struct + open Pathname.Operators + + let clean () = Shell.chdir Pathname.pwd; Shell.rm_rf !Options.build_dir + + type knowledge = + | Yes + | No + | Unknown + + type suspension = (Command.t * (unit -> unit)) + + type build_status = + | Bbuilt + | Bcannot_be_built + | Bnot_built_yet + | Bsuspension of suspension + + type cache_entry = + { mutable built : build_status; + mutable changed : knowledge; + mutable dependencies : Resources.t } + + let empty () = + { built = Bnot_built_yet; + changed = Unknown; + dependencies = Resources.empty } + + let print_knowledge f = + function + | Yes -> pp_print_string f "Yes" + | No -> pp_print_string f "No" + | Unknown -> pp_print_string f "Unknown" + + let print_build_status f = + function + | Bbuilt -> pp_print_string f "Bbuilt" + | Bnot_built_yet -> pp_print_string f "Bnot_built_yet" + | Bcannot_be_built -> pp_print_string f "Bcannot_be_built" + | Bsuspension(cmd, _) -> + fprintf f "@[<2>Bsuspension(%a,@ ( : unit -> unit))@]" Command.print cmd + + let print_cache_entry f e = + fprintf f "@[<2>{ @[<2>built =@ %a@];@ @[<2>changed =@ %a@];@ @[<2>dependencies =@ %a@]@ }@]" + print_build_status e.built print_knowledge e.changed Resources.print e.dependencies + + let cache = Hashtbl.create 103 + + let get r = + try Hashtbl.find cache r + with Not_found -> + let cache_entry = empty () in + Hashtbl.add cache r cache_entry; cache_entry + + let fold_cache f x = Hashtbl.fold f cache x + + let print_cache f () = + fprintf f "@[@[{:"; + fold_cache begin fun k v () -> + fprintf f "@ @[<2>%a =>@ %a@];" print k print_cache_entry v + end (); + fprintf f "@]:}@]" + + let print_graph f () = + fprintf f "@[@[{:"; + fold_cache begin fun k v () -> + if not (Resources.is_empty v.dependencies) then + fprintf f "@ @[<2>%a =>@ %a@];" print k Resources.print v.dependencies + end (); + fprintf f "@]@ :}@]" + + let resource_changed r = + dprintf 10 "resource_changed:@ %a" print r; + (get r).changed <- Yes + + let rec resource_has_changed r = + let cache_entry = get r in + match cache_entry.changed with + | Yes -> true + | No -> false + | Unknown -> + let res = + match cache_entry.built with + | Bbuilt -> false + | Bsuspension _ -> assert false + | Bcannot_be_built -> false + | Bnot_built_yet -> not (Pathname.is_up_to_date false r) in + let () = cache_entry.changed <- if res then Yes else No in res + + let resource_state r = (get r).built + + let resource_is_built r = (get r).built = Bbuilt + + let resource_built r = (get r).built <- Bbuilt + + let resource_is_failed r = (get r).built = Bcannot_be_built + + let resource_failed r = (get r).built <- Bcannot_be_built + + let suspend_resource r cmd kont prods = + let cache_entry = get r in + match cache_entry.built with + | Bsuspension _ -> () + | Bbuilt -> () + | Bcannot_be_built -> assert false + | Bnot_built_yet -> + let kont = begin fun () -> + kont (); + List.iter begin fun prod -> + (get prod).built <- Bbuilt + end prods + end in cache_entry.built <- Bsuspension(cmd, kont) + + let resume_suspension (cmd, kont) = + Command.execute cmd; + kont () + + let resume_resource r = + let cache_entry = get r in + match cache_entry.built with + | Bsuspension(s) -> resume_suspension s + | Bbuilt -> () + | Bcannot_be_built -> () + | Bnot_built_yet -> () + + let get_optional_resource_suspension r = + match (get r).built with + | Bsuspension cmd_kont -> Some cmd_kont + | Bbuilt | Bcannot_be_built | Bnot_built_yet -> None + + let clear_resource_failed r = (get r).built <- Bnot_built_yet + + let dependencies r = (get r).dependencies + + let fold_dependencies f = + fold_cache (fun k v -> Resources.fold (f k) v.dependencies) + + let add_dependency r s = + let cache_entry = get r in + cache_entry.dependencies <- Resources.add s cache_entry.dependencies + + let print_dependencies = print_graph + + let digest_resource p = + let f = Pathname.to_string (Pathname.in_build_dir p) in + let buf = Buffer.create 1024 in + Buffer.add_string buf f; + (if sys_file_exists f then Buffer.add_string buf (Digest.file f)); + Digest.string (Buffer.contents buf) + + let digests = Hashtbl.create 103 + + let get_digest_for name = + try Some (Hashtbl.find digests name) + with Not_found -> None + let store_digest name d = Hashtbl.replace digests name d + + let _digests = lazy (Pathname.pwd / !Options.build_dir / (Pathname.mk "_digests")) + + let finalize () = + with_output_file !*_digests begin fun oc -> + Hashtbl.iter begin fun name digest -> + Printf.fprintf oc "%S: %S\n" name digest + end digests + end + + let init () = + Shell.chdir !Options.build_dir; + if Pathname.exists !*_digests then + with_input_file !*_digests begin fun ic -> + try while true do + let l = input_line ic in + Scanf.sscanf l "%S: %S" store_digest + done with End_of_file -> () + end; + My_unix.at_exit_once finalize + +end + +let clean p = Shell.rm_f p + +(* +type env = string + +let split_percent s = + try + let pos = String.index s '%' in + Some (String.before s pos, String.after s (pos + 1)) + with Not_found -> None + +let extract prefix suffix s = + let lprefix = String.length prefix in + let lsuffix = String.length suffix in + let ls = String.length s in + if lprefix + lsuffix > ls then None else + let s' = String.sub s lprefix (ls - lsuffix - lprefix) in + if equal (prefix ^ s' ^ suffix) s then Some s' else None + +let matchit r1 r2 = + match split_percent r1 with + | Some (x, y) -> extract x y r2 + | _ -> if equal r1 r2 then Some "" else None + +let rec subst percent r = + match split_percent r with + | Some (x, y) -> x ^ percent ^ y + | _ -> r + +let print_env = pp_print_string +*) + +let is_up_to_date path = Pathname.is_up_to_date true path + +let import x = x + +module MetaPath : sig + + type env + + val matchit : string -> string -> env option + val subst : env -> string -> string + val print_env : Format.formatter -> env -> unit + +end = struct + + type atoms = A of string | V of string + type t = atoms list + type env = (string * string) list + + exception No_solution + + let mk s = List.map (fun (s, is_var) -> if is_var then V s else A s) (Lexers.meta_path (Lexing.from_string s)) + + let mk = memo mk + + let match_prefix s pos prefix = + match String.contains_string s pos prefix with + | Some(pos') -> if pos = pos' then pos' + String.length prefix else raise No_solution + | None -> raise No_solution + + let matchit p s = + let sl = String.length s in + let rec loop xs pos acc = + match xs with + | [] -> if pos = sl then acc else raise No_solution + | A prefix :: xs -> loop xs (match_prefix s pos prefix) acc + | V var :: A s2 :: xs -> + begin match String.contains_string s pos s2 with + | Some(pos') -> loop xs (pos' + String.length s2) ((var, String.sub s pos (pos' - pos)) :: acc) + | None -> raise No_solution + end + | [V var] -> (var, String.sub s pos (sl - pos)) :: acc + | V _ :: _ -> assert false + in + try Some (loop (mk p) 0 []) + with No_solution -> None + + let pp_opt pp_elt f = + function + | None -> pp_print_string f "None" + | Some x -> Format.fprintf f "Some(%a)" pp_elt x + + let print_env f env = + List.iter begin fun (k, v) -> + if k = "" then Format.fprintf f "%%=%s " v + else Format.fprintf f "%%(%s)=%s " k v + end env + + (* let matchit p s = + let res = matchit p s in + Format.eprintf "matchit %S %S = %a@." p s (pp_opt print_env) res; + res + + let _ = begin + assert (matchit "%(path)lib%(libname).a" "libfoo.a" <> None); + assert (matchit "%(path)lib%(libname).a" "path/libfoo.a" <> None); + assert (matchit "libfoo.a" "libfoo.a" <> None); + assert (matchit "lib%(libname).a" "libfoo.a" <> None); + assert (matchit "%(path)libfoo.a" "path/libfoo.a" <> None); + assert (matchit "foo%" "foobar" <> None); + exit 42 + end;; *) + + let subst env s = + String.concat "" begin + List.map begin fun x -> + match x with + | A atom -> atom + | V var -> List.assoc var env + end (mk s) + end +end + +type env = MetaPath.env + +let matchit = MetaPath.matchit + +let subst = MetaPath.subst + +let print_env = MetaPath.print_env diff --git a/ocamlbuild/resource.mli b/ocamlbuild/resource.mli new file mode 100644 index 00000000..043742c4 --- /dev/null +++ b/ocamlbuild/resource.mli @@ -0,0 +1,63 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: resource.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +open My_std + +open Pathname +type env + +module Resources : Set.S with type elt = t + +module Cache : + sig + type suspension + + type build_status = + | Bbuilt + | Bcannot_be_built + | Bnot_built_yet + | Bsuspension of suspension + + val clean : unit -> unit + val init : unit -> unit + val resource_state : t -> build_status + val resource_changed : t -> unit + val resource_has_changed : t -> bool + val resource_is_built : t -> bool + val resource_built : t -> unit + val resource_is_failed : t -> bool + val resource_failed : t -> unit + val suspend_resource : t -> Command.t -> (unit -> unit) -> t list -> unit + val resume_resource : t -> unit + val resume_suspension : suspension -> unit + val get_optional_resource_suspension : t -> (Command.t * (unit -> unit)) option + val clear_resource_failed : t -> unit + val dependencies : t -> Resources.t + val add_dependency : t -> t -> unit + val get_digest_for : string -> string option + val store_digest : string -> string -> unit + val digest_resource : t -> string + val print_cache : Format.formatter -> unit -> unit + val print_dependencies : Format.formatter -> unit -> unit + val fold_dependencies : (string -> string -> 'a -> 'a) -> 'a -> 'a + end + +val compare : t -> t -> int +val print : Format.formatter -> t -> unit +val clean : t -> unit +val import : string -> t + +val matchit : t -> t -> env option +val subst : env -> t -> t +val is_up_to_date : t -> bool +val print_env : Format.formatter -> env -> unit diff --git a/ocamlbuild/rule.ml b/ocamlbuild/rule.ml new file mode 100644 index 00000000..83de289a --- /dev/null +++ b/ocamlbuild/rule.ml @@ -0,0 +1,301 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: rule.ml,v 1.2.2.1 2007/03/07 10:36:34 pouillar Exp $ *) +(* Original author: Nicolas Pouillard *) +open My_std +open Format +open Log +open Outcome +module Resources = Resource.Resources + +exception Exit_rule_error of string + +type env = Pathname.t -> Pathname.t +type builder = Pathname.t list list -> (Pathname.t, exn) Outcome.t list +type action = env -> builder -> Command.t + +type t = + { name : string; + tags : Tags.t; + deps : Pathname.t list; + prods : Pathname.t list; + code : env -> builder -> Command.t } + +exception Code_digest of string * (bool -> unit) + +let compare _ _ = assert false + +let print_rule_name f r = pp_print_string f r.name + +let print_resource_list = List.print Resource.print + +let print_rule_contents f r = + fprintf f "@[{@ @[<2>name =@ %S@];@ @[<2>tags =@ %a@];@ @[<2>deps =@ %a@];@ @[<2>prods = %a@];@ @[<2>code = @]@]@ }" + r.name Tags.print r.tags print_resource_list r.deps print_resource_list r.prods + +let pretty_print f r = + fprintf f "@[rule@ %S@ ~deps:%a@ ~prods:%a@ @]" + r.name print_resource_list r.deps print_resource_list r.prods + +let print = print_rule_name + +let subst env rule = + let subst_resources = List.map (Resource.subst env) in + let finder next_finder p = next_finder (Resource.subst env p) in + { (rule) with name = sbprintf "%s (%a)" rule.name Resource.print_env env; + prods = subst_resources rule.prods; + deps = subst_resources rule.deps; + code = (fun env -> rule.code (finder env)) } + +exception Can_produce of t + +let can_produce target rule = + try + List.iter begin fun resource -> + match Resource.matchit resource target with + | Some env -> raise (Can_produce (subst env rule)) + | None -> () + end rule.prods; None + with Can_produce r -> Some r + +let tags_matches tags r = if Tags.does_match tags r.tags then Some r else None + +let digest_prods r = + List.fold_right begin fun p acc -> + let f = Pathname.to_string (Pathname.in_build_dir p) in + if sys_file_exists f then (f, Digest.file f) :: acc else acc + end r.prods [] + +let digest_rule r dyndeps cmd_or_digest = + let buf = Buffer.create 1024 in + (match cmd_or_digest with + | Good cmd -> Buffer.add_string buf (Command.to_string_for_digest cmd) + | Bad(s, _) -> Buffer.add_string buf s); + let add_resource r = Buffer.add_string buf (Resource.Cache.digest_resource r) in + Buffer.add_string buf "prods:"; + List.iter add_resource r.prods; + Buffer.add_string buf "deps:"; + List.iter add_resource r.deps; + Buffer.add_string buf "dyndeps:"; + Resources.iter add_resource dyndeps; + Digest.string (Buffer.contents buf) + +let print_digest f x = pp_print_string f (Digest.to_hex x) + +let exists2 find p rs = + try Some (find p rs) with Not_found -> None + +let all_deps_of_tags = ref [] + +let cons deps acc = + List.fold_left begin fun acc dep -> + if List.mem dep acc then acc else dep :: acc + end acc deps + +let deps_of_tags tags = + List.fold_left begin fun acc (xtags, xdeps) -> + if Tags.does_match tags xtags then cons xdeps acc + else acc + end [] !all_deps_of_tags + +let set_deps_of_tags tags deps = + all_deps_of_tags := (tags, deps) :: !all_deps_of_tags + +let dep tags deps = set_deps_of_tags (Tags.of_list tags) deps + +let build_deps_of_tags builder tags = + match deps_of_tags tags with + | [] -> [] + | deps -> List.map Outcome.good (builder (List.map (fun x -> [x]) deps)) + +let build_deps_of_tags_on_cmd builder x = + let rec spec x = + match x with + | Command.N | Command.A _ | Command.Sh _ | Command.P _ | Command.Px _ | Command.V _ | Command.Quote _ -> () + | Command.S l -> List.iter spec l + | Command.T tags -> + begin match deps_of_tags tags with + | [] -> () + | deps -> List.iter ignore_good (builder (List.map (fun x -> [x]) deps)) + end in + let rec cmd x = + match x with + | Command.Nop -> () + | Command.Cmd(s) -> spec s + | Command.Seq(s) -> List.iter cmd s in + cmd x + +let call builder r = + let dyndeps = ref Resources.empty in + let builder rs = + let results = builder rs in + List.map begin fun res -> + match res with + | Good res' -> + let () = dprintf 10 "new dyndep for %S(%a): %S" r.name print_resource_list r.prods res' in + dyndeps := Resources.add res' !dyndeps; + List.iter (fun x -> Resource.Cache.add_dependency x res') r.prods; + res + | Bad _ -> res + end results in + let () = dprintf 5 "start rule %a" print r in + let cmd_or_digest = + try + let cmd = r.code (fun x -> x) builder in + build_deps_of_tags_on_cmd builder cmd; + Good cmd + with Code_digest(s, kont) -> Bad(s, kont) in + let dyndeps = !dyndeps in + let () = dprintf 10 "dyndeps: %a" Resources.print dyndeps in + let (reason, cached) = + match exists2 List.find (fun r -> not (Pathname.exists_in_build_dir r)) r.prods with + | Some r -> (`cache_miss_missing_prod r, false) + | _ -> + begin match exists2 List.find Resource.Cache.resource_has_changed r.deps with + | Some r -> (`cache_miss_changed_dep r, false) + | _ -> + begin match exists2 Resources.find Resource.Cache.resource_has_changed dyndeps with + | Some r -> (`cache_miss_changed_dyn_dep r, false) + | _ -> + begin match Resource.Cache.get_digest_for r.name with + | None -> (`cache_miss_no_digest, false) + | Some d -> + begin match cmd_or_digest with + | Bad("", _) -> + (`cache_miss_undigest, false) + | Bad(_, _) | Good(_) -> + let rule_digest = digest_rule r dyndeps cmd_or_digest in + if d = rule_digest then (`cache_hit, true) + else (`cache_miss_digest_changed(d, rule_digest), false) + end + end + end + end + in + let explain_reason l = + raw_dprintf (l+1) "mid rule %a: " print r; + match reason with + | `cache_miss_missing_prod r -> + dprintf l "cache miss: a product is not in build dir (%a)" Resource.print r + | `cache_miss_changed_dep r -> + dprintf l "cache miss: a dependency has changed (%a)" Resource.print r + | `cache_miss_changed_dyn_dep r -> + dprintf l "cache miss: a dynamic dependency has changed (%a)" Resource.print r + | `cache_miss_no_digest -> + dprintf l "cache miss: no digest found for %S (the command, a dependency, or a product)" + r.name + | `cache_hit -> dprintf (l+1) "cache hit" + | `cache_miss_digest_changed(old_d, new_d) -> + dprintf l "cache miss: the digest has changed for %S (the command, a dependency, or a product: %a <> %a)" + r.name print_digest old_d print_digest new_d + | `cache_miss_undigest -> + dprintf l "cache miss: cache not supported for the rule %S" r.name in + let prod_digests = digest_prods r in + (if not cached then List.iter Resource.clean r.prods); + (if !Options.nothing_should_be_rebuilt && not cached then + (explain_reason (-1); + let msg = sbprintf "Need to rebuild %a through the rule `%a'" print_resource_list r.prods print r in + raise (Exit_rule_error msg))); + explain_reason 3; + let kont = begin fun () -> + try + (match cmd_or_digest with + | Good cmd -> if cached then Command.execute ~pretend:true cmd + | Bad (_, kont) -> kont cached); + List.iter Resource.Cache.resource_built r.prods; + (if not cached then + let new_rule_digest = digest_rule r dyndeps cmd_or_digest in + let new_prod_digests = digest_prods r in + let () = Resource.Cache.store_digest r.name new_rule_digest in + List.iter begin fun p -> + let f = Pathname.to_string (Pathname.in_build_dir p) in + (try let digest = List.assoc f prod_digests in + let new_digest = List.assoc f new_prod_digests in + if digest <> new_digest then raise Not_found + with Not_found -> Resource.Cache.resource_changed p) + end r.prods); + dprintf 5 "end rule %a" print r + with exn -> (List.iter Resource.clean r.prods; raise exn) + end in + match cmd_or_digest with + | Good cmd when not cached -> + List.iter (fun x -> Resource.Cache.suspend_resource x cmd kont r.prods) r.prods + | Bad _ | Good _ -> kont () + +let (get_rules, add_rule) = + let rules = ref [] in + (fun () -> !rules), + begin fun pos r -> + try + let _ = List.find (fun x -> x.name = r.name) !rules in + raise (Exit_rule_error (sbprintf "Rule.add_rule: already exists: (%a)" print r)) + with Not_found -> + match pos with + | `bottom -> rules := !rules @ [r] + | `top -> rules := r :: !rules + | `after s -> + rules := + List.fold_right begin fun x acc -> + if x.name = s then x :: r :: acc else x :: acc + end !rules [] + | `before s -> + rules := + List.fold_right begin fun x acc -> + if x.name = s then r :: x :: acc else x :: acc + end !rules [] + end + +let rule name ?(tags=[]) ?(prods=[]) ?(deps=[]) ?prod ?dep ?(insert = `bottom) code = + let res_add x acc = + let x = Resource.import x in + if List.mem x acc then + failwith (sprintf "in rule %s, multiple occurences of the resource %s" name x) + else x :: acc in + let res_of_opt = function None -> [] | Some r -> [Resource.import r] in + if prods = [] && prod = None then raise (Exit_rule_error "Can't make a rule that produce nothing"); + add_rule insert + { name = name; + tags = List.fold_right Tags.add tags Tags.empty; + deps = List.fold_right res_add deps (res_of_opt dep); + prods = List.fold_right res_add prods (res_of_opt prod); + code = code } + +let file_rule name ?tags ~prod ?deps ?dep ?insert ~cache action = + rule name ?tags ~prod ?dep ?deps ?insert begin fun env _ -> + raise (Code_digest (cache env, (fun cached -> + if not cached then + with_output_file (env prod) (action env)))) + end + +let custom_rule name ?tags ?prods ?prod ?deps ?dep ?insert ~cache action = + rule name ?tags ?prods ?prod ?dep ?deps ?insert begin fun env _ -> + raise (Code_digest (cache env, fun cached -> action env ~cached)) + end + +module Common_commands = struct + open Command + let mv src dest = Cmd (S [A"mv"; P src; Px dest]) + let cp src dest = Cmd (S [A"cp"; P src; Px dest]) + let cp_p src dest = Cmd (S [A"cp"; A"-p"; P src; Px dest]) + let ln_f pointed pointer = Cmd (S [A"ln"; A"-f"; P pointed; Px pointer]) + let ln_s pointed pointer = Cmd (S[A"ln"; A"-s"; P pointed; Px pointer]) + let rm_f x = Cmd (S [A"rm"; A"-f"; Px x]) + let touch file = Cmd (S[A"touch"; Px file]) + let chmod opts file = Cmd (S[A"chmod"; opts; Px file]) + let cmp a b = Cmd (S[A"cmp"; P a; Px b]) +end +open Common_commands + +let copy_rule name ?insert src dest = + rule name ?insert ~prod:dest ~dep:src + (fun env _ -> cp_p (env src) (env dest)) + diff --git a/ocamlbuild/rule.mli b/ocamlbuild/rule.mli new file mode 100644 index 00000000..f88aceb0 --- /dev/null +++ b/ocamlbuild/rule.mli @@ -0,0 +1,93 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: rule.mli,v 1.2.2.1 2007/03/07 10:36:34 pouillar Exp $ *) +(* Original author: Nicolas Pouillard *) +open My_std +open Resource + +type env = Pathname.t -> Pathname.t +type builder = Pathname.t list list -> (Pathname.t, exn) Outcome.t list +type action = env -> builder -> Command.t + +type t = private + { name : string; + tags : Tags.t; + deps : Pathname.t list; + prods : Pathname.t list; + code : env -> builder -> Command.t } + +val rule : string -> + ?tags:string list -> + ?prods:string list -> + ?deps:string list -> + ?prod:string -> + ?dep:string -> + ?insert:[`top | `before of string | `after of string | `bottom] -> + action -> unit + +val file_rule : string -> + ?tags:string list -> + prod:string -> + ?deps:string list -> + ?dep:string -> + ?insert:[`top | `before of string | `after of string | `bottom] -> + cache:(env -> string) -> + (env -> out_channel -> unit) -> unit + +val custom_rule : string -> + ?tags:string list -> + ?prods:string list -> + ?prod:string -> + ?deps:string list -> + ?dep:string -> + ?insert:[`top | `before of string | `after of string | `bottom] -> + cache:(env -> string) -> + (env -> cached:bool -> unit) -> unit + +(** [copy_rule name ?insert source destination] *) +val copy_rule : string -> + ?insert:[`top | `before of string | `after of string | `bottom] -> + string -> string -> unit + +(** [dep tags deps] Will build [deps] when [tags] will be activated. *) +val dep : string list -> string list -> unit + +module Common_commands : sig + val mv : Pathname.t -> Pathname.t -> Command.t + val cp : Pathname.t -> Pathname.t -> Command.t + val cp_p : Pathname.t -> Pathname.t -> Command.t + val ln_f : Pathname.t -> Pathname.t -> Command.t + val ln_s : Pathname.t -> Pathname.t -> Command.t + val rm_f : Pathname.t -> Command.t + val touch : Pathname.t -> Command.t + val chmod : Command.spec -> Pathname.t -> Command.t + val cmp : Pathname.t -> Pathname.t -> Command.t +end + +val print : Format.formatter -> t -> unit +val pretty_print : Format.formatter -> t -> unit + +(** For system use only *) + +val subst : Resource.env -> t -> t +val can_produce : Pathname.t -> t -> t option +val tags_matches : Tags.t -> t -> t option +val compare : t -> t -> int + +val print_rule_name : Format.formatter -> t -> unit +val print_rule_contents : Format.formatter -> t -> unit + +val get_rules : unit -> t list + +val call : builder -> t -> unit + +val build_deps_of_tags : builder -> Tags.t -> Pathname.t list diff --git a/ocamlbuild/shell.ml b/ocamlbuild/shell.ml new file mode 100644 index 00000000..c56fefbb --- /dev/null +++ b/ocamlbuild/shell.ml @@ -0,0 +1,81 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: shell.ml,v 1.1.4.1 2007/03/07 11:30:14 pouillar Exp $ *) +(* Original author: Nicolas Pouillard *) +open My_std + +let is_simple_filename s = + let ls = String.length s in + ls <> 0 && + let rec loop pos = + if pos >= ls then true else + match s.[pos] with + | 'a'..'z' | 'A'..'Z' | '0'..'9' | '.' | '-' | '/' | '_' | ':' | '@' | '+' | ',' -> loop (pos + 1) + | _ -> false in + loop 0 +let quote_filename_if_needed s = + if is_simple_filename s then s else Filename.quote s +let chdir dir = + reset_filesys_cache (); + Sys.chdir dir +let run args target = + reset_readdir_cache (); + let cmd = String.concat " " (List.map quote_filename_if_needed args) in + if !*My_unix.is_degraded || Sys.os_type = "Win32" then + begin + Log.event cmd target Tags.empty; + let st = sys_command cmd in + if st <> 0 then + failwith (Printf.sprintf "Error during command `%s'.\nExit code %d.\n" cmd st) + else + () + end + else + match My_unix.execute_many ~ticker:Log.update ~display:Log.display [[(cmd, ignore)]] with + | None -> () + | Some(_, x) -> + failwith (Printf.sprintf "Error during command %S: %s" cmd (Printexc.to_string x)) +let rm = sys_remove +let rm_f x = + if sys_file_exists x then rm x +let mkdir dir = + reset_filesys_cache_for_file dir; + (*Sys.mkdir dir (* MISSING in ocaml *) *) + run ["mkdir"; dir] dir +let try_mkdir dir = if not (sys_file_exists dir) then mkdir dir +let rec mkdir_p dir = + if sys_file_exists dir then () + else (mkdir_p (Filename.dirname dir); mkdir dir) + +let cp_pf src dest = + reset_filesys_cache_for_file dest; + run["cp";"-pf";src;dest] dest + +(* L'Arrêté du 2007-03-07 prend en consideration + differement les archives. Pour les autres fichiers + le décret du 2007-02-01 est toujours valable :-) *) +let cp src dst = + if Filename.check_suffix src ".a" + && Filename.check_suffix dst ".a" + then cp_pf src dst + else copy_file src dst + +let readlink = My_unix.readlink +let is_link = My_unix.is_link +let rm_rf x = + reset_filesys_cache (); + run["rm";"-Rf";x] x +let mv src dest = + reset_filesys_cache_for_file src; + reset_filesys_cache_for_file dest; + run["mv"; src; dest] dest + (*Sys.rename src dest*) diff --git a/ocamlbuild/shell.mli b/ocamlbuild/shell.mli new file mode 100644 index 00000000..ae1bbe5b --- /dev/null +++ b/ocamlbuild/shell.mli @@ -0,0 +1,26 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: shell.mli,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +val is_simple_filename : string -> bool +val quote_filename_if_needed : string -> string +val chdir : string -> unit +val rm : string -> unit +val rm_f : string -> unit +val rm_rf : string -> unit +val mkdir : string -> unit +val try_mkdir : string -> unit +val mkdir_p : string -> unit +val cp : string -> string -> unit +val mv : string -> string -> unit +val readlink : string -> string +val is_link : string -> bool diff --git a/ocamlbuild/signatures.mli b/ocamlbuild/signatures.mli new file mode 100644 index 00000000..521e5f8c --- /dev/null +++ b/ocamlbuild/signatures.mli @@ -0,0 +1,550 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: signatures.mli,v 1.8 2007/02/26 17:05:30 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +(** This module contains all module signatures that the user + could use to build an ocamlbuild plugin. *) + +module type OrderedTypePrintable = sig + type t + val compare : t -> t -> int + val print : Format.formatter -> t -> unit +end + +module type SET = sig + include Set.S + val find : (elt -> bool) -> t -> elt + val map : (elt -> elt) -> t -> t + val of_list : elt list -> t + val print : Format.formatter -> t -> unit +end + +module type LIST = sig + (* Added functions *) + val print : (Format.formatter -> 'a -> 'b) -> Format.formatter -> 'a list -> unit + val filter_opt : ('a -> 'b option) -> 'a list -> 'b list + val union : 'a list -> 'a list -> 'a list + + (* Original functions *) + include Std_signatures.LIST +end + +module type STRING = sig + val print : Format.formatter -> string -> unit + val chomp : string -> string + + (** [before s n] returns the substring of all characters of [s] + that precede position [n] (excluding the character at + position [n]). + This is the same function as {!Str.string_before}. *) + val before : string -> int -> string + + (** [after s n] returns the substring of all characters of [s] + that follow position [n] (including the character at + position [n]). + This is the same function as {!Str.string_after}. *) + val after : string -> int -> string + + val first_chars : string -> int -> string + (** [first_chars s n] returns the first [n] characters of [s]. + This is the same function as {!before} ant {!Str.first_chars}. *) + + val last_chars : string -> int -> string + (** [last_chars s n] returns the last [n] characters of [s]. + This is the same function as {!Str.last_chars}. *) + + val eq_sub_strings : string -> int -> string -> int -> int -> bool + + (** [is_prefix u v] is v a prefix of u ? *) + val is_prefix : string -> string -> bool + (** [is_suffix u v] : is v a suffix of u ? *) + val is_suffix : string -> string -> bool + + (** [contains_string s1 p2 s2] Search in [s1] starting from [p1] if it + contains the [s2] string. Returns [Some position] where [position] + is the begining of the string [s2] in [s1], [None] otherwise. *) + val contains_string : string -> int -> string -> int option + + (** [subst patt repl text] *) + val subst : string -> string -> string -> string + + (** [tr patt repl text] *) + val tr : char -> char -> string -> string + + val rev : string -> string + + (** The following are original functions from the [String] module. *) + include Std_signatures.STRING +end + +module type TAGS = sig + include Set.S with type elt = string + val of_list : string list -> t + val print : Format.formatter -> t -> unit + val does_match : t -> t -> bool + module Operators : sig + val ( ++ ) : t -> elt -> t + val ( -- ) : t -> elt -> t + val ( +++ ) : t -> elt option -> t + val ( --- ) : t -> elt option -> t + end +end + +module type PATHNAME = sig + type t = string + val concat : t -> t -> t + val compare : t -> t -> int + val equal : t -> t -> bool + val exists : t -> bool + val mk : string -> t + val define_context : string -> string list -> unit + val include_dirs_of : string -> string list + val copy : t -> t -> unit + val to_string : t -> string + val print : Format.formatter -> t -> unit + val current_dir_name : t + val parent_dir_name : t + val read : t -> string + val same_contents : t -> t -> bool + val basename : t -> t + val dirname : t -> t + val is_relative : t -> bool + val readlink : t -> t + val readdir : t -> t array + val is_link : t -> bool + val is_directory : t -> bool + + val add_extension : string -> t -> t + val check_extension : t -> string -> bool + + val get_extension : t -> string + val remove_extension : t -> t + val update_extension : string -> t -> t + + val get_extensions : t -> string + val remove_extensions : t -> t + val update_extensions : string -> t -> t + + val print_path_list : Format.formatter -> t list -> unit + val pwd : t + val parent : t -> t + (** [is_prefix x y] is [x] a pathname prefix of [y] *) + val is_prefix : t -> t -> bool + val is_implicit : t -> bool + module Operators : sig + val ( / ) : t -> t -> t + val ( -.- ) : t -> string -> t + end +end + +(** Provides an abstract type for easily building complex shell commands without making + quotation mistakes. *) +module type COMMAND = sig + type tags + + (** The type [t] is basically a sequence of command specifications. This avoids having to + flatten lists of lists. *) + type t = Seq of t list | Cmd of spec | Nop + + (** The type for command specifications. *) + and spec = + | N (** No operation. *) + | S of spec list (** A sequence. This gets flattened in the last stages *) + | A of string (** An atom. *) + | P of string (** A pathname. *) + | Px of string (** A pathname, that will also be given to the call_with_target hook. *) + | Sh of string (** A bit of raw shell code, that will not be escaped. *) + | T of tags (** A set of tags, that describe properties and some semantics + information about the command, afterward these tags will be + replaced by command [spec]s (flags for instance). *) + | V of string (** A virtual command, that will be resolved at execution using [resolve_virtuals] *) + | Quote of spec (** A string that should be quoted like a filename but isn't really one. *) + + (*type v = [ `Seq of v list | `Cmd of vspec | `Nop ] + and vspec = + [ `N + | `S of vspec list + | `A of string + | `P of string (* Pathname.t *) + | `Px of string (* Pathname.t *) + | `Sh of string + | `Quote of vspec ] + + val spec_of_vspec : vspec -> spec + val vspec_of_spec : spec -> vspec + val t_of_v : v -> t + val v_of_t : t -> v*) + + (** Will convert a string list to a list of atoms by adding [A] constructors. *) + val atomize : string list -> spec + + (** Will convert a string list to a list of paths by adding [P] constructors. *) + val atomize_paths : string list -> spec + + (** Run the command. *) + val execute : ?quiet:bool -> ?pretend:bool -> t -> unit + + (** Run the commands in the given list, if possible in parallel. + See the module [Executor]. *) + val execute_many : ?quiet:bool -> ?pretend:bool -> t list -> (bool list * exn) option + + (** [setup_virtual_command_solver virtual_command solver] + the given solver can raise Not_found if it fails to find a valid + command for this virtual command. *) + val setup_virtual_command_solver : string -> (unit -> spec) -> unit + + (** Search the given command in the command path and return its absolute + pathname. *) + val search_in_path : string -> string + + (** Simplify a command by flattening the sequences and resolving the tags + into command-line options. *) + val reduce : spec -> spec + + (** Print a command. *) + val print : Format.formatter -> t -> unit + + (** Convert a command to a string. *) + val to_string : t -> string + + (** Build a string representation of a command that can be passed to the + system calls. *) + val string_of_command_spec : spec -> string +end + +(** A self-contained module implementing extended shell glob patterns who have an expressive power + equal to boolean combinations of regular expressions. *) +module type GLOB = sig + + (** A globber is a boolean combination of basic expressions indented to work on + pathnames. Known operators + are [or], [and] and [not], which may also be written [|], [&] and [~]. There are + also constants [true] and [false] (or [1] and [0]). Expression can be grouped + using parentheses. + - [true] matches anything, + - [false] matches nothing, + - {i basic} [or] {i basic} matches strings matching either one of the basic expressions, + - {i basic} [and] {i basic} matches strings matching both basic expressions, + - not {i basic} matches string that don't match the basic expression, + - {i basic} matches strings that match the basic expression. + + A basic expression can be a constant string enclosed in double quotes, in which + double quotes must be preceded by backslashes, or a glob pattern enclosed between a [<] and a [>], + - ["]{i string}["] matches the literal string {i string}, + - [<]{i glob}[>] matches the glob pattern {i glob}. + + A glob pattern is an anchored regular expression in a shell-like syntax. Most characters stand for themselves. + Character ranges are given in usual shell syntax between brackets. The star [*] stands for any sequence of + characters. The joker '?' stands for exactly one, unspecified character. Alternation is achieved using braces [{]. + - {i glob1}{i glob2} matches strings who have a prefix matching {i glob1} and the corresponding suffix + matching {i glob2}. + - [a] matches the string consisting of the single letter [a]. + - [{]{i glob1},{i glob2}[}] matches strings matching {i glob1} or {i glob2}. + - [*] matches all strings, including the empty one. + - [?] matches strings of length 1. + - [\[]{i c1}-{i c2}{i c3}-{i c4}...[\]] matches characters in the range {i c1} to {i c2} inclusive, + or in the range {i c3} to {i c4} inclusive. For instance [\[a-fA-F0-9\]] matches hexadecimal digits. + To match the dash, put it at the end. + *) + + (** The type representing globbers. Do not attempt to compare them, as they get on-the-fly optimizations. *) + type globber + + (** [parse ~dir pattern] will parse the globber pattern [pattern], optionally prefixing its patterns with [dir]. *) + val parse : ?dir:string -> string -> globber + + (** A descriptive exception raised when an invalid glob pattern description is given. *) + exception Parse_error of string + + (** [eval g u] returns [true] if and only if the string [u] matches the given glob expression. Avoid reparsing + the same pattern, since the automaton implementing the pattern is optimized on the fly. The first few evaluations + are done using a time-inefficient but memory-efficient algorithm. It then compiles the pattern into an efficient + but more memory-hungry data structure. *) + val eval : globber -> string -> bool +end + +(** Module for modulating the logging output with the logging level. *) +module type LOG = sig + (** Current logging (debugging) level. *) + val level : int ref + + (** [dprintf level fmt args...] formats the logging information [fmt] + with the arguments [args...] on the logging output if the logging + level is greater than or equal to [level]. The default level is 1. + More obscure debugging information should have a higher logging + level. Youre formats are wrapped inside these two formats + ["@\[<2>"] and ["@\]@."]. *) + val dprintf : int -> ('a, Format.formatter, unit) format -> 'a + + (** Equivalent to calling [dprintf] with a level [< 0]. *) + val eprintf : ('a, Format.formatter, unit) format -> 'a + + (** Same as dprintf but without the format wrapping. *) + val raw_dprintf : int -> ('a, Format.formatter, unit) format -> 'a +end + +module type OUTCOME = sig + type ('a,'b) t = + | Good of 'a + | Bad of 'b + + val wrap : ('a -> 'b) -> 'a -> ('b, exn) t + val ignore_good : ('a, exn) t -> unit + val good : ('a, exn) t -> 'a +end + +module type MISC = sig + val opt_print : + (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit + val the : 'a option -> 'a + val getenv : ?default:string -> string -> string + val with_input_file : ?bin:bool -> string -> (in_channel -> 'a) -> 'a + val with_output_file : ?bin:bool -> string -> (out_channel -> 'a) -> 'a + val with_temp_file : string -> string -> (string -> 'a) -> 'a + val read_file : string -> string + val copy_chan : in_channel -> out_channel -> unit + val copy_file : string -> string -> unit + val print_string_list : Format.formatter -> string list -> unit + + (** A shortcut to force lazy value (See {Lazy.force}). *) + val ( !* ) : 'a Lazy.t -> 'a + + (** The right associative application. + Useful when writing to much parentheses: + << f (g x ... t) >> becomes << f& g x ... t >> + << f (g (h x)) >> becomes << f& g& h x >> *) + val ( & ) : ('a -> 'b) -> 'a -> 'b + + (** [r @:= l] is equivalent to [r := !r @ l] *) + val ( @:= ) : 'a list ref -> 'a list -> unit + + val memo : ('a -> 'b) -> ('a -> 'b) +end + +module type OPTIONS = sig + type command_spec + + val build_dir : string ref + val include_dirs : string list ref + val exclude_dirs : string list ref + val nothing_should_be_rebuilt : bool ref + val ocamlc : command_spec ref + val ocamlopt : command_spec ref + val ocamldep : command_spec ref + val ocamldoc : command_spec ref + val ocamlyacc : command_spec ref + val ocamllex : command_spec ref + val ocamlrun : command_spec ref + val ocamlmklib : command_spec ref + val ocamlmktop : command_spec ref + val hygiene : bool ref + val sanitize : bool ref + val sanitization_script : string ref + val ignore_auto : bool ref + val plugin : bool ref + val just_plugin : bool ref + val native_plugin : bool ref + val make_links : bool ref + val nostdlib : bool ref + val program_to_execute : bool ref + val must_clean : bool ref + val catch_errors : bool ref + val internal_log_file : string option ref + val use_menhir : bool ref + val show_documentation : bool ref + + val targets : string list ref + val ocaml_libs : string list ref + val ocaml_cflags : string list ref + val ocaml_lflags : string list ref + val ocaml_ppflags : string list ref + val ocaml_yaccflags : string list ref + val ocaml_lexflags : string list ref + val program_args : string list ref + val ignore_list : string list ref + val tags : string list ref + val show_tags : string list ref + + val ext_obj : string ref + val ext_lib : string ref + val ext_dll : string ref +end + +module type ARCH = sig + type 'a arch = private + | Arch_dir of string * 'a * 'a arch list + | Arch_dir_pack of string * 'a * 'a arch list + | Arch_file of string * 'a + + val dir : string -> unit arch list -> unit arch + val dir_pack : string -> unit arch list -> unit arch + val file : string -> unit arch + + type info = private { + current_path : string; + include_dirs : string list; + for_pack : string; + } + + val annotate : 'a arch -> info arch + + val print : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a arch -> unit + val print_include_dirs : Format.formatter -> string list -> unit + val print_info : Format.formatter -> info -> unit + + val iter_info : ('a -> unit) -> 'a arch -> unit + val fold_info : ('a -> 'b -> 'b) -> 'a arch -> 'b -> 'b + + val iter_include_dirs : info arch -> (string -> unit) -> unit + + val mk_tables : + info arch -> (string, string list) Hashtbl.t * (string, string) Hashtbl.t + val print_table : + (Format.formatter -> 'a -> unit) -> Format.formatter -> (string, 'a) Hashtbl.t -> unit +end + +(** This module contains the functions and values that can be used by plugins. *) +module type PLUGIN = sig + module Pathname : PATHNAME + module Tags : TAGS + module Command : COMMAND with type tags = Tags.t + module Outcome : OUTCOME + module String : STRING + module List : LIST + module StringSet : Set.S with type elt = String.t + module Options : OPTIONS with type command_spec = Command.spec + module Arch : ARCH + include MISC + + val ( / ) : Pathname.t -> Pathname.t -> Pathname.t + val ( -.- ) : Pathname.t -> string -> Pathname.t + + val ( ++ ) : Tags.t -> Tags.elt -> Tags.t + val ( -- ) : Tags.t -> Tags.elt -> Tags.t + val ( +++ ) : Tags.t -> Tags.elt option -> Tags.t + val ( --- ) : Tags.t -> Tags.elt option -> Tags.t + + type env = Pathname.t -> Pathname.t + type builder = Pathname.t list list -> (Pathname.t, exn) Outcome.t list + type action = env -> builder -> Command.t + + val rule : string -> + ?tags:string list -> + ?prods:string list -> + ?deps:string list -> + ?prod:string -> + ?dep:string -> + ?insert:[`top | `before of string | `after of string | `bottom] -> + action -> unit + + val file_rule : string -> + ?tags:string list -> + prod:string -> + ?deps:string list -> + ?dep:string -> + ?insert:[`top | `before of string | `after of string | `bottom] -> + cache:(env -> string) -> + (env -> out_channel -> unit) -> unit + + val custom_rule : string -> + ?tags:string list -> + ?prods:string list -> + ?prod:string -> + ?deps:string list -> + ?dep:string -> + ?insert:[`top | `before of string | `after of string | `bottom] -> + cache:(env -> string) -> + (env -> cached:bool -> unit) -> unit + + (** [copy_rule name ?insert source destination] *) + val copy_rule : string -> + ?insert:[`top | `before of string | `after of string | `bottom] -> + string -> string -> unit + + (** [dep tags deps] Will build [deps] when [tags] will be activated. *) + val dep : Tags.elt list -> Pathname.t list -> unit + + val flag : Tags.elt list -> Command.spec -> unit + + (** [non_dependency module_path module_name] + Example: + [non_dependency "foo/bar/baz" "Goo"] + Says that the module [Baz] in the file [foo/bar/baz.*] does not depend on [Goo]. *) + val non_dependency : Pathname.t -> string -> unit + + (** [use_lib module_path lib_path]*) + val use_lib : Pathname.t -> Pathname.t -> unit + + (** [ocaml_lib library_pathname] + Declare an ocaml library. + + Example: ocaml_lib "foo/bar" + This will setup the tag use_bar tag. + At link time it will include: + foo/bar.cma or foo/bar.cmxa + If you supply the ~dir:"boo" option -I boo + will be added at link and compile time. + Use ~extern:true for non-ocamlbuild handled libraries. + Use ~byte:false or ~native:false to disable byte or native mode. + Use ~tag_name:"usebar" to override the default tag name. *) + val ocaml_lib : + ?extern:bool -> + ?byte:bool -> + ?native:bool -> + ?dir:Pathname.t -> + ?tag_name:string -> + Pathname.t -> unit + + (** [expand_module include_dirs module_name extensions] + Example: + [expand_module ["a";"b";"c"] "Foo" ["cmo";"cmi"] = + ["a/foo.cmo"; "a/Foo.cmo"; "a/foo.cmi"; "a/Foo.cmi"; + "b/foo.cmo"; "b/Foo.cmo"; "b/foo.cmi"; "b/Foo.cmi"; + "c/foo.cmo"; "c/Foo.cmo"; "c/foo.cmi"; "c/Foo.cmi"]] *) + val expand_module : + Pathname.t list -> Pathname.t -> string list -> Pathname.t list + + val string_list_of_file : Pathname.t -> string list + + val module_name_of_pathname : Pathname.t -> string + + val mv : Pathname.t -> Pathname.t -> Command.t + val cp : Pathname.t -> Pathname.t -> Command.t + val ln_f : Pathname.t -> Pathname.t -> Command.t + val ln_s : Pathname.t -> Pathname.t -> Command.t + val rm_f : Pathname.t -> Command.t + val touch : Pathname.t -> Command.t + val chmod : Command.spec -> Pathname.t -> Command.t + val cmp : Pathname.t -> Pathname.t -> Command.t + + (** [hide_package_contents pack_name] + Don't treat the given package as an open package. + So a module will not be replaced during linking by + this package even if it contains that module. *) + val hide_package_contents : string -> unit + + val tag_file : Pathname.t -> Tags.elt list -> unit + + val tag_any : Tags.elt list -> unit + + val tags_of_pathname : Pathname.t -> Tags.t + + type hook = + | Before_hygiene + | After_hygiene + | Before_options + | After_options + | Before_rules + | After_rules + + val dispatch : (hook -> unit) -> unit +end diff --git a/ocamlbuild/slurp.ml b/ocamlbuild/slurp.ml new file mode 100644 index 00000000..7a9de141 --- /dev/null +++ b/ocamlbuild/slurp.ml @@ -0,0 +1,186 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: slurp.ml,v 1.1 2007/02/07 08:59:14 ertai Exp $ *) +(* Original author: Berke Durak *) +(* Slurp *) +open My_std +open Outcome + +type 'a entry = + | Dir of string * string * My_unix.stats Lazy.t * 'a * 'a entry list Lazy.t + | File of string * string * My_unix.stats Lazy.t * 'a + | Error of exn + | Nothing + +let (/) = filename_concat + +let rec filter predicate = function + | Dir(path, name, st, attr, entries) -> + if predicate path name attr then + Dir(path, name, st, attr, lazy (List.map (filter predicate) !*entries)) + else + Nothing + | File(path, name, _, attr) as f -> + if predicate path name attr then + f + else + Nothing + | Nothing -> Nothing + | Error _ as e -> e + +let real_slurp path = + let cwd = Sys.getcwd () in + let abs x = if Filename.is_implicit x || Filename.is_relative x then cwd/x else x in + let visited = Hashtbl.create 1024 in + let rec scandir path names = + let (file_acc, dir_acc) = + Array.fold_left begin fun ((file_acc, dir_acc) as acc) name -> + match do_entry true path name with + | None -> acc + | Some((Dir _|Error _) as entry) -> (file_acc, entry :: dir_acc) + | Some((File _) as entry) -> (entry :: file_acc, dir_acc) + | Some Nothing -> acc + end + ([], []) + names + in + file_acc @ dir_acc + and do_entry link_mode path name = + let fn = path/name in + let absfn = abs fn in + match + try + Good(if link_mode then My_unix.lstat absfn else My_unix.stat absfn) + with + | x -> Bad x + with + | Bad x -> Some(Error x) + | Good st -> + let key = st.My_unix.stat_key in + if try Hashtbl.find visited key with Not_found -> false + then None + else + begin + Hashtbl.add visited key true; + let res = + match st.My_unix.stat_file_kind with + | My_unix.FK_link -> + let fn' = My_unix.readlink absfn in + if sys_file_exists (abs fn') then + do_entry false path name + else + Some(File(path, name, lazy st, ())) + | My_unix.FK_dir -> + (match sys_readdir absfn with + | Good names -> Some(Dir(path, name, lazy st, (), lazy (scandir fn names))) + | Bad exn -> Some(Error exn)) + | My_unix.FK_other -> None + | My_unix.FK_file -> Some(File(path, name, lazy st, ())) in + Hashtbl.replace visited key false; + res + end + in + match do_entry true "" path with + | None -> raise Not_found + | Some entry -> entry + +let split path = + let rec aux path = + if path = Filename.current_dir_name then [] + else (Filename.basename path) :: aux (Filename.dirname path) + in List.rev (aux path) + +let rec join = + function + | [] -> assert false + | [x] -> x + | x :: xs -> x/(join xs) + +let rec add root path entries = + match path, entries with + | [], _ -> entries + | xpath :: xspath, (Dir(dpath, dname, dst, dattr, dentries) as d) :: entries -> + if xpath = dname then + Dir(dpath, dname, dst, dattr, lazy (add (root/xpath) xspath !*dentries)) :: entries + else d :: add root path entries + | [xpath], [] -> + [File(root, xpath, lazy (My_unix.stat (root/xpath)), ())] + | xpath :: xspath, [] -> + [Dir(root/(join xspath), xpath, + lazy (My_unix.stat (root/(join path))), (), + lazy (add (root/xpath) xspath []))] + | _, Nothing :: entries -> add root path entries + | _, Error _ :: _ -> entries + | [xpath], (File(_, fname, _, _) as f) :: entries' -> + if xpath = fname then entries + else f :: add root path entries' + | xpath :: xspath, (File(fpath, fname, fst, fattr) as f) :: entries' -> + if xpath = fname then + Dir(fpath, fname, fst, fattr, lazy (add (root/xpath) xspath [])) :: entries' + else f :: add root path entries' + +let slurp_with_find path = + let lines = + My_unix.run_and_open (Printf.sprintf "find %s" (Filename.quote path)) begin fun ic -> + let acc = ref [] in + try while true do acc := input_line ic :: !acc done; [] + with End_of_file -> !acc + end in + let res = + List.fold_right begin fun line acc -> + add path (split line) acc + end lines [] in + match res with + | [] -> Nothing + | [entry] -> entry + | entries -> Dir(path, Filename.basename path, lazy (My_unix.stat path), (), lazy entries) + +let slurp x = if !*My_unix.is_degraded then slurp_with_find x else real_slurp x + +let rec print print_attr f entry = + match entry with + | Dir(path, name, _, attr, entries) -> + Format.fprintf f "@[<2>Dir(%S,@ %S,@ _,@ %a,@ %a)@]" + path name print_attr attr (List.print (print print_attr)) !*entries + | File(path, name, _, attr) -> + Format.fprintf f "@[<2>File(%S,@ %S,@ _,@ %a)@]" path name print_attr attr + | Nothing -> + Format.fprintf f "Nothing" + | Error(_) -> + Format.fprintf f "Error(_)" + +let rec fold f entry acc = + match entry with + | Dir(path, name, _, attr, contents) -> + f path name attr (List.fold_right (fold f) !*contents acc) + | File(path, name, _, attr) -> + f path name attr acc + | Nothing | Error _ -> acc + +let map f entry = + let rec self entry = + match entry with + | Dir(path, name, st, attr, contents) -> + Dir(path, name, st, f path name attr, lazy (List.map self !*contents)) + | File(path, name, st, attr) -> + File(path, name, st, f path name attr) + | Nothing -> Nothing + | Error e -> Error e + in self entry + +let rec force = + function + | Dir(_, _, st, _, contents) -> + let _ = !*st in List.iter force !*contents + | File(_, _, st, _) -> + ignore !*st + | Nothing | Error _ -> () diff --git a/ocamlbuild/slurp.mli b/ocamlbuild/slurp.mli new file mode 100644 index 00000000..6a4eece4 --- /dev/null +++ b/ocamlbuild/slurp.mli @@ -0,0 +1,48 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: slurp.mli,v 1.1 2007/02/07 08:59:15 ertai Exp $ *) +(* Original author: Berke Durak *) +(* Slurp *) + +(** Scans a directory lazily to build a tree that can be user-decorated. *) + +type 'a entry = + Dir of string * string * My_unix.stats Lazy.t * 'a * 'a entry list Lazy.t + (** [Dir(path, name, lst, decoration, lentries)] is a directory named [name] whose path is [path]. + Its stat is lazily stored in [lst] and its entries are lazily scanned in [lentries]. [decoration] + is of type 'a. *) + | File of string * string * My_unix.stats Lazy.t * 'a + (** [File(path, name, lst, decoration)] is a file named [name] whose path is [path]. + Its stat is lazily stored in [lst]. [decoration] is of type 'a. *) + | Error of exn + (** [Error x] means that the exception [x] was raised while scanning or statting an entry. *) + | Nothing + (** Convenient when filtering out entries. *) + +(** Recursively scan the filesystem starting at the given directory. *) +val slurp : string -> unit entry + +(** [filter f entry] only retains from [entry] the nodes for which + [f path name] returns [true]. *) +val filter : (string -> string -> 'a -> bool) -> 'a entry -> 'a entry + +(** [map f entries] changes the decoration in [entries] by applying + [f] to them. [f] is called as [f path name decoration]. *) +val map : (string -> string -> 'a -> 'b) -> 'a entry -> 'b entry + +(** [fold f entry x] iterates [f] over the entries and an accumulator + initially containing [x]; at each iteration, [f] gets the current + value of the accumulator and returns its new value. *) +val fold : (string -> string -> 'b -> 'a -> 'a) -> 'b entry -> 'a -> 'a + +(** Force the evaluation of the whole entry. *) +val force : 'a entry -> unit diff --git a/ocamlbuild/solver.ml b/ocamlbuild/solver.ml new file mode 100644 index 00000000..e6cd3744 --- /dev/null +++ b/ocamlbuild/solver.ml @@ -0,0 +1,119 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: solver.ml,v 1.1 2007/02/07 08:59:15 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +open My_std +open Log +open Format +open Outcome + +type backtrace = + | Leaf of Pathname.t + | Choice of backtrace list + | Depth of Pathname.t * backtrace + | Target of string * backtrace +exception Failed of backtrace +exception Circular of Pathname.t * Pathname.t list + +let failed target backtrace = + Resource.Cache.resource_failed target; + raise (Failed backtrace) + +let rec pp_repeat f (n, s) = + if n > 0 then (pp_print_string f s; pp_repeat f (n - 1, s)) + +let rec self depth on_the_go_orig target = + let rules = Rule.get_rules () in + let on_the_go = target :: on_the_go_orig in + + dprintf 4 "==%a> %a" pp_repeat (depth, "==") Resource.print target; + if List.mem target on_the_go_orig then raise (Circular(target, on_the_go_orig)); + match Resource.Cache.resource_state target with + | Resource.Cache.Bbuilt -> + (dprintf 5 "%a already built" Resource.print target) + | Resource.Cache.Bcannot_be_built -> + (dprintf 5 "%a already failed" Resource.print target; failed target (Leaf target)) + | Resource.Cache.Bsuspension(s) -> + (dprintf 5 "%a was suspended -> resuming" Resource.print target; + Resource.Cache.resume_suspension s) + | Resource.Cache.Bnot_built_yet -> + if Resource.is_up_to_date target then + (dprintf 5 "%a exists and up to date" Resource.print target; + Resource.Cache.resource_built target) + else if Pathname.exists_in_source_dir target then + (dprintf 5 "%a exists in source dir -> import it" Resource.print target; + Pathname.import_in_build_dir target; + Resource.Cache.resource_built target; + Resource.Cache.resource_changed target) + else + (* FIXME tags of target + let tags = Configuration.tags_of_target target in + let matching_rules = List.filter_opt (Rule.tags_matches tags) rules in *) + let matching_rules = List.filter_opt (Rule.can_produce target) (*matching_*)rules in + match matching_rules with + | [] -> failed target (Leaf target) + | _ -> + let rec until_works rs backtraces = + match rs with + | [] -> assert false + | r :: rs -> + try + List.iter (force_self (depth + 1) on_the_go) r.Rule.deps; + Rule.call (self_firsts (depth + 1) on_the_go) r + with Failed backtrace -> + if rs = [] then failed target (Depth (target, Choice (backtrace :: backtraces))) + else + let () = + match backtrace with + | Depth (top_prod, _) -> Resource.Cache.clear_resource_failed top_prod + | Target _ | Choice _ | Leaf _ -> () + in until_works rs (backtrace :: backtraces) + in until_works matching_rules [] +and self_first depth on_the_go already_failed rs = + match rs with + | [] -> Bad (Failed (Choice already_failed)) + | r :: rs -> + try self depth on_the_go r; Good r + with Failed backtrace -> self_first depth on_the_go (backtrace :: already_failed) rs +and self_firsts depth on_the_go rss = + let results = List.map (self_first depth on_the_go []) rss in + let cmds, konts = + List.fold_right begin fun res ((acc1, acc2) as acc) -> + match res with + | Bad _ -> acc + | Good res -> + match Resource.Cache.get_optional_resource_suspension res with + | None -> acc + | Some (cmd, kont) -> (cmd :: acc1, kont :: acc2) + end results ([], []) in + let count = List.length cmds in + let job_debug = if !Command.jobs = 1 then 10 else 5 in + if count > 1 then dprintf job_debug ">>> PARALLEL: %d" count; + let opt_exn = Command.execute_many cmds in + if count > 1 then dprintf job_debug "<<< PARALLEL"; + begin match opt_exn with + | Some(res, exn) -> + List.iter2 (fun res kont -> if res then kont ()) res konts; + Log.finish ~how:`Error (); + raise exn + | None -> + List.iter (fun kont -> kont ()) konts + end; + results +and force_self depth on_the_go x = self depth on_the_go x; Resource.Cache.resume_resource x + +let solve = force_self 0 [] +let solve_target name rs = + match self_first 0 [] [] rs with + | Good res -> Resource.Cache.resume_resource res; res + | Bad (Failed backtrace) -> raise (Failed (Target (name, backtrace))) + | Bad exn -> raise exn diff --git a/ocamlbuild/solver.mli b/ocamlbuild/solver.mli new file mode 100644 index 00000000..18ca8aee --- /dev/null +++ b/ocamlbuild/solver.mli @@ -0,0 +1,23 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: solver.mli,v 1.1 2007/02/07 08:59:15 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +type backtrace = private + | Leaf of Pathname.t + | Choice of backtrace list + | Depth of Pathname.t * backtrace + | Target of string * backtrace +exception Failed of backtrace +exception Circular of Pathname.t * Pathname.t list + +val solve : Pathname.t -> unit +val solve_target : string -> Pathname.t list -> Pathname.t diff --git a/ocamlbuild/start.sh b/ocamlbuild/start.sh new file mode 100755 index 00000000..d2525717 --- /dev/null +++ b/ocamlbuild/start.sh @@ -0,0 +1,91 @@ +#!/bin/sh +set -e +set -x +rm -rf _start +mkdir _start +cp *.ml* _start +cd _start +echo "let bindir = ref \"\";; let libdir = bindir;;" > ocamlbuild_where.ml +ocamlc -c std_signatures.mli +ocamlc -c signatures.mli +ocamlc -c tags.mli +ocamlc -c ocamlbuild_where.mli +ocamlc -c my_unix.mli +ocamlc -c my_std.mli +ocamlc -c display.mli +ocamlc -c shell.mli +ocamlc -c log.mli +ocamlc -c bool.mli +ocamlc -c glob_ast.mli +ocamlc -c glob_lexer.mli +ocamlc -c glob.mli +ocamlc -c lexers.mli +ocamlc -c slurp.mli +ocamlc -c pathname.mli +ocamlc -c discard_printf.mli +ocamlc -c command.mli +ocamlc -c resource.mli +ocamlc -c rule.mli +ocamlc -c hygiene.mli +ocamlc -c options.mli +ocamlc -c tools.mli +ocamlc -c main.mli +ocamlc -c ocaml_utils.mli +ocamlc -c ocaml_tools.mli +ocamlc -c ocaml_compiler.mli +ocamlc -c ocaml_dependencies.mli +ocamlc -c hooks.mli +ocamlc -c ocamldep.mli +ocamlc -c ocaml_specific.mli +ocamlc -c configuration.mli +ocamlc -c flags.mli +ocamlc -c ocaml_arch.mli +ocamlc -c solver.mli +ocamlc -c report.mli +ocamlc -c ocamlbuild_where.ml +ocamlc -c fda.mli +ocamlc -c fda.ml +ocamlc -c tools.ml +ocamlc -c plugin.mli +ocamlc -c plugin.ml +ocamlc -c ocaml_dependencies.ml +ocamlc -c main.ml +ocamlc -c ocaml_specific.ml +ocamlc -c display.ml +ocamlc -c command.ml +ocamlc -c -rectypes discard_printf.ml +ocamlc -c my_std.ml +ocamlc -c shell.ml +ocamlc -c my_unix.ml +ocamlc -c log.ml +ocamlc -c pathname.ml +ocamlc -c options.ml +ocamlc -c slurp.ml +ocamlc -c ocaml_utils.ml +ocamlc -c ocaml_tools.ml +ocamlc -c ocaml_compiler.ml +ocamlc -c ocamldep.ml +ocamlc -c hooks.ml +ocamllex lexers.mll +ocamlc -c lexers.ml +ocamllex glob_lexer.mll +ocamlc -c glob_lexer.ml +ocamlc -c bool.ml +ocamlc -c glob_ast.ml +ocamlc -c glob.ml +ocamlc -c tags.ml +ocamlc -c configuration.ml +ocamlc -c flags.ml +ocamlc -c hygiene.ml +ocamlc -c ocaml_arch.ml +ocamlc -c resource.ml +ocamlc -c rule.ml +ocamlc -c report.ml +ocamlc -c solver.ml +ocamlc -c ocamlbuildlight.mli +ocamlc -pack discard_printf.cmo my_std.cmo bool.cmo glob_ast.cmo glob_lexer.cmo glob.cmo lexers.cmo my_unix.cmo tags.cmo display.cmo log.cmo shell.cmo slurp.cmo ocamlbuild_where.cmo command.cmo options.cmo pathname.cmo resource.cmo rule.cmo flags.cmo solver.cmo report.cmo ocaml_arch.cmo hygiene.cmo configuration.cmo tools.cmo fda.cmo plugin.cmo ocaml_utils.cmo ocamldep.cmo ocaml_dependencies.cmo ocaml_compiler.cmo ocaml_tools.cmo hooks.cmo ocaml_specific.cmo main.cmo -o ocamlbuild_pack.cmo +ocamlc -c ocamlbuildlight.ml +ocamlc ocamlbuild_pack.cmo ocamlbuildlight.cmo -o ../ocamlbuild.byte.start +cd .. +rm -rf _start +echo ocamlbuild.byte.start: Sucessfully built. diff --git a/ocamlbuild/std_signatures.mli b/ocamlbuild/std_signatures.mli new file mode 100644 index 00000000..358bb661 --- /dev/null +++ b/ocamlbuild/std_signatures.mli @@ -0,0 +1,94 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: std_signatures.mli,v 1.1 2007/02/07 08:59:15 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +(** Some signatures from the standard library. *) + +module type LIST = sig + val length : 'a list -> int + val hd : 'a list -> 'a + val tl : 'a list -> 'a list + val nth : 'a list -> int -> 'a + val rev : 'a list -> 'a list + val append : 'a list -> 'a list -> 'a list + val rev_append : 'a list -> 'a list -> 'a list + val concat : 'a list list -> 'a list + val flatten : 'a list list -> 'a list + val iter : ('a -> unit) -> 'a list -> unit + val map : ('a -> 'b) -> 'a list -> 'b list + val rev_map : ('a -> 'b) -> 'a list -> 'b list + val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a + val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b + val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit + val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a + val fold_right2 : + ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c + val for_all : ('a -> bool) -> 'a list -> bool + val exists : ('a -> bool) -> 'a list -> bool + val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + val mem : 'a -> 'a list -> bool + val memq : 'a -> 'a list -> bool + val find : ('a -> bool) -> 'a list -> 'a + val filter : ('a -> bool) -> 'a list -> 'a list + val find_all : ('a -> bool) -> 'a list -> 'a list + val partition : ('a -> bool) -> 'a list -> 'a list * 'a list + val assoc : 'a -> ('a * 'b) list -> 'b + val assq : 'a -> ('a * 'b) list -> 'b + val mem_assoc : 'a -> ('a * 'b) list -> bool + val mem_assq : 'a -> ('a * 'b) list -> bool + val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list + val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list + val split : ('a * 'b) list -> 'a list * 'b list + val combine : 'a list -> 'b list -> ('a * 'b) list + val sort : ('a -> 'a -> int) -> 'a list -> 'a list + val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list + val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list + val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list +end + +module type STRING = sig + external length : string -> int = "%string_length" + external get : string -> int -> char = "%string_safe_get" + external set : string -> int -> char -> unit = "%string_safe_set" + external create : int -> string = "caml_create_string" + val make : int -> char -> string + val copy : string -> string + val sub : string -> int -> int -> string + val fill : string -> int -> int -> char -> unit + val blit : string -> int -> string -> int -> int -> unit + val concat : string -> string list -> string + val iter : (char -> unit) -> string -> unit + val escaped : string -> string + val index : string -> char -> int + val rindex : string -> char -> int + val index_from : string -> int -> char -> int + val rindex_from : string -> int -> char -> int + val contains : string -> char -> bool + val contains_from : string -> int -> char -> bool + val rcontains_from : string -> int -> char -> bool + val uppercase : string -> string + val lowercase : string -> string + val capitalize : string -> string + val uncapitalize : string -> string + type t = string + val compare : t -> t -> int + external unsafe_get : string -> int -> char = "%string_unsafe_get" + external unsafe_set : string -> int -> char -> unit + = "%string_unsafe_set" + external unsafe_blit : string -> int -> string -> int -> int -> unit + = "caml_blit_string" "noalloc" + external unsafe_fill : string -> int -> int -> char -> unit + = "caml_fill_string" "noalloc" +end diff --git a/ocamlbuild/tags.ml b/ocamlbuild/tags.ml new file mode 100644 index 00000000..e9dc20d8 --- /dev/null +++ b/ocamlbuild/tags.ml @@ -0,0 +1,43 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: tags.ml,v 1.2 2007/02/22 15:56:23 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +include Set.Make(String) + +(** + does_match {foo, bar, baz} {foo} => ok + does_match {foo, bar, baz} {foo, boo} => ko + does_match {foo, bar, baz} {} => ok + does_match {foo, bar, baz} {foo, bar, baz} => ok +*) +let does_match x y = subset y x + +let of_list l = List.fold_right add l empty + +open Format + +let print f s = + let () = fprintf f "@[<0>" in + let _ = + fold begin fun elt first -> + if not first then fprintf f ",@ "; + pp_print_string f elt; + false + end s true in + fprintf f "@]" + +module Operators = struct + let ( ++ ) x y = add y x + let ( -- ) x y = remove y x + let ( +++ ) x = function Some y -> add y x | None -> x + let ( --- ) x = function Some y -> remove y x | None -> x +end diff --git a/ocamlbuild/tags.mli b/ocamlbuild/tags.mli new file mode 100644 index 00000000..51a154ee --- /dev/null +++ b/ocamlbuild/tags.mli @@ -0,0 +1,15 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: tags.mli,v 1.1 2007/02/07 08:59:15 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) + +include Signatures.TAGS diff --git a/ocamlbuild/tools.ml b/ocamlbuild/tools.ml new file mode 100644 index 00000000..37a32f9c --- /dev/null +++ b/ocamlbuild/tools.ml @@ -0,0 +1,49 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: tools.ml,v 1.2 2007/02/08 16:53:39 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +(* Tools *) + +open My_std +open Format +open Log +open Pathname.Operators +open Tags.Operators +open Rule + +let pp_l = List.print String.print + +let default_tags = ref Tags.empty;; + +let tags_of_pathname p = + (Tags.union (Configuration.tags_of_filename (Pathname.to_string p)) !default_tags) + ++("file:"^p) + ++("extension:"^Pathname.get_extension p) +let flags_of_pathname p = Configuration.flags_of_filename (Pathname.to_string p) + +let opt_print elt ppf = + function + | Some x -> fprintf ppf "@[<2>Some@ %a@]" elt x + | None -> pp_print_string ppf "None" + +let path_and_context_of_string s = + if Pathname.is_implicit s then + let b = Pathname.basename s in + let d = Pathname.dirname s in + if d <> Pathname.current_dir_name then + let () = Pathname.define_context d [d] in + [s] + else + let include_dirs = Pathname.include_dirs_of d in + List.map (fun include_dir -> include_dir/b) include_dirs + else [s] + diff --git a/ocamlbuild/tools.mli b/ocamlbuild/tools.mli new file mode 100644 index 00000000..a7601b84 --- /dev/null +++ b/ocamlbuild/tools.mli @@ -0,0 +1,20 @@ +(***********************************************************************) +(* ocamlbuild *) +(* *) +(* Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: tools.mli,v 1.1 2007/02/07 08:59:15 ertai Exp $ *) +(* Original author: Nicolas Pouillard *) +(* Tools *) + +val tags_of_pathname : Pathname.t -> Tags.t +val flags_of_pathname : Pathname.t -> Command.spec +val default_tags : Tags.t ref +val path_and_context_of_string : Pathname.t -> Pathname.t list +val pp_l : Format.formatter -> string list -> unit diff --git a/ocamldoc/.depend b/ocamldoc/.depend index 238d372c..5e2196a5 100644 --- a/ocamldoc/.depend +++ b/ocamldoc/.depend @@ -1,7 +1,7 @@ odoc.cmo: ../typing/typedtree.cmi odoc_texi.cmo odoc_messages.cmo \ odoc_man.cmo odoc_latex.cmo odoc_info.cmi odoc_html.cmo odoc_global.cmi \ odoc_dot.cmo odoc_config.cmi odoc_args.cmi odoc_analyse.cmi \ - ../utils/misc.cmi ../utils/config.cmi ../utils/clflags.cmo + ../utils/misc.cmi ../utils/config.cmi ../utils/clflags.cmi odoc.cmx: ../typing/typedtree.cmx odoc_texi.cmx odoc_messages.cmx \ odoc_man.cmx odoc_latex.cmx odoc_info.cmx odoc_html.cmx odoc_global.cmx \ odoc_dot.cmx odoc_config.cmx odoc_args.cmx odoc_analyse.cmx \ @@ -16,7 +16,7 @@ odoc_analyse.cmo: ../utils/warnings.cmi ../typing/typetexp.cmi \ odoc_cross.cmi odoc_comments.cmi odoc_class.cmo odoc_ast.cmi \ odoc_args.cmi ../utils/misc.cmi ../parsing/location.cmi \ ../parsing/lexer.cmi ../typing/includemod.cmi ../typing/env.cmi \ - ../typing/ctype.cmi ../utils/config.cmi ../utils/clflags.cmo \ + ../typing/ctype.cmi ../utils/config.cmi ../utils/clflags.cmi \ ../utils/ccomp.cmi odoc_analyse.cmi odoc_analyse.cmx: ../utils/warnings.cmx ../typing/typetexp.cmx \ ../typing/types.cmx ../typing/typemod.cmx ../typing/typedtree.cmx \ @@ -32,7 +32,7 @@ odoc_analyse.cmx: ../utils/warnings.cmx ../typing/typetexp.cmx \ ../utils/ccomp.cmx odoc_analyse.cmi odoc_args.cmo: odoc_types.cmi odoc_module.cmo odoc_messages.cmo \ odoc_global.cmi odoc_config.cmi ../utils/misc.cmi ../utils/config.cmi \ - ../utils/clflags.cmo odoc_args.cmi + ../utils/clflags.cmi odoc_args.cmi odoc_args.cmx: odoc_types.cmx odoc_module.cmx odoc_messages.cmx \ odoc_global.cmx odoc_config.cmx ../utils/misc.cmx ../utils/config.cmx \ ../utils/clflags.cmx odoc_args.cmi @@ -42,24 +42,24 @@ odoc_ast.cmo: ../typing/types.cmi ../typing/typedtree.cmi \ odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_messages.cmo \ odoc_global.cmi odoc_exception.cmo odoc_env.cmi odoc_class.cmo \ odoc_args.cmi ../utils/misc.cmi ../parsing/location.cmi \ - ../parsing/asttypes.cmi odoc_ast.cmi + ../typing/ident.cmi ../parsing/asttypes.cmi odoc_ast.cmi odoc_ast.cmx: ../typing/types.cmx ../typing/typedtree.cmx \ ../typing/predef.cmx ../typing/path.cmx ../parsing/parsetree.cmi \ odoc_value.cmx odoc_types.cmx odoc_type.cmx odoc_sig.cmx \ odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_messages.cmx \ odoc_global.cmx odoc_exception.cmx odoc_env.cmx odoc_class.cmx \ odoc_args.cmx ../utils/misc.cmx ../parsing/location.cmx \ - ../parsing/asttypes.cmi odoc_ast.cmi + ../typing/ident.cmx ../parsing/asttypes.cmi odoc_ast.cmi odoc_class.cmo: ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ odoc_parameter.cmo odoc_name.cmi odoc_class.cmx: ../typing/types.cmx odoc_value.cmx odoc_types.cmx \ odoc_parameter.cmx odoc_name.cmx odoc_comments.cmo: odoc_types.cmi odoc_text.cmi odoc_see_lexer.cmo \ odoc_parser.cmi odoc_misc.cmi odoc_messages.cmo odoc_lexer.cmo \ - odoc_global.cmi odoc_comments_global.cmi odoc_comments.cmi + odoc_global.cmi odoc_cross.cmi odoc_comments_global.cmi odoc_comments.cmi odoc_comments.cmx: odoc_types.cmx odoc_text.cmx odoc_see_lexer.cmx \ odoc_parser.cmx odoc_misc.cmx odoc_messages.cmx odoc_lexer.cmx \ - odoc_global.cmx odoc_comments_global.cmx odoc_comments.cmi + odoc_global.cmx odoc_cross.cmx odoc_comments_global.cmx odoc_comments.cmi odoc_comments_global.cmo: odoc_comments_global.cmi odoc_comments_global.cmx: odoc_comments_global.cmi odoc_config.cmo: ../utils/config.cmi odoc_config.cmi @@ -86,7 +86,7 @@ odoc_env.cmx: ../typing/types.cmx ../typing/printtyp.cmx ../typing/predef.cmx \ ../typing/path.cmx odoc_name.cmx ../typing/btype.cmx odoc_env.cmi odoc_exception.cmo: ../typing/types.cmi odoc_types.cmi odoc_name.cmi odoc_exception.cmx: ../typing/types.cmx odoc_types.cmx odoc_name.cmx -odoc_global.cmo: ../utils/clflags.cmo odoc_global.cmi +odoc_global.cmo: ../utils/clflags.cmi odoc_global.cmi odoc_global.cmx: ../utils/clflags.cmx odoc_global.cmi odoc_html.cmo: odoc_text.cmi odoc_ocamlhtml.cmo odoc_messages.cmo \ odoc_info.cmi odoc_dag2html.cmi odoc_args.cmi @@ -96,14 +96,14 @@ odoc_info.cmo: ../typing/printtyp.cmi odoc_value.cmo odoc_types.cmi \ odoc_type.cmo odoc_text.cmi odoc_str.cmi odoc_search.cmi odoc_scan.cmo \ odoc_print.cmi odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \ odoc_misc.cmi odoc_messages.cmo odoc_global.cmi odoc_exception.cmo \ - odoc_dep.cmo odoc_comments.cmi odoc_class.cmo odoc_args.cmi \ - odoc_analyse.cmi odoc_info.cmi + odoc_dep.cmo odoc_config.cmi odoc_comments.cmi odoc_class.cmo \ + odoc_args.cmi odoc_analyse.cmi odoc_info.cmi odoc_info.cmx: ../typing/printtyp.cmx odoc_value.cmx odoc_types.cmx \ odoc_type.cmx odoc_text.cmx odoc_str.cmx odoc_search.cmx odoc_scan.cmx \ odoc_print.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \ odoc_misc.cmx odoc_messages.cmx odoc_global.cmx odoc_exception.cmx \ - odoc_dep.cmx odoc_comments.cmx odoc_class.cmx odoc_args.cmx \ - odoc_analyse.cmx odoc_info.cmi + odoc_dep.cmx odoc_config.cmx odoc_comments.cmx odoc_class.cmx \ + odoc_args.cmx odoc_analyse.cmx odoc_info.cmi odoc_latex.cmo: odoc_to_text.cmo odoc_messages.cmo odoc_latex_style.cmo \ odoc_info.cmi odoc_latex.cmx: odoc_to_text.cmx odoc_messages.cmx odoc_latex_style.cmx \ @@ -122,8 +122,8 @@ odoc_merge.cmo: odoc_value.cmo odoc_types.cmi odoc_type.cmo \ odoc_merge.cmx: odoc_value.cmx odoc_types.cmx odoc_type.cmx \ odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_messages.cmx \ odoc_exception.cmx odoc_class.cmx odoc_args.cmx odoc_merge.cmi -odoc_messages.cmo: odoc_global.cmi ../utils/config.cmi -odoc_messages.cmx: odoc_global.cmx ../utils/config.cmx +odoc_messages.cmo: odoc_global.cmi odoc_config.cmi ../utils/config.cmi +odoc_messages.cmx: odoc_global.cmx odoc_config.cmx ../utils/config.cmx odoc_misc.cmo: ../typing/types.cmi ../typing/predef.cmi ../typing/path.cmi \ odoc_types.cmi odoc_messages.cmo ../parsing/longident.cmi \ ../typing/ctype.cmi ../typing/btype.cmi odoc_misc.cmi @@ -134,14 +134,14 @@ odoc_module.cmo: ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ odoc_type.cmo odoc_name.cmi odoc_exception.cmo odoc_class.cmo odoc_module.cmx: ../typing/types.cmx odoc_value.cmx odoc_types.cmx \ odoc_type.cmx odoc_name.cmx odoc_exception.cmx odoc_class.cmx -odoc_name.cmo: ../typing/path.cmi ../parsing/longident.cmi \ - ../typing/ident.cmi odoc_name.cmi -odoc_name.cmx: ../typing/path.cmx ../parsing/longident.cmx \ - ../typing/ident.cmx odoc_name.cmi +odoc_name.cmo: ../typing/path.cmi odoc_misc.cmi ../typing/ident.cmi \ + odoc_name.cmi +odoc_name.cmx: ../typing/path.cmx odoc_misc.cmx ../typing/ident.cmx \ + odoc_name.cmi odoc_opt.cmo: ../typing/typedtree.cmi odoc_texi.cmo odoc_messages.cmo \ odoc_man.cmo odoc_latex.cmo odoc_info.cmi odoc_html.cmo odoc_global.cmi \ odoc_dot.cmo odoc_args.cmi odoc_analyse.cmi ../utils/misc.cmi \ - ../utils/config.cmi ../utils/clflags.cmo + ../utils/config.cmi ../utils/clflags.cmi odoc_opt.cmx: ../typing/typedtree.cmx odoc_texi.cmx odoc_messages.cmx \ odoc_man.cmx odoc_latex.cmx odoc_info.cmx odoc_html.cmx odoc_global.cmx \ odoc_dot.cmx odoc_args.cmx odoc_analyse.cmx ../utils/misc.cmx \ @@ -210,8 +210,8 @@ odoc_analyse.cmi: odoc_module.cmo odoc_args.cmi odoc_args.cmi: odoc_types.cmi odoc_module.cmo odoc_ast.cmi: ../typing/types.cmi ../typing/typedtree.cmi ../typing/path.cmi \ ../parsing/parsetree.cmi odoc_sig.cmi odoc_name.cmi odoc_module.cmo -odoc_comments.cmi: odoc_types.cmi -odoc_cross.cmi: odoc_module.cmo +odoc_comments.cmi: odoc_types.cmi odoc_module.cmo +odoc_cross.cmi: odoc_types.cmi odoc_module.cmo odoc_dag2html.cmi: odoc_info.cmi odoc_env.cmi: ../typing/types.cmi odoc_name.cmi odoc_info.cmi: ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index af563710..4e76b3ec 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -9,7 +9,7 @@ #(* *) #(***********************************************************************) -# $Id: Makefile,v 1.60.2.5 2006/08/10 12:45:09 guesdon Exp $ +# $Id: Makefile,v 1.64 2006/09/20 11:14:36 doligez Exp $ include ../config/Makefile @@ -31,7 +31,7 @@ OCAMLPP=-pp './remove_DEBUG' MKDIR=mkdir -p CP=cp -f OCAMLDOC=ocamldoc -OCAMLDOC_RUN=sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES) +OCAMLDOC_RUN=./ocamldoc.opt #sh ./runocamldoc $(SUPPORTS_SHARED_LIBRARIES) OCAMLDOC_OPT=$(OCAMLDOC).opt OCAMLDOC_LIBCMA=odoc_info.cma OCAMLDOC_LIBCMI=odoc_info.cmi @@ -188,12 +188,12 @@ STDLIB_MLIS=../stdlib/*.mli \ ../otherlibs/num/num.mli all: exe lib - $(MAKE) manpages exe: $(OCAMLDOC) lib: $(OCAMLDOC_LIBCMA) $(OCAMLDOC_LIBCMI) $(ODOC_TEST) opt.opt: exeopt libopt + $(MAKE) manpages exeopt: $(OCAMLDOC_OPT) libopt: $(OCAMLDOC_LIBCMXA) $(OCAMLDOC_LIBCMI) debug: @@ -265,7 +265,7 @@ install: dummy $(CP) ocamldoc.hva *.cmi $(OCAMLDOC_LIBCMA) $(INSTALL_LIBDIR) $(CP) $(INSTALL_MLIS) $(INSTALL_CMIS) $(INSTALL_LIBDIR) if test -d $(INSTALL_MANODIR); then : ; else $(MKDIR) $(INSTALL_MANODIR); fi - $(CP) stdlib_man/* $(INSTALL_MANODIR) + if test -d stdlib_man; then $(CP) stdlib_man/* $(INSTALL_MANODIR); else : ; fi installopt: if test -f $(OCAMLDOC_OPT) ; then $(MAKE) installopt_really ; fi diff --git a/ocamldoc/Makefile.nt b/ocamldoc/Makefile.nt index 25e7ed05..07187267 100644 --- a/ocamldoc/Makefile.nt +++ b/ocamldoc/Makefile.nt @@ -9,7 +9,7 @@ #(* *) #(***********************************************************************) -# $Id: Makefile.nt,v 1.25.10.1 2006/09/11 08:57:29 xleroy Exp $ +# $Id: Makefile.nt,v 1.26 2006/09/20 11:14:36 doligez Exp $ include ../config/Makefile diff --git a/ocamldoc/odoc.ml b/ocamldoc/odoc.ml index b55aa7f8..472e93bd 100644 --- a/ocamldoc/odoc.ml +++ b/ocamldoc/odoc.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc.ml,v 1.8.4.1 2006/05/02 12:15:39 guesdon Exp $ *) +(* $Id: odoc.ml,v 1.9 2006/09/20 11:14:36 doligez Exp $ *) (** Main module for bytecode. *) @@ -147,4 +147,4 @@ let _ = exit 0 -(* eof $Id: odoc.ml,v 1.8.4.1 2006/05/02 12:15:39 guesdon Exp $ *) +(* eof $Id: odoc.ml,v 1.9 2006/09/20 11:14:36 doligez Exp $ *) diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index 4ad561c0..43de024b 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_analyse.ml,v 1.12.2.3 2006/02/09 14:14:05 doligez Exp $ *) +(* $Id: odoc_analyse.ml,v 1.14 2006/04/16 23:28:21 doligez Exp $ *) (** Analysis of source files. This module is strongly inspired from driver/main.ml :-) *) diff --git a/ocamldoc/odoc_args.ml b/ocamldoc/odoc_args.ml index 87df0335..7e84db81 100644 --- a/ocamldoc/odoc_args.ml +++ b/ocamldoc/odoc_args.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* cvsid $Id: odoc_args.ml,v 1.18.4.2 2006/08/10 12:34:02 guesdon Exp $ *) +(* cvsid $Id: odoc_args.ml,v 1.20.6.1 2007/03/02 08:55:05 guesdon Exp $ *) (** Command-line arguments. *) @@ -221,6 +221,7 @@ let options = ref [ "-rectypes", Arg.Set recursive_types, M.rectypes ; "-nolabels", Arg.Unit (fun () -> classic := true), M.nolabels ; "-warn-error", Arg.Set Odoc_global.warn_error, M.werr ; + "-hide-warnings", Arg.Clear Odoc_config.print_warnings, M.hide_warnings ; "-o", Arg.String (fun s -> out_file := s), M.out_file ; "-d", Arg.String (fun s -> target_dir := s), M.target_dir ; "-sort", Arg.Unit (fun () -> sort_modules := true), M.sort_modules ; diff --git a/ocamldoc/odoc_args.mli b/ocamldoc/odoc_args.mli index 43e880c3..58377cf2 100644 --- a/ocamldoc/odoc_args.mli +++ b/ocamldoc/odoc_args.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_args.mli,v 1.14.4.2 2006/08/10 12:34:02 guesdon Exp $ *) +(* $Id: odoc_args.mli,v 1.16 2006/09/20 11:14:36 doligez Exp $ *) (** Analysis of the command line arguments. *) diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index ef5bc289..f2d793a4 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_ast.ml,v 1.26.4.3 2006/08/10 11:29:54 guesdon Exp $ *) +(* $Id: odoc_ast.ml,v 1.29 2006/09/20 11:14:36 doligez Exp $ *) (** Analysis of implementation files. *) open Misc @@ -68,12 +68,12 @@ module Typedtree_search = | Typedtree.Tstr_module (ident, _) -> Hashtbl.add table (M (Name.from_ident ident)) tt | Typedtree.Tstr_recmodule mods -> - List.iter - (fun (ident,mod_expr) -> - Hashtbl.add table (M (Name.from_ident ident)) - (Typedtree.Tstr_module (ident,mod_expr)) - ) - mods + List.iter + (fun (ident,mod_expr) -> + Hashtbl.add table (M (Name.from_ident ident)) + (Typedtree.Tstr_module (ident,mod_expr)) + ) + mods | Typedtree.Tstr_modtype (ident, _) -> Hashtbl.add table (MT (Name.from_ident ident)) tt | Typedtree.Tstr_exception (ident, _) -> @@ -88,7 +88,7 @@ module Typedtree_search = ident_type_decl_list | Typedtree.Tstr_class info_list -> List.iter - (fun ((id,_,_,_) as ci) -> + (fun ((id,_,_,_,_) as ci) -> Hashtbl.add table (C (Name.from_ident id)) (Typedtree.Tstr_class [ci])) info_list @@ -146,7 +146,7 @@ module Typedtree_search = let search_class_exp table name = match Hashtbl.find table (C name) with - | (Typedtree.Tstr_class [(_,_,_,ce)]) -> + | (Typedtree.Tstr_class [(_,_,_,ce,_)]) -> ( try let type_decl = search_type_declaration table name in @@ -184,7 +184,7 @@ module Typedtree_search = let rec iter = function | [] -> raise Not_found - | Typedtree.Cf_val (_, ident, exp) :: q + | Typedtree.Cf_val (_, ident, Some exp, _) :: q when Name.from_ident ident = name -> exp.Typedtree.exp_type | _ :: q -> @@ -388,7 +388,7 @@ module Analyser = (* ( match clexp.Typedtree.cl_desc with - Tclass_ident _ -> prerr_endline "Tclass_ident" + Tclass_ident _ -> prerr_endline "Tclass_ident" | Tclass_structure _ -> prerr_endline "Tclass_structure" | Tclass_fun _ -> prerr_endline "Tclass_fun" | Tclass_apply _ -> prerr_endline "Tclass_apply" @@ -507,23 +507,24 @@ module Analyser = with Not_found -> raise (Failure (Odoc_messages.inherit_classexp_not_found_in_typedtree n)) in let (info_opt, ele_comments) = - get_comments_in_class last_pos - p_clexp.Parsetree.pcl_loc.Location.loc_start.Lexing.pos_cnum - in + get_comments_in_class last_pos + p_clexp.Parsetree.pcl_loc.Location.loc_start.Lexing.pos_cnum + in let text_opt = match info_opt with None -> None | Some i -> i.Odoc_types.i_desc in let name = tt_name_of_class_expr tt_clexp in let inher = - { - ic_name = Odoc_env.full_class_or_class_type_name env name ; - ic_class = None ; - ic_text = text_opt ; - } - in + { + ic_name = Odoc_env.full_class_or_class_type_name env name ; + ic_class = None ; + ic_text = text_opt ; + } + in iter (acc_inher @ [ inher ]) (acc_fields @ ele_comments) p_clexp.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum q - | (Parsetree.Pcf_val (label, mutable_flag, expression, loc)) :: q -> + | (Parsetree.Pcf_val (label, mutable_flag, _, loc) | + Parsetree.Pcf_valvirt (label, mutable_flag, _, loc)) :: q -> let complete_name = Name.concat current_class_name label in let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in let type_exp = @@ -825,7 +826,7 @@ module Analyser = { (* A VOIR : chercher dans les modules et les module types, avec quel env ? *) im_name = tt_name_from_module_expr mod_expr ; im_module = None ; - im_info = None ; + im_info = None ; } ] | _ -> @@ -841,7 +842,7 @@ module Analyser = [] | ((Element_included_module im) :: q, (im_repl :: im_q)) -> (Element_included_module { im_repl with im_info = im.im_info }) - :: (f (q, im_q)) + :: (f (q, im_q)) | ((Element_included_module im) :: q, []) -> (Element_included_module im) :: q | (ele :: q, l) -> @@ -854,9 +855,9 @@ module Analyser = and the module has a "structure" kind. *) let rec filter_module_with_module_type_constraint m mt = match m.m_kind, mt with - Module_struct l, Types.Tmty_signature lsig -> + Module_struct l, Types.Tmty_signature lsig -> m.m_kind <- Module_struct (filter_module_elements_with_module_type_constraint l lsig); - m.m_type <- mt; + m.m_type <- mt; | _ -> () (** This function removes the elements of the module type which does not @@ -864,16 +865,16 @@ module Analyser = and the module type has a "structure" kind. *) and filter_module_type_with_module_type_constraint mtyp mt = match mtyp.mt_kind, mt with - Some Module_type_struct l, Types.Tmty_signature lsig -> + Some Module_type_struct l, Types.Tmty_signature lsig -> mtyp.mt_kind <- Some (Module_type_struct (filter_module_elements_with_module_type_constraint l lsig)); - mtyp.mt_type <- Some mt; + mtyp.mt_type <- Some mt; | _ -> () and filter_module_elements_with_module_type_constraint l lsig = let pred ele = let f = match ele with Element_module m -> - (function + (function Types.Tsig_module (ident,t,_) -> let n1 = Name.simple m.m_name and n2 = Ident.name ident in @@ -883,8 +884,8 @@ module Analyser = | false -> false ) | _ -> false) - | Element_module_type mt -> - (function + | Element_module_type mt -> + (function Types.Tsig_modtype (ident,Types.Tmodtype_manifest t) -> let n1 = Name.simple mt.mt_name and n2 = Ident.name ident in @@ -894,44 +895,44 @@ module Analyser = | false -> false ) | _ -> false) - | Element_value v -> - (function + | Element_value v -> + (function Types.Tsig_value (ident,_) -> let n1 = Name.simple v.val_name and n2 = Ident.name ident in n1 = n2 | _ -> false) - | Element_type t -> - (function + | Element_type t -> + (function Types.Tsig_type (ident,_,_) -> - (* A VOIR: il est possible que le détail du type soit caché *) + (* A VOIR: il est possible que le détail du type soit caché *) let n1 = Name.simple t.ty_name and n2 = Ident.name ident in n1 = n2 | _ -> false) - | Element_exception e -> - (function + | Element_exception e -> + (function Types.Tsig_exception (ident,_) -> let n1 = Name.simple e.ex_name and n2 = Ident.name ident in n1 = n2 | _ -> false) - | Element_class c -> - (function + | Element_class c -> + (function Types.Tsig_class (ident,_,_) -> let n1 = Name.simple c.cl_name and n2 = Ident.name ident in n1 = n2 | _ -> false) - | Element_class_type ct -> - (function + | Element_class_type ct -> + (function Types.Tsig_cltype (ident,_,_) -> let n1 = Name.simple ct.clt_name and n2 = Ident.name ident in n1 = n2 | _ -> false) | Element_module_comment _ -> fun _ -> true - | Element_included_module _ -> fun _ -> true + | Element_included_module _ -> fun _ -> true in List.exists f lsig in @@ -1120,13 +1121,13 @@ module Analyser = ty_name = complete_name ; ty_info = com_opt ; ty_parameters = - List.map2 - (fun p (co,cn,_) -> - (Odoc_env.subst_type new_env p, - co, cn) - ) - tt_type_decl.Types.type_params - tt_type_decl.Types.type_variance ; + List.map2 + (fun p (co,cn,_) -> + (Odoc_env.subst_type new_env p, + co, cn) + ) + tt_type_decl.Types.type_params + tt_type_decl.Types.type_variance ; ty_kind = kind ; ty_manifest = (match tt_type_decl.Types.type_manifest with @@ -1134,12 +1135,12 @@ module Analyser = | Some t -> Some (Odoc_env.subst_type new_env t)); ty_loc = { loc_impl = Some (!file_name, loc_start) ; loc_inter = None } ; ty_code = - ( - if !Odoc_args.keep_code then - Some (get_string_of_file loc_start new_end) - else - None - ) ; + ( + if !Odoc_args.keep_code then + Some (get_string_of_file loc_start new_end) + else + None + ) ; } in let (maybe_more2, info_after_opt) = @@ -1173,13 +1174,13 @@ module Analyser = ex_args = List.map (Odoc_env.subst_type new_env) tt_excep_decl ; ex_alias = None ; ex_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; - ex_code = + ex_code = ( - if !Odoc_args.keep_code then + if !Odoc_args.keep_code then Some (get_string_of_file loc_start loc_end) else None - ) ; + ) ; } in (0, new_env, [ Element_exception new_ex ]) @@ -1220,18 +1221,18 @@ module Analyser = module_expr tt_module_expr in - let code = - if !Odoc_args.keep_code then - let loc = module_expr.Parsetree.pmod_loc in - let st = loc.Location.loc_start.Lexing.pos_cnum in - let en = loc.Location.loc_end.Lexing.pos_cnum in - Some (get_string_of_file st en) - else - None - in - let new_module = - { new_module_pre with m_code = code } - in + let code = + if !Odoc_args.keep_code then + let loc = module_expr.Parsetree.pmod_loc in + let st = loc.Location.loc_start.Lexing.pos_cnum in + let en = loc.Location.loc_end.Lexing.pos_cnum in + Some (get_string_of_file st en) + else + None + in + let new_module = + { new_module_pre with m_code = code } + in let new_env = Odoc_env.add_module env new_module.m_name in let new_env2 = match new_module.m_type with @@ -1250,14 +1251,14 @@ module Analyser = ) | Parsetree.Pstr_recmodule mods -> - (* A VOIR ICI pb: pas de lien avec les module type - dans les contraintes sur les modules *) - let new_env = + (* A VOIR ICI pb: pas de lien avec les module type + dans les contraintes sur les modules *) + let new_env = List.fold_left (fun acc_env (name, _, mod_exp) -> let complete_name = Name.concat current_module_name name in - let e = Odoc_env.add_module acc_env complete_name in - let tt_mod_exp = + let e = Odoc_env.add_module acc_env complete_name in + let tt_mod_exp = try Typedtree_search.search_module table name with Not_found -> raise (Failure (Odoc_messages.module_not_found_in_typedtree complete_name)) in @@ -1268,12 +1269,12 @@ module Analyser = None mod_exp tt_mod_exp - in - match new_module.m_type with + in + match new_module.m_type with Types.Tmty_signature s -> Odoc_env.add_signature e new_module.m_name - ~rel: (Name.simple new_module.m_name) s - | _ -> + ~rel: (Name.simple new_module.m_name) s + | _ -> e ) env @@ -1296,14 +1297,14 @@ module Analyser = else get_comments_in_module last_pos loc_start in - let new_module = analyse_module + let new_module = analyse_module new_env current_module_name name com_opt mod_exp tt_mod_exp - in + in let eles = f loc_end q in ele_comments @ ((Element_module new_module) :: eles) in @@ -1458,7 +1459,7 @@ module Analyser = { im_name = "dummy" ; im_module = None ; - im_info = comment_opt ; + im_info = comment_opt ; } in (0, env, [ Element_included_module im ]) (* A VOIR : étendre l'environnement ? avec quoi ? *) @@ -1470,16 +1471,16 @@ module Analyser = let pos_end = p_module_expr.Parsetree.pmod_loc.Location.loc_end.Lexing.pos_cnum in let modtype = (* A VOIR : Odoc_env.subst_module_type env ? *) - tt_module_expr.Typedtree.mod_type + tt_module_expr.Typedtree.mod_type in let m_code_intf = - match p_module_expr.Parsetree.pmod_desc with - Parsetree.Pmod_constraint (_, pmodule_type) -> - let loc_start = pmodule_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in + match p_module_expr.Parsetree.pmod_desc with + Parsetree.Pmod_constraint (_, pmodule_type) -> + let loc_start = pmodule_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in let loc_end = pmodule_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in - Some (get_string_of_file loc_start loc_end) - | _ -> - None + Some (get_string_of_file loc_start loc_end) + | _ -> + None in let m_base = { @@ -1491,9 +1492,9 @@ module Analyser = m_kind = Module_struct [] ; m_loc = { loc_impl = Some (!file_name, pos_start) ; loc_inter = None } ; m_top_deps = [] ; - m_code = None ; (* code is set by the caller, after the module is created *) - m_code_intf = m_code_intf ; - m_text_only = false ; + m_code = None ; (* code is set by the caller, after the module is created *) + m_code_intf = m_code_intf ; + m_text_only = false ; } in match (p_module_expr.Parsetree.pmod_desc, tt_module_expr.Typedtree.mod_desc) with @@ -1511,24 +1512,24 @@ module Analyser = | (Parsetree.Pmod_functor (_, pmodule_type, p_module_expr2), Typedtree.Tmod_functor (ident, mtyp, tt_module_expr2)) -> - let loc_start = pmodule_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in + let loc_start = pmodule_type.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in let loc_end = pmodule_type.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in - let mp_type_code = get_string_of_file loc_start loc_end in - print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code); - let mp_name = Name.from_ident ident in - let mp_kind = Sig.analyse_module_type_kind env - current_module_name pmodule_type mtyp - in + let mp_type_code = get_string_of_file loc_start loc_end in + print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code); + let mp_name = Name.from_ident ident in + let mp_kind = Sig.analyse_module_type_kind env + current_module_name pmodule_type mtyp + in let param = { mp_name = mp_name ; mp_type = Odoc_env.subst_module_type env mtyp ; - mp_type_code = mp_type_code ; - mp_kind = mp_kind ; + mp_type_code = mp_type_code ; + mp_kind = mp_kind ; } in let dummy_complete_name = (*Name.concat "__"*) param.mp_name in - (* TODO: A VOIR CE __ *) + (* TODO: A VOIR CE __ *) let new_env = Odoc_env.add_module env dummy_complete_name in let m_base2 = analyse_module new_env @@ -1545,9 +1546,9 @@ module Analyser = Typedtree.Tmod_apply (tt_module_expr1, tt_module_expr2, _)) | (Parsetree.Pmod_apply (p_module_expr1, p_module_expr2), Typedtree.Tmod_constraint - ({ Typedtree.mod_desc = Typedtree.Tmod_apply (tt_module_expr1, tt_module_expr2, _)}, + ({ Typedtree.mod_desc = Typedtree.Tmod_apply (tt_module_expr1, tt_module_expr2, _)}, _, _) - ) -> + ) -> let m1 = analyse_module env current_module_name @@ -1568,7 +1569,7 @@ module Analyser = | (Parsetree.Pmod_constraint (p_module_expr2, p_modtype), Typedtree.Tmod_constraint (tt_module_expr2, tt_modtype, _)) -> - print_DEBUG ("Odoc_ast: case Parsetree.Pmod_constraint + Typedtree.Tmod_constraint "^module_name); + print_DEBUG ("Odoc_ast: case Parsetree.Pmod_constraint + Typedtree.Tmod_constraint "^module_name); let m_base2 = analyse_module env current_module_name @@ -1581,8 +1582,8 @@ module Analyser = (Name.concat current_module_name "??") p_modtype tt_modtype in - let tt_modtype = Odoc_env.subst_module_type env tt_modtype in - filter_module_with_module_type_constraint m_base2 tt_modtype; + let tt_modtype = Odoc_env.subst_module_type env tt_modtype in + filter_module_with_module_type_constraint m_base2 tt_modtype; { m_base with m_type = tt_modtype ; @@ -1591,40 +1592,40 @@ module Analyser = | (Parsetree.Pmod_structure p_structure, Typedtree.Tmod_constraint - ({ Typedtree.mod_desc = Typedtree.Tmod_structure tt_structure}, - tt_modtype, _) - ) -> - (* needed for recursive modules *) + ({ Typedtree.mod_desc = Typedtree.Tmod_structure tt_structure}, + tt_modtype, _) + ) -> + (* needed for recursive modules *) - print_DEBUG ("Odoc_ast: case Parsetree.Pmod_structure + Typedtree.Tmod_constraint "^module_name); - let elements = analyse_structure env complete_name pos_start pos_end p_structure tt_structure in + print_DEBUG ("Odoc_ast: case Parsetree.Pmod_structure + Typedtree.Tmod_constraint "^module_name); + let elements = analyse_structure env complete_name pos_start pos_end p_structure tt_structure in (* we must complete the included modules *) let included_modules_from_tt = tt_get_included_module_list tt_structure in let elements2 = replace_dummy_included_modules elements included_modules_from_tt in { m_base with - m_type = Odoc_env.subst_module_type env tt_modtype ; - m_kind = Module_struct elements2 ; - } + m_type = Odoc_env.subst_module_type env tt_modtype ; + m_kind = Module_struct elements2 ; + } | (parsetree, typedtree) -> (*DEBUG*)let s_parse = (*DEBUG*) match parsetree with (*DEBUG*) Parsetree.Pmod_ident _ -> "Pmod_ident" - (*DEBUG*) | Parsetree.Pmod_structure _ -> "Pmod_structure" - (*DEBUG*) | Parsetree.Pmod_functor _ -> "Pmod_functor" - (*DEBUG*) | Parsetree.Pmod_apply _ -> "Pmod_apply" - (*DEBUG*) | Parsetree.Pmod_constraint _ -> "Pmod_constraint" - (*DEBUG*)in - (*DEBUG*)let s_typed = + (*DEBUG*) | Parsetree.Pmod_structure _ -> "Pmod_structure" + (*DEBUG*) | Parsetree.Pmod_functor _ -> "Pmod_functor" + (*DEBUG*) | Parsetree.Pmod_apply _ -> "Pmod_apply" + (*DEBUG*) | Parsetree.Pmod_constraint _ -> "Pmod_constraint" + (*DEBUG*)in + (*DEBUG*)let s_typed = (*DEBUG*) match typedtree with (*DEBUG*) Typedtree.Tmod_ident _ -> "Tmod_ident" - (*DEBUG*) | Typedtree.Tmod_structure _ -> "Tmod_structure" - (*DEBUG*) | Typedtree.Tmod_functor _ -> "Tmod_functor" - (*DEBUG*) | Typedtree.Tmod_apply _ -> "Tmod_apply" - (*DEBUG*) | Typedtree.Tmod_constraint _ -> "Tmod_constraint" - (*DEBUG*)in - (*DEBUG*)let code = get_string_of_file pos_start pos_end in - print_DEBUG (Printf.sprintf "code=%s\ns_parse=%s\ns_typed=%s\n" code s_parse s_typed); + (*DEBUG*) | Typedtree.Tmod_structure _ -> "Tmod_structure" + (*DEBUG*) | Typedtree.Tmod_functor _ -> "Tmod_functor" + (*DEBUG*) | Typedtree.Tmod_apply _ -> "Tmod_apply" + (*DEBUG*) | Typedtree.Tmod_constraint _ -> "Tmod_constraint" + (*DEBUG*)in + (*DEBUG*)let code = get_string_of_file pos_start pos_end in + print_DEBUG (Printf.sprintf "code=%s\ns_parse=%s\ns_typed=%s\n" code s_parse s_typed); raise (Failure "analyse_module: parsetree and typedtree don't match.") @@ -1664,12 +1665,8 @@ module Analyser = m_kind = kind ; m_loc = { loc_impl = Some (!file_name, 0) ; loc_inter = None } ; m_top_deps = [] ; - m_code = (if !Odoc_args.keep_code then Some !file else None) ; - m_code_intf = None ; - m_text_only = false ; + m_code = (if !Odoc_args.keep_code then Some !file else None) ; + m_code_intf = None ; + m_text_only = false ; } end - - - -(* eof $Id: odoc_ast.ml,v 1.26.4.3 2006/08/10 11:29:54 guesdon Exp $ *) diff --git a/ocamldoc/odoc_comments.ml b/ocamldoc/odoc_comments.ml index 01a36380..ad22bb64 100644 --- a/ocamldoc/odoc_comments.ml +++ b/ocamldoc/odoc_comments.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_comments.ml,v 1.4.12.2 2006/07/31 14:19:35 guesdon Exp $ *) +(* $Id: odoc_comments.ml,v 1.6 2006/09/20 11:14:36 doligez Exp $ *) (** Analysis of comments. *) @@ -341,5 +341,3 @@ let info_of_comment_file modlist f = with Sys_error s -> failwith s - -(* eof $Id: odoc_comments.ml,v 1.4.12.2 2006/07/31 14:19:35 guesdon Exp $ *) diff --git a/ocamldoc/odoc_comments.mli b/ocamldoc/odoc_comments.mli index 63362192..6a51b88f 100644 --- a/ocamldoc/odoc_comments.mli +++ b/ocamldoc/odoc_comments.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_comments.mli,v 1.3.12.2 2006/07/31 14:19:35 guesdon Exp $ *) +(* $Id: odoc_comments.mli,v 1.5 2006/09/20 11:14:36 doligez Exp $ *) (** Analysis of comments. *) diff --git a/ocamldoc/odoc_config.ml b/ocamldoc/odoc_config.ml index 7538576e..86e9a341 100644 --- a/ocamldoc/odoc_config.ml +++ b/ocamldoc/odoc_config.ml @@ -9,8 +9,10 @@ (* *) (***********************************************************************) -(* $Id: odoc_config.ml,v 1.1 2004/01/28 13:36:20 guesdon Exp $ *) +(* $Id: odoc_config.ml,v 1.1.20.2 2007/03/07 08:50:24 xleroy Exp $ *) -let custom_generators_path = - Filename.concat Config.standard_library +let custom_generators_path = + Filename.concat Config.standard_library (Filename.concat "ocamldoc" "custom") + +let print_warnings = ref true diff --git a/ocamldoc/odoc_config.mli b/ocamldoc/odoc_config.mli index 63ec18b2..a0bf45b3 100644 --- a/ocamldoc/odoc_config.mli +++ b/ocamldoc/odoc_config.mli @@ -9,9 +9,12 @@ (* *) (***********************************************************************) -(* $Id: odoc_config.mli,v 1.1 2004/01/28 13:36:20 guesdon Exp $ *) +(* $Id: odoc_config.mli,v 1.1.20.2 2007/03/07 08:50:05 xleroy Exp $ *) (** Ocamldoc configuration contants. *) (** Default path to search for custom generators and to install them. *) val custom_generators_path : string + +(** A flag to indicate whether to print ocamldoc warnings or not. *) +val print_warnings : bool ref diff --git a/ocamldoc/odoc_cross.ml b/ocamldoc/odoc_cross.ml index eb77f97c..c0714d19 100644 --- a/ocamldoc/odoc_cross.ml +++ b/ocamldoc/odoc_cross.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_cross.ml,v 1.15.10.3 2006/05/03 15:00:24 guesdon Exp $ *) +(* $Id: odoc_cross.ml,v 1.17 2006/09/20 11:14:36 doligez Exp $ *) (** Cross referencing. *) @@ -87,8 +87,8 @@ let rec build_alias_list = function ( match m.m_kind with Module_alias ma -> - Hashtbl.add module_aliases m.m_name (ma.ma_name, Alias_to_resolve); - Hashtbl.add module_and_modtype_aliases m.m_name (ma.ma_name, Alias_to_resolve) + Hashtbl.add module_aliases m.m_name (ma.ma_name, Alias_to_resolve); + Hashtbl.add module_and_modtype_aliases m.m_name (ma.ma_name, Alias_to_resolve) | _ -> () ); build_alias_list q @@ -96,8 +96,8 @@ let rec build_alias_list = function ( match mt.mt_kind with Some (Module_type_alias mta) -> - Hashtbl.add module_and_modtype_aliases - mt.mt_name (mta.mta_name, Alias_to_resolve) + Hashtbl.add module_and_modtype_aliases + mt.mt_name (mta.mta_name, Alias_to_resolve) | _ -> () ); build_alias_list q @@ -106,8 +106,8 @@ let rec build_alias_list = function match e.ex_alias with None -> () | Some ea -> - Hashtbl.add exception_aliases - e.ex_name (ea.ea_name,Alias_to_resolve) + Hashtbl.add exception_aliases + e.ex_name (ea.ea_name,Alias_to_resolve) ); build_alias_list q | _ :: q -> @@ -126,26 +126,26 @@ let name_alias = let rec f t name = try match Hashtbl.find t name with - (s, Alias_resolved) -> s - | (s, Alias_to_resolve) -> f t s + (s, Alias_resolved) -> s + | (s, Alias_to_resolve) -> f t s with Not_found -> - try - Hashtbl.iter - (fun n2 (n3, _) -> - if Name.prefix n2 name then - let ln2 = String.length n2 in - let s = n3^(String.sub name ln2 ((String.length name) - ln2)) in - raise (Found s) - ) - t ; - Hashtbl.replace t name (name, Alias_resolved); - name - with - Found s -> - let s2 = f t s in - Hashtbl.replace t s2 (s2, Alias_resolved); - s2 + try + Hashtbl.iter + (fun n2 (n3, _) -> + if Name.prefix n2 name then + let ln2 = String.length n2 in + let s = n3^(String.sub name ln2 ((String.length name) - ln2)) in + raise (Found s) + ) + t ; + Hashtbl.replace t name (name, Alias_resolved); + name + with + Found s -> + let s2 = f t s in + Hashtbl.replace t s2 (s2, Alias_resolved); + s2 in fun name alias_tbl -> f alias_tbl name @@ -252,10 +252,10 @@ class scan = add_known_element e.ex_name (Odoc_search.Res_exception e) method scan_attribute a = add_known_element a.att_value.val_name - (Odoc_search.Res_attribute a) + (Odoc_search.Res_attribute a) method scan_method m = add_known_element m.met_value.val_name - (Odoc_search.Res_method m) + (Odoc_search.Res_method m) method scan_class_pre c = add_known_element c.cl_name (Odoc_search.Res_class c); true @@ -614,113 +614,113 @@ let rec assoc_comments_text_elements parent_name module_list t_ele = | Ref (initial_name, None) -> ( let rec iter_parent ?parent_name name = - let res = - match get_known_elements name with - [] -> - ( - try - let re = Str.regexp ("^"^(Str.quote name)^"$") in - let t = Odoc_search.find_section module_list re in - let v2 = (name, Some (RK_section t)) in - add_verified v2 ; - (name, Some (RK_section t)) - with - Not_found -> - (name, None) - ) - | ele :: _ -> - (* we look for the first element with this name *) + let res = + match get_known_elements name with + [] -> + ( + try + let re = Str.regexp ("^"^(Str.quote name)^"$") in + let t = Odoc_search.find_section module_list re in + let v2 = (name, Some (RK_section t)) in + add_verified v2 ; + (name, Some (RK_section t)) + with + Not_found -> + (name, None) + ) + | ele :: _ -> + (* we look for the first element with this name *) let (name, kind) = - match ele with - Odoc_search.Res_module m -> (m.m_name, RK_module) - | Odoc_search.Res_module_type mt -> (mt.mt_name, RK_module_type) - | Odoc_search.Res_class c -> (c.cl_name, RK_class) - | Odoc_search.Res_class_type ct -> (ct.clt_name, RK_class_type) - | Odoc_search.Res_value v -> (v.val_name, RK_value) - | Odoc_search.Res_type t -> (t.ty_name, RK_type) - | Odoc_search.Res_exception e -> (e.ex_name, RK_exception) - | Odoc_search.Res_attribute a -> (a.att_value.val_name, RK_attribute) - | Odoc_search.Res_method m -> (m.met_value.val_name, RK_method) - | Odoc_search.Res_section (_ ,t)-> assert false + match ele with + Odoc_search.Res_module m -> (m.m_name, RK_module) + | Odoc_search.Res_module_type mt -> (mt.mt_name, RK_module_type) + | Odoc_search.Res_class c -> (c.cl_name, RK_class) + | Odoc_search.Res_class_type ct -> (ct.clt_name, RK_class_type) + | Odoc_search.Res_value v -> (v.val_name, RK_value) + | Odoc_search.Res_type t -> (t.ty_name, RK_type) + | Odoc_search.Res_exception e -> (e.ex_name, RK_exception) + | Odoc_search.Res_attribute a -> (a.att_value.val_name, RK_attribute) + | Odoc_search.Res_method m -> (m.met_value.val_name, RK_method) + | Odoc_search.Res_section (_ ,t)-> assert false in add_verified (name, Some kind) ; - (name, Some kind) - in - match res with - | (name, Some k) -> Ref (name, Some k) - | (_, None) -> - match parent_name with - None -> - Odoc_messages.pwarning (Odoc_messages.cross_element_not_found initial_name); - Ref (initial_name, None) - | Some p -> - let parent_name = - match Name.father p with - "" -> None - | s -> Some s - in - iter_parent ?parent_name (Name.concat p initial_name) + (name, Some kind) + in + match res with + | (name, Some k) -> Ref (name, Some k) + | (_, None) -> + match parent_name with + None -> + Odoc_messages.pwarning (Odoc_messages.cross_element_not_found initial_name); + Ref (initial_name, None) + | Some p -> + let parent_name = + match Name.father p with + "" -> None + | s -> Some s + in + iter_parent ?parent_name (Name.concat p initial_name) in iter_parent ~parent_name initial_name ) | Ref (initial_name, Some kind) -> ( let rec iter_parent ?parent_name name = - let v = (name, Some kind) in - if was_verified v then - Ref (name, Some kind) - else - let res = - match kind with - | RK_section _ -> - ( - (** we just verify that we find an element of this kind with this name *) - try - let re = Str.regexp ("^"^(Str.quote name)^"$") in - let t = Odoc_search.find_section module_list re in - let v2 = (name, Some (RK_section t)) in - add_verified v2 ; - (name, Some (RK_section t)) - with - Not_found -> - (name, None) - ) - | _ -> - let f = - match kind with - RK_module -> module_exists - | RK_module_type -> module_type_exists - | RK_class -> class_exists - | RK_class_type -> class_type_exists - | RK_value -> value_exists - | RK_type -> type_exists - | RK_exception -> exception_exists - | RK_attribute -> attribute_exists - | RK_method -> method_exists - | RK_section _ -> assert false - in - if f name then - ( - add_verified v ; - (name, Some kind) - ) - else - (name, None) - in - match res with - | (name, Some k) -> Ref (name, Some k) - | (_, None) -> - match parent_name with - None -> - Odoc_messages.pwarning (not_found_of_kind kind initial_name); - Ref (initial_name, None) - | Some p -> - let parent_name = - match Name.father p with - "" -> None - | s -> Some s - in - iter_parent ?parent_name (Name.concat p initial_name) + let v = (name, Some kind) in + if was_verified v then + Ref (name, Some kind) + else + let res = + match kind with + | RK_section _ -> + ( + (** we just verify that we find an element of this kind with this name *) + try + let re = Str.regexp ("^"^(Str.quote name)^"$") in + let t = Odoc_search.find_section module_list re in + let v2 = (name, Some (RK_section t)) in + add_verified v2 ; + (name, Some (RK_section t)) + with + Not_found -> + (name, None) + ) + | _ -> + let f = + match kind with + RK_module -> module_exists + | RK_module_type -> module_type_exists + | RK_class -> class_exists + | RK_class_type -> class_type_exists + | RK_value -> value_exists + | RK_type -> type_exists + | RK_exception -> exception_exists + | RK_attribute -> attribute_exists + | RK_method -> method_exists + | RK_section _ -> assert false + in + if f name then + ( + add_verified v ; + (name, Some kind) + ) + else + (name, None) + in + match res with + | (name, Some k) -> Ref (name, Some k) + | (_, None) -> + match parent_name with + None -> + Odoc_messages.pwarning (not_found_of_kind kind initial_name); + Ref (initial_name, None) + | Some p -> + let parent_name = + match Name.father p with + "" -> None + | s -> Some s + in + iter_parent ?parent_name (Name.concat p initial_name) in iter_parent ~parent_name initial_name ) @@ -781,7 +781,7 @@ and assoc_comments_module_kind parent_name module_list mk = match mk with | Module_struct eles -> Module_struct - (List.map (assoc_comments_module_element parent_name module_list) eles) + (List.map (assoc_comments_module_element parent_name module_list) eles) | Module_alias _ | Module_functor _ -> mk @@ -792,22 +792,22 @@ and assoc_comments_module_kind parent_name module_list mk = Module_with (assoc_comments_module_type_kind parent_name module_list mtk, s) | Module_constraint (mk1, mtk) -> Module_constraint - (assoc_comments_module_kind parent_name module_list mk1, + (assoc_comments_module_kind parent_name module_list mk1, assoc_comments_module_type_kind parent_name module_list mtk) and assoc_comments_module_type_kind parent_name module_list mtk = match mtk with | Module_type_struct eles -> Module_type_struct - (List.map (assoc_comments_module_element parent_name module_list) eles) + (List.map (assoc_comments_module_element parent_name module_list) eles) | Module_type_functor (params, mtk1) -> Module_type_functor - (params, assoc_comments_module_type_kind parent_name module_list mtk1) + (params, assoc_comments_module_type_kind parent_name module_list mtk1) | Module_type_alias _ -> mtk | Module_type_with (mtk1, s) -> Module_type_with - (assoc_comments_module_type_kind parent_name module_list mtk1, s) + (assoc_comments_module_type_kind parent_name module_list mtk1, s) and assoc_comments_class_kind parent_name module_list ck = match ck with @@ -815,12 +815,12 @@ and assoc_comments_class_kind parent_name module_list ck = let inher2 = List.map (fun ic -> - { ic with + { ic with ic_text = ao (assoc_comments_text parent_name module_list) ic.ic_text }) inher in Class_structure - (inher2, List.map (assoc_comments_class_element parent_name module_list) eles) + (inher2, List.map (assoc_comments_class_element parent_name module_list) eles) | Class_apply _ | Class_constr _ -> ck @@ -967,6 +967,3 @@ let associate module_list = (* Find a type for each name of element which is referenced in comments. *) ignore (associate_type_of_elements_in_comments module_list) - - -(* eof $Id: odoc_cross.ml,v 1.15.10.3 2006/05/03 15:00:24 guesdon Exp $ *) diff --git a/ocamldoc/odoc_cross.mli b/ocamldoc/odoc_cross.mli index 56f025ca..f70170a8 100644 --- a/ocamldoc/odoc_cross.mli +++ b/ocamldoc/odoc_cross.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_cross.mli,v 1.2.12.1 2006/07/31 14:19:35 guesdon Exp $ *) +(* $Id: odoc_cross.mli,v 1.3 2006/09/20 11:14:36 doligez Exp $ *) (** Cross-referencing. *) diff --git a/ocamldoc/odoc_dot.ml b/ocamldoc/odoc_dot.ml index 225350e4..d442fcd4 100644 --- a/ocamldoc/odoc_dot.ml +++ b/ocamldoc/odoc_dot.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_dot.ml,v 1.6.12.1 2006/05/02 12:15:39 guesdon Exp $ *) +(* $Id: odoc_dot.ml,v 1.7 2006/09/20 11:14:36 doligez Exp $ *) (** Definition of a class which outputs a dot file showing top modules dependencies.*) diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml index 83db96ae..a6d95f88 100644 --- a/ocamldoc/odoc_html.ml +++ b/ocamldoc/odoc_html.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_html.ml,v 1.58.2.5 2006/08/10 12:34:02 guesdon Exp $ *) +(* $Id: odoc_html.ml,v 1.61 2007/02/26 09:57:39 guesdon Exp $ *) (** Generation of html documentation.*) @@ -110,6 +110,7 @@ module Naming = | ':' -> st "_column_" | '~' -> st "_tilde_" | '!' -> st "_bang_" + | '?' -> st "_questionmark_" | c -> ch c done; Buffer.contents buf @@ -899,7 +900,7 @@ class html = in bs b "\n"; bs b style; - bs b character_encoding ; + bs b character_encoding ; bs b "\n" ; @@ -1168,21 +1169,21 @@ class html = bs b (self#create_fully_qualified_module_idents_links father a.ma_name); bs b "" | Module_functor (p, k) -> - if !Odoc_info.Args.html_short_functors then - bs b " " - else + if !Odoc_info.Args.html_short_functors then + bs b " " + else bs b "
"; self#html_of_module_parameter b father p; - ( - match k with - Module_functor _ -> () - | _ when !Odoc_info.Args.html_short_functors -> - bs b ": " - | _ -> () - ); + ( + match k with + Module_functor _ -> () + | _ when !Odoc_info.Args.html_short_functors -> + bs b ": " + | _ -> () + ); self#html_of_module_kind b father ?modu k; if not !Odoc_info.Args.html_short_functors then - bs b "
" + bs b "" | Module_apply (k1, k2) -> (* TODO: l'application n'est pas correcte dans un .mli. Que faire ? -> afficher le module_type du typedtree *) @@ -1202,10 +1203,10 @@ class html = method html_of_module_parameter b father p = let (s_functor,s_arrow) = - if !Odoc_info.Args.html_short_functors then - "", "" - else - "functor ", "-> " + if !Odoc_info.Args.html_short_functors then + "", "" + else + "functor ", "-> " in self#html_of_text b [ @@ -1647,8 +1648,8 @@ class html = ); ( match m.m_kind with - Module_functor _ when !Odoc_info.Args.html_short_functors -> - () + Module_functor _ when !Odoc_info.Args.html_short_functors -> + () | _ -> bs b ": " ); self#html_of_module_kind b father ~modu: m m.m_kind; @@ -2062,7 +2063,7 @@ class html = let b = new_buf () in let pre_name = opt (fun c -> c.cl_name) pre in let post_name = opt (fun c -> c.cl_name) post in - bs b doctype ; + bs b doctype ; bs b "\n"; self#print_header b ~nav: (Some (pre_name, post_name, cl.cl_name)) @@ -2109,7 +2110,7 @@ class html = let b = new_buf () in let pre_name = opt (fun ct -> ct.clt_name) pre in let post_name = opt (fun ct -> ct.clt_name) post in - bs b doctype ; + bs b doctype ; bs b "\n"; self#print_header b ~nav: (Some (pre_name, post_name, clt.clt_name)) @@ -2155,7 +2156,7 @@ class html = let b = new_buf () in let pre_name = opt (fun mt -> mt.mt_name) pre in let post_name = opt (fun mt -> mt.mt_name) post in - bs b doctype ; + bs b doctype ; bs b "\n"; self#print_header b ~nav: (Some (pre_name, post_name, mt.mt_name)) @@ -2223,7 +2224,7 @@ class html = let b = new_buf () in let pre_name = opt (fun m -> m.m_name) pre in let post_name = opt (fun m -> m.m_name) post in - bs b doctype ; + bs b doctype ; bs b "\n"; self#print_header b ~nav: (Some (pre_name, post_name, modu.m_name)) @@ -2232,16 +2233,16 @@ class html = bs b "\n" ; self#print_navbar b pre_name post_name modu.m_name ; bs b "

"; - if modu.m_text_only then - bs b modu.m_name - else - ( + if modu.m_text_only then + bs b modu.m_name + else + ( bs b ( if Module.module_is_functor modu then - Odoc_messages.functo + Odoc_messages.functo else - Odoc_messages.modul + Odoc_messages.modul ); bp b " %s" type_file modu.m_name; ( @@ -2249,7 +2250,7 @@ class html = None -> () | Some _ -> bp b " (.ml)" code_file ) - ); + ); bs b "

\n
\n"; if not modu.m_text_only then self#html_of_module b ~with_link: false modu; @@ -2304,7 +2305,7 @@ class html = let chanout = open_out (Filename.concat !Args.target_dir self#index) in let b = new_buf () in let title = match !Args.title with None -> "" | Some t -> self#escape t in - bs b doctype ; + bs b doctype ; bs b "\n"; self#print_header b self#title; bs b "\n"; @@ -2313,7 +2314,7 @@ class html = bs b "\n" ; let info = Odoc_info.apply_opt (Odoc_info.info_of_comment_file module_list) - !Odoc_info.Args.intro_file + !Odoc_info.Args.intro_file in ( match info with @@ -2322,7 +2323,7 @@ class html = bs b "
"; self#html_of_Module_list b (List.map (fun m -> m.m_name) module_list); - bs b "\n" + bs b "\n" | Some i -> self#html_of_info ~indent: false b info ); Buffer.output_buffer chanout b; diff --git a/ocamldoc/odoc_info.ml b/ocamldoc/odoc_info.ml index 17d65dd7..12d515ae 100644 --- a/ocamldoc/odoc_info.ml +++ b/ocamldoc/odoc_info.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_info.ml,v 1.22.2.1 2005/11/07 15:59:04 doligez Exp $ *) +(* $Id: odoc_info.ml,v 1.23.6.1 2007/03/02 08:55:05 guesdon Exp $ *) (** Interface for analysing documented OCaml source files and to the collected information. *) @@ -175,6 +175,7 @@ let verbose s = () let warning s = Odoc_messages.pwarning s +let print_warnings = Odoc_config.print_warnings let errors = Odoc_global.errors diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli index ad37fc6f..eb4b6ff8 100644 --- a/ocamldoc/odoc_info.mli +++ b/ocamldoc/odoc_info.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_info.mli,v 1.38.4.5 2006/08/10 12:34:02 guesdon Exp $ *) +(* $Id: odoc_info.mli,v 1.40.6.1 2007/03/02 08:55:05 guesdon Exp $ *) (** Interface to the information collected in source files. *) @@ -210,7 +210,7 @@ module Type : | Type_variant of variant_constructor list * bool (** constructors * bool *) | Type_record of record_field list * bool - (** fields * bool *) + (** fields * bool *) (** Representation of a type. *) type t_type = Odoc_type.t_type = @@ -410,7 +410,7 @@ module Module : { im_name : Name.t ; (** Complete name of the included module. *) mutable im_module : mmt option ; (** The included module or module type, if we found it. *) - mutable im_info : Odoc_types.info option ; (** comment associated to the includ directive *) + mutable im_info : Odoc_types.info option ; (** comment associated to the includ directive *) } and module_alias = Odoc_module.module_alias = @@ -420,10 +420,10 @@ module Module : } and module_parameter = Odoc_module.module_parameter = { - mp_name : string ; (** the name *) - mp_type : Types.module_type ; (** the type *) - mp_type_code : string ; (** the original code *) - mp_kind : module_type_kind ; (** the way the parameter was built *) + mp_name : string ; (** the name *) + mp_type : Types.module_type ; (** the type *) + mp_type_code : string ; (** the original code *) + mp_kind : module_type_kind ; (** the way the parameter was built *) } (** Different kinds of a module. *) @@ -451,9 +451,9 @@ module Module : mutable m_kind : module_kind ; (** The way the module is defined. *) mutable m_loc : location ; mutable m_top_deps : Name.t list ; (** The toplevels module names this module depends on. *) - mutable m_code : string option ; (** The whole code of the module *) - mutable m_code_intf : string option ; (** The whole code of the interface of the module *) - m_text_only : bool ; (** [true] if the module comes from a text file *) + mutable m_code : string option ; (** The whole code of the module *) + mutable m_code_intf : string option ; (** The whole code of the interface of the module *) + m_text_only : bool ; (** [true] if the module comes from a text file *) } and module_type_alias = Odoc_module.module_type_alias = @@ -711,6 +711,9 @@ val verbose : string -> unit error counter is incremented. *) val warning : string -> unit +(** A flag to indicate whether ocamldoc warnings must be printed or not. *) +val print_warnings : bool ref + (** Increment this counter when an error is encountered. The ocamldoc tool will print the number of errors encountered exit with code 1 if this number is greater @@ -920,13 +923,13 @@ module Args : sig (** The kind of source file in arguments. *) type source_file = - Impl_file of string - | Intf_file of string - | Text_file of string + Impl_file of string + | Intf_file of string + | Text_file of string (** The class type of documentation generators. *) class type doc_generator = - object method generate : Module.t_module list -> unit end + object method generate : Module.t_module list -> unit end (** The file used by the generators outputting only one file. *) val out_file : string ref @@ -944,7 +947,7 @@ module Args : val intro_file : string option ref (** Flag to indicate whether we must display the complete list of parameters - for functions and methods. *) + for functions and methods. *) val with_parameter_list : bool ref (** The list of module names to hide. *) @@ -963,7 +966,7 @@ module Args : val colorize_code : bool ref (** To display functors in short form rather than with "functor ... -> ", - in HTML generated documentation. *) + in HTML generated documentation. *) val html_short_functors : bool ref (** The flag which indicates if we must generate a header (for LaTeX). *) diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml index 21dfd047..0df844ef 100644 --- a/ocamldoc/odoc_latex.ml +++ b/ocamldoc/odoc_latex.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_latex.ml,v 1.38.4.3 2006/07/31 14:19:35 guesdon Exp $ *) +(* $Id: odoc_latex.ml,v 1.40 2006/09/20 11:14:37 doligez Exp $ *) (** Generation of LaTeX documentation. *) @@ -1014,15 +1014,15 @@ class latex = method generate_for_top_module fmt m = let (first_t, rest_t) = self#first_and_rest_of_info m.m_info in let text = - if m.m_text_only then - [ Title (1, None, [Raw m.m_name] @ + if m.m_text_only then + [ Title (1, None, [Raw m.m_name] @ (match first_t with [] -> [] | t -> (Raw " : ") :: t) - ) ; - ] - else - [ Title (1, None, + ) ; + ] + else + [ Title (1, None, [ Raw (Odoc_messages.modul^" ") ; Code m.m_name ] @ (match first_t with [] -> [] @@ -1068,7 +1068,7 @@ class latex = ( let info = Odoc_info.apply_opt (Odoc_info.info_of_comment_file module_list) - !Odoc_info.Args.intro_file + !Odoc_info.Args.intro_file in (match info with None -> () | Some _ -> ps fmt "\\vspace{0.2cm}"); self#latex_of_info fmt info; diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml index cc0599da..02a0f2cb 100644 --- a/ocamldoc/odoc_man.ml +++ b/ocamldoc/odoc_man.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_man.ml,v 1.25.2.2 2005/11/10 10:28:50 guesdon Exp $ *) +(* $Id: odoc_man.ml,v 1.26 2006/01/04 16:55:50 doligez Exp $ *) (** The man pages generator. *) open Odoc_info diff --git a/ocamldoc/odoc_merge.ml b/ocamldoc/odoc_merge.ml index f07b93bc..bc88edcd 100644 --- a/ocamldoc/odoc_merge.ml +++ b/ocamldoc/odoc_merge.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_merge.ml,v 1.10.12.2 2006/08/10 12:34:02 guesdon Exp $ *) +(* $Id: odoc_merge.ml,v 1.12 2006/09/20 11:14:37 doligez Exp $ *) (** Merge of information from [.ml] and [.mli] for a module.*) @@ -529,7 +529,7 @@ let rec merge_module_types merge_options mli ml = Element_module m2 -> if m2.m_name = m.m_name then ( - ignore(merge_modules merge_options m m2); + ignore (merge_modules merge_options m m2); (* m.m_info <- merge_info_opt merge_options m.m_info m2.m_info; m.m_loc <- { m.m_loc with loc_impl = m2.m_loc.loc_impl } ; @@ -693,18 +693,18 @@ and merge_modules merge_options mli ml = let code = if !Odoc_args.keep_code then match mli.m_code, ml.m_code with - Some s, _ -> Some s - | _, Some s -> Some s - | _ -> None + Some s, _ -> Some s + | _, Some s -> Some s + | _ -> None else None in let code_intf = if !Odoc_args.keep_code then match mli.m_code_intf, ml.m_code_intf with - Some s, _ -> Some s - | _, Some s -> Some s - | _ -> None + Some s, _ -> Some s + | _, Some s -> Some s + | _ -> None else None in @@ -777,7 +777,7 @@ and merge_modules merge_options mli ml = Element_module m2 -> if m2.m_name = m.m_name then ( - ignore(merge_modules merge_options m m2); + ignore (merge_modules merge_options m m2); (* m.m_info <- merge_info_opt merge_options m.m_info m2.m_info; m.m_loc <- { m.m_loc with loc_impl = m2.m_loc.loc_impl } ; @@ -964,5 +964,3 @@ let merge merge_options modules_list = in iter modules_list - -(* eof $Id: odoc_merge.ml,v 1.10.12.2 2006/08/10 12:34:02 guesdon Exp $ *) diff --git a/ocamldoc/odoc_messages.ml b/ocamldoc/odoc_messages.ml index cf164b78..fd874406 100644 --- a/ocamldoc/odoc_messages.ml +++ b/ocamldoc/odoc_messages.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_messages.ml,v 1.28.2.3 2006/08/10 12:34:02 guesdon Exp $ *) +(* $Id: odoc_messages.ml,v 1.30.6.1 2007/03/02 08:55:05 guesdon Exp $ *) (** The messages of the application. *) @@ -45,6 +45,7 @@ let add_load_dir = "\tAdd the given directory to the search path for custom let load_file = "\n\t\tLoad file defining a new documentation generator\n\t\t"^bytecode_only let nolabels = "\tIgnore non-optional labels in types" let werr = "\tTreat ocamldoc warnings as errors" +let hide_warnings = "\n\t\tdo not print ocamldoc warnings" let target_dir = "\tGenerate files in directory , rather than in current\n"^ "\t\tdirectory (for man and HTML generators)" let dump = "\tDump collected information into " @@ -211,7 +212,7 @@ let merge_options = let warning = "Warning" let pwarning s = - prerr_endline (warning^": "^s); + if !Odoc_config.print_warnings then prerr_endline (warning^": "^s); if !Odoc_global.warn_error then incr Odoc_global.errors let bad_magic_number = diff --git a/ocamldoc/odoc_misc.ml b/ocamldoc/odoc_misc.ml index 8f507bbc..c6634151 100644 --- a/ocamldoc/odoc_misc.ml +++ b/ocamldoc/odoc_misc.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_misc.ml,v 1.19.4.1 2005/11/07 15:59:04 doligez Exp $ *) +(* $Id: odoc_misc.ml,v 1.21 2006/07/06 07:19:06 pouillar Exp $ *) let no_blanks s = let len = String.length s in @@ -70,7 +70,12 @@ let list_concat sep = in iter -let string_of_longident li = String.concat "." (Longident.flatten li) +let rec string_of_longident li = + match li with + | Longident.Lident s -> s + | Longident.Ldot(li, s) -> string_of_longident li ^ "." ^ s + | Longident.Lapply(l1, l2) -> + string_of_longident l1 ^ "(" ^ string_of_longident l2 ^ ")" let get_fields type_expr = let (fields, _) = Ctype.flatten_fields (Ctype.object_fields type_expr) in diff --git a/ocamldoc/odoc_misc.mli b/ocamldoc/odoc_misc.mli index 5ef4757b..83f94ef5 100644 --- a/ocamldoc/odoc_misc.mli +++ b/ocamldoc/odoc_misc.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_misc.mli,v 1.12.4.1 2005/11/07 15:59:04 doligez Exp $ *) +(* $Id: odoc_misc.mli,v 1.13 2006/01/04 16:55:50 doligez Exp $ *) (** Miscelaneous functions *) diff --git a/ocamldoc/odoc_module.ml b/ocamldoc/odoc_module.ml index 62f19014..a9696516 100644 --- a/ocamldoc/odoc_module.ml +++ b/ocamldoc/odoc_module.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_module.ml,v 1.10.4.2 2006/08/10 11:21:36 guesdon Exp $ *) +(* $Id: odoc_module.ml,v 1.12 2006/09/20 11:14:37 doligez Exp $ *) (** Representation and manipulation of modules and module types. *) @@ -207,41 +207,41 @@ let included_modules l = let rec module_elements ?(trans=true) m = let rec iter_kind = function Module_struct l -> - print_DEBUG "Odoc_module.module_element: Module_struct"; - l + print_DEBUG "Odoc_module.module_element: Module_struct"; + l | Module_alias ma -> - print_DEBUG "Odoc_module.module_element: Module_alias"; - if trans then + print_DEBUG "Odoc_module.module_element: Module_alias"; + if trans then match ma.ma_module with None -> [] | Some (Mod m) -> module_elements m | Some (Modtype mt) -> module_type_elements mt - else + else [] | Module_functor (_, k) | Module_apply (k, _) -> - print_DEBUG "Odoc_module.module_element: Module_functor ou Module_apply"; - iter_kind k + print_DEBUG "Odoc_module.module_element: Module_functor ou Module_apply"; + iter_kind k | Module_with (tk,_) -> - print_DEBUG "Odoc_module.module_element: Module_with"; - module_type_elements ~trans: trans + print_DEBUG "Odoc_module.module_element: Module_with"; + module_type_elements ~trans: trans { mt_name = "" ; mt_info = None ; mt_type = None ; mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ; mt_loc = Odoc_types.dummy_loc ; } | Module_constraint (k, tk) -> - print_DEBUG "Odoc_module.module_element: Module_constraint"; + print_DEBUG "Odoc_module.module_element: Module_constraint"; (* A VOIR : utiliser k ou tk ? *) - module_elements ~trans: trans + module_elements ~trans: trans { m_name = "" ; - m_info = None ; - m_type = Types.Tmty_signature [] ; + m_info = None ; + m_type = Types.Tmty_signature [] ; m_is_interface = false ; m_file = "" ; m_kind = k ; m_loc = Odoc_types.dummy_loc ; m_top_deps = [] ; - m_code = None ; - m_code_intf = None ; - m_text_only = false ; + m_code = None ; + m_code_intf = None ; + m_text_only = false ; } (* module_type_elements ~trans: trans @@ -265,11 +265,11 @@ and module_type_elements ?(trans=true) mt = else [] | Some (Module_type_alias mta) -> - if trans then + if trans then match mta.mta_module with None -> [] | Some mt -> module_type_elements mt - else + else [] in iter_kind mt.mt_kind @@ -342,7 +342,7 @@ let rec module_type_parameters ?(trans=true) mt = with Not_found -> (p, None) - in + in param :: (iter (Some k2)) | Some (Module_type_alias mta) -> if trans then @@ -368,38 +368,38 @@ let rec module_type_parameters ?(trans=true) mt = and module_parameters ?(trans=true) m = let rec iter = function Module_functor (p, k) -> - let param = + let param = (* we create the couple (parameter, description opt), using the description of the parameter if we can find it in the comment.*) - match m.m_info with + match m.m_info with None ->(p, None) - | Some i -> - try - let d = List.assoc p.mp_name i.Odoc_types.i_params in - (p, Some d) + | Some i -> + try + let d = List.assoc p.mp_name i.Odoc_types.i_params in + (p, Some d) with - Not_found -> + Not_found -> (p, None) - in - param :: (iter k) + in + param :: (iter k) | Module_alias ma -> - if trans then + if trans then match ma.ma_module with None -> [] | Some (Mod m) -> module_parameters ~trans m | Some (Modtype mt) -> module_type_parameters ~trans mt - else + else [] | Module_constraint (k, tk) -> - module_type_parameters ~trans: trans + module_type_parameters ~trans: trans { mt_name = "" ; mt_info = None ; mt_type = None ; mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ; mt_loc = Odoc_types.dummy_loc } | Module_struct _ | Module_apply _ | Module_with _ -> - [] + [] in iter m.m_kind @@ -435,14 +435,14 @@ let module_is_functor m = let rec iter = function Module_functor _ -> true | Module_alias ma -> - ( - match ma.ma_module with + ( + match ma.ma_module with None -> false - | Some (Mod mo) -> iter mo.m_kind - | Some (Modtype mt) -> module_type_is_functor mt - ) + | Some (Mod mo) -> iter mo.m_kind + | Some (Modtype mt) -> module_type_is_functor mt + ) | Module_constraint (k, _) -> - iter k + iter k | _ -> false in iter m.m_kind diff --git a/ocamldoc/odoc_name.ml b/ocamldoc/odoc_name.ml index 8f7a03bc..edcaf892 100644 --- a/ocamldoc/odoc_name.ml +++ b/ocamldoc/odoc_name.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_name.ml,v 1.9 2004/03/26 09:09:50 guesdon Exp $ *) +(* $Id: odoc_name.ml,v 1.10 2006/07/06 07:19:06 pouillar Exp $ *) (** Representation of element names. *) @@ -172,5 +172,5 @@ let to_path n = None -> raise (Failure "to_path") | Some p -> p -let from_longident longident = String.concat "." (Longident.flatten longident) +let from_longident = Odoc_misc.string_of_longident diff --git a/ocamldoc/odoc_opt.ml b/ocamldoc/odoc_opt.ml index ffcf3819..791db14d 100644 --- a/ocamldoc/odoc_opt.ml +++ b/ocamldoc/odoc_opt.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_opt.ml,v 1.5.14.1 2006/05/02 12:15:39 guesdon Exp $ *) +(* $Id: odoc_opt.ml,v 1.6 2006/09/20 11:14:37 doligez Exp $ *) (** Main module for native version.*) diff --git a/ocamldoc/odoc_search.ml b/ocamldoc/odoc_search.ml index deccb78a..e863fcb2 100644 --- a/ocamldoc/odoc_search.ml +++ b/ocamldoc/odoc_search.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_search.ml,v 1.6.10.1 2005/11/07 15:59:04 doligez Exp $ *) +(* $Id: odoc_search.ml,v 1.7 2006/01/04 16:55:50 doligez Exp $ *) (** Research of elements through modules. *) @@ -632,4 +632,4 @@ let find_section mods regexp = Res_section (_,t) -> t | _ -> assert false -(* eof $Id: odoc_search.ml,v 1.6.10.1 2005/11/07 15:59:04 doligez Exp $ *) +(* eof $Id: odoc_search.ml,v 1.7 2006/01/04 16:55:50 doligez Exp $ *) diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index 2afa85fb..d1575e17 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_sig.ml,v 1.36.2.1 2005/11/10 14:44:36 guesdon Exp $ *) +(* $Id: odoc_sig.ml,v 1.39 2007/02/09 13:31:15 doligez Exp $ *) (** Analysis of interface files. *) @@ -107,7 +107,7 @@ module Signature_search = | _ -> assert false let search_attribute_type name class_sig = - let (_, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in + let (_, _, type_expr) = Types.Vars.find name class_sig.Types.cty_vars in type_expr let search_method_type name class_sig = @@ -181,18 +181,18 @@ module Analyser = (0, acc) | (name, core_type_list, loc) :: [] -> let s = get_string_of_file - loc.Location.loc_end.Lexing.pos_cnum - pos_limit - in + loc.Location.loc_end.Lexing.pos_cnum + pos_limit + in let (len, comment_opt) = My_ir.just_after_special !file_name s in (len, acc @ [ (name, comment_opt) ]) | (name, core_type_list, loc) :: (name2, core_type_list2, loc2) :: q -> - let pos_end_first = loc.Location.loc_end.Lexing.pos_cnum in - let pos_start_second = loc2.Location.loc_start.Lexing.pos_cnum in - let s = get_string_of_file pos_end_first pos_start_second in - let (_,comment_opt) = My_ir.just_after_special !file_name s in - f (acc @ [name, comment_opt]) + let pos_end_first = loc.Location.loc_end.Lexing.pos_cnum in + let pos_start_second = loc2.Location.loc_start.Lexing.pos_cnum in + let s = get_string_of_file pos_end_first pos_start_second in + let (_,comment_opt) = My_ir.just_after_special !file_name s in + f (acc @ [name, comment_opt]) ((name2, core_type_list2, loc2) :: q) in f [] cons_core_type_list_list @@ -269,7 +269,7 @@ module Analyser = [] -> pos_limit | ele2 :: _ -> match ele2 with - Parsetree.Pctf_val (_, _, _, loc) + Parsetree.Pctf_val (_, _, _, _, loc) | Parsetree.Pctf_virt (_, _, _, loc) | Parsetree.Pctf_meth (_, _, _, loc) | Parsetree.Pctf_cstr (_, _, loc) -> loc.Location.loc_start.Lexing.pos_cnum @@ -330,7 +330,7 @@ module Analyser = in ([], ele_comments) - | Parsetree.Pctf_val (name, mutable_flag, _, loc) :: q -> + | Parsetree.Pctf_val (name, mutable_flag, _, _, loc) :: q -> (* of (string * mutable_flag * core_type option * Location.t)*) let (comment_opt, eles_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in let complete_name = Name.concat current_class_name name in @@ -531,8 +531,8 @@ module Analyser = ex_args = List.map (Odoc_env.subst_type env) types_excep_decl ; ex_alias = None ; ex_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; - ex_code = - ( + ex_code = + ( if !Odoc_args.keep_code then Some (get_string_of_file pos_start_ele pos_end_ele) else @@ -595,7 +595,7 @@ module Analyser = in (* get the type kind with the associated comments *) let type_kind = get_type_kind new_env name_comment_list sig_type_decl.Types.type_kind in - let loc_start = type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in + let loc_start = type_decl.Parsetree.ptype_loc.Location.loc_start.Lexing.pos_cnum in let new_end = type_decl.Parsetree.ptype_loc.Location.loc_end.Lexing.pos_cnum + maybe_more in (* associate the comments to each constructor and build the [Type.t_type] *) let new_type = @@ -603,12 +603,12 @@ module Analyser = ty_name = Name.concat current_module_name name ; ty_info = assoc_com ; ty_parameters = - List.map2 (fun p (co,cn,_) -> - (Odoc_env.subst_type new_env p, - co, cn) - ) - sig_type_decl.Types.type_params - sig_type_decl.Types.type_variance; + List.map2 (fun p (co,cn,_) -> + (Odoc_env.subst_type new_env p, + co, cn) + ) + sig_type_decl.Types.type_params + sig_type_decl.Types.type_variance; ty_kind = type_kind ; ty_manifest = (match sig_type_decl.Types.type_manifest with @@ -619,12 +619,12 @@ module Analyser = loc_inter = Some (!file_name,loc_start) ; }; ty_code = - ( - if !Odoc_args.keep_code then - Some (get_string_of_file loc_start new_end) - else - None - ) ; + ( + if !Odoc_args.keep_code then + Some (get_string_of_file loc_start new_end) + else + None + ) ; } in let (maybe_more2, info_after_opt) = @@ -662,15 +662,15 @@ module Analyser = raise (Failure (Odoc_messages.module_not_found current_module_name name)) in let module_kind = analyse_module_kind env complete_name module_type sig_module_type in - let code_intf = - if !Odoc_args.keep_code then - let loc = module_type.Parsetree.pmty_loc in - let st = loc.Location.loc_start.Lexing.pos_cnum in - let en = loc.Location.loc_end.Lexing.pos_cnum in - Some (get_string_of_file st en) - else - None - in + let code_intf = + if !Odoc_args.keep_code then + let loc = module_type.Parsetree.pmty_loc in + let st = loc.Location.loc_start.Lexing.pos_cnum in + let en = loc.Location.loc_end.Lexing.pos_cnum in + Some (get_string_of_file st en) + else + None + in let new_module = { m_name = complete_name ; @@ -681,9 +681,9 @@ module Analyser = m_kind = module_kind ; m_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; m_top_deps = [] ; - m_code = None ; - m_code_intf = code_intf ; - m_text_only = false ; + m_code = None ; + m_code_intf = code_intf ; + m_text_only = false ; } in let (maybe_more, info_after_opt) = @@ -701,7 +701,7 @@ module Analyser = (maybe_more, new_env2, [ Element_module new_module ]) | Parsetree.Psig_recmodule decls -> - (* we start by extending the environment *) + (* we start by extending the environment *) let new_env = List.fold_left (fun acc_env -> fun (name, _) -> @@ -713,13 +713,13 @@ module Analyser = with Not_found -> raise (Failure (Odoc_messages.module_not_found current_module_name name)) in - match sig_module_type with + match sig_module_type with (* A VOIR : cela peut-il être Tmty_ident ? dans ce cas, on aurait pas la signature *) Types.Tmty_signature s -> - Odoc_env.add_signature e complete_name ~rel: name s - | _ -> - print_DEBUG "not a Tmty_signature"; - e + Odoc_env.add_signature e complete_name ~rel: name s + | _ -> + print_DEBUG "not a Tmty_signature"; + e ) env decls @@ -729,8 +729,8 @@ module Analyser = [] -> (acc_maybe_more, []) | (name, modtype) :: q -> - let complete_name = Name.concat current_module_name name in - let loc_start = modtype.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in + let complete_name = Name.concat current_module_name name in + let loc_start = modtype.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in let loc_end = modtype.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in let (assoc_com, ele_comments) = if first then @@ -738,7 +738,7 @@ module Analyser = else get_comments_in_module last_pos - loc_start + loc_start in let pos_limit2 = match q with @@ -752,18 +752,18 @@ module Analyser = raise (Failure (Odoc_messages.module_not_found current_module_name name)) in (* associate the comments to each constructor and build the [Type.t_type] *) - let module_kind = analyse_module_kind new_env complete_name modtype sig_module_type in - let code_intf = - if !Odoc_args.keep_code then - let loc = modtype.Parsetree.pmty_loc in - let st = loc.Location.loc_start.Lexing.pos_cnum in - let en = loc.Location.loc_end.Lexing.pos_cnum in - Some (get_string_of_file st en) - else - None - in - let new_module = - { + let module_kind = analyse_module_kind new_env complete_name modtype sig_module_type in + let code_intf = + if !Odoc_args.keep_code then + let loc = modtype.Parsetree.pmty_loc in + let st = loc.Location.loc_start.Lexing.pos_cnum in + let en = loc.Location.loc_end.Lexing.pos_cnum in + Some (get_string_of_file st en) + else + None + in + let new_module = + { m_name = complete_name ; m_type = sig_module_type; m_info = assoc_com ; @@ -772,17 +772,17 @@ module Analyser = m_kind = module_kind ; m_loc = { loc_impl = None ; loc_inter = Some (!file_name, pos_start_ele) } ; m_top_deps = [] ; - m_code = None ; - m_code_intf = code_intf ; - m_text_only = false ; - } - in - let (maybe_more, info_after_opt) = - My_ir.just_after_special + m_code = None ; + m_code_intf = code_intf ; + m_text_only = false ; + } + in + let (maybe_more, info_after_opt) = + My_ir.just_after_special !file_name (get_string_of_file loc_end pos_limit2) - in - new_module.m_info <- merge_infos new_module.m_info info_after_opt ; + in + new_module.m_info <- merge_infos new_module.m_info info_after_opt ; let (maybe_more2, eles) = f maybe_more @@ -869,13 +869,13 @@ module Analyser = | Parsetree.Pmty_with (mt, _) -> f mt.Parsetree.pmty_desc in - let name = (f module_type.Parsetree.pmty_desc) in - let full_name = Odoc_env.full_module_or_module_type_name env name in + let name = (f module_type.Parsetree.pmty_desc) in + let full_name = Odoc_env.full_module_or_module_type_name env name in let im = { im_name = full_name ; im_module = None ; - im_info = comment_opt; + im_info = comment_opt; } in (0, env, [ Element_included_module im ]) (* A VOIR : étendre l'environnement ? avec quoi ? *) @@ -1057,28 +1057,28 @@ module Analyser = | Parsetree.Pmty_functor (_,pmodule_type2, module_type2) -> ( - let loc_start = pmodule_type2.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in + let loc_start = pmodule_type2.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in let loc_end = pmodule_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in - let mp_type_code = get_string_of_file loc_start loc_end in - print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code); + let mp_type_code = get_string_of_file loc_start loc_end in + print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code); match sig_module_type with Types.Tmty_functor (ident, param_module_type, body_module_type) -> - let mp_kind = analyse_module_type_kind env - current_module_name pmodule_type2 param_module_type - in + let mp_kind = analyse_module_type_kind env + current_module_name pmodule_type2 param_module_type + in let param = { mp_name = Name.from_ident ident ; mp_type = Odoc_env.subst_module_type env param_module_type ; - mp_type_code = mp_type_code ; - mp_kind = mp_kind ; + mp_type_code = mp_type_code ; + mp_kind = mp_kind ; } in - let k = analyse_module_type_kind env - current_module_name - module_type2 - body_module_type - in + let k = analyse_module_type_kind env + current_module_name + module_type2 + body_module_type + in Module_type_functor (param, k) | _ -> @@ -1100,7 +1100,7 @@ module Analyser = and analyse_module_kind env current_module_name module_type sig_module_type = match module_type.Parsetree.pmty_desc with Parsetree.Pmty_ident longident -> - let k = analyse_module_type_kind env current_module_name module_type sig_module_type in + let k = analyse_module_type_kind env current_module_name module_type sig_module_type in Module_with ( k, "" ) | Parsetree.Pmty_signature signature -> @@ -1124,26 +1124,26 @@ module Analyser = ( match sig_module_type with Types.Tmty_functor (ident, param_module_type, body_module_type) -> - let loc_start = pmodule_type2.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in + let loc_start = pmodule_type2.Parsetree.pmty_loc.Location.loc_start.Lexing.pos_cnum in let loc_end = pmodule_type2.Parsetree.pmty_loc.Location.loc_end.Lexing.pos_cnum in - let mp_type_code = get_string_of_file loc_start loc_end in - print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code); - let mp_kind = analyse_module_type_kind env - current_module_name pmodule_type2 param_module_type - in + let mp_type_code = get_string_of_file loc_start loc_end in + print_DEBUG (Printf.sprintf "mp_type_code=%s" mp_type_code); + let mp_kind = analyse_module_type_kind env + current_module_name pmodule_type2 param_module_type + in let param = { mp_name = Name.from_ident ident ; mp_type = Odoc_env.subst_module_type env param_module_type ; - mp_type_code = mp_type_code ; - mp_kind = mp_kind ; + mp_type_code = mp_type_code ; + mp_kind = mp_kind ; } in let k = analyse_module_kind env - current_module_name - module_type2 - body_module_type - in + current_module_name + module_type2 + body_module_type + in Module_functor (param, k) | _ -> @@ -1279,7 +1279,7 @@ module Analyser = raise (Failure "analyse_class_type_kind pas de correspondance dans le match") let analyse_signature source_file input_file - (ast : Parsetree.signature) (signat : Types.signature) = + (ast : Parsetree.signature) (signat : Types.signature) = let complete_source_file = try let curdir = Sys.getcwd () in @@ -1301,13 +1301,13 @@ module Analyser = in let (len,info_opt) = My_ir.first_special !file_name !file in let elements = - analyse_parsetree Odoc_env.empty signat mod_name len (String.length !file) ast + analyse_parsetree Odoc_env.empty signat mod_name len (String.length !file) ast in let code_intf = - if !Odoc_args.keep_code then - Some !file - else - None + if !Odoc_args.keep_code then + Some !file + else + None in { m_name = mod_name ; @@ -1318,9 +1318,9 @@ module Analyser = m_kind = Module_struct elements ; m_loc = { loc_impl = None ; loc_inter = Some (!file_name, 0) } ; m_top_deps = [] ; - m_code = None ; - m_code_intf = code_intf ; - m_text_only = false ; + m_code = None ; + m_code_intf = code_intf ; + m_text_only = false ; } end diff --git a/ocamldoc/odoc_texi.ml b/ocamldoc/odoc_texi.ml index 8255bcb5..b5c20f9a 100644 --- a/ocamldoc/odoc_texi.ml +++ b/ocamldoc/odoc_texi.ml @@ -8,7 +8,7 @@ (* under the terms of the Q Public License version 1.0. *) (***********************************************************************) -(* $Id: odoc_texi.ml,v 1.19.4.3 2006/07/31 14:19:35 guesdon Exp $ *) +(* $Id: odoc_texi.ml,v 1.22 2007/02/12 10:27:29 ertai Exp $ *) (** Generation of Texinfo documentation. *) @@ -736,7 +736,7 @@ class texi = | { mt_name = name } -> name in let t = [ [ self#fixedblock - [ Newline ; minus ; Raw "module type" ; + [ Newline ; minus ; Raw "module type " ; Raw (Name.simple mt.mt_name) ; Raw (if is_alias mt then " = " ^ (resolve_alias_name mt) @@ -993,12 +993,12 @@ class texi = let title = [ self#node depth m.m_name ; Title (depth, None, - if m.m_text_only then - [ Raw m.m_name ] - else - [ Raw (Odoc_messages.modul ^ " ") ; + if m.m_text_only then + [ Raw m.m_name ] + else + [ Raw (Odoc_messages.modul ^ " ") ; Code m.m_name ] - ) ; + ) ; self#index `Module m.m_name ; Newline ] in puts chanout (self#texi_of_text title) ; @@ -1106,7 +1106,7 @@ class texi = nl chan ; puts_nl chan (self#texi_of_info - (Some (Odoc_info.info_of_comment_file m_list f))) + (Some (Odoc_info.info_of_comment_file m_list f))) end ; (* write a top menu *) diff --git a/ocamldoc/odoc_text.ml b/ocamldoc/odoc_text.ml index 05e9e0cb..57dd461a 100644 --- a/ocamldoc/odoc_text.ml +++ b/ocamldoc/odoc_text.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_text.ml,v 1.5.10.1 2005/11/07 15:59:04 doligez Exp $ *) +(* $Id: odoc_text.ml,v 1.6 2006/01/04 16:55:50 doligez Exp $ *) exception Text_syntax of int * int * string (* line, char, string *) diff --git a/ocamldoc/odoc_text_lexer.mll b/ocamldoc/odoc_text_lexer.mll index c7baf93d..d9015f87 100644 --- a/ocamldoc/odoc_text_lexer.mll +++ b/ocamldoc/odoc_text_lexer.mll @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_text_lexer.mll,v 1.8.10.1 2005/11/07 15:59:04 doligez Exp $ *) +(* $Id: odoc_text_lexer.mll,v 1.9 2006/01/04 16:55:50 doligez Exp $ *) (** The lexer for string to build text structures. *) diff --git a/ocamldoc/odoc_text_parser.mly b/ocamldoc/odoc_text_parser.mly index 05668b65..e1e30398 100644 --- a/ocamldoc/odoc_text_parser.mly +++ b/ocamldoc/odoc_text_parser.mly @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_text_parser.mly,v 1.4.10.1 2005/11/07 15:59:04 doligez Exp $ *) +(* $Id: odoc_text_parser.mly,v 1.5 2006/01/04 16:55:50 doligez Exp $ *) open Odoc_types diff --git a/ocamldoc/odoc_types.ml b/ocamldoc/odoc_types.ml index 646b9aab..fb48721b 100644 --- a/ocamldoc/odoc_types.ml +++ b/ocamldoc/odoc_types.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_types.ml,v 1.8.2.1 2005/11/07 15:59:04 doligez Exp $ *) +(* $Id: odoc_types.ml,v 1.9 2006/01/04 16:55:50 doligez Exp $ *) type ref_kind = RK_module diff --git a/ocamldoc/odoc_types.mli b/ocamldoc/odoc_types.mli index c5cebd47..cad2bcc3 100644 --- a/ocamldoc/odoc_types.mli +++ b/ocamldoc/odoc_types.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_types.mli,v 1.5.10.1 2005/11/07 15:59:04 doligez Exp $ *) +(* $Id: odoc_types.mli,v 1.6 2006/01/04 16:55:50 doligez Exp $ *) (** Types for the information collected in comments. *) diff --git a/otherlibs/bigarray/.depend b/otherlibs/bigarray/.depend index ef5e8b5d..c7b0e420 100644 --- a/otherlibs/bigarray/.depend +++ b/otherlibs/bigarray/.depend @@ -1,19 +1,44 @@ bigarray_stubs.o: bigarray_stubs.c ../../byterun/alloc.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/mlvalues.h bigarray.h ../../byterun/custom.h \ - ../../byterun/fail.h ../../byterun/intext.h ../../byterun/io.h \ - ../../byterun/fix_code.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h -mmap_unix.o: mmap_unix.c bigarray.h ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/custom.h \ - ../../byterun/fail.h ../../byterun/sys.h -mmap_win32.o: mmap_win32.c bigarray.h ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/custom.h ../../byterun/fail.h ../../byterun/sys.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/misc.h bigarray.h ../../byterun/custom.h \ + ../../byterun/compatibility.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/intext.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/io.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/fix_code.h \ + ../../byterun/config.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/memory.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/gc.h ../../byterun/mlvalues.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/misc.h ../../byterun/minor_gc.h \ + ../../byterun/misc.h ../../byterun/misc.h ../../byterun/mlvalues.h +mmap_unix.o: mmap_unix.c bigarray.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/custom.h ../../byterun/compatibility.h \ + ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/io.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/sys.h ../../byterun/misc.h +mmap_win32.o: mmap_win32.c bigarray.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/alloc.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/custom.h \ + ../../byterun/compatibility.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/sys.h ../../byterun/misc.h \ ../unix/unixsupport.h bigarray.cmo: bigarray.cmi bigarray.cmx: bigarray.cmi diff --git a/otherlibs/bigarray/Makefile b/otherlibs/bigarray/Makefile index b4f7c2f8..7bea40a1 100644 --- a/otherlibs/bigarray/Makefile +++ b/otherlibs/bigarray/Makefile @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.21 2005/10/19 11:56:24 xleroy Exp $ +# $Id: Makefile,v 1.23 2007/02/07 10:31:36 ertai Exp $ include ../../config/Makefile @@ -20,7 +20,7 @@ CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) CAMLC=../../ocamlcomp.sh -I ../unix CAMLOPT=../../ocamlcompopt.sh -I ../unix MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-warn-error A +COMPFLAGS=-warn-error A -g C_OBJS=bigarray_stubs.o mmap_unix.o @@ -54,7 +54,7 @@ partialclean: rm -f *.cm* clean: partialclean - rm -f libbigarray.* *.o bigarray.a *.so + rm -f *.o *.so *.a .SUFFIXES: .ml .mli .cmo .cmi .cmx diff --git a/otherlibs/bigarray/Makefile.nt b/otherlibs/bigarray/Makefile.nt index d207878e..d07208d1 100644 --- a/otherlibs/bigarray/Makefile.nt +++ b/otherlibs/bigarray/Makefile.nt @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.10 2003/07/08 14:24:07 xleroy Exp $ +# $Id: Makefile.nt,v 1.11 2007/01/29 12:11:16 xleroy Exp $ include ../../config/Makefile @@ -19,6 +19,7 @@ CC=$(BYTECC) CFLAGS=-I../../byterun -I../win32unix -DIN_OCAML_BIGARRAY CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib -I ../win32unix CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -I ../win32unix +COMPFLAGS=-warn-error A -g C_OBJS=bigarray_stubs.obj mmap_win32.obj diff --git a/otherlibs/bigarray/bigarray.h b/otherlibs/bigarray/bigarray.h index 5eee0fc3..3fd80cf8 100644 --- a/otherlibs/bigarray/bigarray.h +++ b/otherlibs/bigarray/bigarray.h @@ -11,71 +11,74 @@ /* */ /***********************************************************************/ -/* $Id: bigarray.h,v 1.8 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: bigarray.h,v 1.9 2006/01/27 14:33:42 doligez Exp $ */ -#ifndef _bigarray_ -#define _bigarray_ +#ifndef CAML_BIGARRAY_H +#define CAML_BIGARRAY_H +#ifndef CAML_NAME_SPACE +#include "compatibility.h" +#endif #include "config.h" #include "mlvalues.h" -typedef signed char int8; -typedef unsigned char uint8; +typedef signed char caml_ba_int8; +typedef unsigned char caml_ba_uint8; #if SIZEOF_SHORT == 2 -typedef short int16; -typedef unsigned short uint16; +typedef short caml_ba_int16; +typedef unsigned short caml_ba_uint16; #else #error "No 16-bit integer type available" #endif -#define MAX_NUM_DIMS 16 +#define CAML_BA_MAX_NUM_DIMS 16 -enum caml_bigarray_kind { - BIGARRAY_FLOAT32, /* Single-precision floats */ - BIGARRAY_FLOAT64, /* Double-precision floats */ - BIGARRAY_SINT8, /* Signed 8-bit integers */ - BIGARRAY_UINT8, /* Unsigned 8-bit integers */ - BIGARRAY_SINT16, /* Signed 16-bit integers */ - BIGARRAY_UINT16, /* Unsigned 16-bit integers */ - BIGARRAY_INT32, /* Signed 32-bit integers */ - BIGARRAY_INT64, /* Signed 64-bit integers */ - BIGARRAY_CAML_INT, /* Caml-style integers (signed 31 or 63 bits) */ - BIGARRAY_NATIVE_INT, /* Platform-native long integers (32 or 64 bits) */ - BIGARRAY_COMPLEX32, /* Single-precision complex */ - BIGARRAY_COMPLEX64, /* Double-precision complex */ - BIGARRAY_KIND_MASK = 0xFF /* Mask for kind in flags field */ +enum caml_ba_kind { + CAML_BA_FLOAT32, /* Single-precision floats */ + CAML_BA_FLOAT64, /* Double-precision floats */ + CAML_BA_SINT8, /* Signed 8-bit integers */ + CAML_BA_UINT8, /* Unsigned 8-bit integers */ + CAML_BA_SINT16, /* Signed 16-bit integers */ + CAML_BA_UINT16, /* Unsigned 16-bit integers */ + CAML_BA_INT32, /* Signed 32-bit integers */ + CAML_BA_INT64, /* Signed 64-bit integers */ + CAML_BA_CAML_INT, /* Caml-style integers (signed 31 or 63 bits) */ + CAML_BA_NATIVE_INT, /* Platform-native long integers (32 or 64 bits) */ + CAML_BA_COMPLEX32, /* Single-precision complex */ + CAML_BA_COMPLEX64, /* Double-precision complex */ + CAML_BA_KIND_MASK = 0xFF /* Mask for kind in flags field */ }; -enum caml_bigarray_layout { - BIGARRAY_C_LAYOUT = 0, /* Row major, indices start at 0 */ - BIGARRAY_FORTRAN_LAYOUT = 0x100, /* Column major, indices start at 1 */ - BIGARRAY_LAYOUT_MASK = 0x100 /* Mask for layout in flags field */ +enum caml_ba_layout { + CAML_BA_C_LAYOUT = 0, /* Row major, indices start at 0 */ + CAML_BA_FORTRAN_LAYOUT = 0x100, /* Column major, indices start at 1 */ + CAML_BA_LAYOUT_MASK = 0x100 /* Mask for layout in flags field */ }; -enum caml_bigarray_managed { - BIGARRAY_EXTERNAL = 0, /* Data is not allocated by Caml */ - BIGARRAY_MANAGED = 0x200, /* Data is allocated by Caml */ - BIGARRAY_MAPPED_FILE = 0x400, /* Data is a memory mapped file */ - BIGARRAY_MANAGED_MASK = 0x600 /* Mask for "managed" bits in flags field */ +enum caml_ba_managed { + CAML_BA_EXTERNAL = 0, /* Data is not allocated by Caml */ + CAML_BA_MANAGED = 0x200, /* Data is allocated by Caml */ + CAML_BA_MAPPED_FILE = 0x400, /* Data is a memory mapped file */ + CAML_BA_MANAGED_MASK = 0x600 /* Mask for "managed" bits in flags field */ }; -struct caml_bigarray_proxy { +struct caml_ba_proxy { intnat refcount; /* Reference count */ void * data; /* Pointer to base of actual data */ uintnat size; /* Size of data in bytes (if mapped file) */ }; -struct caml_bigarray { +struct caml_ba_array { void * data; /* Pointer to raw data */ intnat num_dims; /* Number of dimensions */ - intnat flags; /* Kind of element array + memory layout + allocation status */ - struct caml_bigarray_proxy * proxy; /* The proxy for sub-arrays, or NULL */ + intnat flags; /* Kind of element array + memory layout + allocation status */ + struct caml_ba_proxy * proxy; /* The proxy for sub-arrays, or NULL */ intnat dim[1] /*[num_dims]*/; /* Size in each dimension */ }; -#define Bigarray_val(v) ((struct caml_bigarray *) Data_custom_val(v)) +#define Caml_ba_array_val(v) ((struct caml_ba_array *) Data_custom_val(v)) -#define Data_bigarray_val(v) (Bigarray_val(v)->data) +#define Caml_ba_data_val(v) (Caml_ba_array_val(v)->data) #if defined(IN_OCAML_BIGARRAY) #define CAMLBAextern CAMLexport @@ -83,8 +86,9 @@ struct caml_bigarray { #define CAMLBAextern CAMLextern #endif -CAMLBAextern value alloc_bigarray(int flags, int num_dims, void * data, intnat * dim); -CAMLBAextern value alloc_bigarray_dims(int flags, int num_dims, void * data, +CAMLBAextern value + caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim); +CAMLBAextern value caml_ba_alloc_dims(int flags, int num_dims, void * data, ... /*dimensions, with type intnat */); #endif diff --git a/otherlibs/bigarray/bigarray.ml b/otherlibs/bigarray/bigarray.ml index 58e7fef6..6cd39805 100644 --- a/otherlibs/bigarray/bigarray.ml +++ b/otherlibs/bigarray/bigarray.ml @@ -11,11 +11,11 @@ (* *) (***********************************************************************) -(* $Id: bigarray.ml,v 1.15 2005/09/24 08:38:45 xleroy Exp $ *) +(* $Id: bigarray.ml,v 1.18 2007/02/21 15:16:53 xleroy Exp $ *) (* Module [Bigarray]: large, multi-dimensional, numerical arrays *) -external init : unit -> unit = "bigarray_init" +external init : unit -> unit = "caml_ba_init" let _ = init() @@ -34,7 +34,7 @@ type float64_elt type complex32_elt type complex64_elt -(* Keep those constants in sync with the caml_bigarray_kind enumeration +(* Keep those constants in sync with the caml_ba_kind enumeration in bigarray.h *) let float32 = 0 @@ -56,7 +56,7 @@ type 'a layout = int type c_layout type fortran_layout -(* Keep those constants in sync with the caml_bigarray_layout enumeration +(* Keep those constants in sync with the caml_ba_layout enumeration in bigarray.h *) let c_layout = 0 @@ -65,77 +65,82 @@ let fortran_layout = 0x100 module Genarray = struct type ('a, 'b, 'c) t external create: ('a, 'b) kind -> 'c layout -> int array -> ('a, 'b, 'c) t - = "bigarray_create" + = "caml_ba_create" external get: ('a, 'b, 'c) t -> int array -> 'a - = "bigarray_get_generic" + = "caml_ba_get_generic" external set: ('a, 'b, 'c) t -> int array -> 'a -> unit - = "bigarray_set_generic" - external num_dims: ('a, 'b, 'c) t -> int = "bigarray_num_dims" - external nth_dim: ('a, 'b, 'c) t -> int -> int = "bigarray_dim" + = "caml_ba_set_generic" + external num_dims: ('a, 'b, 'c) t -> int = "caml_ba_num_dims" + external nth_dim: ('a, 'b, 'c) t -> int -> int = "caml_ba_dim" let dims a = let n = num_dims a in let d = Array.make n 0 in for i = 0 to n-1 do d.(i) <- nth_dim a i done; d - external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "bigarray_kind" - external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout" + external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" + external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t - = "bigarray_sub" + = "caml_ba_sub" external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t - = "bigarray_sub" - external slice_left: ('a, 'b, c_layout) t -> int array -> + = "caml_ba_sub" + external slice_left: ('a, 'b, c_layout) t -> int array -> ('a, 'b, c_layout) t - = "bigarray_slice" - external slice_right: ('a, 'b, fortran_layout) t -> int array -> + = "caml_ba_slice" + external slice_right: ('a, 'b, fortran_layout) t -> int array -> ('a, 'b, fortran_layout) t - = "bigarray_slice" + = "caml_ba_slice" external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit - = "bigarray_blit" - external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill" - external map_file: Unix.file_descr -> ('a, 'b) kind -> 'c layout -> - bool -> int array -> ('a, 'b, 'c) t - = "bigarray_map_file" + = "caml_ba_blit" + external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill" + external map_internal: Unix.file_descr -> ('a, 'b) kind -> 'c layout -> + bool -> int array -> int64 -> ('a, 'b, 'c) t + = "caml_ba_map_file_bytecode" "caml_ba_map_file" + let map_file fd ?(pos = 0L) kind layout shared dims = + map_internal fd kind layout shared dims pos end module Array1 = struct type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t let create kind layout dim = Genarray.create kind layout [|dim|] - external get: ('a, 'b, 'c) t -> int -> 'a = "%bigarray_ref_1" - external set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%bigarray_set_1" + external get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_ref_1" + external set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_set_1" let dim a = Genarray.nth_dim a 0 - external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "bigarray_kind" - external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout" - external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t = "bigarray_sub" - external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "bigarray_blit" - external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill" + external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" + external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" + external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t = "caml_ba_sub" + external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit" + external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill" let of_array kind layout data = let ba = create kind layout (Array.length data) in let ofs = if layout = c_layout then 0 else 1 in for i = 0 to Array.length data - 1 do set ba (i + ofs) data.(i) done; ba - let map_file fd kind layout shared dim = - Genarray.map_file fd kind layout shared [|dim|] + let map_file fd ?pos kind layout shared dim = + Genarray.map_file fd ?pos kind layout shared [|dim|] end module Array2 = struct type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t let create kind layout dim1 dim2 = Genarray.create kind layout [|dim1; dim2|] - external get: ('a, 'b, 'c) t -> int -> int -> 'a = "%bigarray_ref_2" - external set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%bigarray_set_2" + external get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_ref_2" + external set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%caml_ba_set_2" let dim1 a = Genarray.nth_dim a 0 let dim2 a = Genarray.nth_dim a 1 - external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "bigarray_kind" - external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout" - external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "bigarray_sub" - external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t = "bigarray_sub" + external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" + external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" + external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t + = "caml_ba_sub" + external sub_right: + ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t + = "caml_ba_sub" let slice_left a n = Genarray.slice_left a [|n|] let slice_right a n = Genarray.slice_right a [|n|] - external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "bigarray_blit" - external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill" + external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit" + external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill" let of_array kind layout data = let dim1 = Array.length data in let dim2 = if dim1 = 0 then 0 else Array.length data.(0) in @@ -150,29 +155,33 @@ module Array2 = struct done done; ba - let map_file fd kind layout shared dim1 dim2 = - Genarray.map_file fd kind layout shared [|dim1;dim2|] + let map_file fd ?pos kind layout shared dim1 dim2 = + Genarray.map_file fd ?pos kind layout shared [|dim1;dim2|] end module Array3 = struct type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t let create kind layout dim1 dim2 dim3 = Genarray.create kind layout [|dim1; dim2; dim3|] - external get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%bigarray_ref_3" - external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit = "%bigarray_set_3" + external get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%caml_ba_ref_3" + external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit + = "%caml_ba_set_3" let dim1 a = Genarray.nth_dim a 0 let dim2 a = Genarray.nth_dim a 1 let dim3 a = Genarray.nth_dim a 2 - external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "bigarray_kind" - external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout" - external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "bigarray_sub" - external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t = "bigarray_sub" + external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" + external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" + external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t + = "caml_ba_sub" + external sub_right: + ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t + = "caml_ba_sub" let slice_left_1 a n m = Genarray.slice_left a [|n; m|] let slice_right_1 a n m = Genarray.slice_right a [|n; m|] let slice_left_2 a n = Genarray.slice_left a [|n|] let slice_right_2 a n = Genarray.slice_right a [|n|] - external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "bigarray_blit" - external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill" + external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "caml_ba_blit" + external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill" let of_array kind layout data = let dim1 = Array.length data in let dim2 = if dim1 = 0 then 0 else Array.length data.(0) in @@ -193,28 +202,34 @@ module Array3 = struct done done; ba - let map_file fd kind layout shared dim1 dim2 dim3 = - Genarray.map_file fd kind layout shared [|dim1;dim2;dim3|] + let map_file fd ?pos kind layout shared dim1 dim2 dim3 = + Genarray.map_file fd ?pos kind layout shared [|dim1;dim2;dim3|] end -external genarray_of_array1: ('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t = "%identity" -external genarray_of_array2: ('a, 'b, 'c) Array2.t -> ('a, 'b, 'c) Genarray.t = "%identity" -external genarray_of_array3: ('a, 'b, 'c) Array3.t -> ('a, 'b, 'c) Genarray.t = "%identity" +external genarray_of_array1: ('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t + = "%identity" +external genarray_of_array2: ('a, 'b, 'c) Array2.t -> ('a, 'b, 'c) Genarray.t + = "%identity" +external genarray_of_array3: ('a, 'b, 'c) Array3.t -> ('a, 'b, 'c) Genarray.t + = "%identity" let array1_of_genarray a = - if Genarray.num_dims a = 1 then a else invalid_arg "Bigarray.array1_of_genarray" + if Genarray.num_dims a = 1 then a + else invalid_arg "Bigarray.array1_of_genarray" let array2_of_genarray a = - if Genarray.num_dims a = 2 then a else invalid_arg "Bigarray.array2_of_genarray" + if Genarray.num_dims a = 2 then a + else invalid_arg "Bigarray.array2_of_genarray" let array3_of_genarray a = - if Genarray.num_dims a = 3 then a else invalid_arg "Bigarray.array3_of_genarray" + if Genarray.num_dims a = 3 then a + else invalid_arg "Bigarray.array3_of_genarray" external reshape: ('a, 'b, 'c) Genarray.t -> int array -> ('a, 'b, 'c) Genarray.t - = "bigarray_reshape" + = "caml_ba_reshape" let reshape_1 a dim1 = reshape a [|dim1|] let reshape_2 a dim1 dim2 = reshape a [|dim1;dim2|] let reshape_3 a dim1 dim2 dim3 = reshape a [|dim1;dim2;dim3|] -(* Force bigarray_get_{1,2,3,N} to be linked in, since we don't refer +(* Force caml_ba_get_{1,2,3,N} to be linked in, since we don't refer to those primitives directly in this file *) let _ = @@ -223,4 +238,3 @@ let _ = let _ = Array2.get in let _ = Array3.get in () - diff --git a/otherlibs/bigarray/bigarray.mli b/otherlibs/bigarray/bigarray.mli index 1dba99df..312cc4fd 100644 --- a/otherlibs/bigarray/bigarray.mli +++ b/otherlibs/bigarray/bigarray.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: bigarray.mli,v 1.22 2005/08/13 20:59:37 doligez Exp $ *) +(* $Id: bigarray.mli,v 1.25 2007/02/21 15:16:53 xleroy Exp $ *) (** Large, multi-dimensional, numerical arrays. @@ -27,9 +27,9 @@ Big arrays support all the Caml ad-hoc polymorphic operations: - comparisons ([=], [<>], [<=], etc, as well as {!Pervasives.compare}); - hashing (module [Hash]); - - and structured input-output ({!Pervasives.output_value} - and {!Pervasives.input_value}, as well as the functions from the - {!Marshal} module). + - and structured input-output ({!Pervasives.output_value} + and {!Pervasives.input_value}, as well as the functions from the + {!Marshal} module). *) (** {6 Element kinds} *) @@ -47,15 +47,15 @@ ({!Bigarray.int8_signed_elt} or {!Bigarray.int8_unsigned_elt}), - 16-bit integers (signed or unsigned) ({!Bigarray.int16_signed_elt} or {!Bigarray.int16_unsigned_elt}), -- Caml integers (signed, 31 bits on 32-bit architectures, +- Caml integers (signed, 31 bits on 32-bit architectures, 63 bits on 64-bit architectures) ({!Bigarray.int_elt}), - 32-bit signed integer ({!Bigarray.int32_elt}), - 64-bit signed integers ({!Bigarray.int64_elt}), - platform-native signed integers (32 bits on 32-bit architectures, 64 bits on 64-bit architectures) ({!Bigarray.nativeint_elt}). - + Each element kind is represented at the type level by one - of the abstract types defined below. + of the abstract types defined below. *) type float32_elt @@ -75,12 +75,12 @@ type ('a, 'b) kind (** To each element kind is associated a Caml type, which is the type of Caml values that can be stored in the big array or read back from it. This type is not necessarily the same - as the type of the array elements proper: for instance, + as the type of the array elements proper: for instance, a big array whose elements are of kind [float32_elt] contains 32-bit single precision floats, but reading or writing one of its elements from Caml uses the Caml type [float], which is 64-bit double precision floats. - + The abstract type [('a, 'b) kind] captures this association of a Caml type ['a] for values read or written in the big array, and of an element kind ['b] which represents the actual contents @@ -150,21 +150,21 @@ type fortran_layout this library supports two different memory layouts for big arrays, one compatible with the C conventions, the other compatible with the Fortran conventions. - - In the C-style layout, array indices start at 0, and + + In the C-style layout, array indices start at 0, and multi-dimensional arrays are laid out in row-major format. That is, for a two-dimensional array, all elements of row 0 are contiguous in memory, followed by all elements of row 1, etc. In other terms, the array elements at [(x,y)] and [(x, y+1)] are adjacent in memory. - - In the Fortran-style layout, array indices start at 1, and + + In the Fortran-style layout, array indices start at 1, and multi-dimensional arrays are laid out in column-major format. That is, for a two-dimensional array, all elements of column 0 are contiguous in memory, followed by all elements of column 1, etc. In other terms, the array elements at [(x,y)] and [(x+1, y)] are adjacent in memory. - + Each layout style is identified at the type level by the abstract types {!Bigarray.c_layout} and [fortran_layout] respectively. *) @@ -177,7 +177,7 @@ type 'a layout (** {7 Supported layouts} The abstract values [c_layout] and [fortran_layout] represent - the two supported layouts at the level of values. + the two supported layouts at the level of values. *) val c_layout : c_layout layout @@ -192,7 +192,7 @@ module Genarray : (** The type [Genarray.t] is the type of big arrays with variable numbers of dimensions. Any number of dimensions between 1 and 16 is supported. - + The three type parameters to [Genarray.t] identify the array element kind and layout, as follows: - the first parameter, ['a], is the Caml type for accessing array @@ -202,14 +202,14 @@ module Genarray : etc); - the third parameter, ['c], identifies the array layout ([c_layout] or [fortran_layout]). - + For instance, [(float, float32_elt, fortran_layout) Genarray.t] is the type of generic big arrays containing 32-bit floats in Fortran layout; reads and writes in this array use the Caml type [float]. *) external create: ('a, 'b) kind -> 'c layout -> int array -> ('a, 'b, 'c) t - = "bigarray_create" + = "caml_ba_create" (** [Genarray.create kind layout dimensions] returns a new big array whose element kind is determined by the parameter [kind] (one of [float32], [float64], [int8_signed], etc) and whose layout is @@ -218,27 +218,27 @@ module Genarray : integers that indicate the size of the big array in each dimension. The length of [dimensions] determines the number of dimensions of the bigarray. - + For instance, [Genarray.create int32 c_layout [|4;6;8|]] returns a fresh big array of 32-bit integers, in C layout, having three dimensions, the three dimensions being 4, 6 and 8 respectively. - + Big arrays returned by [Genarray.create] are not initialized: the initial values of array elements is unspecified. - + [Genarray.create] raises [Invalid_arg] if the number of dimensions is not in the range 1 to 16 inclusive, or if one of the dimensions is negative. *) - - external num_dims: ('a, 'b, 'c) t -> int = "bigarray_num_dims" + + external num_dims: ('a, 'b, 'c) t -> int = "caml_ba_num_dims" (** Return the number of dimensions of the given big array. *) val dims : ('a, 'b, 'c) t -> int array (** [Genarray.dims a] returns all dimensions of the big array [a], as an array of integers of length [Genarray.num_dims a]. *) - external nth_dim: ('a, 'b, 'c) t -> int -> int = "bigarray_dim" + external nth_dim: ('a, 'b, 'c) t -> int -> int = "caml_ba_dim" (** [Genarray.nth_dim a n] returns the [n]-th dimension of the big array [a]. The first dimension corresponds to [n = 0]; the second dimension corresponds to [n = 1]; the last dimension, @@ -246,25 +246,25 @@ module Genarray : Raise [Invalid_arg] if [n] is less than 0 or greater or equal than [Genarray.num_dims a]. *) - external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "bigarray_kind" + external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" (** Return the kind of the given big array. *) - external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout" + external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" (** Return the layout of the given big array. *) - external get: ('a, 'b, 'c) t -> int array -> 'a = "bigarray_get_generic" + external get: ('a, 'b, 'c) t -> int array -> 'a = "caml_ba_get_generic" (** Read an element of a generic big array. [Genarray.get a [|i1; ...; iN|]] returns the element of [a] whose coordinates are [i1] in the first dimension, [i2] in the second dimension, ..., [iN] in the [N]-th dimension. - + If [a] has C layout, the coordinates must be greater or equal than 0 and strictly less than the corresponding dimensions of [a]. If [a] has Fortran layout, the coordinates must be greater or equal than 1 and less or equal than the corresponding dimensions of [a]. Raise [Invalid_arg] if the array [a] does not have exactly [N] dimensions, or if the coordinates are outside the array bounds. - + If [N > 3], alternate syntax is provided: you can write [a.{i1, i2, ..., iN}] instead of [Genarray.get a [|i1; ...; iN|]]. (The syntax [a.{...}] with one, two or three coordinates is @@ -272,16 +272,16 @@ module Genarray : as described below.) *) external set: ('a, 'b, 'c) t -> int array -> 'a -> unit - = "bigarray_set_generic" + = "caml_ba_set_generic" (** Assign an element of a generic big array. [Genarray.set a [|i1; ...; iN|] v] stores the value [v] in the element of [a] whose coordinates are [i1] in the first dimension, [i2] in the second dimension, ..., [iN] in the [N]-th dimension. - + The array [a] must have exactly [N] dimensions, and all coordinates must lie inside the array bounds, as described for [Genarray.get]; otherwise, [Invalid_arg] is raised. - + If [N > 3], alternate syntax is provided: you can write [a.{i1, i2, ..., iN} <- v] instead of [Genarray.set a [|i1; ...; iN|] v]. @@ -290,7 +290,7 @@ module Genarray : as described below.) *) external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t - = "bigarray_sub" + = "caml_ba_sub" (** Extract a sub-array of the given big array by restricting the first (left-most) dimension. [Genarray.sub_left a ofs len] returns a big array with the same number of dimensions as [a], @@ -302,7 +302,7 @@ module Genarray : [[|i1; ...; iN|]] of the sub-array is identical to the element at coordinates [[|i1+ofs; ...; iN|]] of the original array [a]. - + [Genarray.sub_left] applies only to big arrays in C layout. Raise [Invalid_arg] if [ofs] and [len] do not designate a valid sub-array of [a], that is, if [ofs < 0], or [len < 0], @@ -310,7 +310,7 @@ module Genarray : external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t - = "bigarray_sub" + = "caml_ba_sub" (** Extract a sub-array of the given big array by restricting the last (right-most) dimension. [Genarray.sub_right a ofs len] returns a big array with the same number of dimensions as [a], @@ -322,7 +322,7 @@ module Genarray : [[|i1; ...; iN|]] of the sub-array is identical to the element at coordinates [[|i1; ...; iN+ofs|]] of the original array [a]. - + [Genarray.sub_right] applies only to big arrays in Fortran layout. Raise [Invalid_arg] if [ofs] and [len] do not designate a valid sub-array of [a], that is, if [ofs < 1], or [len < 0], @@ -330,7 +330,7 @@ module Genarray : external slice_left: ('a, 'b, c_layout) t -> int array -> ('a, 'b, c_layout) t - = "bigarray_slice" + = "caml_ba_slice" (** Extract a sub-array of lower dimension from the given big array by fixing one or several of the first (left-most) coordinates. [Genarray.slice_left a [|i1; ... ; iM|]] returns the ``slice'' @@ -341,14 +341,14 @@ module Genarray : at coordinates [[|i1; ...; iM; j1; ...; j(N-M)|]] in the original array [a]. No copying of elements is involved: the slice and the original array share the same storage space. - + [Genarray.slice_left] applies only to big arrays in C layout. Raise [Invalid_arg] if [M >= N], or if [[|i1; ... ; iM|]] is outside the bounds of [a]. *) external slice_right: ('a, 'b, fortran_layout) t -> int array -> ('a, 'b, fortran_layout) t - = "bigarray_slice" + = "caml_ba_slice" (** Extract a sub-array of lower dimension from the given big array by fixing one or several of the last (right-most) coordinates. [Genarray.slice_right a [|i1; ... ; iM|]] returns the ``slice'' @@ -359,13 +359,13 @@ module Genarray : at coordinates [[|j1; ...; j(N-M); i1; ...; iM|]] in the original array [a]. No copying of elements is involved: the slice and the original array share the same storage space. - + [Genarray.slice_right] applies only to big arrays in Fortran layout. Raise [Invalid_arg] if [M >= N], or if [[|i1; ... ; iM|]] is outside the bounds of [a]. *) external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit - = "bigarray_blit" + = "caml_ba_blit" (** Copy all elements of a big array in another big array. [Genarray.blit src dst] copies all elements of [src] into [dst]. Both arrays [src] and [dst] must have the same number of @@ -373,33 +373,37 @@ module Genarray : to a sub-array of [dst] can be achieved by applying [Genarray.blit] to sub-array or slices of [src] and [dst]. *) - external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill" + external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill" (** Set all elements of a big array to a given value. [Genarray.fill a v] stores the value [v] in all elements of the big array [a]. Setting only some elements of [a] to [v] can be achieved by applying [Genarray.fill] to a sub-array or a slice of [a]. *) - external map_file: - Unix.file_descr -> ('a, 'b) kind -> 'c layout -> - bool -> int array -> ('a, 'b, 'c) t = "bigarray_map_file" + val map_file: + Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout -> + bool -> int array -> ('a, 'b, 'c) t (** Memory mapping of a file as a big array. [Genarray.map_file fd kind layout shared dims] returns a big array of kind [kind], layout [layout], and dimensions as specified in [dims]. The data contained in this big array are the contents of the file referred to by the file descriptor [fd] (as opened previously with - [Unix.openfile], for example). If [shared] is [true], - all modifications performed on the array are reflected in - the file. This requires that [fd] be opened with write permissions. - If [shared] is [false], modifications performed on the array - are done in memory only, using copy-on-write of the modified - pages; the underlying file is not affected. - + [Unix.openfile], for example). The optional [pos] parameter + is the byte offset in the file of the data being mapped; + it default to 0 (map from the beginning of the file). + + If [shared] is [true], all modifications performed on the array + are reflected in the file. This requires that [fd] be opened + with write permissions. If [shared] is [false], modifications + performed on the array are done in memory only, using + copy-on-write of the modified pages; the underlying file is not + affected. + [Genarray.map_file] is much more efficient than reading the whole file in a big array, modifying that big array, and writing it afterwards. - + To adjust automatically the dimensions of the big array to the actual size of the file, the major dimension (that is, the first dimension for an array with C layout, and the last @@ -408,7 +412,7 @@ module Genarray : from the size of the file. The file must contain an integral number of sub-arrays as determined by the non-major dimensions, otherwise [Failure] is raised. - + If all dimensions of the big array are given, the file size is matched against the size of the big array. If the file is larger than the big array, only the initial portion of the file is @@ -439,41 +443,41 @@ module Array1 : sig as described for [Genarray.create]. *) val dim: ('a, 'b, 'c) t -> int - (** Return the size (dimension) of the given one-dimensional + (** Return the size (dimension) of the given one-dimensional big array. *) - external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "bigarray_kind" + external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" (** Return the kind of the given big array. *) - external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout" + external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" (** Return the layout of the given big array. *) - external get: ('a, 'b, 'c) t -> int -> 'a = "%bigarray_ref_1" - (** [Array1.get a x], or alternatively [a.{x}], + external get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_ref_1" + (** [Array1.get a x], or alternatively [a.{x}], returns the element of [a] at index [x]. [x] must be greater or equal than [0] and strictly less than [Array1.dim a] if [a] has C layout. If [a] has Fortran layout, [x] must be greater or equal than [1] and less or equal than [Array1.dim a]. Otherwise, [Invalid_arg] is raised. *) - external set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%bigarray_set_1" + external set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_set_1" (** [Array1.set a x v], also written [a.{x} <- v], stores the value [v] at index [x] in [a]. - [x] must be inside the bounds of [a] as described in + [x] must be inside the bounds of [a] as described in {!Bigarray.Array1.get}; otherwise, [Invalid_arg] is raised. *) external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t - = "bigarray_sub" + = "caml_ba_sub" (** Extract a sub-array of the given one-dimensional big array. See [Genarray.sub_left] for more details. *) external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit - = "bigarray_blit" + = "caml_ba_blit" (** Copy the first big array to the second big array. See [Genarray.blit] for more details. *) - external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill" + external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill" (** Fill the given big array with the given value. See [Genarray.fill] for more details. *) @@ -481,7 +485,7 @@ module Array1 : sig (** Build a one-dimensional big array initialized from the given array. *) - val map_file: Unix.file_descr -> ('a, 'b) kind -> 'c layout -> + val map_file: Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout -> bool -> int -> ('a, 'b, 'c) t (** Memory mapping of a file as a one-dimensional big array. See {!Bigarray.Genarray.map_file} for more details. *) @@ -512,20 +516,20 @@ module Array2 : val dim2: ('a, 'b, 'c) t -> int (** Return the second dimension of the given two-dimensional big array. *) - external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "bigarray_kind" + external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" (** Return the kind of the given big array. *) - external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout" + external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" (** Return the layout of the given big array. *) - external get: ('a, 'b, 'c) t -> int -> int -> 'a = "%bigarray_ref_2" + external get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_ref_2" (** [Array2.get a x y], also written [a.{x,y}], returns the element of [a] at coordinates ([x], [y]). [x] and [y] must be within the bounds - of [a], as described for {!Bigarray.Genarray.get}; + of [a], as described for {!Bigarray.Genarray.get}; otherwise, [Invalid_arg] is raised. *) - external set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%bigarray_set_2" + external set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%caml_ba_set_2" (** [Array2.set a x y v], or alternatively [a.{x,y} <- v], stores the value [v] at coordinates ([x], [y]) in [a]. [x] and [y] must be within the bounds of [a], @@ -533,18 +537,18 @@ module Array2 : otherwise, [Invalid_arg] is raised. *) external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t - = "bigarray_sub" - (** Extract a two-dimensional sub-array of the given two-dimensional + = "caml_ba_sub" + (** Extract a two-dimensional sub-array of the given two-dimensional big array by restricting the first dimension. - See {!Bigarray.Genarray.sub_left} for more details. + See {!Bigarray.Genarray.sub_left} for more details. [Array2.sub_left] applies only to arrays with C layout. *) external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t - = "bigarray_sub" - (** Extract a two-dimensional sub-array of the given two-dimensional + = "caml_ba_sub" + (** Extract a two-dimensional sub-array of the given two-dimensional big array by restricting the second dimension. - See {!Bigarray.Genarray.sub_right} for more details. + See {!Bigarray.Genarray.sub_right} for more details. [Array2.sub_right] applies only to arrays with Fortran layout. *) val slice_left: ('a, 'b, c_layout) t -> int -> ('a, 'b, c_layout) Array1.t @@ -557,16 +561,16 @@ module Array2 : ('a, 'b, fortran_layout) t -> int -> ('a, 'b, fortran_layout) Array1.t (** Extract a column (one-dimensional slice) of the given two-dimensional big array. The integer parameter is the - index of the column to extract. See {!Bigarray.Genarray.slice_right} + index of the column to extract. See {!Bigarray.Genarray.slice_right} for more details. [Array2.slice_right] applies only to arrays with Fortran layout. *) external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit - = "bigarray_blit" + = "caml_ba_blit" (** Copy the first big array to the second big array. See {!Bigarray.Genarray.blit} for more details. *) - external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill" + external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill" (** Fill the given big array with the given value. See {!Bigarray.Genarray.fill} for more details. *) @@ -574,7 +578,7 @@ module Array2 : (** Build a two-dimensional big array initialized from the given array of arrays. *) - val map_file: Unix.file_descr -> ('a, 'b) kind -> 'c layout -> + val map_file: Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout -> bool -> int -> int -> ('a, 'b, 'c) t (** Memory mapping of a file as a two-dimensional big array. See {!Bigarray.Genarray.map_file} for more details. *) @@ -583,8 +587,9 @@ module Array2 : (** {6 Three-dimensional arrays} *) -(** Three-dimensional arrays. The [Array3] structure provides operations similar to those of - {!Bigarray.Genarray}, but specialized to the case of three-dimensional arrays. *) +(** Three-dimensional arrays. The [Array3] structure provides operations + similar to those of {!Bigarray.Genarray}, but specialized to the case + of three-dimensional arrays. *) module Array3 : sig type ('a, 'b, 'c) t @@ -606,22 +611,22 @@ module Array3 : val dim3: ('a, 'b, 'c) t -> int (** Return the third dimension of the given three-dimensional big array. *) - - external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "bigarray_kind" + + external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" (** Return the kind of the given big array. *) - external layout: ('a, 'b, 'c) t -> 'c layout = "bigarray_layout" + external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" (** Return the layout of the given big array. *) - external get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%bigarray_ref_3" + external get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%caml_ba_ref_3" (** [Array3.get a x y z], also written [a.{x,y,z}], returns the element of [a] at coordinates ([x], [y], [z]). [x], [y] and [z] must be within the bounds of [a], - as described for {!Bigarray.Genarray.get}; + as described for {!Bigarray.Genarray.get}; otherwise, [Invalid_arg] is raised. *) external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit - = "%bigarray_set_3" + = "%caml_ba_set_3" (** [Array3.set a x y v], or alternatively [a.{x,y,z} <- v], stores the value [v] at coordinates ([x], [y], [z]) in [a]. [x], [y] and [z] must be within the bounds of [a], @@ -629,7 +634,7 @@ module Array3 : otherwise, [Invalid_arg] is raised. *) external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t - = "bigarray_sub" + = "caml_ba_sub" (** Extract a three-dimensional sub-array of the given three-dimensional big array by restricting the first dimension. See {!Bigarray.Genarray.sub_left} for more details. [Array3.sub_left] @@ -637,7 +642,7 @@ module Array3 : external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t - = "bigarray_sub" + = "caml_ba_sub" (** Extract a three-dimensional sub-array of the given three-dimensional big array by restricting the second dimension. See {!Bigarray.Genarray.sub_right} for more details. [Array3.sub_right] @@ -678,11 +683,11 @@ module Array3 : layout. *) external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit - = "bigarray_blit" + = "caml_ba_blit" (** Copy the first big array to the second big array. See {!Bigarray.Genarray.blit} for more details. *) - external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill" + external fill: ('a, 'b, 'c) t -> 'a -> unit = "caml_ba_fill" (** Fill the given big array with the given value. See {!Bigarray.Genarray.fill} for more details. *) @@ -691,26 +696,28 @@ module Array3 : (** Build a three-dimensional big array initialized from the given array of arrays of arrays. *) - val map_file: Unix.file_descr -> ('a, 'b) kind -> 'c layout -> + val map_file: Unix.file_descr -> ?pos:int64 -> ('a, 'b) kind -> 'c layout -> bool -> int -> int -> int -> ('a, 'b, 'c) t (** Memory mapping of a file as a three-dimensional big array. See {!Bigarray.Genarray.map_file} for more details. *) - end (** {6 Coercions between generic big arrays and fixed-dimension big arrays} *) external genarray_of_array1 : ('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t = "%identity" -(** Return the generic big array corresponding to the given one-dimensional big array. *) +(** Return the generic big array corresponding to the given one-dimensional + big array. *) external genarray_of_array2 : ('a, 'b, 'c) Array2.t -> ('a, 'b, 'c) Genarray.t = "%identity" -(** Return the generic big array corresponding to the given two-dimensional big array. *) +(** Return the generic big array corresponding to the given two-dimensional + big array. *) external genarray_of_array3 : ('a, 'b, 'c) Array3.t -> ('a, 'b, 'c) Genarray.t = "%identity" -(** Return the generic big array corresponding to the given three-dimensional big array. *) +(** Return the generic big array corresponding to the given three-dimensional + big array. *) val array1_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array1.t (** Return the one-dimensional big array corresponding to the given @@ -747,12 +754,14 @@ val reshape : ('a, 'b, 'c) Genarray.t -> int array -> ('a, 'b, 'c) Genarray.t Otherwise, [Invalid_arg] is raised. *) val reshape_1 : ('a, 'b, 'c) Genarray.t -> int -> ('a, 'b, 'c) Array1.t -(** Specialized version of {!Bigarray.reshape} for reshaping to one-dimensional arrays. *) +(** Specialized version of {!Bigarray.reshape} for reshaping to + one-dimensional arrays. *) val reshape_2 : ('a, 'b, 'c) Genarray.t -> int -> int -> ('a, 'b, 'c) Array2.t -(** Specialized version of {!Bigarray.reshape} for reshaping to two-dimensional arrays. *) +(** Specialized version of {!Bigarray.reshape} for reshaping to + two-dimensional arrays. *) val reshape_3 : ('a, 'b, 'c) Genarray.t -> int -> int -> int -> ('a, 'b, 'c) Array3.t -(** Specialized version of {!Bigarray.reshape} for reshaping to three-dimensional arrays. *) - +(** Specialized version of {!Bigarray.reshape} for reshaping to + three-dimensional arrays. *) diff --git a/otherlibs/bigarray/bigarray_stubs.c b/otherlibs/bigarray/bigarray_stubs.c index 72535603..4f405fe5 100644 --- a/otherlibs/bigarray/bigarray_stubs.c +++ b/otherlibs/bigarray/bigarray_stubs.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: bigarray_stubs.c,v 1.21 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: bigarray_stubs.c,v 1.22 2006/01/27 14:33:42 doligez Exp $ */ #include #include @@ -24,12 +24,12 @@ #include "memory.h" #include "mlvalues.h" -extern void bigarray_unmap_file(void * addr, uintnat len); +extern void caml_ba_unmap_file(void * addr, uintnat len); /* from mmap_xxx.c */ /* Compute the number of elements of a big array */ -static uintnat bigarray_num_elts(struct caml_bigarray * b) +static uintnat caml_ba_num_elts(struct caml_bigarray * b) { uintnat num_elts; int i; @@ -40,7 +40,7 @@ static uintnat bigarray_num_elts(struct caml_bigarray * b) /* Size in bytes of a bigarray element, indexed by bigarray kind */ -int bigarray_element_size[] = +int caml_ba_element_size[] = { 4 /*FLOAT32*/, 8 /*FLOAT64*/, 1 /*SINT8*/, 1 /*UINT8*/, 2 /*SINT16*/, 2 /*UINT16*/, @@ -51,32 +51,32 @@ int bigarray_element_size[] = /* Compute the number of bytes for the elements of a big array */ -uintnat bigarray_byte_size(struct caml_bigarray * b) +uintnat caml_ba_byte_size(struct caml_bigarray * b) { - return bigarray_num_elts(b) - * bigarray_element_size[b->flags & BIGARRAY_KIND_MASK]; + return caml_ba_num_elts(b) + * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK]; } /* Operation table for bigarrays */ -static void bigarray_finalize(value v); -static int bigarray_compare(value v1, value v2); -static intnat bigarray_hash(value v); -static void bigarray_serialize(value, uintnat *, uintnat *); -uintnat bigarray_deserialize(void * dst); -static struct custom_operations bigarray_ops = { +static void caml_ba_finalize(value v); +static int caml_ba_compare(value v1, value v2); +static intnat caml_ba_hash(value v); +static void caml_ba_serialize(value, uintnat *, uintnat *); +uintnat caml_ba_deserialize(void * dst); +static struct custom_operations caml_ba_ops = { "_bigarray", - bigarray_finalize, - bigarray_compare, - bigarray_hash, - bigarray_serialize, - bigarray_deserialize + caml_ba_finalize, + caml_ba_compare, + caml_ba_hash, + caml_ba_serialize, + caml_ba_deserialize }; /* Multiplication of unsigned longs with overflow detection */ static uintnat -bigarray_multov(uintnat a, uintnat b, int * overflow) +caml_ba_multov(uintnat a, uintnat b, int * overflow) { #define HALF_SIZE (sizeof(uintnat) * 4) #define HALF_MASK (((uintnat)1 << HALF_SIZE) - 1) @@ -116,18 +116,18 @@ bigarray_multov(uintnat a, uintnat b, int * overflow) /* Allocation of a big array */ -#define MAX_BIGARRAY_MEMORY 256*1024*1024 +#define CAML_BA_MAX_MEMORY 256*1024*1024 /* 256 Mb -- after allocating that much, it's probably worth speeding up the major GC */ -/* [alloc_bigarray] will allocate a new bigarray object in the heap. +/* [caml_ba_alloc] will allocate a new bigarray object in the heap. If [data] is NULL, the memory for the contents is also allocated - (with [malloc]) by [alloc_bigarray]. + (with [malloc]) by [caml_ba_alloc]. [data] cannot point into the Caml heap. [dim] may point into an object in the Caml heap. */ CAMLexport value -alloc_bigarray(int flags, int num_dims, void * data, intnat * dim) +caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim) { uintnat num_elts, size; int overflow, i; @@ -143,20 +143,20 @@ alloc_bigarray(int flags, int num_dims, void * data, intnat * dim) overflow = 0; num_elts = 1; for (i = 0; i < num_dims; i++) { - num_elts = bigarray_multov(num_elts, dimcopy[i], &overflow); + num_elts = caml_ba_multov(num_elts, dimcopy[i], &overflow); } - size = bigarray_multov(num_elts, - bigarray_element_size[flags & BIGARRAY_KIND_MASK], - &overflow); + size = caml_ba_multov(num_elts, + caml_ba_element_size[flags & BIGARRAY_KIND_MASK], + &overflow); if (overflow) raise_out_of_memory(); data = malloc(size); if (data == NULL && size != 0) raise_out_of_memory(); flags |= BIGARRAY_MANAGED; } - res = alloc_custom(&bigarray_ops, - sizeof(struct caml_bigarray) + res = alloc_custom(&caml_ba_ops, + sizeof(struct caml_ba_array) + (num_dims - 1) * sizeof(intnat), - size, MAX_BIGARRAY_MEMORY); + size, CAML_BA_MAX_MEMORY); b = Bigarray_val(res); b->data = data; b->num_dims = num_dims; @@ -166,10 +166,10 @@ alloc_bigarray(int flags, int num_dims, void * data, intnat * dim) return res; } -/* Same as alloc_bigarray, but dimensions are passed as a list of +/* Same as caml_ba_alloc, but dimensions are passed as a list of arguments */ -CAMLexport value alloc_bigarray_dims(int flags, int num_dims, void * data, ...) +CAMLexport value caml_ba_alloc_dims(int flags, int num_dims, void * data, ...) { va_list ap; intnat dim[MAX_NUM_DIMS]; @@ -179,13 +179,13 @@ CAMLexport value alloc_bigarray_dims(int flags, int num_dims, void * data, ...) va_start(ap, data); for (i = 0; i < num_dims; i++) dim[i] = va_arg(ap, intnat); va_end(ap); - res = alloc_bigarray(flags, num_dims, data, dim); + res = caml_ba_alloc(flags, num_dims, data, dim); return res; } /* Allocate a bigarray from Caml */ -CAMLprim value bigarray_create(value vkind, value vlayout, value vdim) +CAMLprim value caml_ba_create(value vkind, value vlayout, value vdim) { intnat dim[MAX_NUM_DIMS]; mlsize_t num_dims; @@ -200,14 +200,14 @@ CAMLprim value bigarray_create(value vkind, value vlayout, value vdim) invalid_argument("Bigarray.create: negative dimension"); } flags = Int_val(vkind) | Int_val(vlayout); - return alloc_bigarray(flags, num_dims, NULL, dim); + return caml_ba_alloc(flags, num_dims, NULL, dim); } /* Given a big array and a vector of indices, check that the indices are within the bounds and return the offset of the corresponding array element in the data part of the array. */ -static long bigarray_offset(struct caml_bigarray * b, intnat * index) +static long caml_ba_offset(struct caml_ba_array * b, intnat * index) { intnat offset; int i; @@ -243,7 +243,7 @@ static value copy_two_doubles(double d0, double d1) /* Generic code to read from a big array */ -value bigarray_get_N(value vb, value * vind, int nind) +value caml_ba_get_N(value vb, value * vind, int nind) { struct caml_bigarray * b = Bigarray_val(vb); intnat index[MAX_NUM_DIMS]; @@ -256,7 +256,7 @@ value bigarray_get_N(value vb, value * vind, int nind) invalid_argument("Bigarray.get: wrong number of indices"); /* Compute offset and check bounds */ for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]); - offset = bigarray_offset(b, index); + offset = caml_ba_offset(b, index); /* Perform read */ switch ((b->flags) & BIGARRAY_KIND_MASK) { default: @@ -290,74 +290,74 @@ value bigarray_get_N(value vb, value * vind, int nind) } } -CAMLprim value bigarray_get_1(value vb, value vind1) +CAMLprim value caml_ba_get_1(value vb, value vind1) { - return bigarray_get_N(vb, &vind1, 1); + return caml_ba_get_N(vb, &vind1, 1); } -CAMLprim value bigarray_get_2(value vb, value vind1, value vind2) +CAMLprim value caml_ba_get_2(value vb, value vind1, value vind2) { value vind[2]; vind[0] = vind1; vind[1] = vind2; - return bigarray_get_N(vb, vind, 2); + return caml_ba_get_N(vb, vind, 2); } -CAMLprim value bigarray_get_3(value vb, value vind1, value vind2, value vind3) +CAMLprim value caml_ba_get_3(value vb, value vind1, value vind2, value vind3) { value vind[3]; vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; - return bigarray_get_N(vb, vind, 3); + return caml_ba_get_N(vb, vind, 3); } #if 0 -CAMLprim value bigarray_get_4(value vb, value vind1, value vind2, +CAMLprim value caml_ba_get_4(value vb, value vind1, value vind2, value vind3, value vind4) { value vind[4]; vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; vind[3] = vind4; - return bigarray_get_N(vb, vind, 4); + return caml_ba_get_N(vb, vind, 4); } -CAMLprim value bigarray_get_5(value vb, value vind1, value vind2, +CAMLprim value caml_ba_get_5(value vb, value vind1, value vind2, value vind3, value vind4, value vind5) { value vind[5]; - vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; + vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; vind[3] = vind4; vind[4] = vind5; - return bigarray_get_N(vb, vind, 5); + return caml_ba_get_N(vb, vind, 5); } -CAMLprim value bigarray_get_6(value vb, value vind1, value vind2, +CAMLprim value caml_ba_get_6(value vb, value vind1, value vind2, value vind3, value vind4, value vind5, value vind6) { value vind[6]; - vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; + vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; vind[3] = vind4; vind[4] = vind5; vind[5] = vind6; - return bigarray_get_N(vb, vind, 6); + return caml_ba_get_N(vb, vind, 6); } #endif -CAMLprim value bigarray_get_generic(value vb, value vind) +CAMLprim value caml_ba_get_generic(value vb, value vind) { - return bigarray_get_N(vb, &Field(vind, 0), Wosize_val(vind)); + return caml_ba_get_N(vb, &Field(vind, 0), Wosize_val(vind)); } /* Generic write to a big array */ -static value bigarray_set_aux(value vb, value * vind, intnat nind, value newval) +static value caml_ba_set_aux(value vb, value * vind, intnat nind, value newval) { struct caml_bigarray * b = Bigarray_val(vb); intnat index[MAX_NUM_DIMS]; int i; intnat offset; - + /* Check number of indices = number of dimensions of array (maybe not necessary if ML typing guarantees this) */ if (nind != b->num_dims) invalid_argument("Bigarray.set: wrong number of indices"); /* Compute offset and check bounds */ for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]); - offset = bigarray_offset(b, index); + offset = caml_ba_offset(b, index); /* Perform write */ switch (b->flags & BIGARRAY_KIND_MASK) { default: @@ -394,68 +394,68 @@ static value bigarray_set_aux(value vb, value * vind, intnat nind, value newval) return Val_unit; } -CAMLprim value bigarray_set_1(value vb, value vind1, value newval) +CAMLprim value caml_ba_set_1(value vb, value vind1, value newval) { - return bigarray_set_aux(vb, &vind1, 1, newval); + return caml_ba_set_aux(vb, &vind1, 1, newval); } -CAMLprim value bigarray_set_2(value vb, value vind1, value vind2, value newval) +CAMLprim value caml_ba_set_2(value vb, value vind1, value vind2, value newval) { value vind[2]; vind[0] = vind1; vind[1] = vind2; - return bigarray_set_aux(vb, vind, 2, newval); + return caml_ba_set_aux(vb, vind, 2, newval); } -CAMLprim value bigarray_set_3(value vb, value vind1, value vind2, value vind3, +CAMLprim value caml_ba_set_3(value vb, value vind1, value vind2, value vind3, value newval) { value vind[3]; vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; - return bigarray_set_aux(vb, vind, 3, newval); + return caml_ba_set_aux(vb, vind, 3, newval); } #if 0 -CAMLprim value bigarray_set_4(value vb, value vind1, value vind2, +CAMLprim value caml_ba_set_4(value vb, value vind1, value vind2, value vind3, value vind4, value newval) { value vind[4]; vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; vind[3] = vind4; - return bigarray_set_aux(vb, vind, 4, newval); + return caml_ba_set_aux(vb, vind, 4, newval); } -CAMLprim value bigarray_set_5(value vb, value vind1, value vind2, +CAMLprim value caml_ba_set_5(value vb, value vind1, value vind2, value vind3, value vind4, value vind5, value newval) { value vind[5]; - vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; + vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; vind[3] = vind4; vind[4] = vind5; - return bigarray_set_aux(vb, vind, 5, newval); + return caml_ba_set_aux(vb, vind, 5, newval); } -CAMLprim value bigarray_set_6(value vb, value vind1, value vind2, +CAMLprim value caml_ba_set_6(value vb, value vind1, value vind2, value vind3, value vind4, value vind5, value vind6, value newval) { value vind[6]; - vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; + vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; vind[3] = vind4; vind[4] = vind5; vind[5] = vind6; - return bigarray_set_aux(vb, vind, 6, newval); + return caml_ba_set_aux(vb, vind, 6, newval); } -value bigarray_set_N(value vb, value * vind, int nargs) +value caml_ba_set_N(value vb, value * vind, int nargs) { - return bigarray_set_aux(vb, vind, nargs - 1, vind[nargs - 1]); + return caml_ba_set_aux(vb, vind, nargs - 1, vind[nargs - 1]); } #endif -CAMLprim value bigarray_set_generic(value vb, value vind, value newval) +CAMLprim value caml_ba_set_generic(value vb, value vind, value newval) { - return bigarray_set_aux(vb, &Field(vind, 0), Wosize_val(vind), newval); + return caml_ba_set_aux(vb, &Field(vind, 0), Wosize_val(vind), newval); } /* Return the number of dimensions of a big array */ -CAMLprim value bigarray_num_dims(value vb) +CAMLprim value caml_ba_num_dims(value vb) { struct caml_bigarray * b = Bigarray_val(vb); return Val_long(b->num_dims); @@ -463,7 +463,7 @@ CAMLprim value bigarray_num_dims(value vb) /* Return the n-th dimension of a big array */ -CAMLprim value bigarray_dim(value vb, value vn) +CAMLprim value caml_ba_dim(value vb, value vn) { struct caml_bigarray * b = Bigarray_val(vb); intnat n = Long_val(vn); @@ -473,21 +473,21 @@ CAMLprim value bigarray_dim(value vb, value vn) /* Return the kind of a big array */ -CAMLprim value bigarray_kind(value vb) +CAMLprim value caml_ba_kind(value vb) { return Val_int(Bigarray_val(vb)->flags & BIGARRAY_KIND_MASK); } /* Return the layout of a big array */ -CAMLprim value bigarray_layout(value vb) +CAMLprim value caml_ba_layout(value vb) { return Val_int(Bigarray_val(vb)->flags & BIGARRAY_LAYOUT_MASK); } /* Finalization of a big array */ -static void bigarray_finalize(value v) +static void caml_ba_finalize(value v) { struct caml_bigarray * b = Bigarray_val(v); @@ -506,10 +506,10 @@ static void bigarray_finalize(value v) break; case BIGARRAY_MAPPED_FILE: if (b->proxy == NULL) { - bigarray_unmap_file(b->data, bigarray_byte_size(b)); + caml_ba_unmap_file(b->data, caml_ba_byte_size(b)); } else { if (-- b->proxy->refcount == 0) { - bigarray_unmap_file(b->proxy->data, b->proxy->size); + caml_ba_unmap_file(b->proxy->data, b->proxy->size); stat_free(b->proxy); } } @@ -519,7 +519,7 @@ static void bigarray_finalize(value v) /* Comparison of two big arrays */ -static int bigarray_compare(value v1, value v2) +static int caml_ba_compare(value v1, value v2) { struct caml_bigarray * b1 = Bigarray_val(v1); struct caml_bigarray * b2 = Bigarray_val(v2); @@ -535,7 +535,7 @@ static int bigarray_compare(value v1, value v2) if (d1 != d2) return d1 < d2 ? -1 : 1; } /* Same dimensions: compare contents lexicographically */ - num_elts = bigarray_num_elts(b1); + num_elts = caml_ba_num_elts(b1); #define DO_INTEGER_COMPARISON(type) \ { type * p1 = b1->data; type * p2 = b2->data; \ @@ -608,7 +608,7 @@ static int bigarray_compare(value v1, value v2) /* Hashing of a bigarray */ -static intnat bigarray_hash(value v) +static intnat caml_ba_hash(value v) { struct caml_bigarray * b = Bigarray_val(v); intnat num_elts, n, h; @@ -677,9 +677,9 @@ static intnat bigarray_hash(value v) return h; } -static void bigarray_serialize_longarray(void * data, - intnat num_elts, - intnat min_val, intnat max_val) +static void caml_ba_serialize_longarray(void * data, + intnat num_elts, + intnat min_val, intnat max_val) { #ifdef ARCH_SIXTYFOUR int overflow_32 = 0; @@ -700,9 +700,9 @@ static void bigarray_serialize_longarray(void * data, #endif } -static void bigarray_serialize(value v, - uintnat * wsize_32, - uintnat * wsize_64) +static void caml_ba_serialize(value v, + uintnat * wsize_32, + uintnat * wsize_64) { struct caml_bigarray * b = Bigarray_val(v); intnat num_elts; @@ -734,10 +734,10 @@ static void bigarray_serialize(value v, case BIGARRAY_COMPLEX64: serialize_block_8(b->data, num_elts * 2); break; case BIGARRAY_CAML_INT: - bigarray_serialize_longarray(b->data, num_elts, -0x40000000, 0x3FFFFFFF); + caml_ba_serialize_longarray(b->data, num_elts, -0x40000000, 0x3FFFFFFF); break; case BIGARRAY_NATIVE_INT: - bigarray_serialize_longarray(b->data, num_elts, -0x80000000, 0x7FFFFFFF); + caml_ba_serialize_longarray(b->data, num_elts, -0x80000000, 0x7FFFFFFF); break; } /* Compute required size in Caml heap. Assumes struct caml_bigarray @@ -747,7 +747,7 @@ static void bigarray_serialize(value v, *wsize_64 = (4 + b->num_dims) * 8; } -static void bigarray_deserialize_longarray(void * dest, intnat num_elts) +static void caml_ba_deserialize_longarray(void * dest, intnat num_elts) { int sixty = deserialize_uint_1(); #ifdef ARCH_SIXTYFOUR @@ -765,7 +765,7 @@ static void bigarray_deserialize_longarray(void * dest, intnat num_elts) #endif } -uintnat bigarray_deserialize(void * dst) +uintnat caml_ba_deserialize(void * dst) { struct caml_bigarray * b = dst; int i, elt_size; @@ -777,11 +777,11 @@ uintnat bigarray_deserialize(void * dst) b->proxy = NULL; for (i = 0; i < b->num_dims; i++) b->dim[i] = deserialize_uint_4(); /* Compute total number of elements */ - num_elts = bigarray_num_elts(b); + num_elts = caml_ba_num_elts(b); /* Determine element size in bytes */ if ((b->flags & BIGARRAY_KIND_MASK) > BIGARRAY_COMPLEX64) deserialize_error("input_value: bad bigarray kind"); - elt_size = bigarray_element_size[b->flags & BIGARRAY_KIND_MASK]; + elt_size = caml_ba_element_size[b->flags & BIGARRAY_KIND_MASK]; /* Allocate room for data */ b->data = malloc(elt_size * num_elts); if (b->data == NULL) @@ -806,15 +806,15 @@ uintnat bigarray_deserialize(void * dst) deserialize_block_8(b->data, num_elts * 2); break; case BIGARRAY_CAML_INT: case BIGARRAY_NATIVE_INT: - bigarray_deserialize_longarray(b->data, num_elts); break; + caml_ba_deserialize_longarray(b->data, num_elts); break; } return sizeof(struct caml_bigarray) + (b->num_dims - 1) * sizeof(intnat); } /* Create / update proxy to indicate that b2 is a sub-array of b1 */ -static void bigarray_update_proxy(struct caml_bigarray * b1, - struct caml_bigarray * b2) +static void caml_ba_update_proxy(struct caml_bigarray * b1, + struct caml_bigarray * b2) { struct caml_bigarray_proxy * proxy; /* Nothing to do for un-managed arrays */ @@ -830,7 +830,7 @@ static void bigarray_update_proxy(struct caml_bigarray * b1, proxy->refcount = 2; /* original array + sub array */ proxy->data = b1->data; proxy->size = - b1->flags & BIGARRAY_MAPPED_FILE ? bigarray_byte_size(b1) : 0; + b1->flags & BIGARRAY_MAPPED_FILE ? caml_ba_byte_size(b1) : 0; b1->proxy = proxy; b2->proxy = proxy; } @@ -838,7 +838,7 @@ static void bigarray_update_proxy(struct caml_bigarray * b1, /* Slicing */ -CAMLprim value bigarray_slice(value vb, value vind) +CAMLprim value caml_ba_slice(value vb, value vind) { CAMLparam2 (vb, vind); #define b ((struct caml_bigarray *) Bigarray_val(vb)) @@ -858,23 +858,23 @@ CAMLprim value bigarray_slice(value vb, value vind) /* We slice from the left */ for (i = 0; i < num_inds; i++) index[i] = Long_val(Field(vind, i)); for (/*nothing*/; i < b->num_dims; i++) index[i] = 0; - offset = bigarray_offset(b, index); + offset = caml_ba_offset(b, index); sub_dims = b->dim + num_inds; } else { /* We slice from the right */ for (i = 0; i < num_inds; i++) index[b->num_dims - num_inds + i] = Long_val(Field(vind, i)); for (i = 0; i < b->num_dims - num_inds; i++) index[i] = 1; - offset = bigarray_offset(b, index); + offset = caml_ba_offset(b, index); sub_dims = b->dim; } sub_data = (char *) b->data + - offset * bigarray_element_size[b->flags & BIGARRAY_KIND_MASK]; + offset * caml_ba_element_size[b->flags & BIGARRAY_KIND_MASK]; /* Allocate a Caml bigarray to hold the result */ res = alloc_bigarray(b->flags, b->num_dims - num_inds, sub_data, sub_dims); /* Create or update proxy in case of managed bigarray */ - bigarray_update_proxy(b, Bigarray_val(res)); + caml_ba_update_proxy(b, Bigarray_val(res)); /* Return result */ CAMLreturn (res); @@ -883,7 +883,7 @@ CAMLprim value bigarray_slice(value vb, value vind) /* Extracting a sub-array of same number of dimensions */ -CAMLprim value bigarray_sub(value vb, value vofs, value vlen) +CAMLprim value caml_ba_sub(value vb, value vofs, value vlen) { CAMLparam3 (vb, vofs, vlen); CAMLlocal1 (res); @@ -911,13 +911,13 @@ CAMLprim value bigarray_sub(value vb, value vofs, value vlen) invalid_argument("Bigarray.sub: bad sub-array"); sub_data = (char *) b->data + - ofs * mul * bigarray_element_size[b->flags & BIGARRAY_KIND_MASK]; + ofs * mul * caml_ba_element_size[b->flags & BIGARRAY_KIND_MASK]; /* Allocate a Caml bigarray to hold the result */ res = alloc_bigarray(b->flags, b->num_dims, sub_data, b->dim); /* Doctor the changed dimension */ Bigarray_val(res)->dim[changed_dim] = len; /* Create or update proxy in case of managed bigarray */ - bigarray_update_proxy(b, Bigarray_val(res)); + caml_ba_update_proxy(b, Bigarray_val(res)); /* Return result */ CAMLreturn (res); @@ -926,7 +926,7 @@ CAMLprim value bigarray_sub(value vb, value vofs, value vlen) /* Copying a big array into another one */ -CAMLprim value bigarray_blit(value vsrc, value vdst) +CAMLprim value caml_ba_blit(value vsrc, value vdst) { struct caml_bigarray * src = Bigarray_val(vsrc); struct caml_bigarray * dst = Bigarray_val(vdst); @@ -939,8 +939,8 @@ CAMLprim value bigarray_blit(value vsrc, value vdst) if (src->dim[i] != dst->dim[i]) goto blit_error; /* Compute number of bytes in array data */ num_bytes = - bigarray_num_elts(src) - * bigarray_element_size[src->flags & BIGARRAY_KIND_MASK]; + caml_ba_num_elts(src) + * caml_ba_element_size[src->flags & BIGARRAY_KIND_MASK]; /* Do the copying */ memmove (dst->data, src->data, num_bytes); return Val_unit; @@ -951,10 +951,10 @@ CAMLprim value bigarray_blit(value vsrc, value vdst) /* Filling a big array with a given value */ -CAMLprim value bigarray_fill(value vb, value vinit) +CAMLprim value caml_ba_fill(value vb, value vinit) { struct caml_bigarray * b = Bigarray_val(vb); - intnat num_elts = bigarray_num_elts(b); + intnat num_elts = caml_ba_num_elts(b); switch (b->flags & BIGARRAY_KIND_MASK) { default: @@ -978,7 +978,7 @@ CAMLprim value bigarray_fill(value vb, value vinit) for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } - case BIGARRAY_SINT16: + case BIGARRAY_SINT16: case BIGARRAY_UINT16: { int init = Int_val(vinit); int16 * p; @@ -1030,7 +1030,7 @@ CAMLprim value bigarray_fill(value vb, value vinit) /* Reshape an array: change dimensions and number of dimensions, preserving array contents */ -CAMLprim value bigarray_reshape(value vb, value vdim) +CAMLprim value caml_ba_reshape(value vb, value vdim) { CAMLparam2 (vb, vdim); CAMLlocal1 (res); @@ -1051,12 +1051,12 @@ CAMLprim value bigarray_reshape(value vb, value vdim) num_elts *= dim[i]; } /* Check that sizes agree */ - if (num_elts != bigarray_num_elts(b)) + if (num_elts != caml_ba_num_elts(b)) invalid_argument("Bigarray.reshape: size mismatch"); /* Create bigarray with same data and new dimensions */ res = alloc_bigarray(b->flags, num_dims, b->data, dim); /* Create or update proxy in case of managed bigarray */ - bigarray_update_proxy(b, Bigarray_val(res)); + caml_ba_update_proxy(b, Bigarray_val(res)); /* Return result */ CAMLreturn (res); @@ -1065,8 +1065,8 @@ CAMLprim value bigarray_reshape(value vb, value vdim) /* Initialization */ -CAMLprim value bigarray_init(value unit) +CAMLprim value caml_ba_init(value unit) { - register_custom_operations(&bigarray_ops); + register_custom_operations(&caml_ba_ops); return Val_unit; } diff --git a/otherlibs/bigarray/dllbigarray.dlib b/otherlibs/bigarray/dllbigarray.dlib new file mode 100644 index 00000000..5ab81172 --- /dev/null +++ b/otherlibs/bigarray/dllbigarray.dlib @@ -0,0 +1 @@ +bigarray_stubs.d.o mmap_win32.d.o diff --git a/otherlibs/bigarray/libbigarray.clib b/otherlibs/bigarray/libbigarray.clib new file mode 100644 index 00000000..4dc96a4f --- /dev/null +++ b/otherlibs/bigarray/libbigarray.clib @@ -0,0 +1 @@ +bigarray_stubs.o mmap_unix.o diff --git a/otherlibs/bigarray/libbigarraywin32.clib b/otherlibs/bigarray/libbigarraywin32.clib new file mode 100644 index 00000000..16661bb8 --- /dev/null +++ b/otherlibs/bigarray/libbigarraywin32.clib @@ -0,0 +1 @@ +bigarray_stubs.o mmap_win32.o diff --git a/otherlibs/bigarray/mmap_unix.c b/otherlibs/bigarray/mmap_unix.c index a7f2e33b..599792d4 100644 --- a/otherlibs/bigarray/mmap_unix.c +++ b/otherlibs/bigarray/mmap_unix.c @@ -11,17 +11,18 @@ /* */ /***********************************************************************/ -/* $Id: mmap_unix.c,v 1.8 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: mmap_unix.c,v 1.10 2006/06/10 14:15:42 xleroy Exp $ */ #include #include #include "bigarray.h" #include "custom.h" #include "fail.h" +#include "io.h" #include "mlvalues.h" #include "sys.h" -extern int bigarray_element_size[]; /* from bigarray_stubs.c */ +extern int caml_ba_element_size[]; /* from bigarray_stubs.c */ #ifdef HAS_UNISTD #include @@ -37,19 +38,20 @@ extern int bigarray_element_size[]; /* from bigarray_stubs.c */ #define MAP_FAILED ((void *) -1) #endif -CAMLprim value bigarray_map_file(value vfd, value vkind, value vlayout, - value vshared, value vdim) +CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, + value vshared, value vdim, value vstart) { int fd, flags, major_dim, shared; intnat num_dims, i; intnat dim[MAX_NUM_DIMS]; - intnat currpos, file_size; - uintnat array_size; + file_offset currpos, startpos, file_size, data_size; + uintnat array_size, page, delta; char c; void * addr; fd = Int_val(vfd); flags = Int_val(vkind) | Int_val(vlayout); + startpos = File_offset_val(vstart); num_dims = Wosize_val(vdim); major_dim = flags & BIGARRAY_FORTRAN_LAYOUT ? num_dims - 1 : 0; /* Extract dimensions from Caml array */ @@ -72,35 +74,44 @@ CAMLprim value bigarray_map_file(value vfd, value vkind, value vlayout, array_size = bigarray_element_size[flags & BIGARRAY_KIND_MASK]; for (i = 0; i < num_dims; i++) if (dim[i] != -1) array_size *= dim[i]; - /* Check if the first/last dimension is unknown */ + /* Check if the major dimension is unknown */ if (dim[major_dim] == -1) { - /* Determine first/last dimension from file size */ - if ((uintnat) file_size % array_size != 0) + /* Determine major dimension from file size */ + if (file_size < startpos) + failwith("Bigarray.mmap: file position exceeds file size"); + data_size = file_size - startpos; + dim[major_dim] = (uintnat) (data_size / array_size); + array_size = dim[major_dim] * array_size; + if (array_size != data_size) failwith("Bigarray.mmap: file size doesn't match array dimensions"); - dim[major_dim] = (uintnat) file_size / array_size; - array_size = file_size; } else { /* Check that file is large enough, and grow it otherwise */ - if (file_size < array_size) { - if (lseek(fd, array_size - 1, SEEK_SET) == -1) sys_error(NO_ARG); + if (file_size < startpos + array_size) { + if (lseek(fd, startpos + array_size - 1, SEEK_SET) == -1) + sys_error(NO_ARG); c = 0; if (write(fd, &c, 1) != 1) sys_error(NO_ARG); } } /* Restore original file position */ lseek(fd, currpos, SEEK_SET); + /* Determine offset so that the mapping starts at the given file pos */ + page = getpagesize(); + delta = (uintnat) (startpos % page); /* Do the mmap */ shared = Bool_val(vshared) ? MAP_SHARED : MAP_PRIVATE; - addr = mmap(NULL, array_size, PROT_READ | PROT_WRITE, shared, fd, 0); + addr = mmap(NULL, array_size + delta, PROT_READ | PROT_WRITE, + shared, fd, startpos - delta); if (addr == (void *) MAP_FAILED) sys_error(NO_ARG); + addr = (void *) ((uintnat) addr + delta); /* Build and return the Caml bigarray */ return alloc_bigarray(flags | BIGARRAY_MAPPED_FILE, num_dims, addr, dim); } #else -value bigarray_map_file(value vfd, value vkind, value vlayout, - value vshared, value vdim) +value caml_ba_map_file(value vfd, value vkind, value vlayout, + value vshared, value vdim, value vpos) { invalid_argument("Bigarray.map_file: not supported"); return Val_unit; @@ -108,10 +119,17 @@ value bigarray_map_file(value vfd, value vkind, value vlayout, #endif +CAMLprim value caml_ba_map_file_bytecode(value * argv, int argn) +{ + return caml_ba_map_file(argv[0], argv[1], argv[2], + argv[3], argv[4], argv[5]); +} -void bigarray_unmap_file(void * addr, uintnat len) +void caml_ba_unmap_file(void * addr, uintnat len) { #if defined(HAS_MMAP) - munmap(addr, len); + uintnat page = getpagesize(); + uintnat delta = (uintnat) addr % page; + munmap((void *)((uintnat)addr - delta), len + delta); #endif } diff --git a/otherlibs/bigarray/mmap_win32.c b/otherlibs/bigarray/mmap_win32.c index 1c0d8696..dde90068 100644 --- a/otherlibs/bigarray/mmap_win32.c +++ b/otherlibs/bigarray/mmap_win32.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: mmap_win32.c,v 1.5 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: mmap_win32.c,v 1.10 2006/10/01 15:40:28 xleroy Exp $ */ #include #include @@ -24,26 +24,42 @@ #include "sys.h" #include "unixsupport.h" -/* TODO: handle mappings larger than 2^32 bytes on Win64 */ +extern int caml_ba_element_size[]; /* from bigarray_stubs.c */ -extern int bigarray_element_size[]; /* from bigarray_stubs.c */ +static void caml_ba_sys_error(void); -static void bigarray_sys_error(void); +#ifndef INVALID_SET_FILE_POINTER +#define INVALID_SET_FILE_POINTER (-1) +#endif -CAMLprim value bigarray_map_file(value vfd, value vkind, value vlayout, - value vshared, value vdim) +static __int64 caml_ba_set_file_pointer(HANDLE h, __int64 dist, DWORD mode) +{ + LARGE_INTEGER i; + DWORD err; + + i.QuadPart = dist; + i.LowPart = SetFilePointer(h, i.LowPart, &i.HighPart, mode); + if (i.LowPart == INVALID_SET_FILE_POINTER) return -1; + return i.QuadPart; +} + +CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, + value vshared, value vdim, value vstart) { HANDLE fd, fmap; int flags, major_dim, mode, perm; intnat num_dims, i; intnat dim[MAX_NUM_DIMS]; - DWORD currpos, file_size; - uintnat array_size; + __int64 currpos, startpos, file_size, data_size; + uintnat array_size, page, delta; char c; void * addr; + LARGE_INTEGER li; + SYSTEM_INFO sysinfo; fd = Handle_val(vfd); flags = Int_val(vkind) | Int_val(vlayout); + startpos = Int64_val(vstart); num_dims = Wosize_val(vdim); major_dim = flags & BIGARRAY_FORTRAN_LAYOUT ? num_dims - 1 : 0; /* Extract dimensions from Caml array */ @@ -57,10 +73,10 @@ CAMLprim value bigarray_map_file(value vfd, value vkind, value vlayout, invalid_argument("Bigarray.create: negative dimension"); } /* Determine file size */ - currpos = SetFilePointer(fd, 0, NULL, FILE_CURRENT); - if (currpos == INVALID_SET_FILE_POINTER) bigarray_sys_error(); - file_size = SetFilePointer(fd, 0, NULL, FILE_END); - if (file_size == INVALID_SET_FILE_POINTER) bigarray_sys_error(); + currpos = caml_ba_set_file_pointer(fd, 0, FILE_CURRENT); + if (currpos == -1) caml_ba_sys_error(); + file_size = caml_ba_set_file_pointer(fd, 0, FILE_END); + if (file_size == -1) caml_ba_sys_error(); /* Determine array size in bytes (or size of array without the major dimension if that dimension wasn't specified) */ array_size = bigarray_element_size[flags & BIGARRAY_KIND_MASK]; @@ -69,13 +85,16 @@ CAMLprim value bigarray_map_file(value vfd, value vkind, value vlayout, /* Check if the first/last dimension is unknown */ if (dim[major_dim] == -1) { /* Determine first/last dimension from file size */ - if ((uintnat) file_size % array_size != 0) + if (file_size < startpos) + failwith("Bigarray.mmap: file position exceeds file size"); + data_size = file_size - startpos; + dim[major_dim] = (uintnat) (data_size / array_size); + array_size = dim[major_dim] * array_size; + if (array_size != data_size) failwith("Bigarray.mmap: file size doesn't match array dimensions"); - dim[major_dim] = (uintnat) file_size / array_size; - array_size = file_size; } /* Restore original file position */ - SetFilePointer(fd, currpos, NULL, FILE_BEGIN); + caml_ba_set_file_pointer(fd, currpos, FILE_BEGIN); /* Create the file mapping */ if (Bool_val(vshared)) { perm = PAGE_READWRITE; @@ -84,27 +103,45 @@ CAMLprim value bigarray_map_file(value vfd, value vkind, value vlayout, perm = PAGE_READONLY; /* doesn't work under Win98 */ mode = FILE_MAP_COPY; } - fmap = CreateFileMapping(fd, NULL, perm, 0, array_size, NULL); - if (fmap == NULL) bigarray_sys_error(); + li.QuadPart = startpos + array_size; + fmap = CreateFileMapping(fd, NULL, perm, li.HighPart, li.LowPart, NULL); + if (fmap == NULL) caml_ba_sys_error(); + /* Determine offset so that the mapping starts at the given file pos */ + GetSystemInfo(&sysinfo); + delta = (uintnat) (startpos % sysinfo.dwPageSize); /* Map the mapping in memory */ - addr = MapViewOfFile(fmap, mode, 0, 0, array_size); - if (addr == NULL) bigarray_sys_error(); + li.QuadPart = startpos - delta; + addr = + MapViewOfFile(fmap, mode, li.HighPart, li.LowPart, array_size + delta); + if (addr == NULL) caml_ba_sys_error(); + addr = (void *) ((uintnat) addr + delta); /* Close the file mapping */ CloseHandle(fmap); /* Build and return the Caml bigarray */ return alloc_bigarray(flags | BIGARRAY_MAPPED_FILE, num_dims, addr, dim); } -void bigarray_unmap_file(void * addr, uintnat len) +CAMLprim value caml_ba_map_file_bytecode(value * argv, int argn) { - UnmapViewOfFile(addr); + return caml_ba_map_file(argv[0], argv[1], argv[2], + argv[3], argv[4], argv[5]); } -static void bigarray_sys_error(void) +void caml_ba_unmap_file(void * addr, uintnat len) +{ + SYSTEM_INFO sysinfo; + uintnat delta; + + GetSystemInfo(&sysinfo); + delta = (uintnat) addr % sysinfo.dwPageSize; + UnmapViewOfFile((void *)((uintnat)addr - delta)); +} + +static void caml_ba_sys_error(void) { char buffer[512]; DWORD errnum; - + errnum = GetLastError(); if (!FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS, NULL, diff --git a/otherlibs/dbm/libmldbm.clib b/otherlibs/dbm/libmldbm.clib new file mode 100644 index 00000000..3a63b870 --- /dev/null +++ b/otherlibs/dbm/libmldbm.clib @@ -0,0 +1 @@ +cldbm.o diff --git a/otherlibs/dynlink/.depend b/otherlibs/dynlink/.depend index 864268db..1aa2131f 100644 --- a/otherlibs/dynlink/.depend +++ b/otherlibs/dynlink/.depend @@ -1,10 +1,8 @@ dynlink.cmo: ../../bytecomp/symtable.cmi ../../bytecomp/opcodes.cmo \ - ../../utils/misc.cmi ../../bytecomp/meta.cmi ../../bytecomp/emitcode.cmi \ - ../../bytecomp/dll.cmi ../../utils/consistbl.cmi ../../utils/config.cmi \ - dynlink.cmi + ../../utils/misc.cmi ../../bytecomp/meta.cmi ../../bytecomp/dll.cmi \ + ../../utils/consistbl.cmi ../../utils/config.cmi dynlink.cmi dynlink.cmx: ../../bytecomp/symtable.cmx ../../bytecomp/opcodes.cmx \ - ../../utils/misc.cmx ../../bytecomp/meta.cmx ../../bytecomp/emitcode.cmx \ - ../../bytecomp/dll.cmx ../../utils/consistbl.cmx ../../utils/config.cmx \ - dynlink.cmi + ../../utils/misc.cmx ../../bytecomp/meta.cmx ../../bytecomp/dll.cmx \ + ../../utils/consistbl.cmx ../../utils/config.cmx dynlink.cmi extract_crc.cmo: dynlink.cmi extract_crc.cmx: dynlink.cmx diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile index 9f674e36..f3562a4b 100644 --- a/otherlibs/dynlink/Makefile +++ b/otherlibs/dynlink/Makefile @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.29 2004/11/29 14:53:32 doligez Exp $ +# $Id: Makefile,v 1.31 2006/09/19 12:41:33 xleroy Exp $ # Makefile for the dynamic link library @@ -21,18 +21,33 @@ CAMLC=../../boot/ocamlrun ../../ocamlc INCLUDES=-I ../../utils -I ../../typing -I ../../bytecomp COMPFLAGS=-warn-error A -I ../../stdlib $(INCLUDES) -OBJS=dynlink.cmo -COMPILEROBJS=misc.cmo config.cmo tbl.cmo clflags.cmo consistbl.cmo \ - ident.cmo path.cmo \ - types.cmo btype.cmo predef.cmo runtimedef.cmo \ - bytesections.cmo dll.cmo meta.cmo symtable.cmo opcodes.cmo +OBJS=dynlinkaux.cmo dynlink.cmo + +COMPILEROBJS=\ + ../../utils/misc.cmo ../../utils/config.cmo ../../utils/clflags.cmo \ + ../../utils/tbl.cmo ../../utils/consistbl.cmo \ + ../../utils/terminfo.cmo ../../utils/warnings.cmo \ + ../../parsing/asttypes.cmi ../../parsing/linenum.cmo \ + ../../parsing/location.cmo ../../parsing/longident.cmo \ + ../../typing/ident.cmo ../../typing/path.cmo \ + ../../typing/primitive.cmo ../../typing/types.cmo \ + ../../typing/btype.cmo ../../typing/subst.cmo ../../typing/predef.cmo \ + ../../typing/datarepr.cmo ../../typing/env.cmo \ + ../../bytecomp/lambda.cmo ../../bytecomp/instruct.cmo \ + ../../bytecomp/cmo_format.cmi ../../bytecomp/opcodes.cmo \ + ../../bytecomp/runtimedef.cmo ../../bytecomp/bytesections.cmo \ + ../../bytecomp/dll.cmo ../../bytecomp/meta.cmo \ + ../../bytecomp/symtable.cmo all: dynlink.cma extract_crc allopt: dynlink.cma: $(OBJS) - $(CAMLC) $(COMPFLAGS) -a -o dynlink.cma $(COMPILEROBJS) $(OBJS) + $(CAMLC) $(COMPFLAGS) -a -o dynlink.cma $(OBJS) + +dynlinkaux.cmo dynlinkaux.cmi: $(COMPILEROBJS) + $(CAMLC) $(COMPFLAGS) -pack -o dynlinkaux.cmo $(COMPILEROBJS) extract_crc: dynlink.cma extract_crc.cmo $(CAMLC) $(COMPFLAGS) -o extract_crc dynlink.cma extract_crc.cmo @@ -56,6 +71,6 @@ clean: partialclean $(CAMLC) -c $(COMPFLAGS) $< depend: - ../../boot/ocamlrun ../../tools/ocamldep $(INCLUDES) *.mli *.ml >.depend -include .depend +dynlink.cmo: dynlinkaux.cmi dynlink.cmi +extract_crc.cmo: dynlink.cmi diff --git a/otherlibs/dynlink/Makefile.nt b/otherlibs/dynlink/Makefile.nt index c76027ab..12bc42e6 100644 --- a/otherlibs/dynlink/Makefile.nt +++ b/otherlibs/dynlink/Makefile.nt @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.14 2003/03/24 15:31:30 xleroy Exp $ +# $Id: Makefile.nt,v 1.16 2006/09/19 12:41:42 xleroy Exp $ # Makefile for the dynamic link library @@ -21,18 +21,33 @@ CAMLC=../../boot/ocamlrun ../../ocamlc INCLUDES=-I ../../utils -I ../../typing -I ../../bytecomp COMPFLAGS=-warn-error A -I ../../stdlib $(INCLUDES) -OBJS=dynlink.cmo -COMPILEROBJS=misc.cmo config.cmo tbl.cmo clflags.cmo consistbl.cmo \ - ident.cmo path.cmo \ - types.cmo btype.cmo predef.cmo runtimedef.cmo \ - bytesections.cmo dll.cmo symtable.cmo opcodes.cmo meta.cmo +OBJS=dynlinkaux.cmo dynlink.cmo + +COMPILEROBJS=\ + ../../utils/misc.cmo ../../utils/config.cmo ../../utils/clflags.cmo \ + ../../utils/tbl.cmo ../../utils/consistbl.cmo \ + ../../utils/terminfo.cmo ../../utils/warnings.cmo \ + ../../parsing/asttypes.cmi ../../parsing/linenum.cmo \ + ../../parsing/location.cmo ../../parsing/longident.cmo \ + ../../typing/ident.cmo ../../typing/path.cmo \ + ../../typing/primitive.cmo ../../typing/types.cmo \ + ../../typing/btype.cmo ../../typing/subst.cmo ../../typing/predef.cmo \ + ../../typing/datarepr.cmo ../../typing/env.cmo \ + ../../bytecomp/lambda.cmo ../../bytecomp/instruct.cmo \ + ../../bytecomp/cmo_format.cmi ../../bytecomp/opcodes.cmo \ + ../../bytecomp/runtimedef.cmo ../../bytecomp/bytesections.cmo \ + ../../bytecomp/dll.cmo ../../bytecomp/meta.cmo \ + ../../bytecomp/symtable.cmo all: dynlink.cma extract_crc allopt: dynlink.cma: $(OBJS) - $(CAMLC) $(COMPFLAGS) -a -o dynlink.cma $(COMPILEROBJS) $(OBJS) + $(CAMLC) $(COMPFLAGS) -a -o dynlink.cma $(OBJS) + +dynlinkaux.cmo dynlinkaux.cmi: $(COMPILEROBJS) + $(CAMLC) $(COMPFLAGS) -pack -o dynlinkaux.cmo $(COMPILEROBJS) extract_crc: dynlink.cma extract_crc.cmo $(CAMLC) $(COMPFLAGS) -o extract_crc dynlink.cma extract_crc.cmo @@ -57,6 +72,6 @@ clean: partialclean $(CAMLC) -c $(COMPFLAGS) $< depend: - ../../boot/ocamlrun ../../tools/ocamldep $(INCLUDES) *.mli *.ml >.depend -include .depend +dynlink.cmo: dynlinkaux.cmi dynlink.cmi +extract_crc.cmo: dynlink.cmi diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml index a64ac531..24e0e0ad 100644 --- a/otherlibs/dynlink/dynlink.ml +++ b/otherlibs/dynlink/dynlink.ml @@ -11,11 +11,12 @@ (* *) (***********************************************************************) -(* $Id: dynlink.ml,v 1.32 2004/11/29 02:27:25 garrigue Exp $ *) +(* $Id: dynlink.ml,v 1.34 2006/09/28 21:36:38 xleroy Exp $ *) (* Dynamic loading of .cmo files *) -open Emitcode +open Dynlinkaux +open Dynlinkaux.Cmo_format type linking_error = Undefined_global of string @@ -197,7 +198,8 @@ let loadfile file_name = seek_in ic toc_pos; let lib = (input_value ic : library) in begin try - Dll.open_dlls (List.map Dll.extract_dll_name lib.lib_dllibs) + Dll.open_dlls Dll.For_execution + (List.map Dll.extract_dll_name lib.lib_dllibs) with Failure reason -> raise(Error(Cannot_open_dll reason)) end; diff --git a/otherlibs/dynlink/dynlinkaux.mlpack b/otherlibs/dynlink/dynlinkaux.mlpack new file mode 100644 index 00000000..783e624a --- /dev/null +++ b/otherlibs/dynlink/dynlinkaux.mlpack @@ -0,0 +1,5 @@ +Misc Config Clflags Tbl Consistbl +Terminfo Warnings Asttypes Linenum Location Longident +Ident Path Primitive Types Btype Subst Predef +Datarepr Env Lambda Instruct Cmo_format Opcodes +Runtimedef Bytesections Dll Meta Symtable diff --git a/otherlibs/graph/.depend b/otherlibs/graph/.depend index fd9811c3..97fd3415 100644 --- a/otherlibs/graph/.depend +++ b/otherlibs/graph/.depend @@ -2,84 +2,136 @@ color.o: color.c libgraph.h \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h draw.o: draw.c libgraph.h \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h dump_img.o: dump_img.c libgraph.h \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h image.h ../../byterun/alloc.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h image.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h events.o: events.c libgraph.h \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/signals.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/signals.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h fill.o: fill.c libgraph.h \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h image.o: image.c libgraph.h \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h image.h ../../byterun/alloc.h \ - ../../byterun/custom.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h image.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/custom.h \ + ../../byterun/compatibility.h ../../byterun/mlvalues.h make_img.o: make_img.c libgraph.h \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h image.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h image.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h open.o: open.c libgraph.h \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/callback.h \ - ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/callback.h \ + ../../byterun/compatibility.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h point_col.o: point_col.c libgraph.h \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h sound.o: sound.c libgraph.h \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h subwindow.o: subwindow.c libgraph.h \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h text.o: text.c libgraph.h \ \ \ ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h graphics.cmo: graphics.cmi graphics.cmx: graphics.cmi graphicsX11.cmo: graphics.cmi graphicsX11.cmi diff --git a/otherlibs/graph/Makefile b/otherlibs/graph/Makefile index cc2eaf65..8fe421a9 100644 --- a/otherlibs/graph/Makefile +++ b/otherlibs/graph/Makefile @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.39 2005/08/13 20:59:37 doligez Exp $ +# $Id: Makefile,v 1.40 2007/01/29 12:11:16 xleroy Exp $ # Makefile for the portable graphics library @@ -22,7 +22,7 @@ CFLAGS=-I../../byterun $(X11_INCLUDES) -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) CAMLC=../../ocamlcomp.sh CAMLOPT=../../ocamlcompopt.sh MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-warn-error A +COMPFLAGS=-warn-error A -g OBJS=open.o draw.o fill.o color.o text.o \ image.o make_img.o dump_img.o point_col.o sound.o events.o \ diff --git a/otherlibs/graph/graphics.mllib b/otherlibs/graph/graphics.mllib new file mode 100644 index 00000000..d5e8f9eb --- /dev/null +++ b/otherlibs/graph/graphics.mllib @@ -0,0 +1 @@ +Graphics GraphicsX11 diff --git a/otherlibs/graph/libgraphics.clib b/otherlibs/graph/libgraphics.clib new file mode 100644 index 00000000..d3b5b7b6 --- /dev/null +++ b/otherlibs/graph/libgraphics.clib @@ -0,0 +1,3 @@ +open.o draw.o fill.o color.o text.o +image.o make_img.o dump_img.o point_col.o sound.o events.o +subwindow.o diff --git a/otherlibs/labltk/Changes b/otherlibs/labltk/Changes index bd671fdb..e98ed273 100644 --- a/otherlibs/labltk/Changes +++ b/otherlibs/labltk/Changes @@ -1,5 +1,9 @@ -version 1.0a1 +2005-12-20: +----------- +* Add Protocol.do_one_event and Protocol.do_pending. +2002-05-03: +----------- General Changes * Merging CamlTk and LablTk API interfaces * Activate and Deactivate Events are added diff --git a/otherlibs/labltk/browser/editor.ml b/otherlibs/labltk/browser/editor.ml index ac7b238a..1fffd3ba 100644 --- a/otherlibs/labltk/browser/editor.ml +++ b/otherlibs/labltk/browser/editor.ml @@ -12,7 +12,7 @@ (* *) (*************************************************************************) -(* $Id: editor.ml,v 1.40.14.2 2005/12/09 12:40:56 garrigue Exp $ *) +(* $Id: editor.ml,v 1.41 2006/01/04 16:55:50 doligez Exp $ *) open StdLabels open Tk diff --git a/otherlibs/labltk/browser/jg_menu.ml b/otherlibs/labltk/browser/jg_menu.ml index 9cb9a487..574708a6 100644 --- a/otherlibs/labltk/browser/jg_menu.ml +++ b/otherlibs/labltk/browser/jg_menu.ml @@ -12,7 +12,7 @@ (* *) (*************************************************************************) -(* $Id: jg_menu.ml,v 1.8.18.1 2005/12/09 12:29:55 garrigue Exp $ *) +(* $Id: jg_menu.ml,v 1.9 2006/01/04 16:55:50 doligez Exp $ *) open Tk diff --git a/otherlibs/labltk/browser/jglib.mllib b/otherlibs/labltk/browser/jglib.mllib new file mode 100644 index 00000000..5c254ff5 --- /dev/null +++ b/otherlibs/labltk/browser/jglib.mllib @@ -0,0 +1,13 @@ +Jg_tk +Jg_config +Jg_bind +Jg_completion +Jg_box +Jg_button +Jg_toplevel +Jg_text +Jg_message +Jg_menu +Jg_entry +Jg_multibox +Jg_memo diff --git a/otherlibs/labltk/browser/main.ml b/otherlibs/labltk/browser/main.ml index f84d316a..653212b4 100644 --- a/otherlibs/labltk/browser/main.ml +++ b/otherlibs/labltk/browser/main.ml @@ -12,7 +12,7 @@ (* *) (*************************************************************************) -(* $Id: main.ml,v 1.31.4.3 2006/01/25 06:28:19 garrigue Exp $ *) +(* $Id: main.ml,v 1.34 2006/04/16 23:28:21 doligez Exp $ *) open StdLabels module Unix = UnixLabels @@ -117,7 +117,7 @@ let _ = "points to the Objective Caml library." Config.standard_library) end; - + Searchpos.view_defined_ref := (fun s ~env -> Viewer.view_defined s ~env); Searchpos.editor_ref := Editor.f; @@ -126,7 +126,7 @@ let _ = (* bind top ~events:[`Destroy] ~action:(fun _ -> exit 0); *) at_exit Shell.kill_all; - + if !st then Viewer.st_viewer ~on:top () else Viewer.f ~on:top (); diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml index 4a5dd397..377143ee 100644 --- a/otherlibs/labltk/browser/searchpos.ml +++ b/otherlibs/labltk/browser/searchpos.ml @@ -12,7 +12,7 @@ (* *) (*************************************************************************) -(* $Id: searchpos.ml,v 1.48 2005/03/23 03:08:37 garrigue Exp $ *) +(* $Id: searchpos.ml,v 1.49 2006/04/05 02:28:13 garrigue Exp $ *) open StdLabels open Support @@ -141,9 +141,8 @@ let rec search_pos_class_type cl ~pos ~env = List.iter cfl ~f: begin function Pctf_inher cty -> search_pos_class_type cty ~pos ~env - | Pctf_val (_, _, Some ty, loc) -> + | Pctf_val (_, _, _, ty, loc) -> if in_loc loc ~pos then search_pos_type ty ~pos ~env - | Pctf_val _ -> () | Pctf_virt (_, _, ty, loc) -> if in_loc loc ~pos then search_pos_type ty ~pos ~env | Pctf_meth (_, _, ty, loc) -> @@ -675,7 +674,7 @@ let rec search_pos_structure ~pos str = | Tstr_modtype _ -> () | Tstr_open _ -> () | Tstr_class l -> - List.iter l ~f:(fun (id, _, _, cl) -> search_pos_class_expr cl ~pos) + List.iter l ~f:(fun (id, _, _, cl, _) -> search_pos_class_expr cl ~pos) | Tstr_cltype _ -> () | Tstr_include (m, _) -> search_pos_module_expr m ~pos end @@ -685,7 +684,8 @@ and search_pos_class_structure ~pos cls = begin function Cf_inher (cl, _, _) -> search_pos_class_expr cl ~pos - | Cf_val (_, _, exp) -> search_pos_expr exp ~pos + | Cf_val (_, _, Some exp, _) -> search_pos_expr exp ~pos + | Cf_val _ -> () | Cf_meth (_, exp) -> search_pos_expr exp ~pos | Cf_let (_, pel, iel) -> List.iter pel ~f: diff --git a/otherlibs/labltk/browser/shell.ml b/otherlibs/labltk/browser/shell.ml index 2f86e195..4afec1e6 100644 --- a/otherlibs/labltk/browser/shell.ml +++ b/otherlibs/labltk/browser/shell.ml @@ -12,7 +12,7 @@ (* *) (*************************************************************************) -(* $Id: shell.ml,v 1.39.16.1 2005/12/09 12:29:55 garrigue Exp $ *) +(* $Id: shell.ml,v 1.41 2006/01/18 13:26:03 garrigue Exp $ *) open StdLabels module Unix = UnixLabels @@ -152,7 +152,7 @@ object (self) if reading then reading <- false else Text.mark_set textw ~mark:"input" ~index:(`Mark"insert",[`Linestart;`Char 1]); - Text.mark_set textw ~mark:"insert"~index:(`Mark"insert",[`Line 1]); + Text.mark_set textw ~mark:"insert" ~index:(`Mark"insert",[`Lineend]); self#lex ~start:(`Mark"input",[`Linestart]) (); let s = (* input is one character before real input *) diff --git a/otherlibs/labltk/browser/viewer.ml b/otherlibs/labltk/browser/viewer.ml index ea3f9e37..1c1ba14b 100644 --- a/otherlibs/labltk/browser/viewer.ml +++ b/otherlibs/labltk/browser/viewer.ml @@ -12,7 +12,7 @@ (* *) (*************************************************************************) -(* $Id: viewer.ml,v 1.32.4.1 2005/12/09 12:29:55 garrigue Exp $ *) +(* $Id: viewer.ml,v 1.33 2006/01/04 16:55:50 doligez Exp $ *) open StdLabels open Tk diff --git a/otherlibs/labltk/camltk/byte.itarget b/otherlibs/labltk/camltk/byte.itarget new file mode 100644 index 00000000..1b841bec --- /dev/null +++ b/otherlibs/labltk/camltk/byte.itarget @@ -0,0 +1,9 @@ +cPlace.cmo cResource.cmo cWm.cmo cImagephoto.cmo cCanvas.cmo cButton.cmo +cText.cmo cLabel.cmo cScrollbar.cmo cImage.cmo cEncoding.cmo cPixmap.cmo +cPalette.cmo cFont.cmo cMessage.cmo cMenu.cmo cEntry.cmo cListbox.cmo +cFocus.cmo cMenubutton.cmo cPack.cmo cOption.cmo cToplevel.cmo cFrame.cmo +cDialog.cmo cImagebitmap.cmo cClipboard.cmo cRadiobutton.cmo cTkwait.cmo +cGrab.cmo cSelection.cmo cScale.cmo cOptionmenu.cmo cWinfo.cmo cGrid.cmo +cCheckbutton.cmo cBell.cmo cTkvars.cmo + +cTk.cmo camltk.cmo diff --git a/otherlibs/labltk/camltk/native.itarget b/otherlibs/labltk/camltk/native.itarget new file mode 100644 index 00000000..9c589f1f --- /dev/null +++ b/otherlibs/labltk/camltk/native.itarget @@ -0,0 +1,7 @@ +cPlace.cmx cResource.cmx cWm.cmx cImagephoto.cmx cCanvas.cmx cButton.cmx +cText.cmx cLabel.cmx cScrollbar.cmx cImage.cmx cEncoding.cmx cPixmap.cmx +cPalette.cmx cFont.cmx cMessage.cmx cMenu.cmx cEntry.cmx cListbox.cmx +cFocus.cmx cMenubutton.cmx cPack.cmx cOption.cmx cToplevel.cmx cFrame.cmx +cDialog.cmx cImagebitmap.cmx cClipboard.cmx cRadiobutton.cmx cTkwait.cmx +cGrab.cmx cSelection.cmx cScale.cmx cOptionmenu.cmx cWinfo.cmx cGrid.cmx +cCheckbutton.cmx cBell.cmx cTkvars.cmx diff --git a/otherlibs/labltk/frx/frxlib.mllib b/otherlibs/labltk/frx/frxlib.mllib new file mode 100644 index 00000000..3641ae5f --- /dev/null +++ b/otherlibs/labltk/frx/frxlib.mllib @@ -0,0 +1,4 @@ +Frx_misc Frx_widget Frx_font Frx_entry Frx_text +Frx_listbox Frx_req Frx_fillbox Frx_focus +Frx_dialog Frx_mem Frx_rpc Frx_synth Frx_selection +Frx_after Frx_fit Frx_ctext Frx_color diff --git a/otherlibs/labltk/jpf/jpflib.mllib b/otherlibs/labltk/jpf/jpflib.mllib new file mode 100644 index 00000000..6a04d147 --- /dev/null +++ b/otherlibs/labltk/jpf/jpflib.mllib @@ -0,0 +1 @@ +Fileselect Balloon Shell Jpf_font diff --git a/otherlibs/labltk/labltk/byte.itarget b/otherlibs/labltk/labltk/byte.itarget new file mode 100644 index 00000000..1f061ac1 --- /dev/null +++ b/otherlibs/labltk/labltk/byte.itarget @@ -0,0 +1,8 @@ +place.cmo wm.cmo imagephoto.cmo canvas.cmo button.cmo text.cmo label.cmo +scrollbar.cmo image.cmo encoding.cmo pixmap.cmo palette.cmo font.cmo +message.cmo menu.cmo entry.cmo listbox.cmo focus.cmo menubutton.cmo pack.cmo +option.cmo toplevel.cmo frame.cmo dialog.cmo imagebitmap.cmo clipboard.cmo +radiobutton.cmo tkwait.cmo grab.cmo selection.cmo scale.cmo optionmenu.cmo +winfo.cmo grid.cmo checkbutton.cmo bell.cmo tkvars.cmo + +tk.cmo labltk.cmo diff --git a/otherlibs/labltk/labltk/native.itarget b/otherlibs/labltk/labltk/native.itarget new file mode 100644 index 00000000..4bdc92c4 --- /dev/null +++ b/otherlibs/labltk/labltk/native.itarget @@ -0,0 +1,6 @@ +place.cmx wm.cmx imagephoto.cmx canvas.cmx button.cmx text.cmx label.cmx +scrollbar.cmx image.cmx encoding.cmx pixmap.cmx palette.cmx font.cmx +message.cmx menu.cmx entry.cmx listbox.cmx focus.cmx menubutton.cmx pack.cmx +option.cmx toplevel.cmx frame.cmx dialog.cmx imagebitmap.cmx clipboard.cmx +radiobutton.cmx tkwait.cmx grab.cmx selection.cmx scale.cmx optionmenu.cmx +winfo.cmx grid.cmx checkbutton.cmx bell.cmx tkvars.cmx diff --git a/otherlibs/labltk/support/Makefile.common b/otherlibs/labltk/support/Makefile.common index 7e8bfadb..b8aa786f 100644 --- a/otherlibs/labltk/support/Makefile.common +++ b/otherlibs/labltk/support/Makefile.common @@ -20,7 +20,7 @@ CAMLYACC=$(TOPDIR)/boot/ocamlyacc -v CAMLLEX=$(CAMLRUN) $(TOPDIR)/boot/ocamllex CAMLLIBR=$(CAMLC) -a CAMLDEP=$(CAMLRUN) $(TOPDIR)/tools/ocamldep -COMPFLAGS= +COMPFLAGS=-g LINKFLAGS= CAMLOPTLIBR=$(CAMLOPT) -a MKLIB=$(CAMLRUN) $(TOPDIR)/tools/ocamlmklib diff --git a/otherlibs/labltk/support/byte.itarget b/otherlibs/labltk/support/byte.itarget new file mode 100644 index 00000000..6f31e017 --- /dev/null +++ b/otherlibs/labltk/support/byte.itarget @@ -0,0 +1,3 @@ +support.cmo rawwidget.cmo widget.cmo protocol.cmo +textvariable.cmo timer.cmo fileevent.cmo camltkwrap.cmo +tkthread.cmo diff --git a/otherlibs/labltk/support/liblabltk.clib b/otherlibs/labltk/support/liblabltk.clib new file mode 100644 index 00000000..0a127dc9 --- /dev/null +++ b/otherlibs/labltk/support/liblabltk.clib @@ -0,0 +1,2 @@ +cltkCaml.o cltkUtf.o cltkEval.o cltkEvent.o cltkFile.o cltkMain.o +cltkMisc.o cltkTimer.o cltkVar.o cltkWait.o cltkImg.o diff --git a/otherlibs/labltk/support/native.itarget b/otherlibs/labltk/support/native.itarget new file mode 100644 index 00000000..2d2ef8d1 --- /dev/null +++ b/otherlibs/labltk/support/native.itarget @@ -0,0 +1,3 @@ +support.cmx rawwidget.cmx widget.cmx protocol.cmx +textvariable.cmx timer.cmx fileevent.cmx camltkwrap.cmx +tkthread.cmx diff --git a/otherlibs/labltk/support/protocol.ml b/otherlibs/labltk/support/protocol.ml index 14df7aec..79a103c8 100644 --- a/otherlibs/labltk/support/protocol.ml +++ b/otherlibs/labltk/support/protocol.ml @@ -14,7 +14,7 @@ (* *) (***********************************************************************) -(* $Id: protocol.ml,v 1.20 2002/07/23 14:11:59 doligez Exp $ *) +(* $Id: protocol.ml,v 1.21 2005/12/21 05:29:08 garrigue Exp $ *) open Support open Widget @@ -51,6 +51,12 @@ external finalizeTk : unit -> unit let tcl_command s = ignore (tcl_eval s);; +type event_flag = + DONT_WAIT | X_EVENTS | FILE_EVENTS | TIMER_EVENTS | IDLE_EVENTS | ALL_EVENTS +external do_one_event : event_flag list -> bool = "camltk_dooneevent" + +let do_pending () = while do_one_event [DONT_WAIT] do () done + exception TkError of string (* Raised by the communication functions *) let () = Callback.register_exception "tkerror" (TkError "") @@ -176,15 +182,9 @@ let dispatch_callback id args = let protected_dispatch id args = try dispatch_callback id args - with - | e -> - try - Printf.eprintf "Uncaught exception: %s\n" (Printexc.to_string e); - flush stderr; - (* raise x *) - with - Out_of_memory -> raise Out_of_memory - | Sys.Break -> raise Sys.Break + with e -> + Printf.eprintf "Uncaught exception: %s\n" (Printexc.to_string e); + flush stderr let _ = Callback.register "camlcb" protected_dispatch diff --git a/otherlibs/labltk/support/protocol.mli b/otherlibs/labltk/support/protocol.mli index 870339c0..1e419115 100644 --- a/otherlibs/labltk/support/protocol.mli +++ b/otherlibs/labltk/support/protocol.mli @@ -14,7 +14,7 @@ (* *) (***********************************************************************) -(* $Id: protocol.mli,v 1.11 2002/05/03 12:56:59 furuse Exp $ *) +(* $Id: protocol.mli,v 1.12 2005/12/21 05:29:08 garrigue Exp $ *) open Widget @@ -73,6 +73,15 @@ val finalizeTk : unit -> unit called when you call [Pervasives.exit ()] *) val mainLoop : unit -> unit + (* Start the event loop *) + +type event_flag = + DONT_WAIT | X_EVENTS | FILE_EVENTS | TIMER_EVENTS | IDLE_EVENTS | ALL_EVENTS +val do_one_event : event_flag list -> bool + (* Process a single event *) +val do_pending : unit -> unit + (* Process all pending events, without waiting. + This lets you use Tk from the toplevel, for instance. *) (* Direct evaluation of tcl code *) diff --git a/otherlibs/labltk/tkanim/libtkanim.clib b/otherlibs/labltk/tkanim/libtkanim.clib new file mode 100644 index 00000000..0db9d169 --- /dev/null +++ b/otherlibs/labltk/tkanim/libtkanim.clib @@ -0,0 +1 @@ +cltkaniminit.o tkAnimGIF.o diff --git a/otherlibs/num/.depend b/otherlibs/num/.depend index 24e2f837..6fa1caf7 100644 --- a/otherlibs/num/.depend +++ b/otherlibs/num/.depend @@ -1,5 +1,6 @@ -bng.o: bng.c bng.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/compatibility.h bng_ppc.c bng_digit.c +bng.o: bng.c bng.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h bng_ia32.c \ + bng_digit.c bng_alpha.o: bng_alpha.c bng_amd64.o: bng_amd64.c bng_digit.o: bng_digit.c @@ -9,11 +10,23 @@ bng_ppc.o: bng_ppc.c bng_sparc.o: bng_sparc.c nat_stubs.o: nat_stubs.c ../../byterun/alloc.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/mlvalues.h ../../byterun/custom.h ../../byterun/intext.h \ - ../../byterun/io.h ../../byterun/fix_code.h ../../byterun/fail.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h bng.h nat.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/misc.h ../../byterun/custom.h \ + ../../byterun/compatibility.h ../../byterun/mlvalues.h \ + ../../byterun/intext.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/io.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fix_code.h \ + ../../byterun/config.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h bng.h nat.h big_int.cmi: nat.cmi num.cmi: ratio.cmi nat.cmi big_int.cmi ratio.cmi: nat.cmi big_int.cmi diff --git a/otherlibs/num/Makefile b/otherlibs/num/Makefile index a7f2e155..cb461bab 100644 --- a/otherlibs/num/Makefile +++ b/otherlibs/num/Makefile @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.34 2005/01/21 14:15:44 maranget Exp $ +# $Id: Makefile,v 1.35 2007/01/29 12:11:16 xleroy Exp $ # Makefile for the "num" (exact rational arithmetic) library @@ -24,7 +24,7 @@ CFLAGS=-O -I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) \ CAMLC=../../ocamlcomp.sh CAMLOPT=../../ocamlcompopt.sh MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-warn-error A +COMPFLAGS=-warn-error A -g CAMLOBJS=int_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \ ratio.cmo num.cmo arith_status.cmo diff --git a/otherlibs/num/Makefile.nt b/otherlibs/num/Makefile.nt index 8347e46b..22a4f536 100644 --- a/otherlibs/num/Makefile.nt +++ b/otherlibs/num/Makefile.nt @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.19 2005/03/24 17:20:53 doligez Exp $ +# $Id: Makefile.nt,v 1.21 2007/01/29 12:11:16 xleroy Exp $ # Makefile for the "num" (exact rational arithmetic) library @@ -19,10 +19,11 @@ include ../../config/Makefile # Compilation options CC=$(BYTECC) -CFLAGS=-O -I../../byterun \ +CFLAGS=-I../../byterun \ -DBNG_ARCH_$(BNG_ARCH) -DBNG_ASM_LEVEL=$(BNG_ASM_LEVEL) CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../boot -w s CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -w s +COMPFLAGS=-warn-error A -g CAMLOBJS=int_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \ ratio.cmo num.cmo arith_status.cmo diff --git a/otherlibs/num/bng_ppc.c b/otherlibs/num/bng_ppc.c index 3820f3fb..0b4b5c7d 100644 --- a/otherlibs/num/bng_ppc.c +++ b/otherlibs/num/bng_ppc.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: bng_ppc.c,v 1.2 2003/10/27 08:41:46 xleroy Exp $ */ +/* $Id: bng_ppc.c,v 1.3 2006/05/31 08:16:34 xleroy Exp $ */ /* Code specific to the PowerPC architecture. */ @@ -79,8 +79,16 @@ : "=&r" (res), "=&r" (carryaccu) \ : "r" (arg1), "r" (arg2), "r" (arg3), "1" (carryaccu)) +#ifdef __ppc64__ +#define BngMult(resh,resl,arg1,arg2) \ + asm("mulld %0, %2, %3 \n\t" \ + "mulhdu %1, %2, %3" \ + : "=&r" (resl), "=r" (resh) \ + : "r" (arg1), "r" (arg2)) +#else #define BngMult(resh,resl,arg1,arg2) \ asm("mullw %0, %2, %3 \n\t" \ "mulhwu %1, %2, %3" \ : "=&r" (resl), "=r" (resh) \ : "r" (arg1), "r" (arg2)) +#endif \ No newline at end of file diff --git a/otherlibs/num/dllnums.dlib b/otherlibs/num/dllnums.dlib new file mode 100644 index 00000000..e54aa8e2 --- /dev/null +++ b/otherlibs/num/dllnums.dlib @@ -0,0 +1 @@ +bng.d.o nat_stubs.d.o diff --git a/otherlibs/num/libnums.clib b/otherlibs/num/libnums.clib new file mode 100644 index 00000000..47c751f5 --- /dev/null +++ b/otherlibs/num/libnums.clib @@ -0,0 +1 @@ +bng.o nat_stubs.o diff --git a/otherlibs/num/nums.mllib b/otherlibs/num/nums.mllib new file mode 100644 index 00000000..8db16838 --- /dev/null +++ b/otherlibs/num/nums.mllib @@ -0,0 +1 @@ +Int_misc Nat Big_int Arith_flags Ratio Num Arith_status diff --git a/otherlibs/str/.depend b/otherlibs/str/.depend index 782f7c48..43b299de 100644 --- a/otherlibs/str/.depend +++ b/otherlibs/str/.depend @@ -1,7 +1,16 @@ strstubs.o: strstubs.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/alloc.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h str.cmo: str.cmi str.cmx: str.cmi diff --git a/otherlibs/str/Makefile b/otherlibs/str/Makefile index 2436fe6f..06a59306 100644 --- a/otherlibs/str/Makefile +++ b/otherlibs/str/Makefile @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.33 2004/11/29 14:53:32 doligez Exp $ +# $Id: Makefile,v 1.34 2007/01/29 12:11:16 xleroy Exp $ # Makefile for the str library @@ -22,7 +22,7 @@ CC=$(BYTECC) CFLAGS=-O -I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) CAMLC=../../ocamlcomp.sh CAMLOPT=../../ocamlcompopt.sh -COMPFLAGS=-warn-error A +COMPFLAGS=-warn-error A -g COBJS=strstubs.o MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib diff --git a/otherlibs/str/Makefile.nt b/otherlibs/str/Makefile.nt index dae8e5e2..1fce47ca 100644 --- a/otherlibs/str/Makefile.nt +++ b/otherlibs/str/Makefile.nt @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.14 2002/12/09 14:05:18 xleroy Exp $ +# $Id: Makefile.nt,v 1.15 2007/01/29 12:11:16 xleroy Exp $ # Makefile for the str library @@ -22,6 +22,7 @@ CC=$(BYTECC) CFLAGS=-I../../byterun CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../boot CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib +COMPFLAGS=-warn-error A -g DCOBJS=strstubs.$(DO) SCOBJS=strstubs.$(SO) diff --git a/otherlibs/str/dllstr.dlib b/otherlibs/str/dllstr.dlib new file mode 100644 index 00000000..0c346262 --- /dev/null +++ b/otherlibs/str/dllstr.dlib @@ -0,0 +1 @@ +strstubs.d.o diff --git a/otherlibs/str/libstr.clib b/otherlibs/str/libstr.clib new file mode 100644 index 00000000..319e7601 --- /dev/null +++ b/otherlibs/str/libstr.clib @@ -0,0 +1 @@ +strstubs.o diff --git a/otherlibs/str/str.ml b/otherlibs/str/str.ml index eeda9371..e4abb0b0 100644 --- a/otherlibs/str/str.ml +++ b/otherlibs/str/str.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: str.ml,v 1.19.10.1 2005/11/07 15:59:04 doligez Exp $ *) +(* $Id: str.ml,v 1.20 2006/01/04 16:55:50 doligez Exp $ *) (** String utilities *) diff --git a/otherlibs/systhreads/.depend b/otherlibs/systhreads/.depend index 694395ac..4f4e3162 100644 --- a/otherlibs/systhreads/.depend +++ b/otherlibs/systhreads/.depend @@ -1,19 +1,27 @@ posix.o: posix.c ../../byterun/alloc.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/mlvalues.h ../../byterun/backtrace.h \ - ../../byterun/callback.h ../../byterun/custom.h ../../byterun/fail.h \ - ../../byterun/io.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/printexc.h ../../byterun/roots.h \ - ../../byterun/signals.h ../../byterun/stacks.h ../../byterun/sys.h -win32.o: win32.c ../../byterun/alloc.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/mlvalues.h ../../byterun/backtrace.h \ - ../../byterun/callback.h ../../byterun/custom.h ../../byterun/fail.h \ - ../../byterun/io.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/printexc.h ../../byterun/roots.h \ - ../../byterun/signals.h ../../byterun/stacks.h ../../byterun/sys.h + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/misc.h ../../byterun/backtrace.h \ + ../../byterun/mlvalues.h ../../byterun/callback.h \ + ../../byterun/compatibility.h ../../byterun/mlvalues.h \ + ../../byterun/custom.h ../../byterun/compatibility.h \ + ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/io.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/printexc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/roots.h \ + ../../byterun/misc.h ../../byterun/memory.h ../../byterun/signals.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/stacks.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/sys.h \ + ../../byterun/misc.h condition.cmi: mutex.cmi condition.cmo: mutex.cmi condition.cmi condition.cmx: mutex.cmx condition.cmi diff --git a/otherlibs/systhreads/Makefile b/otherlibs/systhreads/Makefile index e909afba..fcb34deb 100644 --- a/otherlibs/systhreads/Makefile +++ b/otherlibs/systhreads/Makefile @@ -11,14 +11,14 @@ # # ######################################################################### -# $Id: Makefile,v 1.37 2004/11/29 14:53:32 doligez Exp $ +# $Id: Makefile,v 1.40.4.1 2007/03/06 16:02:09 xleroy Exp $ include ../../config/Makefile CAMLC=../../ocamlcomp.sh -I ../unix CAMLOPT=../../ocamlcompopt.sh -I ../unix MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-warn-error A +COMPFLAGS=-warn-error A -g BYTECODE_C_OBJS=posix_b.o NATIVECODE_C_OBJS=posix_n.o @@ -55,7 +55,7 @@ threads.cma: $(THREAD_OBJS) # See remark above: force static linking of libthreadsnat.a threads.cmxa: $(THREAD_OBJS:.cmo=.cmx) $(CAMLOPT) -a -o threads.cmxa $(THREAD_OBJS:.cmo=.cmx) \ - -cclib -lthreadsnat -cclib -lunix -cclib "$(PTHREAD_LINK)" + -cclib -lthreadsnat -cclib -lunix $(PTHREAD_LINK) $(THREAD_OBJS:.cmo=.cmx): ../../ocamlopt @@ -90,13 +90,13 @@ installopt: $(CAMLC) -c $(COMPFLAGS) $< .ml.cmo: - $(CAMLC) -c -g $(COMPFLAGS) $< + $(CAMLC) -c $(COMPFLAGS) $< .ml.cmx: $(CAMLOPT) -c $(COMPFLAGS) $< depend: $(GENFILES) - gcc -MM -I../../byterun *.c > .depend + -gcc -MM -I../../byterun *.c > .depend ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend include .depend diff --git a/otherlibs/systhreads/Makefile.nt b/otherlibs/systhreads/Makefile.nt index b47954fd..69224b7d 100644 --- a/otherlibs/systhreads/Makefile.nt +++ b/otherlibs/systhreads/Makefile.nt @@ -11,13 +11,14 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.29 2002/06/27 11:36:02 xleroy Exp $ +# $Id: Makefile.nt,v 1.30 2007/01/29 12:11:17 xleroy Exp $ include ../../config/Makefile # Compilation options CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib -I ../win32unix CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -I ../win32unix +COMPFLAGS=-warn-error A -g THREAD_OBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo diff --git a/otherlibs/systhreads/dllthreads.dlib b/otherlibs/systhreads/dllthreads.dlib new file mode 100644 index 00000000..40686f64 --- /dev/null +++ b/otherlibs/systhreads/dllthreads.dlib @@ -0,0 +1 @@ +win32_b.d.o diff --git a/otherlibs/systhreads/event.mli b/otherlibs/systhreads/event.mli index 0e917efb..672fb78f 100644 --- a/otherlibs/systhreads/event.mli +++ b/otherlibs/systhreads/event.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: event.mli,v 1.9 2001/12/07 13:40:19 xleroy Exp $ *) +(* $Id: event.mli,v 1.10 2006/01/12 03:24:56 garrigue Exp $ *) (** First-class synchronous communication. @@ -27,7 +27,7 @@ type 'a channel val new_channel : unit -> 'a channel (** Return a new channel. *) -type 'a event +type +'a event (** The type of communication events returning a result of type ['a]. *) (** [send ch v] returns the event consisting in sending the value [v] diff --git a/otherlibs/systhreads/libthreads.clib b/otherlibs/systhreads/libthreads.clib new file mode 100644 index 00000000..111ec5ae --- /dev/null +++ b/otherlibs/systhreads/libthreads.clib @@ -0,0 +1 @@ +posix_b.o diff --git a/otherlibs/systhreads/libthreadswin32.clib b/otherlibs/systhreads/libthreadswin32.clib new file mode 100644 index 00000000..51b11a2d --- /dev/null +++ b/otherlibs/systhreads/libthreadswin32.clib @@ -0,0 +1 @@ +win32_b.o diff --git a/otherlibs/systhreads/posix.c b/otherlibs/systhreads/posix.c index d16a5396..d8f81f89 100644 --- a/otherlibs/systhreads/posix.c +++ b/otherlibs/systhreads/posix.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: posix.c,v 1.53.2.1 2006/03/22 13:13:45 xleroy Exp $ */ +/* $Id: posix.c,v 1.55 2007/01/29 12:11:17 xleroy Exp $ */ /* Thread interface for POSIX 1003.1c threads */ @@ -88,10 +88,10 @@ struct caml_thread_struct { value * trapsp; /* Saved value of trapsp for this thread */ struct caml__roots_block * local_roots; /* Saved value of local_roots */ struct longjmp_buffer * external_raise; /* Saved external_raise */ +#endif int backtrace_pos; /* Saved backtrace_pos */ code_t * backtrace_buffer; /* Saved backtrace_buffer */ value backtrace_last_exn; /* Saved backtrace_last_exn (root) */ -#endif }; typedef struct caml_thread_struct * caml_thread_t; @@ -147,9 +147,7 @@ static void caml_thread_scan_roots(scanning_action action) th = curr_thread; do { (*action)(th->descr, &th->descr); -#ifndef NATIVE_CODE (*action)(th->backtrace_last_exn, &th->backtrace_last_exn); -#endif /* Don't rescan the stack of the current thread, it was done already */ if (th != curr_thread) { #ifdef NATIVE_CODE @@ -186,10 +184,10 @@ static void caml_thread_enter_blocking_section(void) curr_thread->trapsp = trapsp; curr_thread->local_roots = local_roots; curr_thread->external_raise = external_raise; +#endif curr_thread->backtrace_pos = backtrace_pos; curr_thread->backtrace_buffer = backtrace_buffer; curr_thread->backtrace_last_exn = backtrace_last_exn; -#endif /* Tell other threads that the runtime is free */ pthread_mutex_lock(&caml_runtime_mutex); caml_runtime_busy = 0; @@ -226,10 +224,10 @@ static void caml_thread_leave_blocking_section(void) trapsp = curr_thread->trapsp; local_roots = curr_thread->local_roots; external_raise = curr_thread->external_raise; +#endif backtrace_pos = curr_thread->backtrace_pos; backtrace_buffer = curr_thread->backtrace_buffer; backtrace_last_exn = curr_thread->backtrace_last_exn; -#endif } static int caml_thread_try_leave_blocking_section(void) @@ -409,8 +407,8 @@ static void caml_thread_stop(void) #ifndef NATIVE_CODE /* Free the memory resources */ stat_free(th->stack_low); - if (th->backtrace_buffer != NULL) free(th->backtrace_buffer); #endif + if (th->backtrace_buffer != NULL) free(th->backtrace_buffer); /* Free the thread descriptor */ stat_free(th); } @@ -479,10 +477,10 @@ value caml_thread_new(value clos) /* ML */ th->trapsp = th->stack_high; th->local_roots = NULL; th->external_raise = NULL; +#endif th->backtrace_pos = 0; th->backtrace_buffer = NULL; th->backtrace_last_exn = Val_unit; -#endif /* Add thread info block to the list of threads */ th->next = curr_thread->next; th->prev = curr_thread; @@ -529,9 +527,7 @@ value caml_thread_uncaught_exception(value exn) /* ML */ fprintf(stderr, "Thread %d killed on uncaught exception %s\n", Int_val(Ident(curr_thread->descr)), msg); free(msg); -#ifndef NATIVE_CODE - if (backtrace_active) print_exception_backtrace(); -#endif + if (caml_backtrace_active) print_exception_backtrace(); fflush(stderr); return Val_unit; } diff --git a/otherlibs/systhreads/threads.mllib b/otherlibs/systhreads/threads.mllib new file mode 100644 index 00000000..3ff8841b --- /dev/null +++ b/otherlibs/systhreads/threads.mllib @@ -0,0 +1 @@ +Thread Mutex Condition Event ThreadUnix diff --git a/otherlibs/systhreads/win32.c b/otherlibs/systhreads/win32.c index 2fde4f77..77d8af3c 100644 --- a/otherlibs/systhreads/win32.c +++ b/otherlibs/systhreads/win32.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: win32.c,v 1.42.2.2 2006/03/22 13:13:45 xleroy Exp $ */ +/* $Id: win32.c,v 1.44 2006/04/16 23:28:21 doligez Exp $ */ /* Thread interface for Win32 threads */ diff --git a/otherlibs/threads/.depend b/otherlibs/threads/.depend index b9ebac47..37a41092 100644 --- a/otherlibs/threads/.depend +++ b/otherlibs/threads/.depend @@ -1,12 +1,26 @@ scheduler.o: scheduler.c ../../byterun/alloc.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/mlvalues.h ../../byterun/backtrace.h \ - ../../byterun/callback.h ../../byterun/fail.h ../../byterun/io.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h \ - ../../byterun/printexc.h ../../byterun/roots.h ../../byterun/signals.h \ - ../../byterun/stacks.h ../../byterun/sys.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/misc.h ../../byterun/backtrace.h ../../byterun/mlvalues.h \ + ../../byterun/callback.h ../../byterun/compatibility.h \ + ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/io.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/printexc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/roots.h \ + ../../byterun/misc.h ../../byterun/memory.h ../../byterun/signals.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/stacks.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/sys.h \ + ../../byterun/misc.h condition.cmi: mutex.cmi thread.cmi: unix.cmi threadUnix.cmi: unix.cmi diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile index aed0d374..d6c8a76c 100644 --- a/otherlibs/threads/Makefile +++ b/otherlibs/threads/Makefile @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.57 2004/11/29 14:53:32 doligez Exp $ +# $Id: Makefile,v 1.59 2007/02/16 09:54:55 ertai Exp $ include ../../config/Makefile @@ -82,14 +82,14 @@ marshal.mli: $(LIB)/marshal.mli marshal.cmi: $(LIB)/marshal.cmi ln -s $(LIB)/marshal.cmi marshal.cmi -unix.cmo: unix.mli unix.cmi unix.ml - $(CAMLC) ${COMPFLAGS} -c unix.ml - unix.mli: $(UNIXLIB)/unix.mli - ln -s $(UNIXLIB)/unix.mli unix.mli + ln -sf $(UNIXLIB)/unix.mli unix.mli unix.cmi: $(UNIXLIB)/unix.cmi - ln -s $(UNIXLIB)/unix.cmi unix.cmi + ln -sf $(UNIXLIB)/unix.cmi unix.cmi + +unix.cmo: unix.mli unix.cmi $(UNIXLIB)/unixLabels.cmo + $(CAMLC) ${COMPFLAGS} -c unix.ml partialclean: rm -f *.cm* diff --git a/otherlibs/threads/event.mli b/otherlibs/threads/event.mli index b3645564..07e1bc90 100644 --- a/otherlibs/threads/event.mli +++ b/otherlibs/threads/event.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: event.mli,v 1.14 2001/12/07 13:40:21 xleroy Exp $ *) +(* $Id: event.mli,v 1.15 2006/01/12 03:24:56 garrigue Exp $ *) (** First-class synchronous communication. @@ -27,7 +27,7 @@ type 'a channel val new_channel : unit -> 'a channel (** Return a new channel. *) -type 'a event +type +'a event (** The type of communication events returning a result of type ['a]. *) (** [send ch v] returns the event consisting in sending the value [v] diff --git a/otherlibs/threads/libvmthreads.clib b/otherlibs/threads/libvmthreads.clib new file mode 100644 index 00000000..0b4f31e5 --- /dev/null +++ b/otherlibs/threads/libvmthreads.clib @@ -0,0 +1 @@ +scheduler.o diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml index 74dd3222..cb8593eb 100644 --- a/otherlibs/threads/pervasives.ml +++ b/otherlibs/threads/pervasives.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: pervasives.ml,v 1.49 2004/07/13 12:25:13 xleroy Exp $ *) +(* $Id: pervasives.ml,v 1.52 2007/02/25 12:37:30 xleroy Exp $ *) (* Same as ../../stdlib/pervasives.ml, except that I/O functions have been redefined to not block the whole process, but only the calling @@ -231,18 +231,14 @@ external thread_wait_write_prim : Unix.file_descr -> unit = "thread_wait_write" let thread_wait_read fd = thread_wait_read_prim fd let thread_wait_write fd = thread_wait_write_prim fd -external inchan_ready : in_channel -> bool = "thread_inchan_ready" -external outchan_ready : out_channel -> int -> bool = "thread_outchan_ready" external descr_inchan : in_channel -> Unix.file_descr = "caml_channel_descriptor" external descr_outchan : out_channel -> Unix.file_descr = "caml_channel_descriptor" -let wait_inchan ic = - if not (inchan_ready ic) then thread_wait_read(descr_inchan ic) +let wait_inchan ic = thread_wait_read (descr_inchan ic) -let wait_outchan oc len = - if not (outchan_ready oc len) then thread_wait_write(descr_outchan oc) +let wait_outchan oc len = thread_wait_write (descr_outchan oc) (* General output functions *) @@ -496,24 +492,34 @@ module LargeFile = end (* Formats *) -type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 -external format_of_string : - ('a, 'b, 'c, 'd) format4 -> ('a, 'b, 'c, 'd) format4 = "%identity" -external string_of_format_sys : - ('a, 'b, 'c, 'd) format4 -> string = "%identity" -external string_to_format : string -> ('a, 'b, 'c, 'd) format4 = "%identity" +type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 -let (( ^^ ) : ('a, 'b, 'c, 'd) format4 -> ('d, 'b, 'c, 'e) format4 -> - ('a, 'b, 'c, 'e) format4) = fun fmt1 fmt2 -> - string_to_format (string_of_format_sys fmt1 ^ string_of_format_sys fmt2);; +type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 -let string_of_format f = - let s = string_of_format_sys f in +external format_of_string : + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" + +external format_to_string : + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string = "%identity" +external string_to_format : + string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" + +let (( ^^ ) : + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + ('f, 'b, 'c, 'e, 'g, 'h) format6 -> + ('a, 'b, 'c, 'd, 'g, 'h) format6) = + fun fmt1 fmt2 -> + string_to_format (format_to_string fmt1 ^ format_to_string fmt2);; + +let string_of_format fmt = + let s = format_to_string fmt in let l = string_length s in let r = string_create l in string_blit s 0 r 0 l; r + (* Miscellaneous *) external sys_exit : int -> 'a = "caml_sys_exit" diff --git a/otherlibs/threads/threads.mllib b/otherlibs/threads/threads.mllib new file mode 100644 index 00000000..3ff8841b --- /dev/null +++ b/otherlibs/threads/threads.mllib @@ -0,0 +1 @@ +Thread Mutex Condition Event ThreadUnix diff --git a/otherlibs/threads/unix.ml b/otherlibs/threads/unix.ml index 9ae91667..ed0f34a3 100644 --- a/otherlibs/threads/unix.ml +++ b/otherlibs/threads/unix.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: unix.ml,v 1.19 2005/03/24 17:20:53 doligez Exp $ *) +(* $Id: unix.ml,v 1.20 2006/09/21 13:54:26 xleroy Exp $ *) (* An alternate implementation of the Unix module from ../unix which is safe in conjunction with bytecode threads. *) @@ -274,6 +274,7 @@ type stats = external stat : string -> stats = "unix_stat" external lstat : string -> stats = "unix_lstat" external fstat : file_descr -> stats = "unix_fstat" +external isatty : file_descr -> bool = "unix_isatty" external unlink : string -> unit = "unix_unlink" external rename : string -> string -> unit = "unix_rename" external link : string -> string -> unit = "unix_link" diff --git a/otherlibs/threads/unix.mllib b/otherlibs/threads/unix.mllib new file mode 100644 index 00000000..8d569c56 --- /dev/null +++ b/otherlibs/threads/unix.mllib @@ -0,0 +1 @@ +Unix UnixLabels diff --git a/otherlibs/unix/.depend b/otherlibs/unix/.depend index 8f0685ae..b0ec6169 100644 --- a/otherlibs/unix/.depend +++ b/otherlibs/unix/.depend @@ -1,371 +1,788 @@ accept.o: accept.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/fail.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h \ - ../../byterun/signals.h unixsupport.h socketaddr.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h socketaddr.h access.o: access.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h addrofstr.o: addrofstr.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/fail.h \ - unixsupport.h socketaddr.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/fail.h ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h socketaddr.h alarm.o: alarm.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h unixsupport.h bind.o: bind.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/mlvalues.h unixsupport.h socketaddr.h + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/misc.h unixsupport.h socketaddr.h chdir.o: chdir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h unixsupport.h chmod.o: chmod.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h unixsupport.h chown.o: chown.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h unixsupport.h chroot.o: chroot.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h unixsupport.h close.o: close.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h unixsupport.h closedir.o: closedir.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h unixsupport.h connect.o: connect.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/mlvalues.h ../../byterun/signals.h \ - unixsupport.h socketaddr.h + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/misc.h ../../byterun/signals.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h socketaddr.h cst2constr.o: cst2constr.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/fail.h cst2constr.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/fail.h ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h cst2constr.h cstringv.o: cstringv.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/memory.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/gc.h ../../byterun/mlvalues.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/misc.h ../../byterun/minor_gc.h \ + ../../byterun/misc.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + unixsupport.h dup.o: dup.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h unixsupport.h dup2.o: dup2.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h unixsupport.h envir.o: envir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h errmsg.o: errmsg.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h execv.o: execv.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h execve.o: execve.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h execvp.o: execvp.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h exit.o: exit.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h unixsupport.h fchmod.o: fchmod.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/misc.h unixsupport.h fchown.o: fchown.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/misc.h unixsupport.h fcntl.o: fcntl.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/misc.h unixsupport.h fork.o: fork.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h unixsupport.h ftruncate.o: ftruncate.c ../../byterun/fail.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/mlvalues.h ../../byterun/io.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/misc.h ../../byterun/io.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h getaddrinfo.o: getaddrinfo.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ - cst2constr.h socketaddr.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/alloc.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h cst2constr.h socketaddr.h getcwd.o: getcwd.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/fail.h \ - unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h getegid.o: getegid.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h unixsupport.h geteuid.o: geteuid.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h unixsupport.h getgid.o: getgid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h unixsupport.h getgr.o: getgr.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/fail.h ../../byterun/alloc.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h getgroups.o: getgroups.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/fail.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/alloc.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h gethost.o: gethost.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ - socketaddr.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/alloc.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h socketaddr.h gethostname.o: gethostname.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/fail.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/alloc.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h getlogin.o: getlogin.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/alloc.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h getnameinfo.o: getnameinfo.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ - socketaddr.h -getpeername.o: getpeername.c ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/alloc.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/mlvalues.h unixsupport.h socketaddr.h +getpeername.o: getpeername.c ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/misc.h unixsupport.h socketaddr.h getpid.o: getpid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h unixsupport.h getppid.o: getppid.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h unixsupport.h getproto.o: getproto.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/alloc.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h getpw.o: getpw.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h getserv.o: getserv.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/alloc.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h getsockname.o: getsockname.c ../../byterun/fail.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/mlvalues.h unixsupport.h socketaddr.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/misc.h unixsupport.h socketaddr.h gettimeofday.o: gettimeofday.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/fail.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/alloc.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h getuid.o: getuid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h unixsupport.h gmtime.o: gmtime.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/fail.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h +isatty.o: isatty.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h unixsupport.h itimer.o: itimer.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/fail.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h kill.o: kill.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/fail.h unixsupport.h \ - ../../byterun/signals.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h ../../byterun/signals.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h link.o: link.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h unixsupport.h listen.o: listen.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/misc.h unixsupport.h lockf.o: lockf.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/mlvalues.h ../../byterun/signals.h \ - unixsupport.h + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/misc.h ../../byterun/signals.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h lseek.o: lseek.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/io.h \ - unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/io.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h mkdir.o: mkdir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h unixsupport.h mkfifo.o: mkfifo.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/misc.h unixsupport.h nice.o: nice.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h unixsupport.h open.o: open.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h opendir.o: opendir.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/alloc.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h pipe.o: pipe.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h putenv.o: putenv.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/mlvalues.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h read.o: read.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h readdir.o: readdir.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/fail.h \ - ../../byterun/alloc.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/fail.h ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h readlink.o: readlink.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/fail.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/alloc.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h rename.o: rename.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h unixsupport.h rewinddir.o: rewinddir.c ../../byterun/fail.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/mlvalues.h unixsupport.h -rmdir.o: rmdir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ ../../byterun/misc.h unixsupport.h +rmdir.o: rmdir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h unixsupport.h select.o: select.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/fail.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h \ - ../../byterun/signals.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h sendrecv.o: sendrecv.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/fail.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ - socketaddr.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/alloc.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h socketaddr.h setgid.o: setgid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h unixsupport.h setsid.o: setsid.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/misc.h unixsupport.h setuid.o: setuid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h unixsupport.h shutdown.o: shutdown.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/misc.h unixsupport.h signals.o: signals.c ../../byterun/alloc.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/mlvalues.h ../../byterun/fail.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h \ - ../../byterun/signals.h unixsupport.h + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/misc.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h sleep.o: sleep.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/signals.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/signals.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h socket.o: socket.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/misc.h unixsupport.h socketaddr.o: socketaddr.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/alloc.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h \ socketaddr.h socketpair.o: socketpair.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/fail.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/alloc.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h sockopt.o: sockopt.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/fail.h unixsupport.h socketaddr.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/alloc.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h socketaddr.h stat.o: stat.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/alloc.h unixsupport.h \ - cst2constr.h ../../byterun/io.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h cst2constr.h ../../byterun/io.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h strofaddr.o: strofaddr.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/fail.h unixsupport.h socketaddr.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/alloc.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h socketaddr.h symlink.o: symlink.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/misc.h unixsupport.h termios.o: termios.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/fail.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/alloc.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h time.o: time.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h times.o: times.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \ - ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h unixsupport.h truncate.o: truncate.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/fail.h \ - ../../byterun/io.h unixsupport.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/fail.h ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/io.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h umask.o: umask.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h unixsupport.h unixsupport.o: unixsupport.c ../../byterun/mlvalues.h \ - ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ - ../../byterun/callback.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h \ - cst2constr.h + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/compatibility.h ../../byterun/config.h \ + ../../byterun/alloc.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/callback.h \ + ../../byterun/compatibility.h ../../byterun/mlvalues.h \ + ../../byterun/memory.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/gc.h ../../byterun/mlvalues.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/misc.h ../../byterun/minor_gc.h \ + ../../byterun/misc.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/fail.h ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h cst2constr.h unlink.o: unlink.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h unixsupport.h utimes.o: utimes.c ../../byterun/fail.h ../../byterun/compatibility.h \ - ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/mlvalues.h unixsupport.h + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/misc.h unixsupport.h wait.o: wait.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/fail.h \ - ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h \ - ../../byterun/signals.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/alloc.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/fail.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h write.o: write.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ - ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h + ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../byterun/memory.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../byterun/gc.h \ + ../../byterun/mlvalues.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/misc.h ../../byterun/mlvalues.h \ + ../../byterun/misc.h ../../byterun/minor_gc.h ../../byterun/misc.h \ + ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ + ../../byterun/compatibility.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h unixsupport.h unixLabels.cmi: unix.cmi unix.cmo: unix.cmi unix.cmx: unix.cmi diff --git a/otherlibs/unix/Makefile b/otherlibs/unix/Makefile index 52bd6116..c293eacc 100644 --- a/otherlibs/unix/Makefile +++ b/otherlibs/unix/Makefile @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.41 2004/11/29 14:53:32 doligez Exp $ +# $Id: Makefile,v 1.45 2007/02/07 15:49:11 doligez Exp $ # Makefile for the Unix interface library @@ -23,7 +23,7 @@ CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) CAMLC=../../ocamlcomp.sh CAMLOPT=../../ocamlcompopt.sh MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-warn-error A +COMPFLAGS=-warn-error A -g OBJS=accept.o access.o addrofstr.o alarm.o bind.o chdir.o chmod.o \ chown.o chroot.o close.o closedir.o connect.o cst2constr.o cstringv.o \ @@ -33,7 +33,7 @@ OBJS=accept.o access.o addrofstr.o alarm.o bind.o chdir.o chmod.o \ getgr.o getgroups.o gethost.o gethostname.o getlogin.o \ getnameinfo.o getpeername.o getpid.o getppid.o getproto.o getpw.o \ gettimeofday.o getserv.o getsockname.o getuid.o \ - gmtime.o itimer.o kill.o link.o listen.o lockf.o lseek.o mkdir.o \ + gmtime.o isatty.o itimer.o kill.o link.o listen.o lockf.o lseek.o mkdir.o \ mkfifo.o nice.o open.o opendir.o pipe.o putenv.o read.o \ readdir.o readlink.o rename.o rewinddir.o rmdir.o select.o sendrecv.o \ setgid.o setsid.o setuid.o shutdown.o signals.o \ @@ -70,6 +70,7 @@ install: cp libunix.a $(LIBDIR)/libunix.a cd $(LIBDIR); $(RANLIB) libunix.a cp unix.cma $(MLOBJS:.cmo=.cmi) $(MLOBJS:.cmo=.mli) $(LIBDIR) + cp unixsupport.h $(LIBDIR)/caml installopt: cp $(MLOBJS:.cmo=.cmx) unix.cmxa unix.a $(LIBDIR) diff --git a/otherlibs/unix/ftruncate.c b/otherlibs/unix/ftruncate.c index 44160d3f..8830ad73 100644 --- a/otherlibs/unix/ftruncate.c +++ b/otherlibs/unix/ftruncate.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: ftruncate.c,v 1.10 2005/03/24 17:20:53 doligez Exp $ */ +/* $Id: ftruncate.c,v 1.11 2007/02/09 13:31:15 doligez Exp $ */ #include #include @@ -43,4 +43,7 @@ CAMLprim value unix_ftruncate_64(value fd, value len) CAMLprim value unix_ftruncate(value fd, value len) { invalid_argument("ftruncate not implemented"); } +CAMLprim value unix_ftruncate_64(value fd, value len) +{ invalid_argument("ftruncate not implemented"); } + #endif diff --git a/otherlibs/unix/gethost.c b/otherlibs/unix/gethost.c index 54b060e7..e5be2594 100644 --- a/otherlibs/unix/gethost.c +++ b/otherlibs/unix/gethost.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: gethost.c,v 1.26.2.1 2006/06/10 09:10:41 xleroy Exp $ */ +/* $Id: gethost.c,v 1.27 2006/09/20 11:14:37 doligez Exp $ */ #include #include diff --git a/otherlibs/unix/isatty.c b/otherlibs/unix/isatty.c new file mode 100644 index 00000000..9d651aad --- /dev/null +++ b/otherlibs/unix/isatty.c @@ -0,0 +1,22 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Gallium, INRIA Rocquencourt */ +/* */ +/* Copyright 2006 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id: isatty.c,v 1.1 2006/09/21 13:54:26 xleroy Exp $ */ + +#include +#include "unixsupport.h" + +CAMLprim value unix_isatty(value fd) +{ + return (Val_bool(isatty(Int_val(fd)))); +} diff --git a/otherlibs/unix/libunix.clib b/otherlibs/unix/libunix.clib new file mode 100644 index 00000000..e6ce2d52 --- /dev/null +++ b/otherlibs/unix/libunix.clib @@ -0,0 +1,16 @@ +accept.o access.o addrofstr.o alarm.o bind.o chdir.o chmod.o +chown.o chroot.o close.o closedir.o connect.o cst2constr.o cstringv.o +dup.o dup2.o envir.o errmsg.o execv.o execve.o execvp.o exit.o +fchmod.o fchown.o fcntl.o fork.o ftruncate.o +getaddrinfo.o getcwd.o getegid.o geteuid.o getgid.o +getgr.o getgroups.o gethost.o gethostname.o getlogin.o +getnameinfo.o getpeername.o getpid.o getppid.o getproto.o getpw.o +gettimeofday.o getserv.o getsockname.o getuid.o +gmtime.o isatty.o itimer.o kill.o link.o listen.o lockf.o lseek.o mkdir.o +mkfifo.o nice.o open.o opendir.o pipe.o putenv.o read.o +readdir.o readlink.o rename.o rewinddir.o rmdir.o select.o sendrecv.o +setgid.o setsid.o setuid.o shutdown.o signals.o +sleep.o socket.o socketaddr.o +socketpair.o sockopt.o stat.o strofaddr.o symlink.o termios.o +time.o times.o truncate.o umask.o unixsupport.o unlink.o +utimes.o wait.o write.o diff --git a/otherlibs/unix/times.c b/otherlibs/unix/times.c index ab97cd4c..afa25278 100644 --- a/otherlibs/unix/times.c +++ b/otherlibs/unix/times.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: times.c,v 1.15.4.1 2006/01/24 13:44:08 doligez Exp $ */ +/* $Id: times.c,v 1.16 2006/04/16 23:28:21 doligez Exp $ */ #include #include diff --git a/otherlibs/unix/truncate.c b/otherlibs/unix/truncate.c index 727133db..75ac4602 100644 --- a/otherlibs/unix/truncate.c +++ b/otherlibs/unix/truncate.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: truncate.c,v 1.10 2005/03/24 17:20:53 doligez Exp $ */ +/* $Id: truncate.c,v 1.11 2007/02/09 13:31:15 doligez Exp $ */ #include #include @@ -43,4 +43,7 @@ CAMLprim value unix_truncate_64(value path, value len) CAMLprim value unix_truncate(value path, value len) { invalid_argument("truncate not implemented"); } +CAMLprim value unix_truncate_64(value path, value len) +{ invalid_argument("truncate not implemented"); } + #endif diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml index 19f303e8..d9be705a 100644 --- a/otherlibs/unix/unix.ml +++ b/otherlibs/unix/unix.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: unix.ml,v 1.65 2005/10/12 14:55:40 xleroy Exp $ *) +(* $Id: unix.ml,v 1.66 2006/09/21 13:54:26 xleroy Exp $ *) type error = E2BIG @@ -223,6 +223,7 @@ type stats = external stat : string -> stats = "unix_stat" external lstat : string -> stats = "unix_lstat" external fstat : file_descr -> stats = "unix_fstat" +external isatty : file_descr -> bool = "unix_isatty" external unlink : string -> unit = "unix_unlink" external rename : string -> string -> unit = "unix_rename" external link : string -> string -> unit = "unix_link" diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli index 7e4ef36d..28942c3c 100644 --- a/otherlibs/unix/unix.mli +++ b/otherlibs/unix/unix.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: unix.mli,v 1.81.4.2 2006/03/21 15:50:29 doligez Exp $ *) +(* $Id: unix.mli,v 1.85 2007/01/22 07:41:00 garrigue Exp $ *) (** Interface to the Unix system *) @@ -339,16 +339,19 @@ type stats = (** The informations returned by the {!Unix.stat} calls. *) val stat : string -> stats -(** Return the informations for the named file. *) +(** Return the information for the named file. *) val lstat : string -> stats (** Same as {!Unix.stat}, but in case the file is a symbolic link, - return the informations for the link itself. *) + return the information for the link itself. *) val fstat : file_descr -> stats -(** Return the informations for the file associated with the given +(** Return the information for the file associated with the given descriptor. *) +val isatty : file_descr -> bool +(** Return [true] if the given file descriptor refers to a terminal or + console window, [false] otherwise. *) (** {6 File operations on large files} *) diff --git a/otherlibs/unix/unix.mllib b/otherlibs/unix/unix.mllib new file mode 100644 index 00000000..8d569c56 --- /dev/null +++ b/otherlibs/unix/unix.mllib @@ -0,0 +1 @@ +Unix UnixLabels diff --git a/otherlibs/unix/unixLabels.mli b/otherlibs/unix/unixLabels.mli index 0232c173..d8749e63 100644 --- a/otherlibs/unix/unixLabels.mli +++ b/otherlibs/unix/unixLabels.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: unixLabels.mli,v 1.13 2004/07/13 12:25:14 xleroy Exp $ *) +(* $Id: unixLabels.mli,v 1.15 2007/01/22 07:41:00 garrigue Exp $ *) (** Interface to the Unix system. To use as replacement to default {!Unix} module, @@ -20,82 +20,81 @@ (** {6 Error report} *) -type error = - Unix.error = - E2BIG (** Argument list too long *) - | EACCES (** Permission denied *) - | EAGAIN (** Resource temporarily unavailable; try again *) - | EBADF (** Bad file descriptor *) - | EBUSY (** Resource unavailable *) - | ECHILD (** No child process *) - | EDEADLK (** Resource deadlock would occur *) - | EDOM (** Domain error for math functions, etc. *) - | EEXIST (** File exists *) - | EFAULT (** Bad address *) - | EFBIG (** File too large *) - | EINTR (** Function interrupted by signal *) - | EINVAL (** Invalid argument *) - | EIO (** Hardware I/O error *) - | EISDIR (** Is a directory *) - | EMFILE (** Too many open files by the process *) - | EMLINK (** Too many links *) - | ENAMETOOLONG (** Filename too long *) - | ENFILE (** Too many open files in the system *) - | ENODEV (** No such device *) - | ENOENT (** No such file or directory *) - | ENOEXEC (** Not an executable file *) - | ENOLCK (** No locks available *) - | ENOMEM (** Not enough memory *) - | ENOSPC (** No space left on device *) - | ENOSYS (** Function not supported *) - | ENOTDIR (** Not a directory *) - | ENOTEMPTY (** Directory not empty *) - | ENOTTY (** Inappropriate I/O control operation *) - | ENXIO (** No such device or address *) - | EPERM (** Operation not permitted *) - | EPIPE (** Broken pipe *) - | ERANGE (** Result too large *) - | EROFS (** Read-only file system *) - | ESPIPE (** Invalid seek e.g. on a pipe *) - | ESRCH (** No such process *) - | EXDEV (** Invalid link *) - - | EWOULDBLOCK (** Operation would block *) - | EINPROGRESS (** Operation now in progress *) - | EALREADY (** Operation already in progress *) - | ENOTSOCK (** Socket operation on non-socket *) - | EDESTADDRREQ (** Destination address required *) - | EMSGSIZE (** Message too long *) - | EPROTOTYPE (** Protocol wrong type for socket *) - | ENOPROTOOPT (** Protocol not available *) - | EPROTONOSUPPORT (** Protocol not supported *) - | ESOCKTNOSUPPORT (** Socket type not supported *) - | EOPNOTSUPP (** Operation not supported on socket *) - | EPFNOSUPPORT (** Protocol family not supported *) - | EAFNOSUPPORT (** Address family not supported by protocol family *) - | EADDRINUSE (** Address already in use *) - | EADDRNOTAVAIL (** Can't assign requested address *) - | ENETDOWN (** Network is down *) - | ENETUNREACH (** Network is unreachable *) - | ENETRESET (** Network dropped connection on reset *) - | ECONNABORTED (** Software caused connection abort *) - | ECONNRESET (** Connection reset by peer *) - | ENOBUFS (** No buffer space available *) - | EISCONN (** Socket is already connected *) - | ENOTCONN (** Socket is not connected *) - | ESHUTDOWN (** Can't send after socket shutdown *) - | ETOOMANYREFS (** Too many references: can't splice *) - | ETIMEDOUT (** Connection timed out *) - | ECONNREFUSED (** Connection refused *) - | EHOSTDOWN (** Host is down *) - | EHOSTUNREACH (** No route to host *) - | ELOOP (** Too many levels of symbolic links *) - | EOVERFLOW (** File size or position not representable *) - - | EUNKNOWNERR of int (** Unknown error *) -(** The type of error codes. + +type error = Unix.error = + E2BIG (** Argument list too long *) + | EACCES (** Permission denied *) + | EAGAIN (** Resource temporarily unavailable; try again *) + | EBADF (** Bad file descriptor *) + | EBUSY (** Resource unavailable *) + | ECHILD (** No child process *) + | EDEADLK (** Resource deadlock would occur *) + | EDOM (** Domain error for math functions, etc. *) + | EEXIST (** File exists *) + | EFAULT (** Bad address *) + | EFBIG (** File too large *) + | EINTR (** Function interrupted by signal *) + | EINVAL (** Invalid argument *) + | EIO (** Hardware I/O error *) + | EISDIR (** Is a directory *) + | EMFILE (** Too many open files by the process *) + | EMLINK (** Too many links *) + | ENAMETOOLONG (** Filename too long *) + | ENFILE (** Too many open files in the system *) + | ENODEV (** No such device *) + | ENOENT (** No such file or directory *) + | ENOEXEC (** Not an executable file *) + | ENOLCK (** No locks available *) + | ENOMEM (** Not enough memory *) + | ENOSPC (** No space left on device *) + | ENOSYS (** Function not supported *) + | ENOTDIR (** Not a directory *) + | ENOTEMPTY (** Directory not empty *) + | ENOTTY (** Inappropriate I/O control operation *) + | ENXIO (** No such device or address *) + | EPERM (** Operation not permitted *) + | EPIPE (** Broken pipe *) + | ERANGE (** Result too large *) + | EROFS (** Read-only file system *) + | ESPIPE (** Invalid seek e.g. on a pipe *) + | ESRCH (** No such process *) + | EXDEV (** Invalid link *) + | EWOULDBLOCK (** Operation would block *) + | EINPROGRESS (** Operation now in progress *) + | EALREADY (** Operation already in progress *) + | ENOTSOCK (** Socket operation on non-socket *) + | EDESTADDRREQ (** Destination address required *) + | EMSGSIZE (** Message too long *) + | EPROTOTYPE (** Protocol wrong type for socket *) + | ENOPROTOOPT (** Protocol not available *) + | EPROTONOSUPPORT (** Protocol not supported *) + | ESOCKTNOSUPPORT (** Socket type not supported *) + | EOPNOTSUPP (** Operation not supported on socket *) + | EPFNOSUPPORT (** Protocol family not supported *) + | EAFNOSUPPORT (** Address family not supported by protocol family *) + | EADDRINUSE (** Address already in use *) + | EADDRNOTAVAIL (** Can't assign requested address *) + | ENETDOWN (** Network is down *) + | ENETUNREACH (** Network is unreachable *) + | ENETRESET (** Network dropped connection on reset *) + | ECONNABORTED (** Software caused connection abort *) + | ECONNRESET (** Connection reset by peer *) + | ENOBUFS (** No buffer space available *) + | EISCONN (** Socket is already connected *) + | ENOTCONN (** Socket is not connected *) + | ESHUTDOWN (** Can't send after socket shutdown *) + | ETOOMANYREFS (** Too many references: can't splice *) + | ETIMEDOUT (** Connection timed out *) + | ECONNREFUSED (** Connection refused *) + | EHOSTDOWN (** Host is down *) + | EHOSTUNREACH (** No route to host *) + | ELOOP (** Too many levels of symbolic links *) + | EOVERFLOW (** File size or position not representable *) + + | EUNKNOWNERR of int (** Unknown error *) +(** The type of error codes. Errors defined in the POSIX standard - and additional errors, mostly BSD. + and additional errors from UNIX98 and BSD. All other errors are mapped to EUNKNOWNERR. *) @@ -133,34 +132,34 @@ val putenv : string -> string -> unit [name] is the name of the environment variable, and [value] its new associated value. *) + (** {6 Process handling} *) -type process_status = - Unix.process_status = - WEXITED of int - (** The process terminated normally by [exit]; + +type process_status = Unix.process_status = + WEXITED of int + (** The process terminated normally by [exit]; the argument is the return code. *) - | WSIGNALED of int + | WSIGNALED of int (** The process was killed by a signal; the argument is the signal number. *) - | WSTOPPED of int + | WSTOPPED of int (** The process was stopped by a signal; the argument is the signal number. *) (** The termination status of a process. *) -type wait_flag = - Unix.wait_flag = - WNOHANG (** do not block if no child has - died yet, but immediately return with a pid equal to 0.*) - | WUNTRACED (** report also the children that receive stop signals. *) -(** Flags for {!UnixLabels.waitpid}. *) +type wait_flag = Unix.wait_flag = + WNOHANG (** do not block if no child has + died yet, but immediately return with a pid equal to 0.*) + | WUNTRACED (** report also the children that receive stop signals. *) +(** Flags for {!Unix.waitpid}. *) val execv : prog:string -> args:string array -> 'a (** [execv prog args] execute the program in file [prog], with - the arguments [args], and the current process environment. - These [execv*] functions never return: on success, the current - program is replaced by the new one; + the arguments [args], and the current process environment. + These [execv*] functions never return: on success, the current + program is replaced by the new one; on failure, a {!UnixLabels.Unix_error} exception is raised. *) val execve : prog:string -> args:string array -> env:string array -> 'a @@ -224,27 +223,27 @@ val stdout : file_descr (** File descriptor for standard output.*) val stderr : file_descr -(** File descriptor for standard standard error. *) - -type open_flag = - Unix.open_flag = - O_RDONLY (** Open for reading *) - | O_WRONLY (** Open for writing *) - | O_RDWR (** Open for reading and writing *) - | O_NONBLOCK (** Open in non-blocking mode *) - | O_APPEND (** Open for append *) - | O_CREAT (** Create if nonexistent *) - | O_TRUNC (** Truncate to 0 length if existing *) - | O_EXCL (** Fail if existing *) - | O_NOCTTY (** Don't make this dev a controlling tty *) - | O_DSYNC (** Writes complete as `Synchronised I/O data integrity completion' *) - | O_SYNC (** Writes complete as `Synchronised I/O file integrity completion' *) - | O_RSYNC (** Reads complete as writes (depending on O_SYNC/O_DSYNC) *) +(** File descriptor for standard error. *) + +type open_flag = Unix.open_flag = + O_RDONLY (** Open for reading *) + | O_WRONLY (** Open for writing *) + | O_RDWR (** Open for reading and writing *) + | O_NONBLOCK (** Open in non-blocking mode *) + | O_APPEND (** Open for append *) + | O_CREAT (** Create if nonexistent *) + | O_TRUNC (** Truncate to 0 length if existing *) + | O_EXCL (** Fail if existing *) + | O_NOCTTY (** Don't make this dev a controlling tty *) + | O_DSYNC (** Writes complete as `Synchronised I/O data integrity completion' *) + | O_SYNC (** Writes complete as `Synchronised I/O file integrity completion' *) + | O_RSYNC (** Reads complete as writes (depending on O_SYNC/O_DSYNC) *) (** The flags to {!UnixLabels.openfile}. *) type file_perm = int -(** The type of file access rights. *) +(** The type of file access rights, e.g. [0o640] is read and write for user, + read for group, none for others *) val openfile : string -> mode:open_flag list -> perm:file_perm -> file_descr (** Open the named file with the given flags. Third argument is @@ -263,20 +262,18 @@ val write : file_descr -> buf:string -> pos:int -> len:int -> int (** [write fd buff ofs len] writes [len] characters to descriptor [fd], taking them from string [buff], starting at position [ofs] in string [buff]. Return the number of characters actually - written. - - When an error is reported some characters might have already been - written. Use [single_write] instead to ensure that this is not the - case. *) + written. [write] repeats the writing operation until all characters + have been written or an error occurs. *) val single_write : file_descr -> buf:string -> pos:int -> len:int -> int -(** Same as [write] but ensures that all errors are reported and - that no character has ever been written when an error is reported. *) - +(** Same as [write], but attempts to write only once. + Thus, if an error occurs, [single_write] guarantees that no data + has been written. *) (** {6 Interfacing with the standard input/output library} *) + val in_channel_of_descr : file_descr -> in_channel (** Create an input channel reading from the given descriptor. The channel is initially in binary mode; use @@ -294,16 +291,16 @@ val descr_of_out_channel : out_channel -> file_descr (** Return the descriptor corresponding to an output channel. *) - (** {6 Seeking and truncating} *) -type seek_command = - Unix.seek_command = - SEEK_SET (** indicates positions relative to the beginning of the file *) - | SEEK_CUR (** indicates positions relative to the current position *) - | SEEK_END (** indicates positions relative to the end of the file *) + +type seek_command = Unix.seek_command = + SEEK_SET (** indicates positions relative to the beginning of the file *) + | SEEK_CUR (** indicates positions relative to the current position *) + | SEEK_END (** indicates positions relative to the end of the file *) (** Positioning modes for {!UnixLabels.lseek}. *) + val lseek : file_descr -> int -> mode:seek_command -> int (** Set the current position for a file descriptor *) @@ -315,37 +312,34 @@ val ftruncate : file_descr -> len:int -> unit to the given size. *) - -(** {6 File statistics} *) - -type file_kind = - Unix.file_kind = - S_REG (** Regular file *) - | S_DIR (** Directory *) - | S_CHR (** Character device *) - | S_BLK (** Block device *) - | S_LNK (** Symbolic link *) - | S_FIFO (** Named pipe *) - | S_SOCK (** Socket *) - -type stats = - Unix.stats = - { st_dev : int; (** Device number *) - st_ino : int; (** Inode number *) - st_kind : file_kind; (** Kind of the file *) - st_perm : file_perm; (** Access rights *) - st_nlink : int; (** Number of links *) - st_uid : int; (** User id of the owner *) - st_gid : int; (** Group ID of the file's group *) - st_rdev : int; (** Device minor number *) - st_size : int; (** Size in bytes *) - st_atime : float; (** Last access time *) - st_mtime : float; (** Last modification time *) - st_ctime : float (** Last status change time *) - } +(** {6 File status} *) + + +type file_kind = Unix.file_kind = + S_REG (** Regular file *) + | S_DIR (** Directory *) + | S_CHR (** Character device *) + | S_BLK (** Block device *) + | S_LNK (** Symbolic link *) + | S_FIFO (** Named pipe *) + | S_SOCK (** Socket *) + +type stats = Unix.stats = + { st_dev : int; (** Device number *) + st_ino : int; (** Inode number *) + st_kind : file_kind; (** Kind of the file *) + st_perm : file_perm; (** Access rights *) + st_nlink : int; (** Number of links *) + st_uid : int; (** User id of the owner *) + st_gid : int; (** Group ID of the file's group *) + st_rdev : int; (** Device minor number *) + st_size : int; (** Size in bytes *) + st_atime : float; (** Last access time *) + st_mtime : float; (** Last modification time *) + st_ctime : float; (** Last status change time *) + } (** The informations returned by the {!UnixLabels.stat} calls. *) - val stat : string -> stats (** Return the information for the named file. *) @@ -357,8 +351,11 @@ val fstat : file_descr -> stats (** Return the information for the file associated with the given descriptor. *) -(** {6 Seeking, truncating and statistics on large files} *) +val isatty : file_descr -> bool +(** Return [true] if the given file descriptor refers to a terminal or + console window, [false] otherwise. *) +(** {6 File operations on large files} *) module LargeFile : sig @@ -377,13 +374,14 @@ module LargeFile : st_size : int64; (** Size in bytes *) st_atime : float; (** Last access time *) st_mtime : float; (** Last modification time *) - st_ctime : float; (** Last status change time *) + st_ctime : float; (** Last status change time *) } val stat : string -> stats val lstat : string -> stats val fstat : file_descr -> stats end -(** This sub-module provides 64-bit variants of the functions +(** File operations on large files. + This sub-module provides 64-bit variants of the functions {!UnixLabels.lseek} (for positioning a file descriptor), {!UnixLabels.truncate} and {!UnixLabels.ftruncate} (for changing the size of a file), @@ -405,19 +403,17 @@ val rename : src:string -> dst:string -> unit val link : src:string -> dst:string -> unit (** [link source dest] creates a hard link named [dest] to the file - named [new]. *) - + named [source]. *) (** {6 File permissions and ownership} *) -type access_permission = - Unix.access_permission = - R_OK (** Read permission *) - | W_OK (** Write permission *) - | X_OK (** Execution permission *) - | F_OK (** File exists *) +type access_permission = Unix.access_permission = + R_OK (** Read permission *) + | W_OK (** Write permission *) + | X_OK (** Execution permission *) + | F_OK (** File exists *) (** Flags for the {!UnixLabels.access} call. *) @@ -434,14 +430,14 @@ val fchown : file_descr -> uid:int -> gid:int -> unit (** Change the owner uid and owner gid of an opened file. *) val umask : int -> int -(** Set the process creation mask, and return the previous mask. *) +(** Set the process's file mode creation mask, and return the previous + mask. *) val access : string -> perm:access_permission list -> unit (** Check that the process has the given permissions over the named file. Raise [Unix_error] otherwise. *) - (** {6 Operations on file descriptors} *) @@ -542,10 +538,7 @@ val create_process : and causes the new process to have the same standard output as the current process. The executable file [prog] is searched in the path. - The new process has the same environment as the current process. - All file descriptors of the current process are closed in the - new process, except those redirected to standard input and - outputs. *) + The new process has the same environment as the current process. *) val create_process_env : prog:string -> args:string array -> env:string array -> stdin:file_descr -> @@ -554,27 +547,33 @@ val create_process_env : works as {!UnixLabels.create_process}, except that the extra argument [env] specifies the environment passed to the program. *) + val open_process_in : string -> in_channel -(** High-level pipe and process management. These functions - (with {!UnixLabels.open_process_out} and {!UnixLabels.open_process}) - run the given command in parallel with the program, - and return channels connected to the standard input and/or - the standard output of the command. The command is interpreted - by the shell [/bin/sh] (cf. [system]). Warning: writes on channels - are buffered, hence be careful to call {!Pervasives.flush} at the right times - to ensure correct synchronization. *) +(** High-level pipe and process management. This function + runs the given command in parallel with the program. + The standard output of the command is redirected to a pipe, + which can be read via the returned input channel. + The command is interpreted by the shell [/bin/sh] (cf. [system]). *) val open_process_out : string -> out_channel -(** See {!UnixLabels.open_process_in}. *) +(** Same as {!UnixLabels.open_process_in}, but redirect the standard input of + the command to a pipe. Data written to the returned output channel + is sent to the standard input of the command. + Warning: writes on output channels are buffered, hence be careful + to call {!Pervasives.flush} at the right times to ensure + correct synchronization. *) val open_process : string -> in_channel * out_channel -(** See {!UnixLabels.open_process_in}. *) +(** Same as {!UnixLabels.open_process_out}, but redirects both the standard + input and standard output of the command to pipes connected to the two + returned channels. The input channel is connected to the output + of the command, and the output channel to the input of the command. *) val open_process_full : string -> env:string array -> in_channel * out_channel * in_channel (** Similar to {!UnixLabels.open_process}, but the second argument specifies the environment passed to the command. The result is a triple - of channels connected to the standard output, standard input, + of channels connected respectively to the standard output, standard input, and standard error of the command. *) val close_process_in : in_channel -> process_status @@ -610,7 +609,6 @@ val readlink : string -> string (** Read the contents of a link. *) - (** {6 Polling} *) @@ -628,17 +626,16 @@ val select : and over which an exceptional condition is pending (third component). *) - (** {6 Locking} *) -type lock_command = - Unix.lock_command = - F_ULOCK (** Unlock a region *) - | F_LOCK (** Lock a region for writing, and block if already locked *) - | F_TLOCK (** Lock a region for writing, or fail if already locked *) - | F_TEST (** Test a region for other process locks *) - | F_RLOCK (** Lock a region for reading, and block if already locked *) - | F_TRLOCK (** Lock a region for reading, or fail if already locked *) + +type lock_command = Unix.lock_command = + F_ULOCK (** Unlock a region *) + | F_LOCK (** Lock a region for writing, and block if already locked *) + | F_TLOCK (** Lock a region for writing, or fail if already locked *) + | F_TEST (** Test a region for other process locks *) + | F_RLOCK (** Lock a region for reading, and block if already locked *) + | F_TRLOCK (** Lock a region for reading, or fail if already locked *) (** Commands for {!UnixLabels.lockf}. *) val lockf : file_descr -> mode:lock_command -> len:int -> unit @@ -647,16 +644,30 @@ val lockf : file_descr -> mode:lock_command -> len:int -> unit [fd] (as set by {!UnixLabels.lseek}), and extends [size] bytes forward if [size] is positive, [size] bytes backwards if [size] is negative, or to the end of the file if [size] is zero. - A write lock (set with [F_LOCK] or [F_TLOCK]) prevents any other + A write lock prevents any other process from acquiring a read or write lock on the region. - A read lock (set with [F_RLOCK] or [F_TRLOCK]) prevents any other + A read lock prevents any other process from acquiring a write lock on the region, but lets - other processes acquire read locks on it. *) + other processes acquire read locks on it. + + The [F_LOCK] and [F_TLOCK] commands attempts to put a write lock + on the specified region. + The [F_RLOCK] and [F_TRLOCK] commands attempts to put a read lock + on the specified region. + If one or several locks put by another process prevent the current process + from acquiring the lock, [F_LOCK] and [F_RLOCK] block until these locks + are removed, while [F_TLOCK] and [F_TRLOCK] fail immediately with an + exception. + The [F_ULOCK] removes whatever locks the current process has on + the specified region. + Finally, the [F_TEST] command tests whether a write lock can be + acquired on the specified region, without actually putting a lock. + It returns immediately if successful, or fails otherwise. *) (** {6 Signals} Note: installation of signal handlers is performed via - the functions {!Sys.signal} and {!Sys.set_signal}. + the functions {!Sys.signal} and {!Sys.set_signal}. *) @@ -664,9 +675,7 @@ val kill : pid:int -> signal:int -> unit (** [kill pid sig] sends signal number [sig] to the process with id [pid]. *) - -type sigprocmask_command = - Unix.sigprocmask_command = +type sigprocmask_command = Unix.sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK @@ -685,7 +694,7 @@ val sigpending : unit -> int list (** Return the set of blocked signals that are currently pending. *) val sigsuspend : int list -> unit -(** [sigsuspend sigs] atomically sets the blocked signals to [sig] +(** [sigsuspend sigs] atomically sets the blocked signals to [sigs] and waits for a non-ignored, non-blocked signal to be delivered. On return, the blocked signals are reset to their initial value. *) @@ -695,29 +704,29 @@ val pause : unit -> unit (** {6 Time functions} *) -type process_times = - Unix.process_times = - { tms_utime : float; (** User time for the process *) - tms_stime : float; (** System time for the process *) - tms_cutime : float; (** User time for the children processes *) - tms_cstime : float; (** System time for the children processes *) - } + +type process_times = Unix.process_times = + { tms_utime : float; (** User time for the process *) + tms_stime : float; (** System time for the process *) + tms_cutime : float; (** User time for the children processes *) + tms_cstime : float; (** System time for the children processes *) + } (** The execution times (CPU times) of a process. *) -type tm = - Unix.tm = - { tm_sec : int; (** Seconds 0..59 *) - tm_min : int; (** Minutes 0..59 *) - tm_hour : int; (** Hours 0..23 *) - tm_mday : int; (** Day of month 1..31 *) - tm_mon : int; (** Month of year 0..11 *) - tm_year : int; (** Year - 1900 *) - tm_wday : int; (** Day of week (Sunday is 0) *) - tm_yday : int; (** Day of year 0..365 *) - tm_isdst : bool; (** Daylight time savings in effect *) - } +type tm = Unix.tm = + { tm_sec : int; (** Seconds 0..60 *) + tm_min : int; (** Minutes 0..59 *) + tm_hour : int; (** Hours 0..23 *) + tm_mday : int; (** Day of month 1..31 *) + tm_mon : int; (** Month of year 0..11 *) + tm_year : int; (** Year - 1900 *) + tm_wday : int; (** Day of week (Sunday is 0) *) + tm_yday : int; (** Day of year 0..365 *) + tm_isdst : bool; (** Daylight time savings in effect *) + } (** The type representing wallclock time and calendar date. *) + val time : unit -> float (** Return the current time since 00:00:00 GMT, Jan. 1, 1970, in seconds. *) @@ -726,19 +735,22 @@ val gettimeofday : unit -> float (** Same as {!UnixLabels.time}, but with resolution better than 1 second. *) val gmtime : float -> tm -(** Convert a time in seconds, as returned by {!UnixLabels.time}, into a date and - a time. Assumes Greenwich meridian time zone, also known as UTC. *) +(** Convert a time in seconds, as returned by {!UnixLabels.time}, into a date + and a time. Assumes UTC (Coordinated Universal Time), also known as GMT. *) val localtime : float -> tm -(** Convert a time in seconds, as returned by {!UnixLabels.time}, into a date and - a time. Assumes the local time zone. *) +(** Convert a time in seconds, as returned by {!UnixLabels.time}, into a date + and a time. Assumes the local time zone. *) val mktime : tm -> float * tm (** Convert a date and time, specified by the [tm] argument, into - a time in seconds, as returned by {!UnixLabels.time}. Also return a normalized - copy of the given [tm] record, with the [tm_wday], [tm_yday], - and [tm_isdst] fields recomputed from the other fields. - The [tm] argument is interpreted in the local time zone. *) + a time in seconds, as returned by {!UnixLabels.time}. The [tm_isdst], + [tm_wday] and [tm_yday] fields of [tm] are ignored. Also return a + normalized copy of the given [tm] record, with the [tm_wday], + [tm_yday], and [tm_isdst] fields recomputed from the other fields, + and the other fields normalized (so that, e.g., 40 October is + changed into 9 November). The [tm] argument is interpreted in the + local time zone. *) val alarm : int -> int (** Schedule a [SIGALRM] signal after the given number of seconds. *) @@ -754,24 +766,21 @@ val utimes : string -> access:float -> modif:float -> unit (third arg) for a file. Times are expressed in seconds from 00:00:00 GMT, Jan. 1, 1970. *) -type interval_timer = - Unix.interval_timer = - ITIMER_REAL +type interval_timer = Unix.interval_timer = + ITIMER_REAL (** decrements in real time, and sends the signal [SIGALRM] when expired.*) - | ITIMER_VIRTUAL + | ITIMER_VIRTUAL (** decrements in process virtual time, and sends [SIGVTALRM] when expired. *) - | ITIMER_PROF + | ITIMER_PROF (** (for profiling) decrements both when the process is running and when the system is running on behalf of the process; it sends [SIGPROF] when expired. *) (** The three kinds of interval timers. *) - -type interval_timer_status = - Unix.interval_timer_status = - { it_interval : float; (** Period *) - it_value : float; (** Current value of the timer *) - } +type interval_timer_status = Unix.interval_timer_status = + { it_interval : float; (** Period *) + it_value : float; (** Current value of the timer *) + } (** The type describing the status of an interval timer *) val getitimer : interval_timer -> interval_timer_status @@ -814,28 +823,25 @@ val getgroups : unit -> int array (** Return the list of groups to which the user executing the process belongs. *) -type passwd_entry = - Unix.passwd_entry = - { pw_name : string; - pw_passwd : string; - pw_uid : int; - pw_gid : int; - pw_gecos : string; - pw_dir : string; - pw_shell : string - } +type passwd_entry = Unix.passwd_entry = + { pw_name : string; + pw_passwd : string; + pw_uid : int; + pw_gid : int; + pw_gecos : string; + pw_dir : string; + pw_shell : string + } (** Structure of entries in the [passwd] database. *) -type group_entry = - Unix.group_entry = - { gr_name : string; - gr_passwd : string; - gr_gid : int; - gr_mem : string array - } +type group_entry = Unix.group_entry = + { gr_name : string; + gr_passwd : string; + gr_gid : int; + gr_mem : string array + } (** Structure of entries in the [groups] database. *) - val getlogin : unit -> string (** Return the login name of the user executing the process. *) @@ -856,7 +862,6 @@ val getgrgid : int -> group_entry [Not_found]. *) - (** {6 Internet addresses} *) @@ -894,24 +899,21 @@ val inet6_addr_loopback : inet_addr (** {6 Sockets} *) -type socket_domain = - Unix.socket_domain = - PF_UNIX (** Unix domain *) - | PF_INET (** Internet domain *) - | PF_INET6 (** Internet domain (IPv6) *) +type socket_domain = Unix.socket_domain = + PF_UNIX (** Unix domain *) + | PF_INET (** Internet domain (IPv4) *) + | PF_INET6 (** Internet domain (IPv6) *) (** The type of socket domains. *) -type socket_type = - Unix.socket_type = - SOCK_STREAM (** Stream socket *) - | SOCK_DGRAM (** Datagram socket *) - | SOCK_RAW (** Raw socket *) - | SOCK_SEQPACKET (** Sequenced packets socket *) +type socket_type = Unix.socket_type = + SOCK_STREAM (** Stream socket *) + | SOCK_DGRAM (** Datagram socket *) + | SOCK_RAW (** Raw socket *) + | SOCK_SEQPACKET (** Sequenced packets socket *) (** The type of socket kinds, specifying the semantics of communications. *) -type sockaddr = - Unix.sockaddr = +type sockaddr = Unix.sockaddr = ADDR_UNIX of string | ADDR_INET of inet_addr * int (** The type of socket addresses. [ADDR_UNIX name] is a socket @@ -920,15 +922,15 @@ type sockaddr = domain; [addr] is the Internet address of the machine, and [port] is the port number. *) -val domain_of_sockaddr: sockaddr -> socket_domain -(** Return the socket domain adequate for the given socket address. *) - val socket : domain:socket_domain -> kind:socket_type -> protocol:int -> file_descr (** Create a new socket in the given domain, and with the given kind. The third argument is the protocol type; 0 selects the default protocol for that kind of sockets. *) +val domain_of_sockaddr: sockaddr -> socket_domain +(** Return the socket domain adequate for the given socket address. *) + val socketpair : domain:socket_domain -> kind:socket_type -> protocol:int -> file_descr * file_descr @@ -949,11 +951,10 @@ val listen : file_descr -> max:int -> unit (** Set up a socket for receiving connection requests. The integer argument is the maximal number of pending requests. *) -type shutdown_command = - Unix.shutdown_command = - SHUTDOWN_RECEIVE (** Close for receiving *) - | SHUTDOWN_SEND (** Close for sending *) - | SHUTDOWN_ALL (** Close both *) +type shutdown_command = Unix.shutdown_command = + SHUTDOWN_RECEIVE (** Close for receiving *) + | SHUTDOWN_SEND (** Close for sending *) + | SHUTDOWN_ALL (** Close both *) (** The type of commands for [shutdown]. *) @@ -979,7 +980,7 @@ type msg_flag = Unix.msg_flag = val recv : file_descr -> buf:string -> pos:int -> len:int -> mode:msg_flag list -> int -(** Receive data from an unconnected socket. *) +(** Receive data from a connected socket. *) val recvfrom : file_descr -> buf:string -> pos:int -> len:int -> mode:msg_flag list -> @@ -988,7 +989,7 @@ val recvfrom : val send : file_descr -> buf:string -> pos:int -> len:int -> mode:msg_flag list -> int -(** Send data over an unconnected socket. *) +(** Send data over a connected socket. *) val sendto : file_descr -> buf:string -> pos:int -> len:int -> mode:msg_flag list -> @@ -996,49 +997,49 @@ val sendto : (** Send data over an unconnected socket. *) + (** {6 Socket options} *) type socket_bool_option = - SO_DEBUG (** Record debugging information *) - | SO_BROADCAST (** Permit sending of broadcast messages *) - | SO_REUSEADDR (** Allow reuse of local addresses for bind *) - | SO_KEEPALIVE (** Keep connection active *) - | SO_DONTROUTE (** Bypass the standard routing algorithms *) - | SO_OOBINLINE (** Leave out-of-band data in line *) - | SO_ACCEPTCONN (** Report whether socket listening is enabled *) + SO_DEBUG (** Record debugging information *) + | SO_BROADCAST (** Permit sending of broadcast messages *) + | SO_REUSEADDR (** Allow reuse of local addresses for bind *) + | SO_KEEPALIVE (** Keep connection active *) + | SO_DONTROUTE (** Bypass the standard routing algorithms *) + | SO_OOBINLINE (** Leave out-of-band data in line *) + | SO_ACCEPTCONN (** Report whether socket listening is enabled *) (** The socket options that can be consulted with {!UnixLabels.getsockopt} and modified with {!UnixLabels.setsockopt}. These options have a boolean ([true]/[false]) value. *) type socket_int_option = - SO_SNDBUF (** Size of send buffer *) - | SO_RCVBUF (** Size of received buffer *) - | SO_ERROR (** Report the error status and clear it *) - | SO_TYPE (** Report the socket type *) - | SO_RCVLOWAT (** Minimum number of bytes to process for input operations *) - | SO_SNDLOWAT (** Minimum number of bytes to process for output operations *) + SO_SNDBUF (** Size of send buffer *) + | SO_RCVBUF (** Size of received buffer *) + | SO_ERROR (** Report the error status and clear it *) + | SO_TYPE (** Report the socket type *) + | SO_RCVLOWAT (** Minimum number of bytes to process for input operations *) + | SO_SNDLOWAT (** Minimum number of bytes to process for output operations *) (** The socket options that can be consulted with {!UnixLabels.getsockopt_int} and modified with {!UnixLabels.setsockopt_int}. These options have an integer value. *) type socket_optint_option = - SO_LINGER (** Whether to linger on closed connections - that have data present, and for how long - (in seconds) *) -(** The socket options that can be consulted with {!UnixLabels.getsockopt_optint} - and modified with {!UnixLabels.setsockopt_optint}. These options have a + SO_LINGER (** Whether to linger on closed connections + that have data present, and for how long + (in seconds) *) +(** The socket options that can be consulted with {!Unix.getsockopt_optint} + and modified with {!Unix.setsockopt_optint}. These options have a value of type [int option], with [None] meaning ``disabled''. *) - + type socket_float_option = - SO_RCVTIMEO (** Timeout for input operations *) - | SO_SNDTIMEO (** Timeout for output operations *) + SO_RCVTIMEO (** Timeout for input operations *) + | SO_SNDTIMEO (** Timeout for output operations *) (** The socket options that can be consulted with {!UnixLabels.getsockopt_float} and modified with {!UnixLabels.setsockopt_float}. These options have a floating-point value representing a time in seconds. The value 0 means infinite timeout. *) - val getsockopt : file_descr -> socket_bool_option -> bool (** Return the current status of a boolean-valued option in the given socket. *) @@ -1078,8 +1079,8 @@ external setsockopt_float : val open_connection : sockaddr -> in_channel * out_channel (** Connect to a server at the given address. Return a pair of buffered channels connected to the server. - Remember to call {!Pervasives.flush} on the output channel at the right times - to ensure correct synchronization. *) + Remember to call {!Pervasives.flush} on the output channel at the right + times to ensure correct synchronization. *) val shutdown_connection : in_channel -> unit (** ``Shut down'' a connection established with {!UnixLabels.open_connection}; @@ -1098,31 +1099,27 @@ val establish_server : (** {6 Host and protocol databases} *) -type host_entry = - Unix.host_entry = - { h_name : string; - h_aliases : string array; - h_addrtype : socket_domain; - h_addr_list : inet_addr array - } +type host_entry = Unix.host_entry = + { h_name : string; + h_aliases : string array; + h_addrtype : socket_domain; + h_addr_list : inet_addr array + } (** Structure of entries in the [hosts] database. *) -type protocol_entry = - Unix.protocol_entry = - { p_name : string; - p_aliases : string array; - p_proto : int - } +type protocol_entry = Unix.protocol_entry = + { p_name : string; + p_aliases : string array; + p_proto : int + } (** Structure of entries in the [protocols] database. *) - -type service_entry = - Unix.service_entry = - { s_name : string; - s_aliases : string array; - s_port : int; - s_proto : string - } +type service_entry = Unix.service_entry = + { s_name : string; + s_aliases : string array; + s_port : int; + s_proto : string + } (** Structure of entries in the [services] database. *) val gethostname : unit -> string @@ -1165,7 +1162,7 @@ type getaddrinfo_option = AI_FAMILY of socket_domain (** Impose the given socket domain *) | AI_SOCKTYPE of socket_type (** Impose the given socket type *) | AI_PROTOCOL of int (** Impose the given protocol *) - | AI_NUMERICHOST (** Do not call name resolver, + | AI_NUMERICHOST (** Do not call name resolver, expect numeric IP address *) | AI_CANONNAME (** Fill the [ai_canonname] field of the result *) @@ -1173,7 +1170,7 @@ type getaddrinfo_option = for use with {!Unix.bind} *) (** Options to {!Unix.getaddrinfo}. *) -val getaddrinfo: +val getaddrinfo: string -> string -> getaddrinfo_option list -> addr_info list (** [getaddrinfo host service opts] returns a list of {!Unix.addr_info} records describing socket parameters and addresses suitable for @@ -1189,7 +1186,7 @@ val getaddrinfo: a port number. [service] can be given as the empty string; in this case, the port field of the returned addresses is set to 0. [opts] is a possibly empty list of options that allows the caller - to force a particular socket domain (e.g. IPv6 only, or IPv4 only) + to force a particular socket domain (e.g. IPv6 only or IPv4 only) or a particular socket type (e.g. TCP only or UDP only). *) type name_info = @@ -1212,69 +1209,69 @@ val getnameinfo : sockaddr -> getnameinfo_option list -> name_info empty list of options that governs how these names are obtained. Raise [Not_found] if an error occurs. *) + (** {6 Terminal interface} *) + (** The following functions implement the POSIX standard terminal interface. They provide control over asynchronous communication ports and pseudo-terminals. Refer to the [termios] man page for a complete description. *) -type terminal_io = - Unix.terminal_io = - { - (* Input modes: *) - mutable c_ignbrk : bool; (** Ignore the break condition. *) - mutable c_brkint : bool; (** Signal interrupt on break condition. *) - mutable c_ignpar : bool; (** Ignore characters with parity errors. *) - mutable c_parmrk : bool; (** Mark parity errors. *) - mutable c_inpck : bool; (** Enable parity check on input. *) - mutable c_istrip : bool; (** Strip 8th bit on input characters. *) - mutable c_inlcr : bool; (** Map NL to CR on input. *) - mutable c_igncr : bool; (** Ignore CR on input. *) - mutable c_icrnl : bool; (** Map CR to NL on input. *) - mutable c_ixon : bool; (** Recognize XON/XOFF characters on input. *) - mutable c_ixoff : bool; (** Emit XON/XOFF chars to control input flow. *) - (* Output modes: *) - mutable c_opost : bool; (** Enable output processing. *) - (* Control modes: *) - mutable c_obaud : int; (** Output baud rate (0 means close connection).*) - mutable c_ibaud : int; (** Input baud rate. *) - mutable c_csize : int; (** Number of bits per character (5-8). *) - mutable c_cstopb : int; (** Number of stop bits (1-2). *) - mutable c_cread : bool; (** Reception is enabled. *) - mutable c_parenb : bool; (** Enable parity generation and detection. *) - mutable c_parodd : bool; (** Specify odd parity instead of even. *) - mutable c_hupcl : bool; (** Hang up on last close. *) - mutable c_clocal : bool; (** Ignore modem status lines. *) - (* Local modes: *) - mutable c_isig : bool; (** Generate signal on INTR, QUIT, SUSP. *) - mutable c_icanon : bool; (** Enable canonical processing - (line buffering and editing) *) - mutable c_noflsh : bool; (** Disable flush after INTR, QUIT, SUSP. *) - mutable c_echo : bool; (** Echo input characters. *) - mutable c_echoe : bool; (** Echo ERASE (to erase previous character). *) - mutable c_echok : bool; (** Echo KILL (to erase the current line). *) - mutable c_echonl : bool; (** Echo NL even if c_echo is not set. *) - (* Control characters: *) - mutable c_vintr : char; (** Interrupt character (usually ctrl-C). *) - mutable c_vquit : char; (** Quit character (usually ctrl-\). *) - mutable c_verase : char; (** Erase character (usually DEL or ctrl-H). *) - mutable c_vkill : char; (** Kill line character (usually ctrl-U). *) - mutable c_veof : char; (** End-of-file character (usually ctrl-D). *) - mutable c_veol : char; (** Alternate end-of-line char. (usually none). *) - mutable c_vmin : int; (** Minimum number of characters to read - before the read request is satisfied. *) - mutable c_vtime : int; (** Maximum read wait (in 0.1s units). *) - mutable c_vstart : char; (** Start character (usually ctrl-Q). *) - mutable c_vstop : char; (** Stop character (usually ctrl-S). *) - } +type terminal_io = Unix.terminal_io = + { + (* input modes *) + mutable c_ignbrk : bool; (** Ignore the break condition. *) + mutable c_brkint : bool; (** Signal interrupt on break condition. *) + mutable c_ignpar : bool; (** Ignore characters with parity errors. *) + mutable c_parmrk : bool; (** Mark parity errors. *) + mutable c_inpck : bool; (** Enable parity check on input. *) + mutable c_istrip : bool; (** Strip 8th bit on input characters. *) + mutable c_inlcr : bool; (** Map NL to CR on input. *) + mutable c_igncr : bool; (** Ignore CR on input. *) + mutable c_icrnl : bool; (** Map CR to NL on input. *) + mutable c_ixon : bool; (** Recognize XON/XOFF characters on input. *) + mutable c_ixoff : bool; (** Emit XON/XOFF chars to control input flow. *) + (* Output modes: *) + mutable c_opost : bool; (** Enable output processing. *) + (* Control modes: *) + mutable c_obaud : int; (** Output baud rate (0 means close connection).*) + mutable c_ibaud : int; (** Input baud rate. *) + mutable c_csize : int; (** Number of bits per character (5-8). *) + mutable c_cstopb : int; (** Number of stop bits (1-2). *) + mutable c_cread : bool; (** Reception is enabled. *) + mutable c_parenb : bool; (** Enable parity generation and detection. *) + mutable c_parodd : bool; (** Specify odd parity instead of even. *) + mutable c_hupcl : bool; (** Hang up on last close. *) + mutable c_clocal : bool; (** Ignore modem status lines. *) + (* Local modes: *) + mutable c_isig : bool; (** Generate signal on INTR, QUIT, SUSP. *) + mutable c_icanon : bool; (** Enable canonical processing + (line buffering and editing) *) + mutable c_noflsh : bool; (** Disable flush after INTR, QUIT, SUSP. *) + mutable c_echo : bool; (** Echo input characters. *) + mutable c_echoe : bool; (** Echo ERASE (to erase previous character). *) + mutable c_echok : bool; (** Echo KILL (to erase the current line). *) + mutable c_echonl : bool; (** Echo NL even if c_echo is not set. *) + (* Control characters: *) + mutable c_vintr : char; (** Interrupt character (usually ctrl-C). *) + mutable c_vquit : char; (** Quit character (usually ctrl-\). *) + mutable c_verase : char; (** Erase character (usually DEL or ctrl-H). *) + mutable c_vkill : char; (** Kill line character (usually ctrl-U). *) + mutable c_veof : char; (** End-of-file character (usually ctrl-D). *) + mutable c_veol : char; (** Alternate end-of-line char. (usually none). *) + mutable c_vmin : int; (** Minimum number of characters to read + before the read request is satisfied. *) + mutable c_vtime : int; (** Maximum read wait (in 0.1s units). *) + mutable c_vstart : char; (** Start character (usually ctrl-Q). *) + mutable c_vstop : char; (** Stop character (usually ctrl-S). *) + } val tcgetattr : file_descr -> terminal_io (** Return the status of the terminal referred to by the given file descriptor. *) -type setattr_when = - Unix.setattr_when = +type setattr_when = Unix.setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH @@ -1298,8 +1295,7 @@ val tcdrain : file_descr -> unit (** Waits until all output written on the given file descriptor has been transmitted. *) -type flush_queue = - Unix.flush_queue = +type flush_queue = Unix.flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH @@ -1311,8 +1307,7 @@ val tcflush : file_descr -> mode:flush_queue -> unit [TCOFLUSH] flushes data written but not transmitted, and [TCIOFLUSH] flushes both. *) -type flow_action = - Unix.flow_action = +type flow_action = Unix.flow_action = TCOOFF | TCOON | TCIOFF diff --git a/otherlibs/win32graph/Makefile.nt b/otherlibs/win32graph/Makefile.nt index 48cc1508..9102d451 100644 --- a/otherlibs/win32graph/Makefile.nt +++ b/otherlibs/win32graph/Makefile.nt @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.6 2004/07/13 12:25:15 xleroy Exp $ +# $Id: Makefile.nt,v 1.7 2007/01/29 12:11:18 xleroy Exp $ include ../../config/Makefile @@ -20,7 +20,7 @@ CC=$(BYTECC) CFLAGS=-I../../byterun CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -COMPFLAGS=-warn-error A +COMPFLAGS=-warn-error A -g COBJS=open.$(O) draw.$(O) events.$(O) dib.$(O) CAMLOBJS=graphics.cmo diff --git a/otherlibs/win32graph/dllgraphics.dlib b/otherlibs/win32graph/dllgraphics.dlib new file mode 100644 index 00000000..ab0ba91b --- /dev/null +++ b/otherlibs/win32graph/dllgraphics.dlib @@ -0,0 +1 @@ +open.d.o draw.d.o events.d.o dib.d.o diff --git a/otherlibs/win32graph/libgraphics.clib b/otherlibs/win32graph/libgraphics.clib new file mode 100644 index 00000000..5084c973 --- /dev/null +++ b/otherlibs/win32graph/libgraphics.clib @@ -0,0 +1 @@ +open.o draw.o events.o dib.o diff --git a/otherlibs/win32graph/open.c b/otherlibs/win32graph/open.c index 4b620c68..f38484ad 100644 --- a/otherlibs/win32graph/open.c +++ b/otherlibs/win32graph/open.c @@ -10,7 +10,7 @@ /* */ /***********************************************************************/ -/* $Id: open.c,v 1.10.2.1 2005/10/27 09:02:59 xleroy Exp $ */ +/* $Id: open.c,v 1.11 2006/05/09 16:02:48 xleroy Exp $ */ #include #include diff --git a/otherlibs/win32unix/Makefile.nt b/otherlibs/win32unix/Makefile.nt index 4adc01a9..1e72a033 100644 --- a/otherlibs/win32unix/Makefile.nt +++ b/otherlibs/win32unix/Makefile.nt @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.32 2004/05/30 08:17:06 xleroy Exp $ +# $Id: Makefile.nt,v 1.35 2007/02/07 15:49:11 doligez Exp $ include ../../config/Makefile @@ -20,7 +20,7 @@ CC=$(BYTECC) CFLAGS=-I../../byterun -I../unix CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -COMPFLAGS=-warn-error A +COMPFLAGS=-warn-error A -g # Files in this directory WIN_FILES = accept.c bind.c channels.c close.c \ @@ -83,6 +83,7 @@ install: cp dllunix.dll $(STUBLIBDIR)/dllunix.dll cp libunix.$(A) $(LIBDIR)/libunix.$(A) cp $(CAML_OBJS:.cmo=.cmi) unix.cma $(CAML_OBJS:.cmo=.mli) $(LIBDIR) + cp unixsupport.h $(LIBDIR)/caml installopt: cp unix.cmxa $(CAML_OBJS:.cmo=.cmx) unix.$(A) $(LIBDIR) diff --git a/otherlibs/win32unix/accept.c b/otherlibs/win32unix/accept.c index ebbb0fd7..d065885b 100644 --- a/otherlibs/win32unix/accept.c +++ b/otherlibs/win32unix/accept.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: accept.c,v 1.19 2005/03/24 17:20:53 doligez Exp $ */ +/* $Id: accept.c,v 1.21 2006/10/18 08:26:54 xleroy Exp $ */ #include #include @@ -29,7 +29,7 @@ CAMLprim value unix_accept(sock) int oldvalue, oldvaluelen, newvalue, retcode; union sock_addr_union addr; socklen_param_type addr_len; - int errcode = 0; + DWORD err = 0; oldvaluelen = sizeof(oldvalue); retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, @@ -43,16 +43,15 @@ CAMLprim value unix_accept(sock) addr_len = sizeof(sock_addr); enter_blocking_section(); snew = accept(sconn, &addr.s_gen, &addr_len); + if (snew == INVALID_SOCKET) err = WSAGetLastError (); leave_blocking_section(); - if( snew == INVALID_SOCKET ) - errcode = WSAGetLastError (); if (retcode == 0) { /* Restore initial mode */ setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, (char *) &oldvalue, oldvaluelen); } if (snew == INVALID_SOCKET) { - win32_maperr(errcode); + win32_maperr(err); uerror("accept", Nothing); } Begin_roots2 (fd, adr) diff --git a/otherlibs/win32unix/channels.c b/otherlibs/win32unix/channels.c index a4208a86..d480cfdc 100644 --- a/otherlibs/win32unix/channels.c +++ b/otherlibs/win32unix/channels.c @@ -11,27 +11,72 @@ /* */ /***********************************************************************/ -/* $Id: channels.c,v 1.10 2003/01/06 14:52:57 xleroy Exp $ */ +/* $Id: channels.c,v 1.12 2006/09/21 09:41:04 xleroy Exp $ */ #include #include +#include +#include #include "unixsupport.h" #include extern long _get_osfhandle(int); extern int _open_osfhandle(long, int); -CAMLprim value win_fd_handle(value handle) +int win_CRT_fd_of_filedescr(value handle) { - int fd; if (CRT_fd_val(handle) != NO_CRT_FD) { - fd = CRT_fd_val(handle); + return CRT_fd_val(handle); } else { - fd = _open_osfhandle((long) Handle_val(handle), O_BINARY); + int fd = _open_osfhandle((long) Handle_val(handle), O_BINARY); if (fd == -1) uerror("channel_of_descr", Nothing); - CRT_fd_val(handle) = fd; + return fd; } - return Val_int(fd); +} + +CAMLprim value win_inchannel_of_filedescr(value handle) +{ + CAMLparam1(handle); + CAMLlocal1(vchan); + struct channel * chan; + + chan = caml_open_descriptor_in(win_CRT_fd_of_filedescr(handle)); + if (Descr_kind_val(handle) == KIND_SOCKET) + chan->flags |= CHANNEL_FLAG_FROM_SOCKET; + vchan = caml_alloc_channel(chan); + CAMLreturn(vchan); +} + +CAMLprim value win_outchannel_of_filedescr(value handle) +{ + CAMLparam1(handle); + CAMLlocal1(vchan); + int fd; + struct channel * chan; + + chan = caml_open_descriptor_out(win_CRT_fd_of_filedescr(handle)); + if (Descr_kind_val(handle) == KIND_SOCKET) + chan->flags |= CHANNEL_FLAG_FROM_SOCKET; + vchan = caml_alloc_channel(chan); + CAMLreturn(vchan); +} + +CAMLprim value win_filedescr_of_channel(value vchan) +{ + CAMLparam1(vchan); + CAMLlocal1(fd); + struct channel * chan; + HANDLE h; + + chan = Channel(vchan); + if (chan->fd == -1) uerror("descr_of_channel", Nothing); + h = (HANDLE) _get_osfhandle(chan->fd); + if (chan->flags & CHANNEL_FLAG_FROM_SOCKET) + fd = win_alloc_socket((SOCKET) h); + else + fd = win_alloc_handle(h); + CRT_fd_val(fd) = chan->fd; + CAMLreturn(fd); } CAMLprim value win_handle_fd(value vfd) diff --git a/otherlibs/win32unix/connect.c b/otherlibs/win32unix/connect.c index a5898d3e..c35985a0 100644 --- a/otherlibs/win32unix/connect.c +++ b/otherlibs/win32unix/connect.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: connect.c,v 1.11 2002/06/07 09:49:41 xleroy Exp $ */ +/* $Id: connect.c,v 1.13 2006/10/18 08:26:54 xleroy Exp $ */ #include #include @@ -22,16 +22,17 @@ CAMLprim value unix_connect(socket, address) value socket, address; { SOCKET s = Socket_val(socket); - int retcode; union sock_addr_union addr; socklen_param_type addr_len; + DWORD err = 0; get_sockaddr(address, &addr, &addr_len); enter_blocking_section(); - retcode = connect(s, &addr.s_gen, addr_len); + if (connect(s, &addr.s_gen, addr_len) == -1) + err = WSAGetLastError(); leave_blocking_section(); - if (retcode == -1) { - win32_maperr(WSAGetLastError()); + if (err) { + win32_maperr(err); uerror("connect", Nothing); } return Val_unit; diff --git a/otherlibs/win32unix/dllunix.dlib b/otherlibs/win32unix/dllunix.dlib new file mode 100644 index 00000000..01ffc59e --- /dev/null +++ b/otherlibs/win32unix/dllunix.dlib @@ -0,0 +1,16 @@ +# Files in this directory +accept.d.o bind.d.o channels.d.o close.d.o +close_on.d.o connect.d.o createprocess.d.o dup.d.o dup2.d.o errmsg.d.o +getpeername.d.o getpid.d.o getsockname.d.o gettimeofday.d.o +link.d.o listen.d.o lockf.d.o lseek.d.o nonblock.d.o +mkdir.d.o open.d.o pipe.d.o read.d.o rename.d.o +select.d.o sendrecv.d.o +shutdown.d.o sleep.d.o socket.d.o sockopt.d.o startup.d.o stat.d.o +system.d.o unixsupport.d.o windir.d.o winwait.d.o write.d.o + +# Files from the ../unix directory +access.d.o addrofstr.d.o chdir.d.o chmod.d.o cst2constr.d.o +cstringv.d.o envir.d.o execv.d.o execve.d.o execvp.d.o +exit.d.o getcwd.d.o gethost.d.o gethostname.d.o getproto.d.o +getserv.d.o gmtime.d.o putenv.d.o rmdir.d.o +socketaddr.d.o strofaddr.d.o time.d.o unlink.d.o utimes.d.o diff --git a/otherlibs/win32unix/dup2.c b/otherlibs/win32unix/dup2.c index d4bd7b2d..288d6df7 100644 --- a/otherlibs/win32unix/dup2.c +++ b/otherlibs/win32unix/dup2.c @@ -11,12 +11,11 @@ /* */ /***********************************************************************/ -/* $Id: dup2.c,v 1.7 2003/01/06 14:52:57 xleroy Exp $ */ +/* $Id: dup2.c,v 1.9 2006/09/21 09:43:58 xleroy Exp $ */ #include #include "unixsupport.h" -extern value win_fd_handle(value); extern int _dup2(int, int); CAMLprim value unix_dup2(value fd1, value fd2) @@ -38,6 +37,6 @@ CAMLprim value unix_dup2(value fd1, value fd2) Descr_kind_val(fd2) = Descr_kind_val(fd1); /* Reflect the dup2 on the CRT fds, if any */ if (CRT_fd_val(fd1) != NO_CRT_FD || CRT_fd_val(fd2) != NO_CRT_FD) - _dup2(Int_val(win_fd_handle(fd1)), Int_val(win_fd_handle(fd2))); + _dup2(win_CRT_fd_of_filedescr(fd1), win_CRT_fd_of_filedescr(fd2)); return Val_unit; } diff --git a/otherlibs/win32unix/gettimeofday.c b/otherlibs/win32unix/gettimeofday.c index f9554243..971acdc9 100644 --- a/otherlibs/win32unix/gettimeofday.c +++ b/otherlibs/win32unix/gettimeofday.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: gettimeofday.c,v 1.6 2001/12/07 13:40:44 xleroy Exp $ */ +/* $Id: gettimeofday.c,v 1.7 2007/03/01 13:51:24 xleroy Exp $ */ #include #include @@ -24,12 +24,13 @@ static DWORD initial_tickcount; CAMLprim value unix_gettimeofday(value unit) { - if (initial_time == 0) { - initial_tickcount = GetTickCount(); + DWORD tickcount = GetTickCount(); + if (initial_time == 0 || tickcount < initial_tickcount) { + initial_tickcount = tickcount; initial_time = time(NULL); return copy_double((double) initial_time); } else { - return copy_double(initial_time + - (GetTickCount() - initial_tickcount) * 1e-3); + return copy_double((double) initial_time + + (double) (tickcount - initial_tickcount) * 1e-3); } } diff --git a/otherlibs/win32unix/libunix.clib b/otherlibs/win32unix/libunix.clib new file mode 100644 index 00000000..29b8d6e6 --- /dev/null +++ b/otherlibs/win32unix/libunix.clib @@ -0,0 +1,16 @@ +# Files in this directory +accept.o bind.o channels.o close.o +close_on.o connect.o createprocess.o dup.o dup2.o errmsg.o +getpeername.o getpid.o getsockname.o gettimeofday.o +link.o listen.o lockf.o lseek.o nonblock.o +mkdir.o open.o pipe.o read.o rename.o +select.o sendrecv.o +shutdown.o sleep.o socket.o sockopt.o startup.o stat.o +system.o unixsupport.o windir.o winwait.o write.o + +# Files from the ../unix directory +access.o addrofstr.o chdir.o chmod.o cst2constr.o +cstringv.o envir.o execv.o execve.o execvp.o +exit.o getcwd.o gethost.o gethostname.o getproto.o +getserv.o gmtime.o putenv.o rmdir.o +socketaddr.o strofaddr.o time.o unlink.o utimes.o diff --git a/otherlibs/win32unix/read.c b/otherlibs/win32unix/read.c index 650c2ed0..944c72ad 100644 --- a/otherlibs/win32unix/read.c +++ b/otherlibs/win32unix/read.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: read.c,v 1.7 2002/07/23 14:12:01 doligez Exp $ */ +/* $Id: read.c,v 1.9 2006/10/18 08:26:54 xleroy Exp $ */ #include #include @@ -19,35 +19,34 @@ #include #include "unixsupport.h" -CAMLprim value unix_read(value fd, value buf, value ofs, value len) +CAMLprim value unix_read(value fd, value buf, value ofs, value vlen) { + intnat len; DWORD numbytes, numread; char iobuf[UNIX_BUFFER_SIZE]; + DWORD err = 0; Begin_root (buf); - numbytes = Long_val(len); - if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; + len = Long_val(vlen); + numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len; if (Descr_kind_val(fd) == KIND_SOCKET) { int ret; SOCKET s = Socket_val(fd); enter_blocking_section(); ret = recv(s, iobuf, numbytes, 0); + if (ret == SOCKET_ERROR) err = WSAGetLastError(); leave_blocking_section(); - if (ret == SOCKET_ERROR) { - win32_maperr(WSAGetLastError()); - uerror("read", Nothing); - } numread = ret; } else { - BOOL ret; HANDLE h = Handle_val(fd); enter_blocking_section(); - ret = ReadFile(h, iobuf, numbytes, &numread, NULL); + if (! ReadFile(h, iobuf, numbytes, &numread, NULL)) + err = GetLastError(); leave_blocking_section(); - if (! ret) { - win32_maperr(GetLastError()); - uerror("read", Nothing); - } + } + if (err) { + win32_maperr(err); + uerror("read", Nothing); } memmove (&Byte(buf, Long_val(ofs)), iobuf, numread); End_roots(); diff --git a/otherlibs/win32unix/select.c b/otherlibs/win32unix/select.c index f10eaf27..41fb1e90 100644 --- a/otherlibs/win32unix/select.c +++ b/otherlibs/win32unix/select.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: select.c,v 1.10 2003/01/07 16:16:44 xleroy Exp $ */ +/* $Id: select.c,v 1.12 2006/10/18 08:26:54 xleroy Exp $ */ #include #include @@ -54,6 +54,7 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value int retcode; value res; value read_list = Val_unit, write_list = Val_unit, except_list = Val_unit; + DWORD err = 0; Begin_roots3 (readfds, writefds, exceptfds) Begin_roots3 (read_list, write_list, except_list) @@ -79,10 +80,11 @@ CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value tvp = &tv; } enter_blocking_section(); - retcode = select(FD_SETSIZE, &read, &write, &except, tvp); + if (select(FD_SETSIZE, &read, &write, &except, tvp) == -1) + err = WSAGetLastError(); leave_blocking_section(); - if (retcode == -1) { - win32_maperr(WSAGetLastError()); + if (err) { + win32_maperr(err); uerror("select", Nothing); } read_list = fdset_to_fdlist(readfds, &read); diff --git a/otherlibs/win32unix/sendrecv.c b/otherlibs/win32unix/sendrecv.c index 3b8d39f7..054f8ba1 100644 --- a/otherlibs/win32unix/sendrecv.c +++ b/otherlibs/win32unix/sendrecv.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: sendrecv.c,v 1.18 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: sendrecv.c,v 1.21 2006/10/18 08:26:54 xleroy Exp $ */ #include #include @@ -26,19 +26,22 @@ static int msg_flag_table[] = { CAMLprim value unix_recv(value sock, value buff, value ofs, value len, value flags) { + SOCKET s = Socket_val(sock); + int flg = convert_flag_list(flags, msg_flag_table); int ret; intnat numbytes; char iobuf[UNIX_BUFFER_SIZE]; + DWORD err = 0; Begin_root (buff); numbytes = Long_val(len); if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; enter_blocking_section(); - ret = recv(Socket_val(sock), iobuf, (int) numbytes, - convert_flag_list(flags, msg_flag_table)); + ret = recv(s, iobuf, (int) numbytes, flg); + if (ret == -1) err = WSAGetLastError(); leave_blocking_section(); if (ret == -1) { - win32_maperr(WSAGetLastError()); + win32_maperr(err); uerror("recv", Nothing); } memmove (&Byte(buff, Long_val(ofs)), iobuf, ret); @@ -48,6 +51,8 @@ CAMLprim value unix_recv(value sock, value buff, value ofs, value len, value fla CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, value flags) { + SOCKET s = Socket_val(sock); + int flg = convert_flag_list(flags, msg_flag_table); int ret; intnat numbytes; char iobuf[UNIX_BUFFER_SIZE]; @@ -55,19 +60,18 @@ CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, value value adr = Val_unit; union sock_addr_union addr; socklen_param_type addr_len; + DWORD err = 0; Begin_roots2 (buff, adr); numbytes = Long_val(len); if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; addr_len = sizeof(sock_addr); enter_blocking_section(); - ret = recvfrom(Socket_val(sock), - iobuf, (int) numbytes, - convert_flag_list(flags, msg_flag_table), - &addr.s_gen, &addr_len); + ret = recvfrom(s, iobuf, (int) numbytes, flg, &addr.s_gen, &addr_len); + if (ret == -1) err = WSAGetLastError(); leave_blocking_section(); if (ret == -1) { - win32_maperr(WSAGetLastError()); + win32_maperr(err); uerror("recvfrom", Nothing); } memmove (&Byte(buff, Long_val(ofs)), iobuf, ret); @@ -81,19 +85,22 @@ CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, value CAMLprim value unix_send(value sock, value buff, value ofs, value len, value flags) { + SOCKET s = Socket_val(sock); + int flg = convert_flag_list(flags, msg_flag_table); int ret; intnat numbytes; char iobuf[UNIX_BUFFER_SIZE]; + DWORD err = 0; numbytes = Long_val(len); if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes); enter_blocking_section(); - ret = send(Socket_val(sock), iobuf, (int) numbytes, - convert_flag_list(flags, msg_flag_table)); + ret = send(s, iobuf, (int) numbytes, flg); + if (ret == -1) err = WSAGetLastError(); leave_blocking_section(); if (ret == -1) { - win32_maperr(WSAGetLastError()); + win32_maperr(err); uerror("send", Nothing); } return Val_int(ret); @@ -101,24 +108,25 @@ CAMLprim value unix_send(value sock, value buff, value ofs, value len, value fla value unix_sendto_native(value sock, value buff, value ofs, value len, value flags, value dest) { + SOCKET s = Socket_val(sock); + int flg = convert_flag_list(flags, msg_flag_table); int ret; intnat numbytes; char iobuf[UNIX_BUFFER_SIZE]; union sock_addr_union addr; socklen_param_type addr_len; + DWORD err = 0; get_sockaddr(dest, &addr, &addr_len); numbytes = Long_val(len); if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE; memmove (iobuf, &Byte(buff, Long_val(ofs)), numbytes); enter_blocking_section(); - ret = sendto(Socket_val(sock), - iobuf, (int) numbytes, - convert_flag_list(flags, msg_flag_table), - &addr.s_gen, addr_len); + ret = sendto(s, iobuf, (int) numbytes, flg, &addr.s_gen, addr_len); + if (ret == -1) err = WSAGetLastError(); leave_blocking_section(); if (ret == -1) { - win32_maperr(WSAGetLastError()); + win32_maperr(err); uerror("sendto", Nothing); } return Val_int(ret); diff --git a/otherlibs/win32unix/stat.c b/otherlibs/win32unix/stat.c index 0af9376f..d9a6e461 100644 --- a/otherlibs/win32unix/stat.c +++ b/otherlibs/win32unix/stat.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: stat.c,v 1.1.14.1 2006/04/06 13:26:58 doligez Exp $ */ +/* $Id: stat.c,v 1.3 2006/09/21 13:57:34 xleroy Exp $ */ #include #include @@ -86,3 +86,30 @@ CAMLprim value unix_stat_64(value path) return stat_aux(1, &buf); } +CAMLprim value unix_fstat(value handle) +{ + int ret; + struct _stati64 buf; + + ret = _fstati64(win_CRT_fd_of_filedescr(handle), &buf); + if (ret == -1) uerror("fstat", Nothing); + if (buf.st_size > Max_long) { + win32_maperr(ERROR_ARITHMETIC_OVERFLOW); + uerror("fstat", Nothing); + } + return stat_aux(0, &buf); +} + +CAMLprim value unix_fstat_64(value handle) +{ + int ret; + struct _stati64 buf; + + ret = _fstati64(win_CRT_fd_of_filedescr(handle), &buf); + if (ret == -1) uerror("fstat", Nothing); + if (buf.st_size > Max_long) { + win32_maperr(ERROR_ARITHMETIC_OVERFLOW); + uerror("fstat", Nothing); + } + return stat_aux(1, &buf); +} diff --git a/otherlibs/win32unix/system.c b/otherlibs/win32unix/system.c index 57100b33..cca39fca 100644 --- a/otherlibs/win32unix/system.c +++ b/otherlibs/win32unix/system.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: system.c,v 1.8 2002/06/07 09:49:41 xleroy Exp $ */ +/* $Id: system.c,v 1.9 2006/09/21 08:03:56 xleroy Exp $ */ #include #include @@ -26,11 +26,17 @@ CAMLprim value win_system(cmd) { int ret; value st; + char *buf; + intnat len; + len = caml_string_length (cmd); + buf = caml_stat_alloc (len + 1); + memmove (buf, String_val (cmd), len + 1); enter_blocking_section(); _flushall(); - ret = system(String_val(cmd));; + ret = system(buf); leave_blocking_section(); + caml_stat_free(buf); if (ret == -1) uerror("system", Nothing); st = alloc_small(1, 0); /* Tag 0: Exited */ Field(st, 0) = Val_int(ret); diff --git a/otherlibs/win32unix/unix.ml b/otherlibs/win32unix/unix.ml index 3a41ba89..2feb2e4f 100644 --- a/otherlibs/win32unix/unix.ml +++ b/otherlibs/win32unix/unix.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: unix.ml,v 1.43 2004/11/30 17:06:19 xleroy Exp $ *) +(* $Id: unix.ml,v 1.46 2007/02/25 14:38:11 xleroy Exp $ *) (* Initialization *) @@ -198,23 +198,10 @@ let single_write fd buf ofs len = (* Interfacing with the standard input/output library *) -external open_read_descriptor : int -> in_channel = "caml_ml_open_descriptor_in" -external open_write_descriptor : int -> out_channel - = "caml_ml_open_descriptor_out" -external fd_of_in_channel : in_channel -> int = "caml_channel_descriptor" -external fd_of_out_channel : out_channel -> int = "caml_channel_descriptor" - -external open_handle : file_descr -> int = "win_fd_handle" - -let in_channel_of_descr handle = - open_read_descriptor(open_handle handle) -let out_channel_of_descr handle = - open_write_descriptor(open_handle handle) - -let descr_of_in_channel inchan = - filedescr_of_fd(fd_of_in_channel inchan) -let descr_of_out_channel outchan = - filedescr_of_fd(fd_of_out_channel outchan) +external in_channel_of_descr: file_descr -> in_channel = "win_inchannel_of_filedescr" +external out_channel_of_descr: file_descr -> out_channel = "win_outchannel_of_filedescr" +external descr_of_in_channel : in_channel -> file_descr = "win_filedescr_of_channel" +external descr_of_out_channel : out_channel -> file_descr = "win_filedescr_of_channel" (* Seeking and truncating *) @@ -255,7 +242,9 @@ type stats = external stat : string -> stats = "unix_stat" let lstat = stat -let fstat fd = invalid_arg "Unix.fstat not implemented" +external fstat : file_descr -> stats = "unix_fstat" +let isatty fd = + match (fstat fd).st_kind with S_CHR -> true | _ -> false (* Operations on file names *) @@ -286,7 +275,7 @@ module LargeFile = } external stat : string -> stats = "unix_stat_64" let lstat = stat - let fstat fd = invalid_arg "Unix.LargeFile.fstat not implemented" + external fstat : file_descr -> stats = "unix_fstat_64" end (* File permissions and ownership *) @@ -337,7 +326,7 @@ external findnext : int -> string= "win_findnext" let opendir dirname = try - let (first_entry, handle) = findfirst (dirname ^ "\\*.*") in + let (first_entry, handle) = findfirst (Filename.concat dirname "*.*") in { dirname = dirname; handle = handle; entry_read = Dir_read first_entry } with End_of_file -> { dirname = dirname; handle = 0; entry_read = Dir_empty } diff --git a/otherlibs/win32unix/unixsupport.c b/otherlibs/win32unix/unixsupport.c index a1098ca7..ae2d527d 100644 --- a/otherlibs/win32unix/unixsupport.c +++ b/otherlibs/win32unix/unixsupport.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: unixsupport.c,v 1.20 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: unixsupport.c,v 1.21 2007/02/07 14:45:46 doligez Exp $ */ #include #include @@ -221,6 +221,22 @@ int error_table[] = { static value * unix_error_exn = NULL; +value unix_error_of_code (int errcode) +{ + int errconstr; + value err; + + errconstr = + cst_to_constr(errcode, error_table, sizeof(error_table)/sizeof(int), -1); + if (errconstr == Val_int(-1)) { + err = alloc_small(1, 0); + Field(err, 0) = Val_int(errcode); + } else { + err = errconstr; + } + return err; +} + void unix_error(int errcode, char *cmdname, value cmdarg) { value res; @@ -230,14 +246,7 @@ void unix_error(int errcode, char *cmdname, value cmdarg) Begin_roots3 (name, err, arg); arg = cmdarg == Nothing ? copy_string("") : cmdarg; name = copy_string(cmdname); - errconstr = - cst_to_constr(errcode, error_table, sizeof(error_table)/sizeof(int), -1); - if (errconstr == Val_int(-1)) { - err = alloc_small(1, 0); - Field(err, 0) = Val_int(errcode); - } else { - err = errconstr; - } + err = unix_error_of_code (errcode); if (unix_error_exn == NULL) { unix_error_exn = caml_named_value("Unix.Unix_error"); if (unix_error_exn == NULL) diff --git a/otherlibs/win32unix/unixsupport.h b/otherlibs/win32unix/unixsupport.h index 4a28041b..07fc8017 100644 --- a/otherlibs/win32unix/unixsupport.h +++ b/otherlibs/win32unix/unixsupport.h @@ -11,15 +11,12 @@ /* */ /***********************************************************************/ -/* $Id: unixsupport.h,v 1.16 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: unixsupport.h,v 1.19 2007/02/07 14:45:46 doligez Exp $ */ #define WIN32_LEAN_AND_MEAN #include #include #include -/* Include io.h in current dir, which is a copy of the system's io.h, - not io.h from ../../byterun */ -/*#include "io.h"*/ #include #include #include @@ -42,11 +39,13 @@ struct filedescr { extern value win_alloc_handle_or_socket(HANDLE); extern value win_alloc_handle(HANDLE); extern value win_alloc_socket(SOCKET); +extern int win_CRT_fd_of_filedescr(value handle); #define NO_CRT_FD (-1) #define Nothing ((value) 0) extern void win32_maperr(DWORD errcode); +extern value unix_error_of_code (int errcode); extern void unix_error (int errcode, char * cmdname, value arg); extern void uerror (char * cmdname, value arg); extern value unix_freeze_buffer (value); diff --git a/otherlibs/win32unix/winwait.c b/otherlibs/win32unix/winwait.c index 7872d399..3cbcb1dc 100644 --- a/otherlibs/win32unix/winwait.c +++ b/otherlibs/win32unix/winwait.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: winwait.c,v 1.15 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: winwait.c,v 1.18 2006/10/18 08:26:54 xleroy Exp $ */ #include #include @@ -41,13 +41,18 @@ static int wait_flag_table[] = { CAML_WNOHANG, CAML_WUNTRACED }; CAMLprim value win_waitpid(value vflags, value vpid_req) { int flags; - DWORD status; + DWORD status, retcode; HANDLE pid_req = (HANDLE) Long_val(vpid_req); + DWORD err = 0; flags = convert_flag_list(vflags, wait_flag_table); if ((flags & CAML_WNOHANG) == 0) { - if (WaitForSingleObject(pid_req, INFINITE) == WAIT_FAILED) { - win32_maperr(GetLastError()); + enter_blocking_section(); + retcode = WaitForSingleObject(pid_req, INFINITE); + if (retcode == WAIT_FAILED) err = GetLastError(); + leave_blocking_section(); + if (err) { + win32_maperr(err); uerror("waitpid", Nothing); } } diff --git a/otherlibs/win32unix/write.c b/otherlibs/win32unix/write.c index 5be0260f..c1f1916a 100644 --- a/otherlibs/win32unix/write.c +++ b/otherlibs/win32unix/write.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: write.c,v 1.9 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: write.c,v 1.11 2006/10/18 08:26:54 xleroy Exp $ */ #include #include @@ -25,6 +25,7 @@ CAMLprim value unix_write(value fd, value buf, value vofs, value vlen) intnat ofs, len, written; DWORD numbytes, numwritten; char iobuf[UNIX_BUFFER_SIZE]; + DWORD err = 0; Begin_root (buf); ofs = Long_val(vofs); @@ -38,22 +39,19 @@ CAMLprim value unix_write(value fd, value buf, value vofs, value vlen) SOCKET s = Socket_val(fd); enter_blocking_section(); ret = send(s, iobuf, numbytes, 0); + if (ret == SOCKET_ERROR) err = WSAGetLastError(); leave_blocking_section(); - if (ret == SOCKET_ERROR) { - win32_maperr(WSAGetLastError()); - uerror("write", Nothing); - } numwritten = ret; } else { - BOOL ret; HANDLE h = Handle_val(fd); enter_blocking_section(); - ret = WriteFile(h, iobuf, numbytes, &numwritten, NULL); + if (! WriteFile(h, iobuf, numbytes, &numwritten, NULL)) + err = GetLastError(); leave_blocking_section(); - if (! ret) { - win32_maperr(GetLastError()); - uerror("write", Nothing); - } + } + if (err) { + win32_maperr(err); + uerror("write", Nothing); } written += numwritten; ofs += numwritten; @@ -68,6 +66,7 @@ CAMLprim value unix_single_write(value fd, value buf, value vofs, value vlen) intnat ofs, len, written; DWORD numbytes, numwritten; char iobuf[UNIX_BUFFER_SIZE]; + DWORD err; Begin_root (buf); ofs = Long_val(vofs); @@ -81,22 +80,19 @@ CAMLprim value unix_single_write(value fd, value buf, value vofs, value vlen) SOCKET s = Socket_val(fd); enter_blocking_section(); ret = send(s, iobuf, numbytes, 0); + if (ret == SOCKET_ERROR) err = WSAGetLastError(); leave_blocking_section(); - if (ret == SOCKET_ERROR) { - win32_maperr(WSAGetLastError()); - uerror("single_write", Nothing); - } numwritten = ret; } else { - BOOL ret; HANDLE h = Handle_val(fd); enter_blocking_section(); - ret = WriteFile(h, iobuf, numbytes, &numwritten, NULL); + if (! WriteFile(h, iobuf, numbytes, &numwritten, NULL)) + err = GetLastError(); leave_blocking_section(); - if (! ret) { - win32_maperr(GetLastError()); - uerror("single_write", Nothing); - } + } + if (err) { + win32_maperr(err); + uerror("single_write", Nothing); } written = numwritten; } diff --git a/parsing/parser.mly b/parsing/parser.mly index 236ca64d..e6a0d88a 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -10,7 +10,7 @@ /* */ /***********************************************************************/ -/* $Id: parser.mly,v 1.123.4.1 2006/01/24 13:47:51 doligez Exp $ */ +/* $Id: parser.mly,v 1.126 2006/12/15 04:50:30 garrigue Exp $ */ /* The parser definition */ @@ -180,7 +180,7 @@ let bigarray_set arr arg newval = ["", arr; "", c1; "", c2; "", c3; "", newval])) | coords -> mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "set")), - ["", arr; + ["", arr; "", ghexp(Pexp_array coords); "", newval])) %} @@ -623,6 +623,8 @@ class_fields: { [] } | class_fields INHERIT class_expr parent_binder { Pcf_inher ($3, $4) :: $1 } + | class_fields VAL virtual_value + { Pcf_valvirt $3 :: $1 } | class_fields VAL value { Pcf_val $3 :: $1 } | class_fields virtual_method @@ -638,14 +640,20 @@ parent_binder: AS LIDENT { Some $2 } | /* empty */ - {None} + { None } +; +virtual_value: + MUTABLE VIRTUAL label COLON core_type + { $3, Mutable, $5, symbol_rloc () } + | VIRTUAL mutable_flag label COLON core_type + { $3, $2, $5, symbol_rloc () } ; value: - mutable_flag label EQUAL seq_expr - { $2, $1, $4, symbol_rloc () } - | mutable_flag label type_constraint EQUAL seq_expr - { $2, $1, (let (t, t') = $3 in ghexp(Pexp_constraint($5, t, t'))), - symbol_rloc () } + mutable_flag label EQUAL seq_expr + { $2, $1, $4, symbol_rloc () } + | mutable_flag label type_constraint EQUAL seq_expr + { $2, $1, (let (t, t') = $3 in ghexp(Pexp_constraint($5, t, t'))), + symbol_rloc () } ; virtual_method: METHOD PRIVATE VIRTUAL label COLON poly_type @@ -711,8 +719,12 @@ class_sig_fields: | class_sig_fields CONSTRAINT constrain { Pctf_cstr $3 :: $1 } ; value_type: - mutable_flag label COLON core_type - { $2, $1, Some $4, symbol_rloc () } + VIRTUAL mutable_flag label COLON core_type + { $3, $2, Virtual, $5, symbol_rloc () } + | MUTABLE virtual_flag label COLON core_type + { $3, Mutable, $2, $5, symbol_rloc () } + | label COLON core_type + { $1, Immutable, Concrete, $3, symbol_rloc () } ; method_type: METHOD private_flag label COLON poly_type @@ -770,7 +782,8 @@ labeled_simple_pattern: { ("", None, $1) } ; pattern_var: - LIDENT { mkpat(Ppat_var $1) } + LIDENT { mkpat(Ppat_var $1) } + | UNDERSCORE { mkpat Ppat_any } ; opt_default: /* empty */ { None } diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 7eb1f706..3d6c0c52 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: parsetree.mli,v 1.42 2005/03/23 03:08:37 garrigue Exp $ *) +(* $Id: parsetree.mli,v 1.43 2006/04/05 02:28:13 garrigue Exp $ *) (* Abstract syntax tree produced by parsing *) @@ -152,7 +152,7 @@ and class_signature = core_type * class_type_field list and class_type_field = Pctf_inher of class_type - | Pctf_val of (string * mutable_flag * core_type option * Location.t) + | Pctf_val of (string * mutable_flag * virtual_flag * core_type * Location.t) | Pctf_virt of (string * private_flag * core_type * Location.t) | Pctf_meth of (string * private_flag * core_type * Location.t) | Pctf_cstr of (core_type * core_type * Location.t) @@ -179,6 +179,7 @@ and class_structure = pattern * class_field list and class_field = Pcf_inher of class_expr * string option + | Pcf_valvirt of (string * mutable_flag * core_type * Location.t) | Pcf_val of (string * mutable_flag * expression * Location.t) | Pcf_virt of (string * private_flag * core_type * Location.t) | Pcf_meth of (string * private_flag * expression * Location.t) diff --git a/parsing/printast.ml b/parsing/printast.ml index 898a5c93..51f5e405 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: printast.ml,v 1.28.4.1 2005/11/16 16:01:12 doligez Exp $ *) +(* $Id: printast.ml,v 1.30 2006/04/05 02:28:13 garrigue Exp $ *) open Asttypes;; open Format;; @@ -353,10 +353,11 @@ and class_type_field i ppf x = | Pctf_inher (ct) -> line i ppf "Pctf_inher\n"; class_type i ppf ct; - | Pctf_val (s, mf, cto, loc) -> + | Pctf_val (s, mf, vf, ct, loc) -> line i ppf - "Pctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc; - option i core_type ppf cto; + "Pctf_val \"%s\" %a %a %a\n" s + fmt_mutable_flag mf fmt_virtual_flag vf fmt_location loc; + core_type (i+1) ppf ct; | Pctf_virt (s, pf, ct, loc) -> line i ppf "Pctf_virt \"%s\" %a %a\n" s fmt_private_flag pf fmt_location loc; @@ -428,6 +429,10 @@ and class_field i ppf x = line i ppf "Pcf_inher\n"; class_expr (i+1) ppf ce; option (i+1) string ppf so; + | Pcf_valvirt (s, mf, ct, loc) -> + line i ppf + "Pcf_valvirt \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc; + core_type (i+1) ppf ct; | Pcf_val (s, mf, e, loc) -> line i ppf "Pcf_val \"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc; diff --git a/stdlib/.cvsignore b/stdlib/.cvsignore index 1f035fa0..343f6abd 100644 --- a/stdlib/.cvsignore +++ b/stdlib/.cvsignore @@ -3,3 +3,4 @@ camlheader_ur labelled-* caml *.annot +sys.ml diff --git a/stdlib/.depend b/stdlib/.depend index ba9daffa..fe9f5ad1 100644 --- a/stdlib/.depend +++ b/stdlib/.depend @@ -5,7 +5,7 @@ genlex.cmi: stream.cmi moreLabels.cmi: set.cmi map.cmi hashtbl.cmi oo.cmi: camlinternalOO.cmi parsing.cmi: obj.cmi lexing.cmi -printf.cmi: buffer.cmi +printf.cmi: obj.cmi buffer.cmi random.cmi: nativeint.cmi int64.cmi int32.cmi weak.cmi: hashtbl.cmi arg.cmo: sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi arg.cmi @@ -72,8 +72,10 @@ pervasives.cmo: pervasives.cmi pervasives.cmx: pervasives.cmi printexc.cmo: printf.cmi obj.cmi printexc.cmi printexc.cmx: printf.cmx obj.cmx printexc.cmi -printf.cmo: string.cmi obj.cmi list.cmi char.cmi buffer.cmi printf.cmi -printf.cmx: string.cmx obj.cmx list.cmx char.cmx buffer.cmx printf.cmi +printf.cmo: string.cmi obj.cmi list.cmi char.cmi buffer.cmi array.cmi \ + printf.cmi +printf.cmx: string.cmx obj.cmx list.cmx char.cmx buffer.cmx array.cmx \ + printf.cmi queue.cmo: obj.cmi queue.cmi queue.cmx: obj.cmx queue.cmi random.cmo: string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \ @@ -81,9 +83,9 @@ random.cmo: string.cmi pervasives.cmi nativeint.cmi int64.cmi int32.cmi \ random.cmx: string.cmx pervasives.cmx nativeint.cmx int64.cmx int32.cmx \ digest.cmx char.cmx array.cmx random.cmi scanf.cmo: string.cmi printf.cmi obj.cmi list.cmi hashtbl.cmi buffer.cmi \ - scanf.cmi + array.cmi scanf.cmi scanf.cmx: string.cmx printf.cmx obj.cmx list.cmx hashtbl.cmx buffer.cmx \ - scanf.cmi + array.cmx scanf.cmi set.cmo: set.cmi set.cmx: set.cmi sort.cmo: array.cmi sort.cmi diff --git a/stdlib/Makefile b/stdlib/Makefile index fd2bde41..905df33e 100644 --- a/stdlib/Makefile +++ b/stdlib/Makefile @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.85 2004/11/29 14:53:30 doligez Exp $ +# $Id: Makefile,v 1.88 2007/02/09 13:24:20 doligez Exp $ include ../config/Makefile @@ -21,7 +21,7 @@ CAMLC=$(RUNTIME) $(COMPILER) COMPFLAGS=-g -warn-error A -nostdlib OPTCOMPILER=../ocamlopt CAMLOPT=$(RUNTIME) $(OPTCOMPILER) -OPTCOMPFLAGS=-warn-error A -nostdlib +OPTCOMPFLAGS=-warn-error A -nostdlib -g CAMLDEP=../boot/ocamlrun ../tools/ocamldep OBJS=pervasives.cmo $(OTHERS) @@ -90,6 +90,12 @@ camlheader camlheader_ur: header.c ../config/Makefile cp camlheader camlheader_ur; \ fi +sys.ml: sys.mlp ../VERSION + sed -e "s|%%VERSION%%|`head -1 ../VERSION`|" sys.mlp >sys.ml + +clean:: + rm -f sys.ml + clean:: rm -f camlheader camlheader_ur diff --git a/stdlib/Makefile.nt b/stdlib/Makefile.nt index 5c1879df..0022f050 100644 --- a/stdlib/Makefile.nt +++ b/stdlib/Makefile.nt @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.37.4.1 2006/03/29 14:48:28 doligez Exp $ +# $Id: Makefile.nt,v 1.43 2007/02/23 12:42:42 doligez Exp $ include ../config/Makefile @@ -21,7 +21,7 @@ CAMLC=$(RUNTIME) $(COMPILER) COMPFLAGS=-warn-error A -nostdlib OPTCOMPILER=../ocamlopt CAMLOPT=$(RUNTIME) $(OPTCOMPILER) -OPTCOMPFLAGS=-warn-error A -nostdlib +OPTCOMPFLAGS=-warn-error A -nostdlib -g CAMLDEP=../boot/ocamlrun ../tools/ocamldep OBJS=pervasives.cmo $(OTHERS) @@ -55,11 +55,17 @@ stdlib.cmxa: $(OBJS:.cmo=.cmx) $(CAMLOPT) -a -o stdlib.cmxa $(OBJS:.cmo=.cmx) camlheader camlheader_ur: headernt.c ../config/Makefile - $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) -o tmpheader.exe headernt.c + $(call MKEXE,tmpheader.exe,-I../byterun $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) headernt.c $(EXTRALIBS)) rm -f camlheader.exe mv tmpheader.exe camlheader cp camlheader camlheader_ur +sys.ml: sys.mlp ../VERSION + sed -e "s|%%VERSION%%|`head -1 ../VERSION`|" sys.mlp >sys.ml + +clean:: + rm -f sys.ml + clean:: rm -f camlheader camlheader_ur diff --git a/stdlib/arrayLabels.mli b/stdlib/arrayLabels.mli index 8aee7684..8bd10255 100644 --- a/stdlib/arrayLabels.mli +++ b/stdlib/arrayLabels.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: arrayLabels.mli,v 1.11 2005/10/25 18:34:07 doligez Exp $ *) +(* $Id: arrayLabels.mli,v 1.12 2007/01/22 08:06:09 garrigue Exp $ *) (** Array operations. *) @@ -22,17 +22,18 @@ external get : 'a array -> int -> 'a = "%array_safe_get" (** [Array.get a n] returns the element number [n] of array [a]. The first element has number 0. The last element has number [Array.length a - 1]. - Raise [Invalid_argument "Array.get"] if [n] is outside the range - 0 to [(Array.length a - 1)]. - You can also write [a.(n)] instead of [Array.get a n]. *) + You can also write [a.(n)] instead of [Array.get a n]. + + Raise [Invalid_argument "index out of bounds"] + if [n] is outside the range 0 to [(Array.length a - 1)]. *) external set : 'a array -> int -> 'a -> unit = "%array_safe_set" (** [Array.set a n x] modifies array [a] in place, replacing element number [n] with [x]. + You can also write [a.(n) <- x] instead of [Array.set a n x]. - Raise [Invalid_argument "Array.set"] if [n] is outside the range - 0 to [Array.length a - 1]. - You can also write [a.(n) <- x] instead of [Array.set a n x]. *) + Raise [Invalid_argument "index out of bounds"] + if [n] is outside the range 0 to [Array.length a - 1]. *) external make : int -> 'a -> 'a array = "caml_make_vect" (** [Array.make n x] returns a fresh array of length [n], @@ -54,7 +55,11 @@ val init : int -> f:(int -> 'a) -> 'a array (** [Array.init n f] returns a fresh array of length [n], with element number [i] initialized to the result of [f i]. In other terms, [Array.init n f] tabulates the results of [f] - applied to the integers [0] to [n-1]. *) + applied to the integers [0] to [n-1]. + + Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. + If the return type of [f] is [float], then the maximum + size is only [Sys.max_array_length / 2].*) val make_matrix : dimx:int -> dimy:int -> 'a -> 'a array array (** [Array.make_matrix dimx dimy e] returns a two-dimensional array @@ -64,7 +69,7 @@ val make_matrix : dimx:int -> dimy:int -> 'a -> 'a array array The element ([x,y]) of a matrix [m] is accessed with the notation [m.(x).(y)]. - Raise [Invalid_argument] if [dimx] or [dimy] is less than 1 or + Raise [Invalid_argument] if [dimx] or [dimy] is negative or greater than [Sys.max_array_length]. If the value of [e] is a floating-point number, then the maximum size is only [Sys.max_array_length / 2]. *) @@ -151,7 +156,6 @@ val fold_right : f:('b -> 'a -> 'a) -> 'b array -> init:'a -> 'a where [n] is the length of the array [a]. *) - (** {6 Sorting} *) @@ -159,24 +163,36 @@ val sort : cmp:('a -> 'a -> int) -> 'a array -> unit (** Sort an array in increasing order according to a comparison function. The comparison function must return 0 if its arguments compare as equal, a positive integer if the first is greater, - and a negative integer if the first is smaller. For example, - the {!Pervasives.compare} function is a suitable comparison function. - After calling [Array.sort], the array is sorted in place in - increasing order. + and a negative integer if the first is smaller (see below for a + complete specification). For example, {!Pervasives.compare} is + a suitable comparison function, provided there are no floating-point + NaN values in the data. After calling [Array.sort], the + array is sorted in place in increasing order. [Array.sort] is guaranteed to run in constant heap space - and logarithmic stack space. - + and (at most) logarithmic stack space. The current implementation uses Heap Sort. It runs in constant stack space. + + Specification of the comparison function: + Let [a] be the array and [cmp] the comparison function. The following + must be true for all x, y, z in a : +- [cmp x y] > 0 if and only if [cmp y x] < 0 +- if [cmp x y] >= 0 and [cmp y z] >= 0 then [cmp x z] >= 0 + + When [Array.sort] returns, [a] contains the same elements as before, + reordered in such a way that for all i and j valid indices of [a] : +- [cmp a.(i) a.(j)] >= 0 if and only if i >= j *) val stable_sort : cmp:('a -> 'a -> int) -> 'a array -> unit -(** Same as {!ArrayLabels.sort}, but the sorting algorithm is stable and - not guaranteed to use a fixed amount of heap memory. - The current implementation is Merge Sort. It uses [n/2] +(** Same as {!ArrayLabels.sort}, but the sorting algorithm is stable (i.e. + elements that compare equal are kept in their original order) and + not guaranteed to run in constant heap space. + + The current implementation uses Merge Sort. It uses [n/2] words of heap space, where [n] is the length of the array. - It is faster than the current implementation of {!ArrayLabels.sort}. + It is usually faster than the current implementation of {!ArrayLabels.sort}. *) val fast_sort : cmp:('a -> 'a -> int) -> 'a array -> unit diff --git a/stdlib/camlinternalMod.ml b/stdlib/camlinternalMod.ml index 3b477e0e..92934707 100644 --- a/stdlib/camlinternalMod.ml +++ b/stdlib/camlinternalMod.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: camlinternalMod.ml,v 1.4.2.1 2006/05/06 07:27:40 xleroy Exp $ *) +(* $Id: camlinternalMod.ml,v 1.5 2006/09/20 11:14:37 doligez Exp $ *) type shape = | Function diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml index dfd9a772..d654cb69 100644 --- a/stdlib/camlinternalOO.ml +++ b/stdlib/camlinternalOO.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: camlinternalOO.ml,v 1.14 2005/10/25 18:34:07 doligez Exp $ *) +(* $Id: camlinternalOO.ml,v 1.15 2006/04/05 02:28:13 garrigue Exp $ *) open Obj @@ -206,7 +206,11 @@ let narrow table vars virt_meths concr_meths = (table.methods_by_name, table.methods_by_label, table.hidden_meths, table.vars, virt_meth_labs, vars) :: table.previous_states; - table.vars <- Vars.empty; + table.vars <- + Vars.fold + (fun lab info tvars -> + if List.mem lab vars then Vars.add lab info tvars else tvars) + table.vars Vars.empty; let by_name = ref Meths.empty in let by_label = ref Labs.empty in List.iter2 @@ -255,9 +259,11 @@ let new_slot table = index let new_variable table name = - let index = new_slot table in - table.vars <- Vars.add name index table.vars; - index + try Vars.find name table.vars + with Not_found -> + let index = new_slot table in + table.vars <- Vars.add name index table.vars; + index let to_array arr = if arr = Obj.magic 0 then [||] else arr @@ -265,16 +271,17 @@ let to_array arr = let new_methods_variables table meths vals = let meths = to_array meths in let nmeths = Array.length meths and nvals = Array.length vals in - let index = new_variable table vals.(0) in - let res = Array.create (nmeths + 1) index in - for i = 1 to nvals - 1 do ignore (new_variable table vals.(i)) done; + let res = Array.create (nmeths + nvals) 0 in for i = 0 to nmeths - 1 do - res.(i+1) <- get_method_label table meths.(i) + res.(i) <- get_method_label table meths.(i) + done; + for i = 0 to nvals - 1 do + res.(i+nmeths) <- new_variable table vals.(i) done; res let get_variable table name = - Vars.find name table.vars + try Vars.find name table.vars with Not_found -> assert false let get_variables table names = Array.map (get_variable table) names @@ -315,9 +322,12 @@ let inherits cla vals virt_meths concr_meths (_, super, _, env) top = let init = if top then super cla env else Obj.repr (super cla) in widen cla; - (init, Array.map (get_variable cla) (to_array vals), - Array.map (fun nm -> get_method cla (get_method_label cla nm)) - (to_array concr_meths)) + Array.concat + [[| repr init |]; + magic (Array.map (get_variable cla) (to_array vals) : int array); + Array.map + (fun nm -> repr (get_method cla (get_method_label cla nm) : closure)) + (to_array concr_meths) ] let make_class pub_meths class_init = let table = create_table pub_meths in diff --git a/stdlib/camlinternalOO.mli b/stdlib/camlinternalOO.mli index b81314ef..fb6d4f2d 100644 --- a/stdlib/camlinternalOO.mli +++ b/stdlib/camlinternalOO.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: camlinternalOO.mli,v 1.9 2005/10/25 18:34:07 doligez Exp $ *) +(* $Id: camlinternalOO.mli,v 1.10 2006/04/05 02:28:13 garrigue Exp $ *) (** Run-time support for objects and classes. All functions in this module are for system use only, not for the @@ -46,8 +46,7 @@ val create_table : string array -> table val init_class : table -> unit val inherits : table -> string array -> string array -> string array -> - (t * (table -> obj -> Obj.t) * t * obj) -> bool -> - (Obj.t * int array * closure array) + (t * (table -> obj -> Obj.t) * t * obj) -> bool -> Obj.t array val make_class : string array -> (table -> Obj.t -> t) -> (t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t) @@ -79,6 +78,7 @@ val lookup_tables : tables -> closure array -> tables (** {6 Builtins to reduce code size} *) +(* val get_const : t -> closure val get_var : int -> closure val get_env : int -> int -> closure @@ -103,6 +103,7 @@ val send_const : tag -> obj -> int -> closure val send_var : tag -> int -> int -> closure val send_env : tag -> int -> int -> int -> closure val send_meth : tag -> label -> int -> closure +*) type impl = GetConst diff --git a/stdlib/filename.ml b/stdlib/filename.ml index b2bf144c..a94a12f3 100644 --- a/stdlib/filename.ml +++ b/stdlib/filename.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: filename.ml,v 1.37.2.2 2006/01/05 19:19:52 doligez Exp $ *) +(* $Id: filename.ml,v 1.41 2007/01/09 13:42:17 doligez Exp $ *) let generic_quote quotequote s = let l = String.length s in @@ -97,14 +97,21 @@ module Win32 = struct let l = String.length s in let b = Buffer.create (l + 20) in Buffer.add_char b '\"'; - for i = 0 to l - 1 do + let rec loop i = + if i = l then () else match s.[i] with - '\"' -> Buffer.add_string b "\\\"" - | '\\' -> if i + 1 = l then Buffer.add_string b "\\\\" - else if s.[i + 1] = '\"' then Buffer.add_string b "\\\\\\\"" - else Buffer.add_char b '\\' - | c -> Buffer.add_char b c - done; + | '\"' -> loop_bs 0 i; + | '\\' -> loop_bs 0 i; + | c -> Buffer.add_char b c; loop (i+1); + and loop_bs n i = + if i = l then add_bs (2*n) else + match s.[i] with + | '\"' -> add_bs (2*n+1); Buffer.add_char b '\"'; loop (i+1); + | '\\' -> loop_bs (n+1) (i+1); + | c -> add_bs n; loop i + and add_bs n = for j = 1 to n do Buffer.add_char b '\\'; done + in + loop 0; Buffer.add_char b '\"'; Buffer.contents b let has_drive s = diff --git a/stdlib/filename.mli b/stdlib/filename.mli index e8cf9fe0..a9c78379 100644 --- a/stdlib/filename.mli +++ b/stdlib/filename.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: filename.mli,v 1.33.2.1 2005/11/29 12:17:27 doligez Exp $ *) +(* $Id: filename.mli,v 1.35 2007/01/09 13:42:17 doligez Exp $ *) (** Operations on file names. *) @@ -100,5 +100,8 @@ val temp_dir_name : string val quote : string -> string (** Return a quoted version of a file name, suitable for use as - one argument in a shell command line, escaping all shell - meta-characters. *) + one argument in a command line, escaping all meta-characters. + Warning: under Windows, the output is only suitable for use + with programs that follow the standard Windows quoting + conventions. + *) diff --git a/stdlib/format.ml b/stdlib/format.ml index 49b40678..caa66a15 100644 --- a/stdlib/format.ml +++ b/stdlib/format.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: format.ml,v 1.65 2005/09/26 10:13:08 weis Exp $ *) +(* $Id: format.ml,v 1.70 2006/11/17 08:34:05 weis Exp $ *) (************************************************************** @@ -910,14 +910,17 @@ and set_tags = **************************************************************) +module Sformat = Printf.CamlinternalPr.Sformat;; +module Tformat = Printf.CamlinternalPr.Tformat;; + (* Error messages when processing formats. *) (* Trailer: giving up at character number ... *) let giving_up mess fmt i = - "fprintf: " ^ mess ^ " ``" ^ fmt ^ "'', \ + "fprintf: " ^ mess ^ " ``" ^ Sformat.to_string fmt ^ "'', \ giving up at character number " ^ string_of_int i ^ - (if i < String.length fmt - then " (" ^ String.make 1 fmt.[i] ^ ")." + (if i < Sformat.length fmt + then " (" ^ String.make 1 (Sformat.get fmt i) ^ ")." else String.make 1 '.');; (* When an invalid format deserves a special error explanation. *) @@ -963,20 +966,20 @@ let implode_rev s0 = function | [] -> s0 | l -> String.concat "" (List.rev (s0 :: l));; -external format_to_string : ('a, 'b, 'c, 'd) format4 -> string = "%identity";; - -(* [fprintf_out] is the printf-like function generator: given the - - [str] flag that tells if we are printing into a string, - - the [out] function that has to be called at the end of formatting, - it generates a [fprintf] function that takes as arguments a [ppf] - formatter and a printing format to print the rest of arguments - according to the format. +(* [mkprintf] is the printf-like function generator: given the + - [to_s] flag that tells if we are printing into a string, + - the [get_out] function that has to be called to get a [ppf] function to + output onto. + It generates a [kprintf] function that takes as arguments a [k] + continuation function to be called at the end of formatting, + and a printing format string to print the rest of the arguments + according to the format string. Regular [fprintf]-like functions of this module are obtained via partial - applications of [fprintf_out]. *) -let mkprintf str get_out = + applications of [mkprintf]. *) +let mkprintf to_s get_out = + let rec kprintf k fmt = - let fmt = format_to_string fmt in - let len = String.length fmt in + let len = Sformat.length fmt in let kpr fmt v = let ppf = get_out fmt in @@ -996,13 +999,13 @@ let mkprintf str get_out = let rec doprn n i = if i >= len then Obj.magic (k ppf) else - match fmt.[i] with + match Sformat.get fmt i with | '%' -> - Printf.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m + Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m | '@' -> let i = succ i in if i >= len then invalid_format fmt i else - begin match fmt.[i] with + begin match Sformat.get fmt i with | '[' -> do_pp_open_box ppf n (succ i) | ']' -> @@ -1047,26 +1050,25 @@ let mkprintf str get_out = and cont_s n s i = pp_print_as_string s; doprn n i and cont_a n printer arg i = - if str then + if to_s then pp_print_as_string ((Obj.magic printer : unit -> _ -> string) () arg) else printer ppf arg; doprn n i and cont_t n printer i = - if str then + if to_s then pp_print_as_string ((Obj.magic printer : unit -> string) ()) else printer ppf; doprn n i and cont_f n i = pp_print_flush ppf (); doprn n i - and cont_m n sfmt i = kprintf (Obj.magic (fun _ -> doprn n i)) sfmt and get_int n i c = if i >= len then invalid_integer fmt i else - match fmt.[i] with + match Sformat.get fmt i with | ' ' -> get_int n (succ i) c | '%' -> let cont_s n s i = c (format_int_of_string fmt i s) n i @@ -1074,37 +1076,38 @@ let mkprintf str get_out = and cont_t n printer i = invalid_integer fmt i and cont_f n i = invalid_integer fmt i and cont_m n sfmt i = invalid_integer fmt i in - Printf.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m + Tformat.scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m | _ -> let rec get j = if j >= len then invalid_integer fmt j else - match fmt.[j] with + match Sformat.get fmt j with | '0' .. '9' | '-' -> get (succ j) | _ -> let size = if j = i then size_of_int 0 else - format_int_of_string fmt j (String.sub fmt i (j - i)) in + let s = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in + format_int_of_string fmt j s in c size n j in get i and skip_gt i = if i >= len then invalid_format fmt i else - match fmt.[i] with + match Sformat.get fmt i with | ' ' -> skip_gt (succ i) | '>' -> succ i | _ -> invalid_format fmt i and get_box_kind i = if i >= len then Pp_box, i else - match fmt.[i] with + match Sformat.get fmt i with | 'h' -> let i = succ i in if i >= len then Pp_hbox, i else - begin match fmt.[i] with + begin match Sformat.get fmt i with | 'o' -> let i = succ i in if i >= len then format_invalid_arg "bad box format" fmt i else - begin match fmt.[i] with + begin match Sformat.get fmt i with | 'v' -> Pp_hovbox, succ i | c -> format_invalid_arg @@ -1119,21 +1122,21 @@ let mkprintf str get_out = and get_tag_name n i c = let rec get accu n i j = if j >= len - then c (implode_rev (String.sub fmt i (j - i)) accu) n j else - match fmt.[j] with - | '>' -> c (implode_rev (String.sub fmt i (j - i)) accu) n j + then c (implode_rev (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) accu) n j else + match Sformat.get fmt j with + | '>' -> c (implode_rev (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) accu) n j | '%' -> - let s0 = String.sub fmt i (j - i) in + let s0 = Sformat.sub fmt (Sformat.index_of_int i) (j - i) in let cont_s n s i = get (s :: s0 :: accu) n i i and cont_a n printer arg i = let s = - if str + if to_s then (Obj.magic printer : unit -> _ -> string) () arg else exstring printer arg in get (s :: s0 :: accu) n i i and cont_t n printer i = let s = - if str + if to_s then (Obj.magic printer : unit -> string) () else exstring (fun ppf () -> printer ppf) () in get (s :: s0 :: accu) n i i @@ -1141,13 +1144,13 @@ let mkprintf str get_out = format_invalid_arg "bad tag name specification" fmt i and cont_m n sfmt i = format_invalid_arg "bad tag name specification" fmt i in - Printf.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m + Tformat.scan_format fmt v n j cont_s cont_a cont_t cont_f cont_m | c -> get accu n i (succ j) in get [] n i i and do_pp_break ppf n i = if i >= len then begin pp_print_space ppf (); doprn n i end else - match fmt.[i] with + match Sformat.get fmt i with | '<' -> let rec got_nspaces nspaces n i = get_int n i (got_offset nspaces) @@ -1159,7 +1162,7 @@ let mkprintf str get_out = and do_pp_open_box ppf n i = if i >= len then begin pp_open_box_gen ppf 0 Pp_box; doprn n i end else - match fmt.[i] with + match Sformat.get fmt i with | '<' -> let kind, i = get_box_kind (succ i) in let got_size size n i = @@ -1170,7 +1173,7 @@ let mkprintf str get_out = and do_pp_open_tag ppf n i = if i >= len then begin pp_open_tag ppf ""; doprn n i end else - match fmt.[i] with + match Sformat.get fmt i with | '<' -> let got_name tag_name n i = pp_open_tag ppf tag_name; @@ -1178,9 +1181,9 @@ let mkprintf str get_out = get_tag_name n (succ i) got_name | c -> pp_open_tag ppf ""; doprn n i in - doprn (Printf.index_of_int 0) 0 in + doprn (Sformat.index_of_int 0) 0 in - Printf.kapr kpr fmt in + Tformat.kapr kpr fmt in kprintf;; @@ -1191,6 +1194,7 @@ let mkprintf str get_out = **************************************************************) let kfprintf k ppf = mkprintf false (fun _ -> ppf) k;; +let ifprintf ppf = Tformat.kapr (fun _ -> Obj.magic ignore);; let fprintf ppf = kfprintf ignore ppf;; let printf fmt = fprintf std_formatter fmt;; diff --git a/stdlib/format.mli b/stdlib/format.mli index 984dcfec..f0266e57 100644 --- a/stdlib/format.mli +++ b/stdlib/format.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: format.mli,v 1.71 2005/10/25 18:34:07 doligez Exp $ *) +(* $Id: format.mli,v 1.74 2006/11/17 08:37:07 weis Exp $ *) (** Pretty printing. @@ -24,13 +24,6 @@ [Format], read {{:http://caml.inria.fr/resources/doc/guides/format.html}http://caml.inria.fr/resources/doc/guides/format.html}. - Warning: the material output by the following functions is delayed - in the pretty-printer queue in order to compute the proper line - breaking. Hence, you should not mix calls to the printing functions - of the basic I/O system with calls to the functions of this module: - this could result in some strange output seemingly unrelated with - the evaluation order of printing commands. - You may consider this module as providing an extension to the [printf] facility to provide automatic line breaking. The addition of pretty-printing annotations to your regular [printf] formats gives you @@ -70,6 +63,13 @@ flushes all pending text (as with the [print_newline] function) after each phrase. Each phrase is therefore executed in the initial state of the pretty-printer. + + Warning: the material output by the following functions is delayed + in the pretty-printer queue in order to compute the proper line + breaking. Hence, you should not mix calls to the printing functions + of the basic I/O system with calls to the functions of this module: + this could result in some strange output seemingly unrelated with + the evaluation order of printing commands. *) @@ -590,7 +590,7 @@ val fprintf : formatter -> ('a, formatter, unit) format -> 'a;; [nspaces] and [offset] parameters of the break may be optionally specified with the following syntax: the [<] character, followed by an integer [nspaces] value, - then an integer offset, and a closing [>] character. + then an integer [offset], and a closing [>] character. If no parameters are provided, the good break defaults to a space. - [@?]: flush the pretty printer as with [print_flush ()]. @@ -656,6 +656,10 @@ val kfprintf : (formatter -> 'a) -> formatter -> (** Same as [fprintf] above, but instead of returning immediately, passes the formatter to its first argument at the end of printing. *) +val ifprintf : formatter -> ('a, formatter, unit) format -> 'a;; +(** Same as [fprintf] above, but does not print anything. + Useful to ignore some material when conditionally printing. *) + val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; (** Same as [sprintf] above, but instead of returning the string, passes it to the first argument. *) diff --git a/stdlib/headernt.c b/stdlib/headernt.c index 5a8ba2c9..cf459fa5 100644 --- a/stdlib/headernt.c +++ b/stdlib/headernt.c @@ -11,14 +11,14 @@ /* */ /***********************************************************************/ -/* $Id: headernt.c,v 1.19 2002/07/23 14:12:01 doligez Exp $ */ +/* $Id: headernt.c,v 1.20 2007/02/07 10:31:36 ertai Exp $ */ #define STRICT #define WIN32_LEAN_AND_MEAN #include -#include "../byterun/mlvalues.h" -#include "../byterun/exec.h" +#include "mlvalues.h" +#include "exec.h" #ifndef __MINGW32__ #pragma comment(linker , "/entry:headerentry") diff --git a/stdlib/int32.ml b/stdlib/int32.ml index c0364854..a81acec0 100644 --- a/stdlib/int32.ml +++ b/stdlib/int32.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: int32.ml,v 1.9 2004/01/01 16:42:40 doligez Exp $ *) +(* $Id: int32.ml,v 1.10 2007/01/30 09:34:36 xleroy Exp $ *) (* Module [Int32]: 32-bit integers *) @@ -51,4 +51,4 @@ external of_string : string -> int32 = "caml_int32_of_string" type t = int32 -let compare = (Pervasives.compare: t -> t -> int) +let compare (x: t) (y: t) = Pervasives.compare x y diff --git a/stdlib/int64.ml b/stdlib/int64.ml index 11b6ffac..58f71f40 100644 --- a/stdlib/int64.ml +++ b/stdlib/int64.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: int64.ml,v 1.11 2004/01/01 16:42:40 doligez Exp $ *) +(* $Id: int64.ml,v 1.12 2007/01/30 09:34:36 xleroy Exp $ *) (* Module [Int64]: 64-bit integers *) @@ -56,4 +56,4 @@ external float_of_bits : int64 -> float = "caml_int64_float_of_bits" type t = int64 -let compare = (Pervasives.compare: t -> t -> int) +let compare (x: t) (y: t) = Pervasives.compare x y diff --git a/stdlib/lexing.mli b/stdlib/lexing.mli index 7d86b727..d7c95bcf 100644 --- a/stdlib/lexing.mli +++ b/stdlib/lexing.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: lexing.mli,v 1.31 2005/10/25 18:34:07 doligez Exp $ *) +(* $Id: lexing.mli,v 1.32 2006/09/12 10:38:18 doligez Exp $ *) (** The run-time library for lexers generated by [ocamllex]. *) @@ -29,6 +29,9 @@ type position = { of characters between the beginning of the file and the beginning of the line); [pos_cnum] is the offset of the position (number of characters between the beginning of the file and the position). + + See the documentation of type [lexbuf] for information about + how the lexing engine will manage positions. *) val dummy_pos : position;; @@ -59,11 +62,13 @@ type lexbuf = The lexer buffer holds the current state of the scanner, plus a function to refill the buffer from the input. - Note that the lexing engine will only manage the [pos_cnum] field + Note that the lexing engine will only change the [pos_cnum] field of [lex_curr_p] by updating it with the number of characters read - since the start of the [lexbuf]. For the other fields to be + since the start of the [lexbuf]. The other fields are copied + without change by the lexing engine. In order to keep them accurate, they must be initialised before the first use of the - lexbuf, and updated by the lexer actions. + lexbuf, and updated by the relevant lexer actions (i.e. at each + end of line). *) val from_channel : in_channel -> lexbuf diff --git a/stdlib/list.ml b/stdlib/list.ml index 68575bf3..e51b0b76 100644 --- a/stdlib/list.ml +++ b/stdlib/list.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: list.ml,v 1.32 2005/10/25 18:34:07 doligez Exp $ *) +(* $Id: list.ml,v 1.33 2006/09/11 12:18:00 doligez Exp $ *) (* List operations *) @@ -29,13 +29,13 @@ let tl = function [] -> failwith "tl" | a::l -> l -let rec nth l n = - match l with - [] -> failwith "nth" - | a::l -> - if n = 0 then a else - if n > 0 then nth l (n-1) else - invalid_arg "List.nth" +let nth l n = + if n < 0 then invalid_arg "List.nth" else + let rec nth_aux l n = + match l with + | [] -> failwith "nth" + | a::l -> if n = 0 then a else nth_aux l (n-1) + in nth_aux l n let append = (@) diff --git a/stdlib/list.mli b/stdlib/list.mli index 37cdeb84..0ee4adca 100644 --- a/stdlib/list.mli +++ b/stdlib/list.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: list.mli,v 1.46 2005/10/25 18:34:07 doligez Exp $ *) +(* $Id: list.mli,v 1.47 2006/09/11 12:18:00 doligez Exp $ *) (** List operations. @@ -38,9 +38,10 @@ val tl : 'a list -> 'a list [Failure "tl"] if the list is empty. *) val nth : 'a list -> int -> 'a -(** Return the n-th element of the given list. +(** Return the [n]-th element of the given list. The first element (head of the list) is at position 0. - Raise [Failure "nth"] if the list is too short. *) + Raise [Failure "nth"] if the list is too short. + Raise [Invalid_argument "List.nth"] if [n] is negative. *) val rev : 'a list -> 'a list (** List reversal. *) diff --git a/stdlib/listLabels.mli b/stdlib/listLabels.mli index e4cd50ef..730a974f 100644 --- a/stdlib/listLabels.mli +++ b/stdlib/listLabels.mli @@ -11,8 +11,7 @@ (* *) (***********************************************************************) -(* $Id: listLabels.mli,v 1.11 2005/10/25 18:34:07 doligez Exp $ *) - +(* $Id: listLabels.mli,v 1.12 2007/01/22 08:06:09 garrigue Exp $ *) (** List operations. @@ -39,9 +38,10 @@ val tl : 'a list -> 'a list [Failure "tl"] if the list is empty. *) val nth : 'a list -> int -> 'a -(** Return the n-th element of the given list. +(** Return the [n]-th element of the given list. The first element (head of the list) is at position 0. - Raise [Failure "nth"] if the list is too short. *) + Raise [Failure "nth"] if the list is too short. + Raise [Invalid_argument "List.nth"] if [n] is negative. *) val rev : 'a list -> 'a list (** List reversal. *) @@ -57,11 +57,13 @@ val rev_append : 'a list -> 'a list -> 'a list tail-recursive and more efficient. *) val concat : 'a list list -> 'a list -(** Concatenate a list of lists. Not tail-recursive +(** Concatenate a list of lists. The elements of the argument are all + concatenated together (in the same order) to give the result. + Not tail-recursive (length of the argument + length of the longest sub-list). *) val flatten : 'a list list -> 'a list -(** Flatten a list of lists. Not tail-recursive +(** Same as [concat]. Not tail-recursive (length of the argument + length of the longest sub-list). *) @@ -108,8 +110,8 @@ val map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list different lengths. Not tail-recursive. *) val rev_map2 : f:('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list -(** [List.rev_map2 f l] gives the same result as - {!ListLabels.rev}[ (]{!ListLabels.map2}[ f l)], but is tail-recursive and +(** [List.rev_map2 f l1 l2] gives the same result as + {!ListLabels.rev}[ (]{!ListLabels.map2}[ f l1 l2)], but is tail-recursive and more efficient. *) val fold_left2 : @@ -127,8 +129,6 @@ val fold_right2 : different lengths. Not tail-recursive. *) - - (** {6 List scanning} *) @@ -161,8 +161,6 @@ val memq : 'a -> set:'a list -> bool equality to compare list elements. *) - - (** {6 List searching} *) @@ -188,8 +186,6 @@ val partition : f:('a -> bool) -> 'a list -> 'a list * 'a list The order of the elements in the input list is preserved. *) - - (** {6 Association lists} *) @@ -202,8 +198,8 @@ val assoc : 'a -> ('a * 'b) list -> 'b list [l]. *) val assq : 'a -> ('a * 'b) list -> 'b -(** Same as {!ListLabels.assoc}, but uses physical equality instead of structural - equality to compare keys. *) +(** Same as {!ListLabels.assoc}, but uses physical equality instead of + structural equality to compare keys. *) val mem_assoc : 'a -> map:('a * 'b) list -> bool (** Same as {!ListLabels.assoc}, but simply return true if a binding exists, @@ -219,12 +215,10 @@ val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list Not tail-recursive. *) val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list -(** Same as {!ListLabels.remove_assq}, but uses physical equality instead +(** Same as {!ListLabels.remove_assoc}, but uses physical equality instead of structural equality to compare keys. Not tail-recursive. *) - - (** {6 Lists of pairs} *) @@ -242,29 +236,31 @@ val combine : 'a list -> 'b list -> ('a * 'b) list have different lengths. Not tail-recursive. *) - (** {6 Sorting} *) val sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list (** Sort a list in increasing order according to a comparison - function. The comparison function must return 0 if it arguments + function. The comparison function must return 0 if its arguments compare as equal, a positive integer if the first is greater, - and a negative integer if the first is smaller. For example, - the [compare] function is a suitable comparison function. + and a negative integer if the first is smaller (see Array.sort for + a complete specification). For example, + {!Pervasives.compare} is a suitable comparison function. The resulting list is sorted in increasing order. [List.sort] is guaranteed to run in constant heap space (in addition to the size of the result list) and logarithmic stack space. - The current implementation uses Merge Sort and is the same as - {!ListLabels.stable_sort}. + The current implementation uses Merge Sort. It runs in constant + heap space and logarithmic stack space. *) val stable_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list -(** Same as {!ListLabels.sort}, but the sorting algorithm is stable. +(** Same as {!ListLabels.sort}, but the sorting algorithm is guaranteed to + be stable (i.e. elements that compare equal are kept in their + original order) . - The current implementation is Merge Sort. It runs in constant + The current implementation uses Merge Sort. It runs in constant heap space and logarithmic stack space. *) diff --git a/stdlib/nativeint.ml b/stdlib/nativeint.ml index 02c1ecf1..83c2a9ba 100644 --- a/stdlib/nativeint.ml +++ b/stdlib/nativeint.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: nativeint.ml,v 1.10 2004/01/01 16:42:40 doligez Exp $ *) +(* $Id: nativeint.ml,v 1.11 2007/01/30 09:34:36 xleroy Exp $ *) (* Module [Nativeint]: processor-native integers *) @@ -52,4 +52,4 @@ external of_string: string -> nativeint = "caml_nativeint_of_string" type t = nativeint -let compare = (Pervasives.compare: t -> t -> int) +let compare (x: t) (y: t) = Pervasives.compare x y diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml index a36d9873..01667568 100644 --- a/stdlib/pervasives.ml +++ b/stdlib/pervasives.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: pervasives.ml,v 1.79 2005/10/25 18:34:07 doligez Exp $ *) +(* $Id: pervasives.ml,v 1.81 2006/11/17 08:34:01 weis Exp $ *) (* type 'a option = None | Some of 'a *) @@ -398,16 +398,25 @@ external incr: int ref -> unit = "%incr" external decr: int ref -> unit = "%decr" (* Formats *) +type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 + type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 + external format_of_string : - ('a, 'b, 'c, 'd) format4 -> ('a, 'b, 'c, 'd) format4 = "%identity" -external format_to_string : - ('a, 'b, 'c, 'd) format4 -> string = "%identity" -external string_to_format : string -> ('a, 'b, 'c, 'd) format4 = "%identity" + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" -let (( ^^ ) : ('a, 'b, 'c, 'd) format4 -> ('d, 'b, 'c, 'e) format4 -> - ('a, 'b, 'c, 'e) format4) = fun fmt1 fmt2 -> - string_to_format (format_to_string fmt1 ^ format_to_string fmt2);; +external format_to_string : + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string = "%identity" +external string_to_format : + string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" + +let (( ^^ ) : + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + ('f, 'b, 'c, 'e, 'g, 'h) format6 -> + ('a, 'b, 'c, 'd, 'g, 'h) format6) = + fun fmt1 fmt2 -> + string_to_format (format_to_string fmt1 ^ format_to_string fmt2);; let string_of_format fmt = let s = format_to_string fmt in diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli index 7e23ec68..aa85e4da 100644 --- a/stdlib/pervasives.mli +++ b/stdlib/pervasives.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: pervasives.mli,v 1.104.2.1 2006/02/01 14:32:00 doligez Exp $ *) +(* $Id: pervasives.mli,v 1.108 2007/02/21 14:15:19 xleroy Exp $ *) (** The initially opened module. @@ -337,7 +337,7 @@ external truncate : float -> int = "%intoffloat" external int_of_float : float -> int = "%intoffloat" (** Truncate the given floating-point number to an integer. - The result is unspecified if it falls outside the + The result is unspecified if the argument is [nan] or falls outside the range of representable integers. *) val infinity : float @@ -818,6 +818,7 @@ external decr : int ref -> unit = "%decr" (** See modules {!Printf} and {!Scanf} for more operations on format strings. *) +type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 (** Simplified type for format strings, included for backward compatibility @@ -827,17 +828,19 @@ type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 and ['b] is the type of the first argument given to [%a] and [%t] printing functions. *) -val string_of_format : ('a, 'b, 'c, 'd) format4 -> string +val string_of_format : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string (** Converts a format string into a string. *) external format_of_string : - ('a, 'b, 'c, 'd) format4 -> ('a, 'b, 'c, 'd) format4 = "%identity" + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" (** [format_of_string s] returns a format string read from the string literal [s]. *) val ( ^^ ) : - ('a, 'b, 'c, 'd) format4 -> ('d, 'b, 'c, 'e) format4 -> - ('a, 'b, 'c, 'e) format4;; + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + ('f, 'b, 'c, 'e, 'g, 'h) format6 -> + ('a, 'b, 'c, 'd, 'g, 'h) format6 (** [f1 ^^ f2] catenates formats [f1] and [f2]. The result is a format that accepts arguments from [f1], then arguments from [f2]. *) diff --git a/stdlib/printf.ml b/stdlib/printf.ml index 415f2e60..1365f694 100644 --- a/stdlib/printf.ml +++ b/stdlib/printf.ml @@ -11,49 +11,75 @@ (* *) (***********************************************************************) -(* $Id: printf.ml,v 1.40.2.1 2006/01/23 17:35:13 weis Exp $ *) - -external format_int: string -> int -> string = "caml_format_int" -external format_int32: string -> int32 -> string = "caml_int32_format" +(* $Id: printf.ml,v 1.53 2006/11/17 08:34:05 weis Exp $ *) + +external format_float: string -> float -> string + = "caml_format_float" +external format_int: string -> int -> string + = "caml_format_int" +external format_int32: string -> int32 -> string + = "caml_int32_format" external format_nativeint: string -> nativeint -> string - = "caml_nativeint_format" -external format_int64: string -> int64 -> string = "caml_int64_format" -external format_float: string -> float -> string = "caml_format_float" - -external format_to_string: ('a, 'b, 'c, 'd) format4 -> string = "%identity" - -type index;; - -external index_of_int : int -> index = "%identity";; -external int_of_index : index -> int = "%identity";; - -let add_int_index i idx = index_of_int (i + int_of_index idx);; -let succ_index = add_int_index 1;; -(* Litteral position are one-based (hence pred p instead of p). *) -let index_of_litteral_position p = index_of_int (pred p);; - -let bad_conversion fmt i c = + = "caml_nativeint_format" +external format_int64: string -> int64 -> string + = "caml_int64_format" + +module Sformat = struct + + type index;; + + external unsafe_index_of_int : int -> index = "%identity";; + let index_of_int i = + if i >= 0 then unsafe_index_of_int i + else failwith ("index_of_int: negative argument " ^ string_of_int i);; + external int_of_index : index -> int = "%identity";; + + let add_int_index i idx = index_of_int (i + int_of_index idx);; + let succ_index = add_int_index 1;; + (* Litteral position are one-based (hence pred p instead of p). *) + let index_of_litteral_position p = index_of_int (pred p);; + + external length : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int + = "%string_length";; + external get : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char + = "%string_safe_get";; + external unsafe_get : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char + = "%string_unsafe_get";; + external unsafe_to_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string + = "%identity";; + let sub fmt idx len = + String.sub (unsafe_to_string fmt) (int_of_index idx) len;; + let to_string fmt = sub fmt (unsafe_index_of_int 0) (length fmt);; + +end;; + +let bad_conversion sfmt i c = invalid_arg ("printf: bad conversion %" ^ String.make 1 c ^ ", at char number " ^ - string_of_int i ^ " in format string ``" ^ fmt ^ "''");; + string_of_int i ^ " in format string ``" ^ sfmt ^ "''");; + +let bad_conversion_format fmt i c = + bad_conversion (Sformat.to_string fmt) i c;; let incomplete_format fmt = invalid_arg - ("printf: premature end of format string ``" ^ fmt ^ "''");; + ("printf: premature end of format string ``" ^ + Sformat.to_string fmt ^ "''");; -(* Parses a format to return the specified length and the padding direction. *) -let parse_format fmt = +(* Parses a string conversion to return the specified length and the padding direction. *) +let parse_string_conversion sfmt = let rec parse neg i = - if i >= String.length fmt then (0, neg) else - match String.unsafe_get fmt i with + if i >= String.length sfmt then (0, neg) else + match String.unsafe_get sfmt i with | '1'..'9' -> - (int_of_string (String.sub fmt i (String.length fmt - i - 1)), - neg) + (int_of_string + (String.sub sfmt i (String.length sfmt - i - 1)), + neg) | '-' -> - parse true (succ i) + parse true (succ i) | _ -> - parse neg (succ i) in - try parse false 1 with Failure _ -> bad_conversion fmt 0 's' + parse neg (succ i) in + try parse false 1 with Failure _ -> bad_conversion sfmt 0 's' (* Pad a (sub) string into a blank string of length [p], on the right if [neg] is true, on the left otherwise. *) @@ -68,18 +94,19 @@ let pad_string pad_char p neg s i len = (* Format a string given a %s format, e.g. %40s or %-20s. To do: ignore other flags (#, +, etc)? *) -let format_string fmt s = - let (p, neg) = parse_format fmt in - pad_string ' ' p neg s 0 (String.length s) +let format_string sfmt s = + let (p, neg) = parse_string_conversion sfmt in + pad_string ' ' p neg s 0 (String.length s);; -(* Extract a %format from [fmt] between [start] and [stop] inclusive. - '*' in the format are replaced by integers taken from the [widths] list. *) +(* Extract a format string out of [fmt] between [start] and [stop] inclusive. + '*' in the format are replaced by integers taken from the [widths] list. + extract_format returns a string. *) let extract_format fmt start stop widths = let skip_positional_spec start = - match String.unsafe_get fmt start with + match Sformat.unsafe_get fmt start with | '0'..'9' -> let rec skip_int_litteral i = - match String.unsafe_get fmt i with + match Sformat.unsafe_get fmt i with | '0'..'9' -> skip_int_litteral (succ i) | '$' -> succ i | _ -> start in @@ -90,7 +117,7 @@ let extract_format fmt start stop widths = Buffer.add_char b '%'; let rec fill_format i widths = if i <= stop then - match (String.unsafe_get fmt i, widths) with + match (Sformat.unsafe_get fmt i, widths) with | ('*', h :: t) -> Buffer.add_string b (string_of_int h); let i = skip_positional_spec (succ i) in @@ -102,46 +129,51 @@ let extract_format fmt start stop widths = fill_format start (List.rev widths); Buffer.contents b;; -let format_int_with_conv conv fmt i = +let extract_format_int conv fmt start stop widths = + let sfmt = extract_format fmt start stop widths in match conv with - | 'n' | 'N' -> fmt.[String.length fmt - 1] <- 'u'; format_int fmt i - | _ -> format_int fmt i + | 'n' | 'N' -> + sfmt.[String.length sfmt - 1] <- 'u'; + sfmt + | _ -> sfmt;; -(* Returns the position of the last character of the meta format +(* Returns the position of the next character following the meta format string, starting from position [i], inside a given format [fmt]. According to the character [conv], the meta format string is enclosed by the delimitors %{ and %} (when [conv = '{']) or %( and %) (when [conv = '(']). Hence, [sub_format] returns the index of - the character ')' or '}' that ends the meta format, according to - the character [conv]. *) -let sub_format incomplete_format bad_conversion conv fmt i = - let len = String.length fmt in + the character following the [')'] or ['}'] that ends the meta format, + according to the character [conv]. *) +let sub_format incomplete_format bad_conversion_format conv fmt i = + let len = Sformat.length fmt in let rec sub_fmt c i = let close = if c = '(' then ')' else (* '{' *) '}' in let rec sub j = if j >= len then incomplete_format fmt else - match fmt.[j] with + match Sformat.get fmt j with | '%' -> sub_sub (succ j) | _ -> sub (succ j) and sub_sub j = if j >= len then incomplete_format fmt else - match fmt.[j] with + match Sformat.get fmt j with | '(' | '{' as c -> let j = sub_fmt c (succ j) in sub (succ j) | '}' | ')' as c -> - if c = close then j else bad_conversion fmt i c + if c = close then succ j else bad_conversion_format fmt i c | _ -> sub (succ j) in sub i in sub_fmt conv i;; -let sub_format_for_printf = sub_format incomplete_format bad_conversion;; +let sub_format_for_printf conv = + sub_format incomplete_format bad_conversion_format conv;; let iter_on_format_args fmt add_conv add_char = - let lim = String.length fmt - 1 in + + let lim = Sformat.length fmt - 1 in let rec scan_flags skip i = if i > lim then incomplete_format fmt else - match String.unsafe_get fmt i with + match Sformat.unsafe_get fmt i with | '*' -> scan_flags skip (add_conv skip i 'i') | '$' -> scan_flags skip (succ i) | '#' | '-' | ' ' | '+' -> scan_flags skip (succ i) @@ -151,41 +183,44 @@ let iter_on_format_args fmt add_conv add_char = | _ -> scan_conv skip i and scan_conv skip i = if i > lim then incomplete_format fmt else - match String.unsafe_get fmt i with + match Sformat.unsafe_get fmt i with | '%' | '!' -> succ i | 's' | 'S' | '[' -> add_conv skip i 's' | 'c' | 'C' -> add_conv skip i 'c' - | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' -> add_conv skip i 'i' + | 'd' | 'i' |'o' | 'u' | 'x' | 'X' | 'N' -> add_conv skip i 'i' | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> add_conv skip i 'f' | 'B' | 'b' -> add_conv skip i 'B' - | 'a' | 't' as conv -> add_conv skip i conv + | 'a' | 'r' | 't' as conv -> add_conv skip i conv | 'l' | 'n' | 'L' as conv -> - let j = succ i in - if j > lim then add_conv skip i 'i' else begin - match fmt.[j] with - | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' -> - add_char (add_conv skip i conv) 'i' - | c -> add_conv skip i 'i' end + let j = succ i in + if j > lim then add_conv skip i 'i' else begin + match Sformat.get fmt j with + | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' -> + add_char (add_conv skip i conv) 'i' + | c -> add_conv skip i 'i' end | '{' as conv -> (* Just get a regular argument, skipping the specification. *) let i = add_conv skip i conv in + (* To go on, find the index of the next char after the meta format. *) let j = sub_format_for_printf conv fmt i in - (* Add the meta specification anyway. *) + (* Add the meta specification to the summary anyway. *) let rec loop i = - if i < j - 1 then loop (add_char i fmt.[i]) in + if i < j - 2 then loop (add_char i (Sformat.get fmt i)) in loop i; - scan_conv skip j + (* Go on, starting at the closing brace to properly close the meta + specification in the summary. *) + scan_conv skip (j - 1) | '(' as conv -> (* Use the static format argument specification instead of the runtime format argument value: they must have the same type anyway. *) scan_fmt (add_conv skip i conv) | '}' | ')' as conv -> add_conv skip i conv - | conv -> bad_conversion fmt i conv + | conv -> bad_conversion_format fmt i conv and scan_fmt i = if i < lim then - if fmt.[i] = '%' + if Sformat.get fmt i = '%' then scan_fmt (scan_flags false (succ i)) else scan_fmt (succ i) else i in @@ -194,10 +229,10 @@ let iter_on_format_args fmt add_conv add_char = (* Returns a string that summarizes the typing information that a given format string contains. - It also checks the well-formedness of the format string. - For instance, [summarize_format_type "A number %d\n"] is "%i". *) + For instance, [summarize_format_type "A number %d\n"] is "%i". + It also checks the well-formedness of the format string. *) let summarize_format_type fmt = - let len = String.length fmt in + let len = Sformat.length fmt in let b = Buffer.create len in let add_char i c = Buffer.add_char b c; succ i in let add_conv skip i c = @@ -206,24 +241,43 @@ let summarize_format_type fmt = iter_on_format_args fmt add_conv add_char; Buffer.contents b;; +module Ac = struct + type ac = { + mutable ac_rglr : int; + mutable ac_skip : int; + mutable ac_rdrs : int; + } +end;; + +open Ac;; + (* Computes the number of arguments of a format (including flag arguments if any). *) -let nargs_of_format_type fmt = - let num_args = ref 0 - and skip_args = ref 0 in +let ac_of_format fmt = + let ac = { ac_rglr = 0; ac_skip = 0; ac_rdrs = 0; } in + let incr_ac skip c = + let inc = if c = 'a' then 2 else 1 in + if c = 'r' then ac.ac_rdrs <- ac.ac_rdrs + 1; + if skip + then ac.ac_skip <- ac.ac_skip + inc + else ac.ac_rglr <- ac.ac_rglr + inc in let add_conv skip i c = (* Just finishing a meta format: no additional argument to record. *) - if c = ')' || c = '}' then succ i else - let incr_args n = if c = 'a' then n := !n + 2 else n := !n + 1 in - if skip then incr_args skip_args else incr_args num_args; + if c <> ')' && c <> '}' then incr_ac skip c; succ i and add_char i c = succ i in + iter_on_format_args fmt add_conv add_char; - !skip_args + !num_args;; + ac;; + +let count_arguments_of_format fmt = + let ac = ac_of_format fmt in + ac.ac_rglr + ac.ac_skip + ac.ac_rdrs;; let list_iter_i f l = let rec loop i = function | [] -> () + | [x] -> f i x (* Tail calling [f] *) | x :: xs -> f i x; loop (succ i) xs in loop 0 l;; @@ -232,7 +286,7 @@ let list_iter_i f l = Note: in the following, we are careful not to be badly caught by the compiler optimizations on the representation of arrays. *) let kapr kpr fmt = - match nargs_of_format_type fmt with + match count_arguments_of_format fmt with | 0 -> kpr fmt [||] | 1 -> Obj.magic (fun x -> let a = Array.make 1 (Obj.repr 0) in @@ -270,36 +324,40 @@ let kapr kpr fmt = else Obj.magic (fun x -> loop (succ i) (x :: args)) in loop 0 [];; -type param_spec = Spec_none | Spec_index of index;; +type positional_specification = + | Spec_none | Spec_index of Sformat.index;; (* To scan an optional positional parameter specification, - i.e. an integer followed by a $. - We do not support *$ specifications, since this would lead to type checking - problems: the type would be dependant of the {\em value} of an integer - argument to printf. *) -let scan_positional_spec fmt got_pos n i = - match String.unsafe_get fmt i with + i.e. an integer followed by a [$]. + We do not support [*$] specifications, since this would lead to type checking + problems: the type of the specified [*$] parameter would be the type of the + corresponding argument to [printf], hence the type of the $n$-th argument to + [printf] with $n$ being the {\em value} of the integer argument defining + [*]; this means type dependency, which is out of scope of the Caml type + algebra. *) +let scan_positional_spec fmt got_spec n i = + match Sformat.unsafe_get fmt i with | '0'..'9' as d -> let rec get_int_litteral accu j = - match String.unsafe_get fmt j with + match Sformat.unsafe_get fmt j with | '0'..'9' as d -> get_int_litteral (10 * accu + (int_of_char d - 48)) (succ j) | '$' -> if accu = 0 then failwith "printf: bad positional specification (0)." else - got_pos (Spec_index (index_of_litteral_position accu)) (succ j) + got_spec (Spec_index (Sformat.index_of_litteral_position accu)) (succ j) (* Not a positional specification. *) - | _ -> got_pos Spec_none i in + | _ -> got_spec Spec_none i in get_int_litteral (int_of_char d - 48) (succ i) (* No positional specification. *) - | _ -> got_pos Spec_none i;; + | _ -> got_spec Spec_none i;; (* Get the position of the next argument to printf, according to the given positional specification. *) let next_index spec n = match spec with - | Spec_none -> succ_index n - | Spec_index p -> n;; + | Spec_none -> Sformat.succ_index n + | Spec_index _ -> n;; (* Get the position of the actual argument to printf, according to its optional positional specification. *) @@ -308,45 +366,48 @@ let get_index spec n = | Spec_none -> n | Spec_index p -> p;; -(* Decode a %format and act on it. +(* Decode a format string and act on it. [fmt] is the printf format string, and [pos] points to a [%] character. After consuming the appropriate number of arguments and formatting them, one of the five continuations is called: - [cont_s] for outputting a string (args: string, next pos) - [cont_a] for performing a %a action (args: fn, arg, next pos) - [cont_t] for performing a %t action (args: fn, next pos) - [cont_f] for performing a flush action - [cont_m] for performing a %( action (args: sfmt, next pos) + [cont_s] for outputting a string (args: arg num, string, next pos) + [cont_a] for performing a %a action (args: arg num, fn, arg, next pos) + [cont_t] for performing a %t action (args: arg num, fn, next pos) + [cont_f] for performing a flush action (args: arg num, next pos) + [cont_m] for performing a %( action (args: arg num, sfmt, next pos) + + "arg num" is the index in array args of the next argument to printf. "next pos" is the position in [fmt] of the first character following - the %format in [fmt]. *) + the %conversion specification in [fmt]. *) -(* Note: here, rather than test explicitly against [String.length fmt] - to detect the end of the format, we use [String.unsafe_get] and +(* Note: here, rather than test explicitly against [Sformat.length fmt] + to detect the end of the format, we use [Sformat.unsafe_get] and rely on the fact that we'll get a "nul" character if we access one past the end of the string. These "nul" characters are then caught by the [_ -> bad_conversion] clauses below. Don't do this at home, kids. *) let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m = - let get_arg spec n = Obj.magic args.(int_of_index (get_index spec n)) in + let get_arg spec n = + Obj.magic (args.(Sformat.int_of_index (get_index spec n))) in let rec scan_positional n widths i = - let got_pos spec i = scan_flags spec n widths i in - scan_positional_spec fmt got_pos n i + let got_spec spec i = scan_flags spec n widths i in + scan_positional_spec fmt got_spec n i and scan_flags spec n widths i = - match String.unsafe_get fmt i with + match Sformat.unsafe_get fmt i with | '*' -> - let got_pos wspec i = + let got_spec wspec i = let (width : int) = get_arg wspec n in scan_flags spec (next_index wspec n) (width :: widths) i in - scan_positional_spec fmt got_pos n (succ i) + scan_positional_spec fmt got_spec n (succ i) | '0'..'9' | '.' | '#' | '-' | ' ' | '+' -> scan_flags spec n widths (succ i) | _ -> scan_conv spec n widths i and scan_conv spec n widths i = - match String.unsafe_get fmt i with + match Sformat.unsafe_get fmt i with | '%' -> cont_s n "%" (succ i) | 's' | 'S' as conv -> @@ -362,16 +423,18 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m = let s = if conv = 'c' then String.make 1 x else "'" ^ Char.escaped x ^ "'" in cont_s (next_index spec n) s (succ i) - | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' as conv -> + | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' | 'N' as conv -> let (x : int) = get_arg spec n in - let s = format_int_with_conv conv (extract_format fmt pos i widths) x in + let s = + format_int (extract_format_int conv fmt pos i widths) x in cont_s (next_index spec n) s (succ i) - | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' as conv -> + | 'f' | 'e' | 'E' | 'g' | 'G' -> let (x : float) = get_arg spec n in - let s = - if conv = 'F' then string_of_float x else - format_float (extract_format fmt pos i widths) x in + let s = format_float (extract_format fmt pos i widths) x in cont_s (next_index spec n) s (succ i) + | 'F' -> + let (x : float) = get_arg spec n in + cont_s (next_index spec n) (string_of_float x) (succ i) | 'B' | 'b' -> let (x : bool) = get_arg spec n in cont_s (next_index spec n) (string_of_bool x) (succ i) @@ -380,80 +443,78 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m = (* If the printer spec is Spec_none, go on as usual. If the printer spec is Spec_index p, printer's argument spec is Spec_index (succ_index p). *) - let n = succ_index (get_index spec n) in + let n = Sformat.succ_index (get_index spec n) in let arg = get_arg Spec_none n in cont_a (next_index spec n) printer arg (succ i) | 't' -> let printer = get_arg spec n in cont_t (next_index spec n) printer (succ i) | 'l' | 'n' | 'L' as conv -> - begin match String.unsafe_get fmt (succ i) with - | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' -> + begin match Sformat.unsafe_get fmt (succ i) with + | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' -> + let i = succ i in let s = match conv with | 'l' -> let (x : int32) = get_arg spec n in - format_int32 (extract_format fmt pos (succ i) widths) x + format_int32 (extract_format fmt pos i widths) x | 'n' -> let (x : nativeint) = get_arg spec n in - format_nativeint (extract_format fmt pos (succ i) widths) x + format_nativeint (extract_format fmt pos i widths) x | _ -> let (x : int64) = get_arg spec n in - format_int64 (extract_format fmt pos (succ i) widths) x in - cont_s (next_index spec n) s (i + 2) + format_int64 (extract_format fmt pos i widths) x in + cont_s (next_index spec n) s (succ i) | _ -> let (x : int) = get_arg spec n in - cont_s - (next_index spec n) - (format_int_with_conv 'n' (extract_format fmt pos i widths) x) - (succ i) + let s = format_int (extract_format_int 'n' fmt pos i widths) x in + cont_s (next_index spec n) s (succ i) end | '!' -> cont_f n (succ i) | '{' | '(' as conv (* ')' '}' *) -> - let (xf : ('a, 'b, 'c, 'd) format4) = get_arg spec n in + let (xf : ('a, 'b, 'c, 'd, 'e, 'f) format6) = get_arg spec n in let i = succ i in - let j = sub_format_for_printf conv fmt i + 1 in + let j = sub_format_for_printf conv fmt i in if conv = '{' (* '}' *) then (* Just print the format argument as a specification. *) cont_s (next_index spec n) - (summarize_format_type (format_to_string xf)) + (summarize_format_type xf) j else (* Use the format argument instead of the format specification. *) cont_m (next_index spec n) xf j | (* '(' *) ')' -> cont_s n "" (succ i) | conv -> - bad_conversion fmt i conv in + bad_conversion_format fmt i conv in scan_positional n [] (succ pos);; -let mkprintf str get_out outc outs flush k fmt = +let mkprintf to_s get_out outc outs flush k fmt = - let fmt = format_to_string fmt in (* out is global to this invocation of pr, and must be shared by all its - recursive calls (fif) any. *) + recursive calls (if any). *) let out = get_out fmt in let rec pr k n fmt v = - let len = String.length fmt in + let len = Sformat.length fmt in let rec doprn n i = if i >= len then Obj.magic (k out) else - match String.unsafe_get fmt i with + match Sformat.unsafe_get fmt i with | '%' -> scan_format fmt v n i cont_s cont_a cont_t cont_f cont_m | c -> outc out c; doprn n (succ i) and cont_s n s i = outs out s; doprn n i and cont_a n printer arg i = - if str then + if to_s then outs out ((Obj.magic printer : unit -> _ -> string) () arg) else printer out arg; doprn n i and cont_t n printer i = - if str then + if to_s then outs out ((Obj.magic printer : unit -> string) ()) else printer out; @@ -461,27 +522,29 @@ let mkprintf str get_out outc outs flush k fmt = and cont_f n i = flush out; doprn n i and cont_m n xf i = - let m = add_int_index (nargs_of_format_type (format_to_string xf)) n in - pr (Obj.magic (fun _ -> doprn m i)) n (format_to_string xf) v in + let m = Sformat.add_int_index (count_arguments_of_format xf) n in + pr (Obj.magic (fun _ -> doprn m i)) n xf v in doprn n 0 in - let kpr = pr k (index_of_int 0) in + let kpr = pr k (Sformat.index_of_int 0) in kapr kpr fmt;; let kfprintf k oc = - mkprintf false (fun _ -> oc) output_char output_string flush k -let fprintf oc = kfprintf ignore oc -let printf fmt = fprintf stdout fmt -let eprintf fmt = fprintf stderr fmt + mkprintf false (fun _ -> oc) output_char output_string flush k;; +let ifprintf oc = kapr (fun _ -> Obj.magic ignore);; + +let fprintf oc = kfprintf ignore oc;; +let printf fmt = fprintf stdout fmt;; +let eprintf fmt = fprintf stderr fmt;; let kbprintf k b = - mkprintf false (fun _ -> b) Buffer.add_char Buffer.add_string ignore k -let bprintf b = kbprintf ignore b + mkprintf false (fun _ -> b) Buffer.add_char Buffer.add_string ignore k;; +let bprintf b = kbprintf ignore b;; let get_buff fmt = - let len = 2 * String.length fmt in + let len = 2 * Sformat.length fmt in Buffer.create len;; let get_contents b = @@ -497,3 +560,30 @@ let ksprintf k = let kprintf = ksprintf;; let sprintf fmt = ksprintf (fun s -> s) fmt;; + +module CamlinternalPr = struct + + module Sformat = Sformat;; + + module Tformat = struct + + type ac = + Ac.ac = { + mutable ac_rglr : int; + mutable ac_skip : int; + mutable ac_rdrs : int; + };; + + let ac_of_format = ac_of_format;; + + let sub_format = sub_format;; + + let summarize_format_type = summarize_format_type;; + + let scan_format = scan_format;; + + let kapr = kapr;; + + end;; + +end;; diff --git a/stdlib/printf.mli b/stdlib/printf.mli index 46f9d7ab..0b5b75ab 100644 --- a/stdlib/printf.mli +++ b/stdlib/printf.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: printf.mli,v 1.46.2.1 2005/12/15 12:46:10 doligez Exp $ *) +(* $Id: printf.mli,v 1.54 2006/11/17 08:34:05 weis Exp $ *) (** Formatted output functions. *) @@ -62,7 +62,7 @@ val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a the format specified by the second letter. - [Ld], [Li], [Lu], [Lx], [LX], [Lo]: convert an [int64] argument to the format specified by the second letter. - - [a]: user-defined printer. Takes two arguments and apply the + - [a]: user-defined printer. Takes two arguments and applies the first one to [outchan] (the current output channel) and to the second argument. The first argument must therefore have type [out_channel -> 'b -> unit] and the second ['b]. @@ -113,16 +113,20 @@ val printf : ('a, out_channel, unit) format -> 'a val eprintf : ('a, out_channel, unit) format -> 'a (** Same as {!Printf.fprintf}, but output on [stderr]. *) +val ifprintf : 'a -> ('b, 'a, unit) format -> 'b +(** Same as {!Printf.fprintf}, but does not print anything. + Useful to ignore some material when conditionally printing. *) + val sprintf : ('a, unit, string) format -> 'a (** Same as {!Printf.fprintf}, but instead of printing on an output channel, - return a string containing the result of formatting - the arguments. *) + return a string containing the result of formatting the arguments. *) val bprintf : Buffer.t -> ('a, Buffer.t, unit) format -> 'a (** Same as {!Printf.fprintf}, but instead of printing on an output channel, append the formatted arguments to the given extensible buffer (see module {!Buffer}). *) +(** Formatted output functions with continuations. *) val kfprintf : (out_channel -> 'a) -> out_channel -> ('b, out_channel, unit, 'a) format4 -> 'b;; (** Same as [fprintf], but instead of returning immediately, @@ -132,25 +136,73 @@ val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; (** Same as [sprintf] above, but instead of returning the string, passes it to the first argument. *) +val kbprintf : (Buffer.t -> 'a) -> Buffer.t -> + ('b, Buffer.t, unit, 'a) format4 -> 'b;; +(** Same as [bprintf], but instead of returning immediately, + passes the buffer to its first argument at the end of printing. *) + val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b;; (** A deprecated synonym for [ksprintf]. *) (**/**) (* For system use only. Don't call directly. *) -type index;; - -external index_of_int : int -> index = "%identity";; - -val scan_format : string -> 'a array -> index -> int -> - (index -> string -> int -> 'b) -> - (index -> 'c -> 'd -> int -> 'b) -> - (index -> 'e -> int -> 'b) -> - (index -> int -> 'b) -> - (index -> ('h, 'i, 'j, 'k) format4 -> int -> 'b) -> 'b - -val sub_format : - (string -> int) -> (string -> int -> char -> int) -> - char -> string -> int -> int -val summarize_format_type : string -> string -val kapr : (string -> Obj.t array -> 'a) -> string -> 'a + +module CamlinternalPr : sig + + module Sformat : sig + type index;; + + val index_of_int : int -> index;; + external int_of_index : index -> int = "%identity";; + external unsafe_index_of_int : int -> index = "%identity";; + + val succ_index : index -> index;; + + val sub : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> index -> int -> string;; + val to_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string;; + external length : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int + = "%string_length";; + external get : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char + = "%string_safe_get";; + external unsafe_to_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string + = "%identity";; + external unsafe_get : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char + = "%string_unsafe_get";; + + end;; + + module Tformat : sig + + type ac = { + mutable ac_rglr : int; + mutable ac_skip : int; + mutable ac_rdrs : int; + };; + + val ac_of_format : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ac;; + + val sub_format : + (('a, 'b, 'c, 'd, 'e, 'f) format6 -> int) -> + (('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char -> int) -> + char -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> int + + val summarize_format_type : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string + + val scan_format : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + 'g array -> + Sformat.index -> + int -> + (Sformat.index -> string -> int -> 'h) -> + (Sformat.index -> 'i -> 'j -> int -> 'h) -> + (Sformat.index -> 'k -> int -> 'h) -> + (Sformat.index -> int -> 'h) -> + (Sformat.index -> ('l, 'm, 'n, 'o, 'p, 'q) format6 -> int -> 'h) -> 'h + + val kapr : + (('a, 'b, 'c, 'd, 'e, 'f) format6 -> Obj.t array -> 'g) -> + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g + end;; + +end;; + diff --git a/stdlib/random.mli b/stdlib/random.mli index 19ee2731..37f05306 100644 --- a/stdlib/random.mli +++ b/stdlib/random.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: random.mli,v 1.16 2003/06/24 09:50:23 xleroy Exp $ *) +(* $Id: random.mli,v 1.17 2007/02/09 13:31:15 doligez Exp $ *) (** Pseudo-random number generators (PRNG). *) @@ -33,7 +33,7 @@ val bits : unit -> int val int : int -> int (** [Random.int bound] returns a random integer between 0 (inclusive) - and [bound] (exclusive). [bound] must be more than 0 and less + and [bound] (exclusive). [bound] must be greater than 0 and less than 2{^30}. *) val int32 : Int32.t -> Int32.t;; diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml index d56d804f..eb4dc51a 100644 --- a/stdlib/scanf.ml +++ b/stdlib/scanf.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: scanf.ml,v 1.63.2.2 2006/01/03 17:32:43 weis Exp $ *) +(* $Id: scanf.ml,v 1.73 2006/11/17 08:34:05 weis Exp $ *) (* The run-time library for scanners. *) @@ -133,8 +133,8 @@ let next_char ib = let c = ib.get_next_char () in ib.current_char <- c; ib.current_char_is_valid <- true; - ib.char_count <- ib.char_count + 1; - if c == '\n' then ib.line_count <- ib.line_count + 1; + ib.char_count <- succ ib.char_count; + if c == '\n' then ib.line_count <- succ ib.line_count; c with | End_of_file -> let c = null_char in @@ -173,7 +173,7 @@ let token ib = let tokbuf = ib.tokbuf in let tok = Buffer.contents tokbuf in Buffer.clear tokbuf; - ib.token_count <- ib.token_count + 1; + ib.token_count <- succ ib.token_count; tok;; let token_count ib = ib.token_count;; @@ -214,40 +214,104 @@ let from_string s = let from_function = create "function input";; +(* Scan from an input channel. *) + +(* The input channel [ic] may not be allocated in this library, hence it may be + shared (two functions of the user's program may successively read from + it). Furthermore, the user may define more than one scanning buffer reading + from the same [ic] channel. + + However, we cannot prevent the scanning mechanism to use one lookahead + character, if needed by the semantics of format string specifications + (e.g. a trailing ``skip space'' specification in the format string); in this + case, the mandatory lookahead character is read from the channel and stored + into the scanning buffer for further reading. This implies that multiple + functions alternatively scanning the same [ic] channel will miss characters + from time to time, due to unnoticed look ahead characters, silently read + from [ic] (hence no more available for reading) and retained inside the + scanning buffer to ensure the correct incremental scanning of the same + scanning buffer. This phenomenon is even worse if one defines more than one + scanning buffer reading from the same input channel [ic]. We have no simple + way to circumvent this problem (unless the scanning buffer allocation is a + memo function that never allocates two different scanning buffers for the + same input channel, orelse the input channel API offers a ``consider this + char as unread'' procedure to keep back the lookahead character as available + in the input channel for further reading). + + Hence, we do bufferize characters to create a scanning buffer from an input + channel in order to preserve the same semantics as other from_* functions + above: two successive calls to the scanner will work appropriately, since + the bufferized character (if any) will be retained inside the scanning + buffer from a call to the next one. + + Otherwise, if we do not bufferize characters, we will loose the clearly + correct scanning behaviour even for the simple regular case, when we scan + the (possibly shared) channel [ic] using a unique function, while not + gaining anything for multiple functions reading from [ic] or multiple + allocation of scanning buffers reading from the same [ic]. + + As mentioned above, a more ambitious fix could be to change the input + channel API or to have a memo scanning buffer allocation for reading from + input channel not allocated from within Scanf's input buffer creation + functions. *) + (* Perform bufferized input to improve efficiency. *) let file_buffer_size = ref 1024;; -let from_file_channel fname ic = +(* To close a channel at end of input. *) +let scan_close_at_end ic = close_in ic; raise End_of_file;; + +let from_ic scan_close_ic fname ic = let len = !file_buffer_size in let buf = String.create len in let i = ref 0 in let lim = ref 0 in + let eof = ref false in let next () = - if !i < !lim then begin let c = buf.[!i] in incr i; c end else begin + if !i < !lim then begin let c = buf.[!i] in incr i; c end else + if !eof then raise End_of_file else begin lim := input ic buf 0 len; - if !lim = 0 then raise End_of_file else begin + if !lim = 0 then begin eof := true; scan_close_ic ic end else begin i := 1; buf.[0] end end in create fname next;; -let from_file fname = from_file_channel fname (open_in fname);; -let from_file_bin fname = from_file_channel fname (open_in_bin fname);; +let from_ic_close_at_end = from_ic scan_close_at_end;; -let from_input_channel fname ic = - let next () = input_char ic in - create fname next;; +let from_file fname = from_ic_close_at_end fname (open_in fname);; +let from_file_bin fname = from_ic_close_at_end fname (open_in_bin fname);; -let from_channel = from_input_channel "input channel";; +let scan_raise_at_end ic = raise End_of_file;; -(* The scanning buffer reading from [stdin].*) -let stdib = from_input_channel "stdin" stdin;; +let from_channel = from_ic scan_raise_at_end "input channel";; + +(* The scanning buffer reading from [stdin]. + One could try to define stdib as a scanning buffer reading a character at a + time (no bufferization at all), but unfortunately the toplevel + interaction would be wrong. + This is due to some kind of ``race condition'' when reading from stdin, + since the interactive compiler and scanf will simultaneously read the + material they need from stdin; then, confusion will result from what should + be read by the toplevel and what should be read by scanf. + This is even more complicated by the one character lookahead that scanf + is sometimes obliged to maintain: the lookahead character will be available + for the next (scanf) entry, seamingly coming from nowhere. + Also no End_of_file is raised when reading from stdin: if not enough + characters have been read, we simply ask to read more. *) +let stdib = from_ic scan_raise_at_end "stdin" stdin;; end;; (* Formatted input functions. *) +type ('a, 'b, 'c, 'd) scanner = + ('a, Scanning.scanbuf, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c;; + +external string_to_format : + string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity";; + (* Reporting errors. *) exception Scan_failure of string;; @@ -259,31 +323,37 @@ let bad_input_escape c = let scanf_bad_input ib = function | Scan_failure s | Failure s -> - let i = Scanning.char_count ib in - bad_input (Printf.sprintf "scanf: bad input at char number %i: %s" i s) + let i = Scanning.char_count ib in + bad_input (Printf.sprintf "scanf: bad input at char number %i: %s" i s) | x -> raise x;; +module Sformat = Printf.CamlinternalPr.Sformat;; +module Tformat = Printf.CamlinternalPr.Tformat;; + let bad_conversion fmt i c = invalid_arg (Printf.sprintf "scanf: bad conversion %%%c, at char number %i \ - in format string ``%s''" c i fmt);; + in format string ``%s''" c i (Sformat.to_string fmt));; let incomplete_format fmt = invalid_arg - (Printf.sprintf "scanf: premature end of format string ``%s''" fmt);; + (Printf.sprintf "scanf: premature end of format string ``%s''" + (Sformat.to_string fmt));; let bad_float () = bad_input "no dot or exponent part found in float token";; let format_mismatch_err fmt1 fmt2 = - Printf.sprintf "format read %S does not match specification %S" fmt1 fmt2;; + Printf.sprintf + "format read ``%s'' does not match specification ``%s''" fmt1 fmt2;; let format_mismatch fmt1 fmt2 ib = scanf_bad_input ib (Scan_failure (format_mismatch_err fmt1 fmt2));; (* Checking that 2 format string are type compatible. *) let compatible_format_type fmt1 fmt2 = - Printf.summarize_format_type fmt1 = Printf.summarize_format_type fmt2;; + Tformat.summarize_format_type (string_to_format fmt1) = + Tformat.summarize_format_type (string_to_format fmt2);; (* Checking that [c] is indeed in the input, then skips it. In this case, the character c has been explicitely specified in the @@ -347,9 +417,12 @@ let token_float ib = float_of_string (Scanning.token ib);; since those modules are not available to Scanf. However, we can bind and use the corresponding primitives that are available in the runtime. *) -external nativeint_of_string: string -> nativeint = "caml_nativeint_of_string";; -external int32_of_string : string -> int32 = "caml_int32_of_string";; -external int64_of_string : string -> int64 = "caml_int64_of_string";; +external nativeint_of_string : string -> nativeint + = "caml_nativeint_of_string";; +external int32_of_string : string -> int32 + = "caml_int32_of_string";; +external int64_of_string : string -> int64 + = "caml_int64_of_string";; let token_nativeint conv ib = nativeint_of_string (token_int_literal conv ib);; let token_int32 conv ib = int32_of_string (token_int_literal conv ib);; @@ -373,11 +446,11 @@ let rec scan_decimal_digits max ib = if Scanning.eof ib then max else match c with | '0' .. '9' as c -> - let max = Scanning.store_char ib c max in - scan_decimal_digits max ib + let max = Scanning.store_char ib c max in + scan_decimal_digits max ib | '_' -> - let max = Scanning.ignore_char ib max in - scan_decimal_digits max ib + let max = Scanning.ignore_char ib max in + scan_decimal_digits max ib | _ -> max;; let scan_decimal_digits_plus max ib = @@ -397,11 +470,11 @@ let scan_digits_plus digitp max ib = if Scanning.eof ib then max else match c with | c when digitp c -> - let max = Scanning.store_char ib c max in - scan_digits max + let max = Scanning.store_char ib c max in + scan_digits max | '_' -> - let max = Scanning.ignore_char ib max in - scan_digits max + let max = Scanning.ignore_char ib max in + scan_digits max | _ -> max in let c = Scanning.checked_peek_char ib in @@ -449,15 +522,15 @@ let scan_optionally_signed_decimal_int max ib = let scan_unsigned_int max ib = match Scanning.checked_peek_char ib with | '0' as c -> - let max = Scanning.store_char ib c max in - if max = 0 then max else - let c = Scanning.peek_char ib in - if Scanning.eof ib then max else - begin match c with - | 'x' | 'X' -> scan_hexadecimal_int (Scanning.store_char ib c max) ib - | 'o' -> scan_octal_int (Scanning.store_char ib c max) ib - | 'b' -> scan_binary_int (Scanning.store_char ib c max) ib - | c -> scan_decimal_digits max ib end + let max = Scanning.store_char ib c max in + if max = 0 then max else + let c = Scanning.peek_char ib in + if Scanning.eof ib then max else + begin match c with + | 'x' | 'X' -> scan_hexadecimal_int (Scanning.store_char ib c max) ib + | 'o' -> scan_octal_int (Scanning.store_char ib c max) ib + | 'b' -> scan_binary_int (Scanning.store_char ib c max) ib + | c -> scan_decimal_digits max ib end | c -> scan_unsigned_decimal_int max ib;; let scan_optionally_signed_int max ib = @@ -492,7 +565,7 @@ let scan_exp_part max ib = if Scanning.eof ib then max else match c with | 'e' | 'E' as c -> - scan_optionally_signed_decimal_int (Scanning.store_char ib c max) ib + scan_optionally_signed_decimal_int (Scanning.store_char ib c max) ib | _ -> max;; (* Scan the integer part of a floating point number, (not using the @@ -510,9 +583,9 @@ let scan_float max ib = if Scanning.eof ib then max else match c with | '.' -> - let max = Scanning.store_char ib c max in - let max = scan_frac_part max ib in - scan_exp_part max ib + let max = Scanning.store_char ib c max in + let max = scan_frac_part max ib in + scan_exp_part max ib | c -> scan_exp_part max ib;; let scan_Float max ib = @@ -522,11 +595,11 @@ let scan_Float max ib = if Scanning.eof ib then bad_float () else match c with | '.' -> - let max = Scanning.store_char ib c max in - let max = scan_frac_part max ib in - scan_exp_part max ib + let max = Scanning.store_char ib c max in + let max = scan_frac_part max ib in + scan_exp_part max ib | 'e' | 'E' -> - scan_exp_part max ib + scan_exp_part max ib | c -> bad_float ();; (* Scan a regular string: stops when encountering a space or one of the @@ -554,7 +627,7 @@ let char_for_backslash = function | 'r' -> '\013' | 'b' -> '\008' | 't' -> '\009' - | c -> c + | c -> c;; (* The integer value corresponding to the facial value of a valid decimal digit character. *) @@ -577,17 +650,17 @@ let scan_backslash_char max ib = if Scanning.eof ib then bad_input "a char" else match c with | '\\' | '\'' | '"' | 'n' | 't' | 'b' | 'r' (* '"' helping Emacs *) -> - Scanning.store_char ib (char_for_backslash c) max + Scanning.store_char ib (char_for_backslash c) max | '0' .. '9' as c -> - let get_digit () = - let c = Scanning.next_char ib in - match c with - | '0' .. '9' as c -> c - | c -> bad_input_escape c in - let c0 = c in - let c1 = get_digit () in - let c2 = get_digit () in - Scanning.store_char ib (char_for_decimal_code c0 c1 c2) (max - 2) + let get_digit () = + let c = Scanning.next_char ib in + match c with + | '0' .. '9' as c -> c + | c -> bad_input_escape c in + let c0 = c in + let c1 = get_digit () in + let c2 = get_digit () in + Scanning.store_char ib (char_for_decimal_code c0 c1 c2) (max - 2) | c -> bad_input_char c;; let scan_Char max ib = @@ -610,11 +683,11 @@ let scan_String max ib = if Scanning.eof ib then bad_input "a string" else match c, s with | '"', true (* '"' helping Emacs *) -> - loop false (Scanning.ignore_char ib max) + loop false (Scanning.ignore_char ib max) | '"', false (* '"' helping Emacs *) -> - Scanning.ignore_char ib max + Scanning.ignore_char ib max | '\\', false -> - skip_spaces true (Scanning.ignore_char ib max) + skip_spaces true (Scanning.ignore_char ib max) | c, false -> loop false (Scanning.store_char ib c max) | c, _ -> bad_input_char c and skip_spaces s max = @@ -624,7 +697,7 @@ let scan_String max ib = match c, s with | '\n', true | ' ', false -> - skip_spaces false (Scanning.ignore_char ib max) + skip_spaces false (Scanning.ignore_char ib max) | '\\', false -> loop false max | c, false -> loop false (Scanning.store_char ib c max) | _, _ -> loop false (scan_backslash_char (max - 1) ib) in @@ -648,29 +721,29 @@ type char_set = (* Char sets are read as sub-strings in the format string. *) let read_char_set fmt i = - let lim = String.length fmt - 1 in + let lim = Sformat.length fmt - 1 in let rec find_in_set j = if j > lim then incomplete_format fmt else - match fmt.[j] with + match Sformat.get fmt j with | ']' -> j - | c -> find_in_set (j + 1) + | c -> find_in_set (succ j) and find_set i = if i > lim then incomplete_format fmt else - match fmt.[i] with - | ']' -> find_in_set (i + 1) + match Sformat.get fmt i with + | ']' -> find_in_set (succ i) | c -> find_in_set i in if i > lim then incomplete_format fmt else - match fmt.[i] with + match Sformat.get fmt i with | '^' -> - let i = i + 1 in - let j = find_set i in - j, Neg_set (String.sub fmt i (j - i)) + let i = succ i in + let j = find_set i in + j, Neg_set (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) | _ -> - let j = find_set i in - j, Pos_set (String.sub fmt i (j - i));; + let j = find_set i in + j, Pos_set (Sformat.sub fmt (Sformat.index_of_int i) (j - i));; (* Char sets are now represented as bitvects that are represented as byte strings. *) @@ -716,18 +789,18 @@ let make_char_bit_vect bit set = if i <= lim then match set.[i] with | '-' when rp -> - (* if i = 0 then rp is false (since the initial call is - loop bit false 0). Hence i >= 1 and the following is safe. *) - let c1 = set.[i - 1] in - let i = i + 1 in - if i > lim then loop bit false (i - 1) else - let c2 = set.[i] in - for j = int_of_char c1 to int_of_char c2 do - set_bit_of_range r j bit done; - loop bit false (i + 1) + (* if i = 0 then rp is false (since the initial call is + loop bit false 0). Hence i >= 1 and the following is safe. *) + let c1 = set.[i - 1] in + let i = succ i in + if i > lim then loop bit false (i - 1) else + let c2 = set.[i] in + for j = int_of_char c1 to int_of_char c2 do + set_bit_of_range r j bit done; + loop bit false (succ i) | c -> - set_bit_of_range r (int_of_char set.[i]) bit; - loop bit true (i + 1) in + set_bit_of_range r (int_of_char set.[i]) bit; + loop bit true (succ i) in loop bit false 0; r;; @@ -741,35 +814,35 @@ let make_pred bit set stp = let make_setp stp char_set = match char_set with | Pos_set set -> - begin match String.length set with - | 0 -> (fun c -> 0) - | 1 -> - let p = set.[0] in - (fun c -> if c == p then 1 else 0) - | 2 -> - let p1 = set.[0] and p2 = set.[1] in - (fun c -> if c == p1 || c == p2 then 1 else 0) - | 3 -> - let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in - if p2 = '-' then make_pred 1 set stp else - (fun c -> if c == p1 || c == p2 || c == p3 then 1 else 0) - | n -> make_pred 1 set stp - end + begin match String.length set with + | 0 -> (fun c -> 0) + | 1 -> + let p = set.[0] in + (fun c -> if c == p then 1 else 0) + | 2 -> + let p1 = set.[0] and p2 = set.[1] in + (fun c -> if c == p1 || c == p2 then 1 else 0) + | 3 -> + let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in + if p2 = '-' then make_pred 1 set stp else + (fun c -> if c == p1 || c == p2 || c == p3 then 1 else 0) + | n -> make_pred 1 set stp + end | Neg_set set -> - begin match String.length set with - | 0 -> (fun c -> 1) - | 1 -> - let p = set.[0] in - (fun c -> if c != p then 1 else 0) - | 2 -> - let p1 = set.[0] and p2 = set.[1] in - (fun c -> if c != p1 && c != p2 then 1 else 0) - | 3 -> - let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in - if p2 = '-' then make_pred 0 set stp else - (fun c -> if c != p1 && c != p2 && c != p3 then 1 else 0) - | n -> make_pred 0 set stp - end;; + begin match String.length set with + | 0 -> (fun c -> 1) + | 1 -> + let p = set.[0] in + (fun c -> if c != p then 1 else 0) + | 2 -> + let p1 = set.[0] and p2 = set.[1] in + (fun c -> if c != p1 && c != p2 then 1 else 0) + | 3 -> + let p1 = set.[0] and p2 = set.[1] and p3 = set.[2] in + if p2 = '-' then make_pred 0 set stp else + (fun c -> if c != p1 && c != p2 && c != p3 then 1 else 0) + | n -> make_pred 0 set stp + end;; let setp_table = Hashtbl.create 7;; @@ -777,17 +850,17 @@ let add_setp stp char_set setp = let char_set_tbl = try Hashtbl.find setp_table char_set with | Not_found -> - let char_set_tbl = Hashtbl.create 3 in - Hashtbl.add setp_table char_set char_set_tbl; - char_set_tbl in + let char_set_tbl = Hashtbl.create 3 in + Hashtbl.add setp_table char_set char_set_tbl; + char_set_tbl in Hashtbl.add char_set_tbl stp setp;; let find_setp stp char_set = try Hashtbl.find (Hashtbl.find setp_table char_set) stp with | Not_found -> - let setp = make_setp stp char_set in - add_setp stp char_set setp; - setp;; + let setp = make_setp stp char_set in + add_setp stp char_set setp; + setp;; let scan_chars_in_char_set stp char_set max ib = let rec loop_pos1 cp1 max = @@ -843,19 +916,19 @@ let scan_chars_in_char_set stp char_set max ib = let max = match char_set with | Pos_set set -> - begin match String.length set with - | 0 -> loop (fun c -> 0) max - | 1 -> loop_pos1 set.[0] max - | 2 -> loop_pos2 set.[0] set.[1] max - | 3 when set.[1] != '-' -> loop_pos3 set.[0] set.[1] set.[2] max - | n -> loop (find_setp stp char_set) max end + begin match String.length set with + | 0 -> loop (fun c -> 0) max + | 1 -> loop_pos1 set.[0] max + | 2 -> loop_pos2 set.[0] set.[1] max + | 3 when set.[1] != '-' -> loop_pos3 set.[0] set.[1] set.[2] max + | n -> loop (find_setp stp char_set) max end | Neg_set set -> - begin match String.length set with - | 0 -> loop (fun c -> 1) max - | 1 -> loop_neg1 set.[0] max - | 2 -> loop_neg2 set.[0] set.[1] max - | 3 when set.[1] != '-' -> loop_neg3 set.[0] set.[1] set.[2] max - | n -> loop (find_setp stp char_set) max end in + begin match String.length set with + | 0 -> loop (fun c -> 1) max + | 1 -> loop_neg1 set.[0] max + | 2 -> loop_neg2 set.[0] set.[1] max + | 3 when set.[1] != '-' -> loop_neg3 set.[0] set.[1] set.[2] max + | n -> loop (find_setp stp char_set) max end in ignore_stoppers stp ib; max;; @@ -874,10 +947,12 @@ let rec skip_whites ib = | _ -> () end;; -external format_to_string : - ('a, 'b, 'c, 'd) format4 -> string = "%identity";; -external string_to_format : - string -> ('a, 'b, 'c, 'd) format4 = "%identity";; +let list_iter_i f l = + let rec loop i = function + | [] -> () + | [x] -> f i x (* Tail calling [f] *) + | x :: xs -> f i x; loop (succ i) xs in + loop 0 l;; (* The [kscanf] main scanning function. It takes as arguments: @@ -898,129 +973,163 @@ external string_to_format : If the scanning or some conversion fails, the main scanning function aborts and applies the scanning buffer and a string that explains the error to the error handling function [ef] (the error continuation). *) -let kscanf ib ef fmt f = - let fmt = format_to_string fmt in - let lim = String.length fmt - 1 in +let ascanf sc fmt = + let ac = Tformat.ac_of_format fmt in + match ac.Tformat.ac_rdrs with + | 0 -> Obj.magic (fun f -> sc fmt [||] f) + | 1 -> Obj.magic (fun x f -> sc fmt [| Obj.repr x |] f) + | 2 -> Obj.magic (fun x y f -> sc fmt [| Obj.repr x; Obj.repr y; |] f) + | 3 -> Obj.magic (fun x y z f -> + sc fmt [| Obj.repr x; Obj.repr y; Obj.repr z; |] f) + | nargs -> + let rec loop i args = + if i >= nargs then + let a = Array.make nargs (Obj.repr 0) in + list_iter_i (fun i arg -> a.(nargs - i - 1) <- arg) args; + Obj.magic (fun f -> sc fmt a f) + else Obj.magic (fun x -> loop (succ i) (x :: args)) in + loop 0 [];; + +let scan_format ib ef fmt v f = + + let lim = Sformat.length fmt - 1 in + + let limr = Array.length v - 1 in let return v = Obj.magic v () in let delay f x () = f x in let stack f = delay (return f) in let no_stack f x = f in - let rec scan_fmt f i = + let rec scan_fmt ir f i = if i > lim then f else - match fmt.[i] with - | ' ' -> skip_whites ib; scan_fmt f (i + 1) + match Sformat.get fmt i with + | ' ' -> skip_whites ib; scan_fmt ir f (succ i) | '%' -> - if i > lim then incomplete_format fmt else - scan_conversion false max_int f (i + 1) + if i > lim then incomplete_format fmt else + scan_conversion false max_int ir f (succ i) | '@' -> - let i = i + 1 in - if i > lim then incomplete_format fmt else begin - check_char ib fmt.[i]; - scan_fmt f (i + 1) end - | c -> check_char ib c; scan_fmt f (i + 1) + let i = succ i in + if i > lim then incomplete_format fmt else begin + check_char ib (Sformat.get fmt i); + scan_fmt ir f (succ i) end + | c -> check_char ib c; scan_fmt ir f (succ i) - and scan_conversion skip max f i = + and scan_conversion skip max ir f i = let stack = if skip then no_stack else stack in - match fmt.[i] with + match Sformat.get fmt i with | '%' as conv -> - check_char ib conv; scan_fmt f (i + 1) + check_char ib conv; scan_fmt ir f (succ i) + | 's' -> + let i, stp = scan_fmt_stoppers (succ i) in + let _x = scan_string stp max ib in + scan_fmt ir (stack f (token_string ib)) (succ i) + | 'S' -> + let _x = scan_String max ib in + scan_fmt ir (stack f (token_string ib)) (succ i) + | '[' (* ']' *) -> + let i, char_set = read_char_set fmt (succ i) in + let i, stp = scan_fmt_stoppers (succ i) in + let _x = scan_chars_in_char_set stp char_set max ib in + scan_fmt ir (stack f (token_string ib)) (succ i) | 'c' when max = 0 -> - let c = Scanning.checked_peek_char ib in - scan_fmt (stack f c) (i + 1) + let c = Scanning.checked_peek_char ib in + scan_fmt ir (stack f c) (succ i) | 'c' | 'C' as conv -> - if max <> 1 && max <> max_int then bad_conversion fmt i conv else - let _x = - if conv = 'c' then scan_char max ib else scan_Char max ib in - scan_fmt (stack f (token_char ib)) (i + 1) + if max <> 1 && max <> max_int then bad_conversion fmt i conv else + let _x = + if conv = 'c' then scan_char max ib else scan_Char max ib in + scan_fmt ir (stack f (token_char ib)) (succ i) | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv -> - let _x = scan_int_conv conv max ib in - scan_fmt (stack f (token_int conv ib)) (i + 1) - | 'f' | 'g' | 'G' | 'e' | 'E' -> - let _x = scan_float max ib in - scan_fmt (stack f (token_float ib)) (i + 1) + let _x = scan_int_conv conv max ib in + scan_fmt ir (stack f (token_int conv ib)) (succ i) + | 'N' as conv -> + scan_fmt ir (stack f (get_count conv ib)) (succ i) + | 'f' | 'e' | 'E' | 'g' | 'G' -> + let _x = scan_float max ib in + scan_fmt ir (stack f (token_float ib)) (succ i) | 'F' -> - let _x = scan_Float max ib in - scan_fmt (stack f (token_float ib)) (i + 1) - | 's' -> - let i, stp = scan_fmt_stoppers (i + 1) in - let _x = scan_string stp max ib in - scan_fmt (stack f (token_string ib)) (i + 1) - | '[' -> - let i, char_set = read_char_set fmt (i + 1) in - let i, stp = scan_fmt_stoppers (i + 1) in - let _x = scan_chars_in_char_set stp char_set max ib in - scan_fmt (stack f (token_string ib)) (i + 1) - | 'S' -> - let _x = scan_String max ib in - scan_fmt (stack f (token_string ib)) (i + 1) + let _x = scan_Float max ib in + scan_fmt ir (stack f (token_float ib)) (succ i) | 'B' | 'b' -> - let _x = scan_bool max ib in - scan_fmt (stack f (token_bool ib)) (i + 1) - | 'l' | 'n' | 'L' as typ -> - let i = i + 1 in - if i > lim then scan_fmt (stack f (get_count typ ib)) i else begin - match fmt.[i] with - | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv -> - let _x = scan_int_conv conv max ib in - begin match typ with - | 'l' -> scan_fmt (stack f (token_int32 conv ib)) (i + 1) - | 'n' -> scan_fmt (stack f (token_nativeint conv ib)) (i + 1) - | _ -> scan_fmt (stack f (token_int64 conv ib)) (i + 1) end - | c -> scan_fmt (stack f (get_count typ ib)) i end - | 'N' as conv -> - scan_fmt (stack f (get_count conv ib)) (i + 1) + let _x = scan_bool max ib in + scan_fmt ir (stack f (token_bool ib)) (succ i) + | 'r' -> + if ir > limr then assert false else + let token = Obj.magic v.(ir) ib in + scan_fmt (succ ir) (stack f token) (succ i) + | 'l' | 'n' | 'L' as conv -> + let i = succ i in + if i > lim then scan_fmt ir (stack f (get_count conv ib)) i else begin + match Sformat.get fmt i with + (* This is in fact an integer conversion (e.g. %ld, %ni, or %Lo). *) + | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' as conv -> + let _x = scan_int_conv conv max ib in + (* Look back to the character that triggered the integer conversion + (this character is either 'l', 'n' or 'L'), to find the + conversion to apply to the integer token read. *) + begin match Sformat.get fmt (i - 1) with + | 'l' -> scan_fmt ir (stack f (token_int32 conv ib)) (succ i) + | 'n' -> scan_fmt ir (stack f (token_nativeint conv ib)) (succ i) + | _ -> scan_fmt ir (stack f (token_int64 conv ib)) (succ i) end + (* This is not an integer conversion, but a regular %l, %n or %L. *) + | _ -> scan_fmt ir (stack f (get_count conv ib)) i end | '!' -> - if Scanning.end_of_input ib then scan_fmt f (i + 1) - else bad_input "end of input not found" + if Scanning.end_of_input ib then scan_fmt ir f (succ i) + else bad_input "end of input not found" | '_' -> - if i > lim then incomplete_format fmt else - scan_conversion true max f (i + 1) + if i > lim then incomplete_format fmt else + scan_conversion true max ir f (succ i) | '0' .. '9' as conv -> - let rec read_width accu i = - if i > lim then accu, i else - match fmt.[i] with - | '0' .. '9' as c -> - let accu = 10 * accu + int_value_of_char c in - read_width accu (i + 1) - | _ -> accu, i in - let max, i = read_width (int_value_of_char conv) (i + 1) in - if i > lim then incomplete_format fmt else begin - match fmt.[i] with - | '.' -> - let p, i = read_width 0 (i + 1) in - scan_conversion skip (max + p + 1) f i - | _ -> scan_conversion skip max f i end - | '(' | '{' as conv -> - let i = succ i in - let j = - Printf.sub_format incomplete_format bad_conversion conv fmt i + 1 in - let mf = String.sub fmt i (j - i - 2) in - let _x = scan_String max ib in - let rf = token_string ib in - if not (compatible_format_type mf rf) - then format_mismatch rf mf ib else - if conv = '{' then scan_fmt (stack f rf) j else - let nf = scan_fmt (Obj.magic rf) 0 in - scan_fmt (stack f nf) j + let rec read_width accu i = + if i > lim then accu, i else + match Sformat.get fmt i with + | '0' .. '9' as c -> + let accu = 10 * accu + int_value_of_char c in + read_width accu (succ i) + | _ -> accu, i in + let max, i = read_width (int_value_of_char conv) (succ i) in + if i > lim then incomplete_format fmt else begin + match Sformat.get fmt i with + | '.' -> + let p, i = read_width 0 (succ i) in + scan_conversion skip (succ (max + p)) ir f i + | _ -> scan_conversion skip max ir f i end + | '(' | '{' as conv (* ')' '}' *) -> + let i = succ i in + let j = + Tformat.sub_format + incomplete_format bad_conversion conv fmt i in + let mf = Sformat.sub fmt (Sformat.index_of_int i) (j - 2 - i) in + let _x = scan_String max ib in + let rf = token_string ib in + if not (compatible_format_type rf mf) then format_mismatch rf mf ib else + if conv = '{' (* '}' *) then scan_fmt ir (stack f rf) j else + let nf = scan_fmt ir (Obj.magic rf) 0 in + scan_fmt ir (stack f nf) j | c -> bad_conversion fmt i c and scan_fmt_stoppers i = if i > lim then i - 1, [] else - match fmt.[i] with - | '@' when i < lim -> let i = i + 1 in i, [fmt.[i]] + match Sformat.get fmt i with + | '@' when i < lim -> let i = succ i in i, [Sformat.get fmt i] | '@' when i = lim -> incomplete_format fmt | _ -> i - 1, [] in Scanning.reset_token ib; let v = - try scan_fmt (fun () -> f) 0 with + try scan_fmt 0 (fun () -> f) 0 with | (Scan_failure _ | Failure _ | End_of_file) as exc -> - stack (delay ef ib) exc in + stack (delay ef ib) exc in return v;; +let mkscanf ib ef fmt = + let sc = scan_format ib ef in + ascanf sc fmt;; + +let kscanf ib ef fmt = mkscanf ib ef fmt;; + let bscanf ib = kscanf ib scanf_bad_input;; let fscanf ic = bscanf (Scanning.from_channel ic);; @@ -1030,17 +1139,20 @@ let sscanf s = bscanf (Scanning.from_string s);; let scanf fmt = bscanf Scanning.stdib fmt;; let bscanf_format ib fmt f = - let fmt = format_to_string fmt in + let fmt = Sformat.unsafe_to_string fmt in let fmt1 = ignore (scan_String max_int ib); token_string ib in if not (compatible_format_type fmt1 fmt) then format_mismatch fmt1 fmt ib else - let fresh_fmt1 = String.copy fmt1 in - f (string_to_format fresh_fmt1);; + f (string_to_format fmt1);; -let sscanf_format s fmt = - let fmt = format_to_string fmt in - let fmt1 = s in - if not (compatible_format_type fmt1 fmt) then - bad_input (format_mismatch_err fmt1 fmt) else - let fresh_fmt1 = String.copy fmt1 in - string_to_format fresh_fmt1;; +let sscanf_format s fmt f = bscanf_format (Scanning.from_string s) fmt f;; + +let quote_string s = + let b = Buffer.create (String.length s + 2) in + Buffer.add_char b '\"'; + Buffer.add_string b s; + Buffer.add_char b '\"'; + Buffer.contents b;; + +let format_from_string s fmt = + sscanf_format (quote_string s) fmt (fun x -> x);; diff --git a/stdlib/scanf.mli b/stdlib/scanf.mli index a53eda32..8882cf9f 100644 --- a/stdlib/scanf.mli +++ b/stdlib/scanf.mli @@ -11,34 +11,77 @@ (* *) (***********************************************************************) -(* $Id: scanf.mli,v 1.58.2.1 2006/01/03 17:16:01 weis Exp $ *) +(* $Id: scanf.mli,v 1.69 2007/01/22 08:51:29 weis Exp $ *) (** Formatted input functions. *) -(** Scanning buffers. *) +(** {6 Functional input with format strings.} *) + +(** The formatted input functions provided by module [Scanf] are functionals + that apply the values they read in the input to their function argument. + The specification of the values to read is simply given by a format string + (the same format strings as those used to print material using module + {!Printf} or module {!Format}). + + As an example, consider the formatted input function [scanf] that reads + from standard input; a typical call to [scanf] is simply [scanf fmt f], + meaning that [f] should be applied to the arguments read according to the + format string [fmt]. For instance, if [f] is defined as [let f x = x + 1], then + [scanf "%d" f] will read a decimal integer [i] from [stdin] and return + [f i]; thus, if we enter [41] at the keyboard, [scanf "%d" f] evaluates to [42]. + + This module provides general formatted input functions that reads from any + kind of input, including strings, files, or anything that can return + characters. + Hence, a typical call to a formatted input function [bscan] is + [bscan ib fmt f], meaning that [f] should be applied to the arguments + read from input [ib], according to the format string [fmt]. + + The Caml scanning facility is reminiscent of the corresponding C feature. + However, it is also largely different, simpler, and yet more powerful: the + formatted input functions are higher-order functionals and the parameter + passing mechanism is simply the regular function application not the + variable assigment based mechanism which is typical of formatted input in + imperative languages; the format strings also feature useful additions to + easily define complex tokens; as expected of a functional programming + language feature, the formatted input functions support polymorphism, in + particular arbitrary interaction with polymorphic user-defined scanners. + Furthermore, the Caml formatted input facility is fully type-checked at + compile time. *) + +(** {6 Scanning buffers} *) module Scanning : sig type scanbuf;; -(** The type of scanning buffers. A scanning buffer is the argument passed - to the scanning functions used by the [scanf] family of functions. - The scanning buffer holds the current state of the scan, plus - a function to get the next char from the input, and a token buffer - to store the string matched so far. *) +(** The type of scanning buffers. A scanning buffer is the source from which a + formatted input function gets characters. The scanning buffer holds the current + state of the scan, plus a function to get the next char from the input, and + a token buffer to store the string matched so far. + + Note: a scan may often require to examine one character in advance; + when this ``lookahead'' character does not belong to the token read, + it is stored back in the scanning buffer and becomes the next + character read. *) val stdib : scanbuf;; (** The scanning buffer reading from [stdin]. - [stdib] is equivalent to [Scanning.from_channel stdin]. *) + [stdib] is equivalent to [Scanning.from_channel stdin]. + + Note: when input is read interactively from [stdin], the carriage return + that triggers the evaluation is incorporated in the input; thus, scanning + specifications must properly skip this character (simply add a ['\n'] + as the last character of the format string). *) val from_string : string -> scanbuf;; -(** [Scanning.from_string s] returns a scanning buffer which reads - from the given string. +(** [Scanning.from_string s] returns a scanning buffer which reads from the + given string. Reading starts from the first character in the string. The end-of-input condition is set when the end of the string is reached. *) val from_file : string -> scanbuf;; (** Bufferized file reading in text mode. The efficient and usual way to scan text mode files (in effect, [from_file] returns a - buffer that reads characters in large chunks, rather than one + scanning buffer that reads characters in large chunks, rather than one character at a time as buffers returned by [from_channel] do). [Scanning.from_file fname] returns a scanning buffer which reads from the given file [fname] in text mode. *) @@ -47,11 +90,13 @@ val from_file_bin : string -> scanbuf;; (** Bufferized file reading in binary mode. *) val from_function : (unit -> char) -> scanbuf;; -(** [Scanning.from_function f] returns a scanning buffer with - the given function as its reading method. +(** [Scanning.from_function f] returns a scanning buffer with the given + function as its reading method. + When scanning needs one more character, the given function is called. - When the function has no more character to provide, it must signal - an end-of-input condition by raising the exception [End_of_file]. *) + + When the function has no more character to provide, it must signal an + end-of-input condition by raising the exception [End_of_file]. *) val from_channel : in_channel -> scanbuf;; (** [Scanning.from_channel ic] returns a scanning buffer which reads @@ -59,38 +104,62 @@ val from_channel : in_channel -> scanbuf;; current reading position. *) val end_of_input : scanbuf -> bool;; -(** [Scanning.end_of_input ib] tests the end-of-input condition - of the given buffer. *) +(** [Scanning.end_of_input ib] tests the end-of-input condition of the given + scanning buffer. *) + val beginning_of_input : scanbuf -> bool;; -(** [Scanning.beginning_of_input ib] tests the beginning of input - condition of the given buffer. *) +(** [Scanning.beginning_of_input ib] tests the beginning of input condition of + the given scanning buffer. *) val name_of_input : scanbuf -> string;; -(** [Scanning.file_name_of_input ib] returns the name of the character - source for the input buffer [ib]. *) +(** [Scanning.file_name_of_input ib] returns the name of the character source + for the scanning buffer [ib]. *) end;; exception Scan_failure of string;; -(** The exception that formatted input functions raise when the input - cannot be read according to the given format. *) - -val bscanf : - Scanning.scanbuf -> ('a, Scanning.scanbuf, 'b) format -> 'a -> 'b;; -(** [bscanf ib fmt f] reads tokens from the scanning buffer [ib] according - to the format string [fmt], converts these tokens to values, and - applies the function [f] to these values. - The result of this application of [f] is the result of the whole construct. - - For instance, if [p] is the function [fun s i -> i + 1], then - [Scanf.sscanf "x = 1" "%s = %i" p] returns [2]. +(** The exception that formatted input functions raise when the input cannot be + read according to the given format. *) + +type ('a, 'b, 'c, 'd) scanner = + ('a, Scanning.scanbuf, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c;; +(** The type of formatted input scanners: [('a, 'b, 'c, 'd) scanner] is the + type of a formatted input function that reads from some scanning buffer + according to some format string; more precisely, if [scan] is some + formatted input function, then [scan ib fmt f] applies [f] to the arguments + specified by the format string [fmt], when [scan] has read those arguments + from some scanning buffer [ib]. + + For instance, the [scanf] function below has type [('a, 'b, 'c, 'd) + scanner], since it is a formatted input function that reads from [stdib]: + [scanf fmt f] applies [f] to the arguments specified by [fmt], reading + those arguments from [stdin] as expected. + + If the format [fmt] has some [%r] indications, the corresponding input + functions must be provided before the [f] argument. For instance, if + [read_elem] is an input function for values of type [t], then [bscanf ib + "%r;" read_elem f] reads a value of type [t] followed by a [';'] + character. *) + +(** {6 Formatted input functions} *) + +val bscanf : Scanning.scanbuf -> ('a, 'b, 'c, 'd) scanner;; +(** [bscanf ib fmt r1 ... rN f] reads arguments for the function [f] from the + scanning buffer [ib] according to the format string [fmt], and applies [f] + to these values. + This application of [f] is the result of the whole construct. + For instance, if [f] is the function [fun s i -> i + 1], then + [Scanf.sscanf "x = 1" "%s = %i" f] returns [2]. + + Arguments [r1] to [rN] are user-defined input functions that read the + argument corresponding to a [%r] conversion. The format is a character string which contains three types of objects: - - plain characters, which are simply matched with the - characters of the input, - - conversion specifications, each of which causes reading and - conversion of one argument for [f], + - plain characters, which are simply matched with the characters of the + input, + - conversion specifications, each of which causes reading and conversion of + one argument for [f], - scanning indications to specify boundaries of tokens. Among plain characters the space character (ASCII code 32) has a @@ -150,6 +219,10 @@ val bscanf : first character of the range (or just after the [^] in case of range negation); hence [\[\]\]] matches a [\]] character and [\[^\]\]] matches any character that is not [\]]. + - [r]: user-defined reader. Takes the next [ri] formatted input function and + applies it to the scanning buffer [ib] to read the next argument. The + input function [ri] must therefore have type [Scanning.scanbuf -> 'a] and + the argument read has type ['a]. - [\{ fmt %\}]: reads a format string argument to the format specified by the internal format [fmt]. The format string to be read must have the same type as the internal format [fmt]. @@ -159,15 +232,17 @@ val bscanf : - [\( fmt %\)]: scanning format substitution. Reads a format string to replace [fmt]. The format string read must have the same type as [fmt]. - - [l]: applies [f] to the number of lines read so far. - - [n]: applies [f] to the number of characters read so far. - - [N] or [L]: applies [f] to the number of tokens read so far. + - [l]: returns the number of lines read so far. + - [n]: returns the number of characters read so far. + - [N] or [L]: returns the number of tokens read so far. - [!]: matches the end of input condition. - [%]: matches one [%] character in the input. Following the [%] character introducing a conversion, there may be the special flag [_]: the conversion that follows occurs as usual, but the resulting value is discarded. + For instance, if [f] is the function [fun i -> i + 1], then + [Scanf.sscanf "x = 1" "%_s = %i" f] returns [2]. The field widths are composed of an optional integer literal indicating the maximal width of the token to read. @@ -176,8 +251,8 @@ val bscanf : returns the next 8 characters (or all the characters still available, if less than 8 characters are available in the input). - Scanning indications appear just after the string conversions [s] - and [\[ range \]] to delimit the end of the token. A scanning + Scanning indications appear just after the string conversions [%s] + and [%\[ range \]] to delimit the end of the token. A scanning indication is introduced by a [@] character, followed by some constant character [c]. It means that the string token should end just before the next matching [c] (which is skipped). If no [c] @@ -187,15 +262,17 @@ val bscanf : indication [\@c] does not follow a string conversion, it is treated as a plain [c] character. - Raise [Scanf.Scan_failure] if the given input does not match the format. + Raise [Scanf.Scan_failure] if the input does not match the format. Raise [Failure] if a conversion to a number is not possible. - Raise [End_of_file] if the end of input is encountered while some - more characters are needed to read the current conversion - specification (this means in particular that scanning a [%s] - conversion never raises exception [End_of_file]: if the end of - input is reached the conversion succeeds and simply returns [""]). + Raise [End_of_file] if the end of input is encountered while some more + characters are needed to read the current conversion specification. + As a consequence, scanning a [%s] conversion never raises exception + [End_of_file]: if the end of input is reached the conversion succeeds and + simply returns the characters read so far, or [""] if none were read. + + Raise [Invalid_argument] if the format string is invalid. Notes: @@ -209,7 +286,7 @@ val bscanf : ['\@'] characters). - in addition to relevant digits, ['_'] characters may appear - inside numbers (this is reminiscent to the usual Caml + inside numbers (this is reminiscent to the usual Caml lexical conventions). If stricter scanning is desired, use the range conversion facility instead of the number conversions. @@ -220,16 +297,16 @@ val bscanf : [ocamlyacc]-generated parsers. *) -val fscanf : in_channel -> ('a, Scanning.scanbuf, 'b) format -> 'a -> 'b;; -(** Same as {!Scanf.bscanf}, but inputs from the given channel. +val fscanf : in_channel -> ('a, 'b, 'c, 'd) scanner;; +(** Same as {!Scanf.bscanf}, but reads from the given channel. - Warning: since all scanning functions operate from a scanning + Warning: since all formatted input functions operate from a scanning buffer, be aware that each [fscanf] invocation must allocate a new fresh scanning buffer (unless careful use of partial evaluation in the program). Hence, there are chances that some characters seem to be skipped (in fact they are pending in the previously used - buffer). This happens in particular when calling [fscanf] again - after a scan involving a format that necessitates some look ahead + scanning buffer). This happens in particular when calling [fscanf] again + after a scan involving a format that necessitated some look ahead (such as a format that ends by skipping whitespace in the input). To avoid confusion, consider using [bscanf] with an explicitly @@ -239,16 +316,16 @@ val fscanf : in_channel -> ('a, Scanning.scanbuf, 'b) format -> 'a -> 'b;; This method is not only clearer it is also faster, since scanning buffers to files are optimized for fast bufferized reading. *) -val sscanf : string -> ('a, Scanning.scanbuf, 'b) format -> 'a -> 'b;; -(** Same as {!Scanf.bscanf}, but inputs from the given string. *) +val sscanf : string -> ('a, 'b, 'c, 'd) scanner;; +(** Same as {!Scanf.bscanf}, but reads from the given string. *) -val scanf : ('a, Scanning.scanbuf, 'b) format -> 'a -> 'b;; +val scanf : ('a, 'b, 'c, 'd) scanner;; (** Same as {!Scanf.bscanf}, but reads from the predefined scanning buffer {!Scanf.Scanning.stdib} that is connected to [stdin]. *) val kscanf : - Scanning.scanbuf -> (Scanning.scanbuf -> exn -> 'a) -> - ('b, Scanning.scanbuf, 'a) format -> 'b -> 'a;; + Scanning.scanbuf -> (Scanning.scanbuf -> exn -> 'd) -> + ('a, 'b, 'c, 'd) scanner;; (** Same as {!Scanf.bscanf}, but takes an additional function argument [ef] that is called in case of error: if the scanning process or some conversion fails, the scanning function aborts and applies the @@ -256,16 +333,23 @@ val kscanf : exception that aborted the scanning process. *) val bscanf_format : - Scanning.scanbuf -> ('a, 'b, 'c, 'd) format4 -> - (('a, 'b, 'c, 'd) format4 -> 'e) -> 'e;; - -(** [bscanf_format ib fmt f] reads a format string token in buffer [ib], - according to the format string [fmt], and applies the function [f] to the - resulting format string value. + Scanning.scanbuf -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g;; +(** [bscanf_format ib fmt f] reads a format string token from the scannning + buffer [ib], according to the given format string [fmt], and applies [f] to + the resulting format string value. Raises [Scan_failure] if the format string value read has not the same type as [fmt]. *) val sscanf_format : - string -> ('a, 'b, 'c, 'd) format4 -> ('a, 'b, 'c, 'd) format4;; -(** Same as {!Scanf.bscanf_format}, but converts the given string to a format - string. *) + string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + (('a, 'b, 'c, 'd, 'e, 'f) format6 -> 'g) -> 'g;; +(** Same as {!Scanf.bscanf_format}, but reads from the given string. *) + +val format_from_string : + string -> + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('a, 'b, 'c, 'd, 'e, 'f) format6;; +(** [format_from_string s fmt] converts a string argument to a format string, + according to the given format string [fmt]. + Raises [Scan_failure] if [s], considered as a format string, has not the same + type as [fmt]. *) diff --git a/stdlib/stdlib.mllib b/stdlib/stdlib.mllib new file mode 100644 index 00000000..58947c9b --- /dev/null +++ b/stdlib/stdlib.mllib @@ -0,0 +1,47 @@ +# This file lists all standard library modules. +# It is used in particular to know what to expunge in toplevels. +# $Id: stdlib.mllib,v 1.1 2007/02/07 09:52:28 ertai Exp $ + +Pervasives +Arg +Array +ArrayLabels +Buffer +Callback +CamlinternalMod +CamlinternalOO +Char +Complex +Digest +Filename +Format +Gc +Genlex +Hashtbl +Int32 +Int64 +Lazy +Lexing +List +ListLabels +Map +Marshal +MoreLabels +Nativeint +Obj +Oo +Parsing +Printexc +Printf +Queue +Random +Scanf +Set +Sort +Stack +StdLabels +Stream +String +StringLabels +Sys +Weak diff --git a/stdlib/string.ml b/stdlib/string.ml index 9299bad2..043dad96 100644 --- a/stdlib/string.ml +++ b/stdlib/string.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: string.ml,v 1.25 2003/12/16 18:09:43 doligez Exp $ *) +(* $Id: string.ml,v 1.26 2007/01/30 09:34:36 xleroy Exp $ *) (* String operations *) @@ -174,4 +174,4 @@ let contains s c = contains_from s 0 c;; type t = string -let compare = (Pervasives.compare: t -> t -> int) +let compare (x: t) (y: t) = Pervasives.compare x y diff --git a/stdlib/stringLabels.mli b/stdlib/stringLabels.mli index 1425cb80..0489ba9f 100644 --- a/stdlib/stringLabels.mli +++ b/stdlib/stringLabels.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: stringLabels.mli,v 1.10 2004/11/25 00:04:15 doligez Exp $ *) +(* $Id: stringLabels.mli,v 1.11 2007/01/22 08:06:09 garrigue Exp $ *) (** String operations. *) @@ -22,16 +22,18 @@ external get : string -> int -> char = "%string_safe_get" (** [String.get s n] returns character number [n] in string [s]. The first character is character number 0. The last character is character number [String.length s - 1]. - Raise [Invalid_argument] if [n] is outside the range - 0 to [(String.length s - 1)]. - You can also write [s.[n]] instead of [String.get s n]. *) + You can also write [s.[n]] instead of [String.get s n]. + + Raise [Invalid_argument "index out of bounds"] + if [n] is outside the range 0 to [(String.length s - 1)]. *) + external set : string -> int -> char -> unit = "%string_safe_set" (** [String.set s n c] modifies string [s] in place, replacing the character number [n] by [c]. - Raise [Invalid_argument] if [n] is outside the range - 0 to [(String.length s - 1)]. - You can also write [s.[n] <- c] instead of [String.set s n c]. *) + You can also write [s.[n] <- c] instead of [String.set s n c]. + Raise [Invalid_argument "index out of bounds"] + if [n] is outside the range 0 to [(String.length s - 1)]. *) external create : int -> string = "caml_create_string" (** [String.create n] returns a fresh string of length [n]. @@ -80,7 +82,7 @@ val concat : sep:string -> string list -> string val iter : f:(char -> unit) -> string -> unit (** [String.iter f s] applies function [f] in turn to all the characters of [s]. It is equivalent to - [f s.(0); f s.(1); ...; f s.(String.length s - 1); ()]. *) + [f s.[0]; f s.[1]; ...; f s.[String.length s - 1]; ()]. *) val escaped : string -> string (** Return a copy of the argument, with special characters @@ -137,10 +139,10 @@ val lowercase : string -> string Latin-1 (8859-1) character set. *) val capitalize : string -> string -(** Return a copy of the argument, with the first letter set to uppercase. *) +(** Return a copy of the argument, with the first character set to uppercase. *) val uncapitalize : string -> string -(** Return a copy of the argument, with the first letter set to lowercase. *) +(** Return a copy of the argument, with the first character set to lowercase. *) type t = string (** An alias for the type of strings. *) diff --git a/stdlib/sys.ml b/stdlib/sys.ml deleted file mode 100644 index 759396be..00000000 --- a/stdlib/sys.ml +++ /dev/null @@ -1,81 +0,0 @@ -(***********************************************************************) -(* *) -(* Objective Caml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU Library General Public License, with *) -(* the special exception on linking described in file ../LICENSE. *) -(* *) -(***********************************************************************) - -(* $Id: sys.ml,v 1.138.2.24 2006/09/15 09:18:14 doligez Exp $ *) - -(* System interface *) - -external get_config: unit -> string * int = "caml_sys_get_config" -external get_argv: unit -> string * string array = "caml_sys_get_argv" - -let (executable_name, argv) = get_argv() -let (os_type, word_size) = get_config() -let max_array_length = (1 lsl (word_size - 10)) - 1;; -let max_string_length = word_size / 8 * max_array_length - 1;; - -external file_exists: string -> bool = "caml_sys_file_exists" -external remove: string -> unit = "caml_sys_remove" -external rename : string -> string -> unit = "caml_sys_rename" -external getenv: string -> string = "caml_sys_getenv" -external command: string -> int = "caml_sys_system_command" -external time: unit -> float = "caml_sys_time" -external chdir: string -> unit = "caml_sys_chdir" -external getcwd: unit -> string = "caml_sys_getcwd" -external readdir : string -> string array = "caml_sys_read_directory" - -let interactive = ref false - -type signal_behavior = - Signal_default - | Signal_ignore - | Signal_handle of (int -> unit) - -external signal : int -> signal_behavior -> signal_behavior - = "caml_install_signal_handler" - -let set_signal sig_num sig_beh = ignore(signal sig_num sig_beh) - -let sigabrt = -1 -let sigalrm = -2 -let sigfpe = -3 -let sighup = -4 -let sigill = -5 -let sigint = -6 -let sigkill = -7 -let sigpipe = -8 -let sigquit = -9 -let sigsegv = -10 -let sigterm = -11 -let sigusr1 = -12 -let sigusr2 = -13 -let sigchld = -14 -let sigcont = -15 -let sigstop = -16 -let sigtstp = -17 -let sigttin = -18 -let sigttou = -19 -let sigvtalrm = -20 -let sigprof = -21 - -exception Break - -let catch_break on = - if on then - set_signal sigint (Signal_handle(fun _ -> raise Break)) - else - set_signal sigint Signal_default - - -(* OCaml version string, must be in the format described in sys.mli. *) - -let ocaml_version = "3.09.3";; diff --git a/stdlib/sys.mli b/stdlib/sys.mli index 18e97d02..d209e705 100644 --- a/stdlib/sys.mli +++ b/stdlib/sys.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: sys.mli,v 1.47 2005/10/25 18:34:07 doligez Exp $ *) +(* $Id: sys.mli,v 1.49 2007/02/26 14:21:57 xleroy Exp $ *) (** System interface. *) @@ -27,6 +27,11 @@ val executable_name : string external file_exists : string -> bool = "caml_sys_file_exists" (** Test if a file with the given name exists. *) +external is_directory : string -> bool = "caml_sys_is_directory" +(** Returns [true] if the given name refers to a directory, + [false] if it refers to another kind of file. + Raise [Sys_error] if no file exists with the given name. *) + external remove : string -> unit = "caml_sys_remove" (** Remove the given file name from the file system. *) @@ -193,7 +198,7 @@ val catch_break : bool -> unit val ocaml_version : string;; (** [ocaml_version] is the version of Objective Caml. - It is a string of the form ["major.minor[.patchlevel][+additional-info]"] - Where [major], [minor], and [patchlevel] are integers, and - [additional-info] is an arbitrary string. The [[.patchlevel]] and + It is a string of the form ["major.minor[.patchlevel][+additional-info]"], + where [major], [minor], and [patchlevel] are integers, and + [additional-info] is an arbitrary string. The [[.patchlevel]] and [[+additional-info]] parts may be absent. *) diff --git a/stdlib/sys.mlp b/stdlib/sys.mlp new file mode 100644 index 00000000..97e7318c --- /dev/null +++ b/stdlib/sys.mlp @@ -0,0 +1,86 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id: sys.mlp,v 1.2 2007/02/26 14:21:57 xleroy Exp $ *) + +(* WARNING: sys.ml is generated from sys.mlp. DO NOT EDIT sys.ml or + your changes will be lost. +*) + +(* System interface *) + +external get_config: unit -> string * int = "caml_sys_get_config" +external get_argv: unit -> string * string array = "caml_sys_get_argv" + +let (executable_name, argv) = get_argv() +let (os_type, word_size) = get_config() +let max_array_length = (1 lsl (word_size - 10)) - 1;; +let max_string_length = word_size / 8 * max_array_length - 1;; + +external file_exists: string -> bool = "caml_sys_file_exists" +external is_directory : string -> bool = "caml_sys_is_directory" +external remove: string -> unit = "caml_sys_remove" +external rename : string -> string -> unit = "caml_sys_rename" +external getenv: string -> string = "caml_sys_getenv" +external command: string -> int = "caml_sys_system_command" +external time: unit -> float = "caml_sys_time" +external chdir: string -> unit = "caml_sys_chdir" +external getcwd: unit -> string = "caml_sys_getcwd" +external readdir : string -> string array = "caml_sys_read_directory" + +let interactive = ref false + +type signal_behavior = + Signal_default + | Signal_ignore + | Signal_handle of (int -> unit) + +external signal : int -> signal_behavior -> signal_behavior + = "caml_install_signal_handler" + +let set_signal sig_num sig_beh = ignore(signal sig_num sig_beh) + +let sigabrt = -1 +let sigalrm = -2 +let sigfpe = -3 +let sighup = -4 +let sigill = -5 +let sigint = -6 +let sigkill = -7 +let sigpipe = -8 +let sigquit = -9 +let sigsegv = -10 +let sigterm = -11 +let sigusr1 = -12 +let sigusr2 = -13 +let sigchld = -14 +let sigcont = -15 +let sigstop = -16 +let sigtstp = -17 +let sigttin = -18 +let sigttou = -19 +let sigvtalrm = -20 +let sigprof = -21 + +exception Break + +let catch_break on = + if on then + set_signal sigint (Signal_handle(fun _ -> raise Break)) + else + set_signal sigint Signal_default + + +(* The version string is found in file ../VERSION *) + +let ocaml_version = "%%VERSION%%";; diff --git a/stdlib/weak.ml b/stdlib/weak.ml index c7be1710..0ad9a022 100644 --- a/stdlib/weak.ml +++ b/stdlib/weak.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: weak.ml,v 1.13 2004/01/01 16:42:41 doligez Exp $ *) +(* $Id: weak.ml,v 1.14 2007/02/16 16:05:36 doligez Exp $ *) (** Weak array operations *) @@ -145,7 +145,7 @@ module Make (H : Hashtbl.HashedType) : (S with type data = H.t) = struct fold (fun d () -> add newt d) t (); (* assert Array.length newt.table = newlen; *) t.table <- newt.table; - t.limit <- t.limit + 2; + (* t.limit <- t.limit + 2; -- performance bug *) end and add_aux t d index = diff --git a/tools/.cvsignore b/tools/.cvsignore index 1aa5013d..da394be9 100644 --- a/tools/.cvsignore +++ b/tools/.cvsignore @@ -19,4 +19,4 @@ ocamlmklib.ml lexer301.ml scrapelabels addlabels - +myocamlbuild_config.ml diff --git a/tools/.depend b/tools/.depend index e52904cc..3ce73f53 100644 --- a/tools/.depend +++ b/tools/.depend @@ -12,37 +12,43 @@ dumpapprox.cmo: ../utils/config.cmi ../asmcomp/compilenv.cmi \ dumpapprox.cmx: ../utils/config.cmx ../asmcomp/compilenv.cmx \ ../asmcomp/clambda.cmx dumpobj.cmo: ../utils/tbl.cmi opnames.cmo ../bytecomp/opcodes.cmo \ - ../bytecomp/lambda.cmi ../bytecomp/instruct.cmi ../typing/ident.cmi \ - ../bytecomp/emitcode.cmi ../utils/config.cmi ../bytecomp/bytesections.cmi \ + ../parsing/location.cmi ../bytecomp/lambda.cmi ../bytecomp/instruct.cmi \ + ../typing/ident.cmi ../bytecomp/emitcode.cmi ../utils/config.cmi \ + ../bytecomp/cmo_format.cmi ../bytecomp/bytesections.cmi \ ../parsing/asttypes.cmi dumpobj.cmx: ../utils/tbl.cmx opnames.cmx ../bytecomp/opcodes.cmx \ - ../bytecomp/lambda.cmx ../bytecomp/instruct.cmx ../typing/ident.cmx \ - ../bytecomp/emitcode.cmx ../utils/config.cmx ../bytecomp/bytesections.cmx \ + ../parsing/location.cmx ../bytecomp/lambda.cmx ../bytecomp/instruct.cmx \ + ../typing/ident.cmx ../bytecomp/emitcode.cmx ../utils/config.cmx \ + ../bytecomp/cmo_format.cmi ../bytecomp/bytesections.cmx \ ../parsing/asttypes.cmi lexer301.cmo: ../utils/warnings.cmi ../utils/misc.cmi ../parsing/location.cmi lexer301.cmx: ../utils/warnings.cmx ../utils/misc.cmx ../parsing/location.cmx -objinfo.cmo: ../bytecomp/emitcode.cmi ../utils/config.cmi -objinfo.cmx: ../bytecomp/emitcode.cmx ../utils/config.cmx +objinfo.cmo: ../utils/config.cmi ../bytecomp/cmo_format.cmi +objinfo.cmx: ../utils/config.cmx ../bytecomp/cmo_format.cmi ocamlcp.cmo: ../driver/main_args.cmi ocamlcp.cmx: ../driver/main_args.cmx ocamldep.cmo: ../parsing/syntaxerr.cmi ../parsing/parsetree.cmi \ ../parsing/parse.cmi ../utils/misc.cmi ../parsing/longident.cmi \ ../parsing/location.cmi ../parsing/lexer.cmi depend.cmi \ - ../utils/config.cmi ../utils/clflags.cmo + ../utils/config.cmi ../utils/clflags.cmi ocamldep.cmx: ../parsing/syntaxerr.cmx ../parsing/parsetree.cmi \ ../parsing/parse.cmx ../utils/misc.cmx ../parsing/longident.cmx \ ../parsing/location.cmx ../parsing/lexer.cmx depend.cmx \ ../utils/config.cmx ../utils/clflags.cmx +ocamlmklib.cmo: myocamlbuild_config.cmo +ocamlmklib.cmx: myocamlbuild_config.cmx ocamlmktop.cmo: ../utils/ccomp.cmi ocamlmktop.cmx: ../utils/ccomp.cmx -ocamlprof.cmo: ../parsing/syntaxerr.cmi ../parsing/parsetree.cmi \ - ../parsing/parse.cmi ../utils/misc.cmi ../parsing/location.cmi \ - ../parsing/lexer.cmi ../utils/config.cmi ../utils/clflags.cmo -ocamlprof.cmx: ../parsing/syntaxerr.cmx ../parsing/parsetree.cmi \ - ../parsing/parse.cmx ../utils/misc.cmx ../parsing/location.cmx \ - ../parsing/lexer.cmx ../utils/config.cmx ../utils/clflags.cmx -primreq.cmo: ../bytecomp/emitcode.cmi ../utils/config.cmi -primreq.cmx: ../bytecomp/emitcode.cmx ../utils/config.cmx +ocamlprof.cmo: ../utils/warnings.cmi ../parsing/syntaxerr.cmi \ + ../parsing/parsetree.cmi ../parsing/parse.cmi ../utils/misc.cmi \ + ../parsing/location.cmi ../parsing/lexer.cmi ../utils/config.cmi \ + ../utils/clflags.cmi +ocamlprof.cmx: ../utils/warnings.cmx ../parsing/syntaxerr.cmx \ + ../parsing/parsetree.cmi ../parsing/parse.cmx ../utils/misc.cmx \ + ../parsing/location.cmx ../parsing/lexer.cmx ../utils/config.cmx \ + ../utils/clflags.cmx +primreq.cmo: ../utils/config.cmi ../bytecomp/cmo_format.cmi +primreq.cmx: ../utils/config.cmx ../bytecomp/cmo_format.cmi profiling.cmo: profiling.cmi profiling.cmx: profiling.cmi scrapelabels.cmo: lexer301.cmo diff --git a/tools/Makefile b/tools/Makefile index b68227d7..557a3caa 100644 --- a/tools/Makefile +++ b/tools/Makefile @@ -10,7 +10,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.61.2.2 2006/07/25 09:00:15 doligez Exp $ +# $Id: Makefile,v 1.64 2007/02/07 10:31:36 ertai Exp $ include ../config/Makefile @@ -88,8 +88,13 @@ clean:: # To help building mixed-mode libraries (Caml + C) -ocamlmklib: ocamlmklib.cmo - $(CAMLC) $(LINKFLAGS) -o ocamlmklib ocamlmklib.cmo +ocamlmklib: myocamlbuild_config.cmo ocamlmklib.cmo + $(CAMLC) $(LINKFLAGS) -o ocamlmklib myocamlbuild_config.cmo ocamlmklib.cmo + +ocamlmklib.cmo: myocamlbuild_config.cmi +myocamlbuild_config.ml: ../config/Makefile + ../build/mkmyocamlbuild_config.sh + cp ../myocamlbuild_config.ml . install:: cp ocamlmklib $(BINDIR)/ocamlmklib diff --git a/tools/addlabels.ml b/tools/addlabels.ml index 4f765e37..79afef0e 100644 --- a/tools/addlabels.ml +++ b/tools/addlabels.ml @@ -1,4 +1,4 @@ -(* $Id: addlabels.ml,v 1.10 2003/11/25 09:20:45 garrigue Exp $ *) +(* $Id: addlabels.ml,v 1.11 2006/05/29 03:55:36 garrigue Exp $ *) open StdLabels open Asttypes @@ -307,7 +307,7 @@ let rec add_labels_class ~text ~classes ~values ~methods cl = | Pcf_init e -> add_labels_expr ~text ~classes ~values e; values - | Pcf_inher _ | Pcf_virt _ | Pcf_cstr _ -> values + | Pcf_inher _ | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _ -> values | Pcf_let _ -> values (* not in the grammar *) end; () diff --git a/tools/checkstack.c b/tools/checkstack.c index 2f83af44..8abbd1e1 100644 --- a/tools/checkstack.c +++ b/tools/checkstack.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: checkstack.c,v 1.2.16.1 2006/01/23 17:36:47 doligez Exp $ */ +/* $Id: checkstack.c,v 1.3 2006/04/16 23:28:21 doligez Exp $ */ #include #include diff --git a/tools/depend.ml b/tools/depend.ml index 3e966319..564c5486 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: depend.ml,v 1.9 2005/03/23 03:08:37 garrigue Exp $ *) +(* $Id: depend.ml,v 1.10 2006/04/05 02:28:13 garrigue Exp $ *) open Format open Location @@ -87,7 +87,7 @@ let rec add_class_type bv cty = and add_class_type_field bv = function Pctf_inher cty -> add_class_type bv cty - | Pctf_val(_, _, oty, _) -> add_opt add_type bv oty + | Pctf_val(_, _, _, ty, _) -> add_type bv ty | Pctf_virt(_, _, ty, _) -> add_type bv ty | Pctf_meth(_, _, ty, _) -> add_type bv ty | Pctf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2 @@ -280,6 +280,7 @@ and add_class_expr bv ce = and add_class_field bv = function Pcf_inher(ce, _) -> add_class_expr bv ce | Pcf_val(_, _, e, _) -> add_expr bv e + | Pcf_valvirt(_, _, ty, _) | Pcf_virt(_, _, ty, _) -> add_type bv ty | Pcf_meth(_, _, e, _) -> add_expr bv e | Pcf_cstr(ty1, ty2, _) -> add_type bv ty1; add_type bv ty2 diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml index b720a728..838a507d 100644 --- a/tools/dumpobj.ml +++ b/tools/dumpobj.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: dumpobj.ml,v 1.35.2.2 2006/01/04 09:22:50 xleroy Exp $ *) +(* $Id: dumpobj.ml,v 1.37 2006/05/15 09:00:48 weis Exp $ *) (* Disassembler for executable and .cmo object files *) @@ -23,6 +23,7 @@ open Location open Obj open Opcodes open Opnames +open Cmo_format open Printf (* Read signed and unsigned integers *) diff --git a/tools/make-package-macosx b/tools/make-package-macosx index 4064806e..51e33321 100755 --- a/tools/make-package-macosx +++ b/tools/make-package-macosx @@ -12,16 +12,14 @@ # # ######################################################################### -# $Id: make-package-macosx,v 1.10.2.2 2006/01/04 13:05:49 doligez Exp $ +# $Id: make-package-macosx,v 1.13 2007/02/09 13:31:15 doligez Exp $ cd package-macosx rm -rf ocaml.pkg ocaml-rw.dmg -VERSION=`sed -n -e '/ocaml_version/s/.*"\([^"]*\)".*/\1/p' ../stdlib/sys.ml` -VERSION_MAJOR=`sed -n -e '/ocaml_version/s/.*"\([0-9]*\)\..*/\1/p' \ - ../stdlib/sys.ml` -VERSION_MINOR=`sed -n -e '/ocaml_version/s/.*"[0-9]*\.\([0-9]*\)[.+].*/\1/p' \ - ../stdlib/sys.ml` +VERSION=`head -1 ../VERSION` +VERSION_MAJOR=`sed -n -e '1s/^\([0-9]*\)\..*/\1/p' ../VERSION +VERSION_MINOR=`sed -n -e '1s/^[0-9]*\.\([0-9]*\)[.+].*/\1/p' ../VERSION # Worked in 10.2: @@ -104,7 +102,7 @@ mkdir -p resources cat >resources/ReadMe.txt < raise Not_found | (dir, contents) :: rem -> match find_in_array contents 0 with - Some truename -> concat_filename dir truename + Some truename -> + if dir = "." then truename else Filename.concat dir truename | None -> find_in_path rem in find_in_path !load_path @@ -76,6 +85,7 @@ let find_dependency modname (byt_deps, opt_deps) = let (depends_on, escaped_eol) = (": ", "\\\n ") let print_filename s = + let s = if !force_slash then fix_slash s else s in if not (String.contains s ' ') then begin print_string s; end else begin @@ -119,10 +129,19 @@ let print_dependencies target_file deps = end in print_items (String.length target_file + 2) deps +let print_raw_dependencies source_file deps = + print_filename source_file; print_string ":"; + Depend.StringSet.iter + (fun dep -> print_char ' '; print_string dep) + deps; + print_char '\n' + (* Optionally preprocess a source file *) let preprocessor = ref None +exception Preprocessing_error + let preprocess sourcefile = match !preprocessor with None -> sourcefile @@ -132,8 +151,7 @@ let preprocess sourcefile = let comm = Printf.sprintf "%s %s > %s" pp sourcefile tmpfile in if Sys.command comm <> 0 then begin Misc.remove_file tmpfile; - Printf.eprintf "Preprocessing error\n"; - exit 2 + raise Preprocessing_error end; tmpfile @@ -144,20 +162,15 @@ let remove_preprocessed inputfile = (* Parse a file or get a dumped syntax tree in it *) -exception Outdated_version - let is_ast_file ic ast_magic = try let buffer = String.create (String.length ast_magic) in really_input ic buffer 0 (String.length ast_magic); if buffer = ast_magic then true else if String.sub buffer 0 9 = String.sub ast_magic 0 9 then - raise Outdated_version - else false - with - Outdated_version -> failwith "Ocaml and preprocessor have incompatible versions" - | _ -> false + else false + with End_of_file -> false let parse_use_file ic = if is_ast_file ic Config.ast_impl_magic_number then @@ -181,58 +194,81 @@ let parse_interface ic = (* Process one file *) +let ml_file_dependencies source_file = + Depend.free_structure_names := Depend.StringSet.empty; + let input_file = preprocess source_file in + let ic = open_in_bin input_file in + try + let ast = parse_use_file ic in + Depend.add_use_file Depend.StringSet.empty ast; + if !raw_dependencies then begin + print_raw_dependencies source_file !Depend.free_structure_names + end else begin + let basename = Filename.chop_suffix source_file ".ml" in + let init_deps = + if Sys.file_exists (basename ^ ".mli") + then let cmi_name = basename ^ ".cmi" in ([cmi_name], [cmi_name]) + else ([], []) in + let (byt_deps, opt_deps) = + Depend.StringSet.fold find_dependency + !Depend.free_structure_names init_deps in + print_dependencies (basename ^ ".cmo") byt_deps; + print_dependencies (basename ^ ".cmx") opt_deps + end; + close_in ic; remove_preprocessed input_file + with x -> + close_in ic; remove_preprocessed input_file; raise x + +let mli_file_dependencies source_file = + Depend.free_structure_names := Depend.StringSet.empty; + let input_file = preprocess source_file in + let ic = open_in_bin input_file in + try + let ast = parse_interface ic in + Depend.add_signature Depend.StringSet.empty ast; + if !raw_dependencies then begin + print_raw_dependencies source_file !Depend.free_structure_names + end else begin + let basename = Filename.chop_suffix source_file ".mli" in + let (byt_deps, opt_deps) = + Depend.StringSet.fold find_dependency + !Depend.free_structure_names ([], []) in + print_dependencies (basename ^ ".cmi") byt_deps + end; + close_in ic; remove_preprocessed input_file + with x -> + close_in ic; remove_preprocessed input_file; raise x + let file_dependencies source_file = Location.input_name := source_file; - if Sys.file_exists source_file then begin - try - Depend.free_structure_names := Depend.StringSet.empty; - let input_file = preprocess source_file in - let ic = open_in_bin input_file in - try - if Filename.check_suffix source_file ".ml" then begin - let ast = parse_use_file ic in - Depend.add_use_file Depend.StringSet.empty ast; - let basename = Filename.chop_suffix source_file ".ml" in - let init_deps = - if Sys.file_exists (basename ^ ".mli") - then let cmi_name = basename ^ ".cmi" in ([cmi_name], [cmi_name]) - else ([], []) in - let (byt_deps, opt_deps) = - Depend.StringSet.fold find_dependency !Depend.free_structure_names init_deps in - print_dependencies (basename ^ ".cmo") byt_deps; - print_dependencies (basename ^ ".cmx") opt_deps - end else - if Filename.check_suffix source_file ".mli" then begin - let ast = parse_interface ic in - Depend.add_signature Depend.StringSet.empty ast; - let basename = Filename.chop_suffix source_file ".mli" in - let (byt_deps, opt_deps) = - Depend.StringSet.fold find_dependency !Depend.free_structure_names ([], []) in - print_dependencies (basename ^ ".cmi") byt_deps - end else - (); - close_in ic; remove_preprocessed input_file - with x -> - close_in ic; remove_preprocessed input_file; - raise x - with x -> - let report_err = function - | Lexer.Error(err, range) -> - fprintf Format.err_formatter "@[%a%a@]@." - Location.print range Lexer.report_error err - | Syntaxerr.Error err -> - fprintf Format.err_formatter "@[%a@]@." - Syntaxerr.report_error err - | Sys_error msg -> - fprintf Format.err_formatter "@[I/O error:@ %s@]@." msg - | x -> raise x in - error_occurred := true; - report_err x - end + try + if Sys.file_exists source_file then begin + if Filename.check_suffix source_file ".ml" then + ml_file_dependencies source_file + else if Filename.check_suffix source_file ".mli" then + mli_file_dependencies source_file + else () + end + with x -> + let report_err = function + | Lexer.Error(err, range) -> + fprintf Format.err_formatter "@[%a%a@]@." + Location.print range Lexer.report_error err + | Syntaxerr.Error err -> + fprintf Format.err_formatter "@[%a@]@." + Syntaxerr.report_error err + | Sys_error msg -> + fprintf Format.err_formatter "@[I/O error:@ %s@]@." msg + | Preprocessing_error -> + fprintf Format.err_formatter "@[Preprocessing error on file %s@]@." + source_file + | x -> raise x in + error_occurred := true; + report_err x (* Entry point *) -let usage = "Usage: ocamldep [-I ] [-native] " +let usage = "Usage: ocamldep [options] \nOptions are:" let print_version () = printf "ocamldep, version %s@." Sys.ocaml_version; @@ -245,6 +281,8 @@ let _ = Arg.parse [ "-I", Arg.String add_to_load_path, " Add to the list of include directories"; + "-modules", Arg.Set raw_dependencies, + " Print module dependencies in raw form (output is not suitable for make)"; "-native", Arg.Set native_only, " Generate dependencies for a pure native-code project \ (no .cmo files)"; diff --git a/tools/ocamlmklib.mlp b/tools/ocamlmklib.mlp index ae4848fa..e65f3cc6 100644 --- a/tools/ocamlmklib.mlp +++ b/tools/ocamlmklib.mlp @@ -10,21 +10,14 @@ (* *) (***********************************************************************) -(* $Id: ocamlmklib.mlp,v 1.12 2004/11/27 01:04:19 doligez Exp $ *) +(* $Id: ocamlmklib.mlp,v 1.13 2007/02/07 10:31:36 ertai Exp $ *) open Printf - -let bindir = "%%BINDIR%%" -and supports_shared_libraries = %%SUPPORTS_SHARED_LIBRARIES%% -and mksharedlib = "%%MKSHAREDLIB%%" -and bytecc_rpath = "%%BYTECCRPATH%%" -and nativecc_rpath = "%%NATIVECCRPATH%%" -and mksharedlib_rpath = "%%MKSHAREDLIBRPATH%%" -and ranlib = "%%RANLIB%%" +open Myocamlbuild_config let bytecode_objs = ref [] (* .cmo,.cma,.ml,.mli files to pass to ocamlc *) and native_objs = ref [] (* .cmx,.cmxa,.ml,.mli files to pass to ocamlopt *) -and c_objs = ref [] (* .o, .a files to pass to mksharedlib and ar *) +and c_objs = ref [] (* .o, .a, .obj, .lib files to pass to mksharedlib and ar *) and caml_libs = ref [] (* -cclib to pass to ocamlc, ocamlopt *) and caml_opts = ref [] (* -ccopt to pass to ocamlc, ocamlopt *) and dynlink = ref supports_shared_libraries @@ -37,6 +30,7 @@ and ocamlopt = ref (Filename.concat bindir "ocamlopt") and output = ref "a" (* Output name for Caml part of library *) and output_c = ref "" (* Output name for C part of library *) and rpath = ref [] (* rpath options *) +and implib = ref "" (* windows implib flag *) and verbose = ref false let starts_with s pref = @@ -69,7 +63,7 @@ let parse_arguments argv = else if ends_with s ".ml" || ends_with s ".mli" then (bytecode_objs := s :: !bytecode_objs; native_objs := s :: !native_objs) - else if ends_with s ".o" || ends_with s ".a" then + else if List.exists (ends_with s) [".o"; ".a"; ".obj"; ".lib"] then c_objs := s :: !c_objs else if s = "-cclib" then caml_libs := next_arg () :: "-cclib" :: !caml_libs @@ -77,6 +71,8 @@ let parse_arguments argv = caml_opts := next_arg () :: "-ccopt" :: !caml_opts else if s = "-custom" then dynlink := false + else if s = "-implib" then + implib := next_arg () else if s = "-I" then caml_opts := next_arg () :: "-I" :: !caml_opts else if s = "-failsafe" then @@ -135,7 +131,7 @@ let parse_arguments argv = if !output_c = "" then output_c := !output let usage = "\ -Usage: ocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a files> +Usage: ocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a|.obj|.lib files> Options are: -cclib C library passed to ocamlc -a or ocamlopt -a only -ccopt C option passed to ocamlc -a or ocamlopt -a only @@ -202,25 +198,20 @@ let build_libs () = if !c_objs <> [] then begin if !dynlink then begin let retcode = command - (sprintf "%s %s %s %s %s %s %s" - mksharedlib - (prepostfix "dll" !output_c ".so") + (mkdll (prepostfix "dll" !output_c ext_dll) + !implib + (sprintf "%s %s %s %s %s" (String.concat " " !c_objs) (String.concat " " !c_opts) (String.concat " " !ld_opts) - (make_rpath mksharedlib_rpath) - (String.concat " " !c_libs)) in + (make_rpath mksharedlibrpath) + (String.concat " " !c_libs)) "") in if retcode <> 0 then if !failsafe then dynlink := false else exit 2 end; - safe_remove (prepostfix "lib" !output_c ".a"); - scommand - (sprintf "ar rc %s %s" - (prepostfix "lib" !output_c ".a") - (String.concat " " !c_objs)); + safe_remove (prepostfix "lib" !output_c ext_lib); scommand - (sprintf "%s %s" - ranlib - (prepostfix "lib" !output_c ".a")) + (mklib (prepostfix "lib" !output_c ext_lib) + (String.concat " " !c_objs) ""); end; if !bytecode_objs <> [] then scommand @@ -230,10 +221,10 @@ let build_libs () = !output (String.concat " " !caml_opts) (String.concat " " !bytecode_objs) - !output_c - !output_c + (Filename.basename !output_c) + (Filename.basename !output_c) (String.concat " " (prefix_list "-ccopt " !c_opts)) - (make_rpath_ccopt bytecc_rpath) + (make_rpath_ccopt byteccrpath) (String.concat " " (prefix_list "-cclib " !c_libs)) (String.concat " " !caml_libs)); if !native_objs <> [] then @@ -243,9 +234,9 @@ let build_libs () = !output (String.concat " " !caml_opts) (String.concat " " !native_objs) - !output_c + (Filename.basename !output_c) (String.concat " " (prefix_list "-ccopt " !c_opts)) - (make_rpath_ccopt nativecc_rpath) + (make_rpath_ccopt nativeccrpath) (String.concat " " (prefix_list "-cclib " !c_libs)) (String.concat " " !caml_libs)) diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml index 9bdd09a0..7218a0ea 100644 --- a/tools/ocamlprof.ml +++ b/tools/ocamlprof.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: ocamlprof.ml,v 1.38.4.1 2006/05/02 14:54:35 guesdon Exp $ *) +(* $Id: ocamlprof.ml,v 1.41 2007/02/09 13:31:15 doligez Exp $ *) open Printf @@ -328,7 +328,7 @@ and rewrite_class_field iflag = rewrite_patexp_list iflag spat_sexp_list | Pcf_init sexp -> rewrite_exp iflag sexp - | Pcf_virt _ | Pcf_cstr _ -> () + | Pcf_valvirt _ | Pcf_virt _ | Pcf_cstr _ -> () and rewrite_class_expr iflag cexpr = match cexpr.pcl_desc with @@ -456,6 +456,7 @@ let print_version () = let main () = try + Warnings.parse_options false "a"; Arg.parse [ "-f", Arg.String (fun s -> dumpfile := s), " Use as dump file (default ocamlprof.dump)"; diff --git a/tools/primreq.ml b/tools/primreq.ml index 08a1b741..81c68ad7 100644 --- a/tools/primreq.ml +++ b/tools/primreq.ml @@ -10,13 +10,13 @@ (* *) (***********************************************************************) -(* $Id: primreq.ml,v 1.4 2005/06/22 13:53:34 doligez Exp $ *) +(* $Id: primreq.ml,v 1.5 2006/07/05 12:09:18 pouillar Exp $ *) (* Determine the set of C primitives required by the given .cmo and .cma files *) open Config -open Emitcode +open Cmo_format module StringSet = Set.Make(struct type t = string let compare = compare end) diff --git a/tools/profiling.ml b/tools/profiling.ml index 7678753c..b6339def 100644 --- a/tools/profiling.ml +++ b/tools/profiling.ml @@ -12,7 +12,7 @@ (* *) (***********************************************************************) -(* $Id: profiling.ml,v 1.7 2005/03/24 17:20:54 doligez Exp $ *) +(* $Id: profiling.ml,v 1.8 2006/11/28 15:59:35 doligez Exp $ *) (* Run-time library for profiled programs *) @@ -24,8 +24,11 @@ let incr a i = a.(i) <- a.(i) + 1;; exception Bad_profile let dump_counters () = - begin try - let ic = open_in_bin "ocamlprof.dump" in + let dumpfile = + try Sys.getenv "OCAMLPROF_DUMP" with Not_found -> "ocamlprof.dump" + in + begin try + let ic = open_in_bin dumpfile in let prevl = (input_value ic : profiling_counters) in close_in ic; List.iter2 @@ -44,7 +47,7 @@ let dump_counters () = with _ -> () end; begin try - let oc = open_out_bin "ocamlprof.dump" in + let oc = open_out_bin dumpfile in output_value oc !counters; close_out oc with _ -> () diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index f97afe1b..204df79a 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: topdirs.ml,v 1.64 2004/11/29 02:27:25 garrigue Exp $ *) +(* $Id: topdirs.ml,v 1.66 2006/09/28 21:36:38 xleroy Exp $ *) (* Toplevel directives *) @@ -19,7 +19,7 @@ open Misc open Longident open Path open Types -open Emitcode +open Cmo_format open Trace open Toploop @@ -105,7 +105,7 @@ let load_file ppf name = List.iter (fun dllib -> let name = Dll.extract_dll_name dllib in - try Dll.open_dlls [name] + try Dll.open_dlls Dll.For_execution [name] with Failure reason -> fprintf ppf "Cannot load required shared library %s.@.Reason: %s.@." diff --git a/toplevel/toplevellib.mllib b/toplevel/toplevellib.mllib new file mode 100644 index 00000000..906aeb43 --- /dev/null +++ b/toplevel/toplevellib.mllib @@ -0,0 +1,19 @@ +Myocamlbuild_config +Misc Tbl Config Clflags Terminfo Ccomp Warnings Consistbl + +Linenum Location Longident Syntaxerr Parser +Lexer Parse Printast + +Unused_var Ident Path Primitive Types +Btype Oprint Subst Predef Datarepr Env +Typedtree Ctype Printtyp Includeclass Mtype Includecore +Includemod Parmatch Typetexp Stypes Typecore +Typedecl Typeclass Typemod + +Lambda Printlambda Typeopt Switch Matching Translobj Translcore +Translclass Translmod Simplif Runtimedef + +Meta Instruct Bytegen Printinstr Opcodes Emitcode +Bytesections Dll Symtable Bytelink Bytelibrarian Bytepackager + +Pparse Errors Compile Genprintval Toploop Trace Topdirs Topmain diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index e1e3ca79..1a202bb5 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: toploop.ml,v 1.92.2.1 2005/11/16 16:37:20 doligez Exp $ *) +(* $Id: toploop.ml,v 1.93 2006/01/04 16:55:50 doligez Exp $ *) (* The interactive toplevel loop *) diff --git a/typing/btype.ml b/typing/btype.ml index 36ec05c7..4d759508 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: btype.ml,v 1.37.4.1 2005/12/05 13:18:42 garrigue Exp $ *) +(* $Id: btype.ml,v 1.39 2006/04/05 02:28:13 garrigue Exp $ *) (* Basic operations on core types *) @@ -330,7 +330,7 @@ let unmark_type_decl decl = let unmark_class_signature sign = unmark_type sign.cty_self; - Vars.iter (fun l (m, t) -> unmark_type t) sign.cty_vars + Vars.iter (fun l (m, v, t) -> unmark_type t) sign.cty_vars let rec unmark_class_type = function diff --git a/typing/btype.mli b/typing/btype.mli index 5dc3ff30..455ba5f3 100644 --- a/typing/btype.mli +++ b/typing/btype.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: btype.mli,v 1.17.4.1 2005/12/05 13:18:43 garrigue Exp $ *) +(* $Id: btype.mli,v 1.18 2006/01/04 16:55:50 doligez Exp $ *) (* Basic operations on core types *) diff --git a/typing/ctype.ml b/typing/ctype.ml index e6d7df5c..b96eae2f 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: ctype.ml,v 1.197.2.8 2006/06/23 03:02:19 garrigue Exp $ *) +(* $Id: ctype.ml,v 1.205.2.1 2007/03/05 01:24:10 garrigue Exp $ *) (* Operations on core types *) @@ -427,15 +427,11 @@ let rec closed_type ty = let closed_parameterized_type params ty = List.iter mark_type params; - try - closed_type ty; - List.iter unmark_type params; - unmark_type ty; - true - with Non_closed _ -> - List.iter unmark_type params; - unmark_type ty; - false + let ok = + try closed_type ty; true with Non_closed _ -> false in + List.iter unmark_type params; + unmark_type ty; + ok let closed_type_decl decl = try @@ -579,7 +575,7 @@ let rec generalize_spine ty = generalize_spine ty' | _ -> () -let try_expand_head' = (* Forward declaration *) +let try_expand_once' = (* Forward declaration *) ref (fun env ty -> raise Cannot_expand) (* @@ -601,7 +597,7 @@ let rec update_level env level ty = Tconstr(p, tl, abbrev) when level < Path.binding_time p -> (* Try first to replace an abbreviation by its expansion. *) begin try - link_type ty (!try_expand_head' env ty); + link_type ty (!try_expand_once' env ty); update_level env level ty with Cannot_expand -> (* +++ Levels should be restored... *) @@ -791,14 +787,14 @@ let rec copy ty = let keep = more.level <> generic_level in let more' = match more.desc with - Tsubst ty -> ty - | Tconstr _ -> - if keep then save_desc more more.desc; - copy more + Tsubst ty -> ty + | Tconstr _ -> + if keep then save_desc more more.desc; + copy more | Tvar | Tunivar -> save_desc more more.desc; if keep then more else newty more.desc - | _ -> assert false + | _ -> assert false in (* Register new type first for recursion *) more.desc <- Tsubst(newgenty(Ttuple[more';t])); @@ -857,7 +853,7 @@ let instance_class params cty = Tcty_signature {cty_self = copy sign.cty_self; cty_vars = - Vars.map (function (mut, ty) -> (mut, copy ty)) sign.cty_vars; + Vars.map (function (m, v, ty) -> (m, v, copy ty)) sign.cty_vars; cty_concr = sign.cty_concr; cty_inher = List.map (fun (p,tl) -> (p, List.map copy tl)) sign.cty_inher} @@ -928,7 +924,7 @@ let delayed_copy = ref [] let rec copy_sep fixed free bound visited ty = let ty = repr ty in let univars = free ty in - if TypeSet.is_empty univars then + if TypeSet.is_empty univars then if ty.level <> generic_level then ty else let t = newvar () in delayed_copy := @@ -1040,7 +1036,7 @@ let apply env params body args = (* Abbreviation expansion *) (****************************) -(* +(* If the environnement has changed, memorized expansions might not be correct anymore, and so we flush the cache. This is safe but quite pessimistic: it would be enough to flush the cache when a @@ -1054,7 +1050,7 @@ let check_abbrev_env env = end (* Expand an abbreviation. The expansion is memorized. *) -(* +(* Assume the level is greater than the path binding time of the expanded abbreviation. *) @@ -1112,23 +1108,24 @@ let safe_abbrev env ty = Btype.backtrack snap; false +let try_expand_once env ty = + let ty = repr ty in + match ty.desc with + Tconstr _ -> repr (expand_abbrev env ty) + | _ -> raise Cannot_expand + +let _ = try_expand_once' := try_expand_once + (* Fully expand the head of a type. Raise Cannot_expand if the type cannot be expanded. May raise Unify, if a recursion was hidden in the type. *) let rec try_expand_head env ty = - let ty = repr ty in - match ty.desc with - Tconstr _ -> - let ty' = expand_abbrev env ty in - begin try - try_expand_head env ty' - with Cannot_expand -> - repr ty' - end - | _ -> - raise Cannot_expand - -let _ = try_expand_head' := try_expand_head + let ty' = try_expand_once env ty in + begin try + try_expand_head env ty' + with Cannot_expand -> + ty' + end (* Expand once the head of a type *) let expand_head_once env ty = @@ -1338,7 +1335,7 @@ let occur_univar env ty = with exn -> unmark_type ty; raise exn -(* Grouping univars by families according to their binders *) +(* Grouping univars by families according to their binders *) let add_univars = List.fold_left (fun s (t,_) -> TypeSet.add (repr t) s) @@ -1536,7 +1533,7 @@ and unify3 env t1 t1' t2 t2' = (* Third step: truly unification *) (* Assumes either [t1 == t1'] or [t2 != t2'] *) let d1 = t1'.desc and d2 = t2'.desc in - + let create_recursion = (t2 != t2') && (deep_occur t1' t2) in occur env t1' t2; update_level env t1'.level t2; @@ -1618,7 +1615,7 @@ and unify3 env t1 t1' t2 t2' = end (* - (* + (* Can only be done afterwards, once the row variable has (possibly) been instantiated. *) @@ -1760,12 +1757,11 @@ and unify_row env row1 row2 = in let md1 = rm1.desc and md2 = rm2.desc in begin try - set_more row1 r2; set_more row2 r1; - let undo = ref [] in + set_more row1 r2; List.iter (fun (l,f1,f2) -> - try unify_row_field env row1.row_fixed row2.row_fixed undo l f1 f2 + try unify_row_field env row1.row_fixed row2.row_fixed l f1 f2 with Unify trace -> raise (Unify ((mkvariant [l,f1] true, mkvariant [l,f2] true) :: trace))) @@ -1774,7 +1770,7 @@ and unify_row env row1 row2 = log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn end -and unify_row_field env fixed1 fixed2 undo l f1 f2 = +and unify_row_field env fixed1 fixed2 l f1 f2 = let f1 = row_field_repr f1 and f2 = row_field_repr f2 in if f1 == f2 then () else match f1, f2 with @@ -1790,7 +1786,7 @@ and unify_row_field env fixed1 fixed2 undo l f1 f2 = List.iter (unify env t1) tl; !e1 <> None || !e2 <> None end in - if redo then unify_row_field env fixed1 fixed2 undo l f1 f2 else + if redo then unify_row_field env fixed1 fixed2 l f1 f2 else let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in let rec remq tl = function [] -> [] | ty :: tl' -> @@ -1801,7 +1797,6 @@ and unify_row_field env fixed1 fixed2 undo l f1 f2 = let f1' = Reither(c1 || c2, tl1', m1 || m2, e) and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in set_row_field e1 f1'; set_row_field e2 f2'; - undo := (l, e2) :: !undo | Reither(_, _, false, e1), Rabsent -> set_row_field e1 f2 | Rabsent, Reither(_, _, false, e2) -> set_row_field e2 f1 | Rabsent, Rabsent -> () @@ -1818,7 +1813,7 @@ and unify_row_field env fixed1 fixed2 undo l f1 f2 = | Rpresent None, Reither(true, [], _, e2) when not fixed2 -> set_row_field e2 f1 | _ -> raise (Unify []) - + let unify env ty1 ty2 = try @@ -1938,7 +1933,7 @@ let filter_self_method env lab priv meths ty = Update the level of [ty]. First check that the levels of generic variables from the subject are not lowered. *) -let moregen_occur env level ty = +let moregen_occur env level ty = let rec occur ty = let ty = repr ty in if ty.level > level then begin @@ -2057,7 +2052,7 @@ and moregen_row inst_nongen type_pairs env row1 row2 = filter_row_fields true r1, filter_row_fields false r2 else r1, r2 in - if r1 <> [] || row1.row_closed && (not row2.row_closed || r2 <> []) + if r1 <> [] || row1.row_closed && (not row2.row_closed || r2 <> []) then raise (Unify []); let rm1 = repr row1.row_more and rm2 = repr row2.row_more in let univ = @@ -2265,7 +2260,7 @@ let rec eqtype rename type_pairs subst env t1 t2 = enter_poly env univar_pairs t1 tl1 t2 tl2 (eqtype rename type_pairs subst env) | (Tunivar, Tunivar) -> - unify_univar t1 t2 !univar_pairs + unify_univar t1' t2' !univar_pairs | (_, _) -> raise (Unify []) end @@ -2339,7 +2334,7 @@ and eqtype_row rename type_pairs subst env row1 row2 = | Rabsent, Rabsent -> () | _ -> raise (Unify [])) pairs - + (* Two modes: with or without renaming of variables *) let equal env rename tyl1 tyl2 = try @@ -2348,7 +2343,7 @@ let equal env rename tyl1 tyl2 = with Unify _ -> false -(* Must empty univar_pairs first *) +(* Must empty univar_pairs first *) let eqtype rename type_pairs subst env t1 t2 = univar_pairs := []; eqtype rename type_pairs subst env t1 t2 @@ -2368,10 +2363,11 @@ type class_match_failure = | CM_Val_type_mismatch of string * (type_expr * type_expr) list | CM_Meth_type_mismatch of string * (type_expr * type_expr) list | CM_Non_mutable_value of string + | CM_Non_concrete_value of string | CM_Missing_value of string | CM_Missing_method of string | CM_Hide_public of string - | CM_Hide_virtual of string + | CM_Hide_virtual of string * string | CM_Public_method of string | CM_Private_method of string | CM_Virtual_method of string @@ -2404,8 +2400,8 @@ let rec moregen_clty trace type_pairs env cty1 cty2 = end) pairs; Vars.iter - (fun lab (mut, ty) -> - let (mut', ty') = Vars.find lab sign1.cty_vars in + (fun lab (mut, v, ty) -> + let (mut', v', ty') = Vars.find lab sign1.cty_vars in try moregen true type_pairs env ty' ty with Unify trace -> raise (Failure [CM_Val_type_mismatch (lab, expand_trace env trace)])) @@ -2451,7 +2447,7 @@ let match_class_types env pat_sch subj_sch = end in if Concr.mem lab sign1.cty_concr then err - else CM_Hide_virtual lab::err) + else CM_Hide_virtual ("method", lab) :: err) miss1 [] in let missing_method = List.map (fun (m, _, _) -> m) miss2 in @@ -2469,17 +2465,27 @@ let match_class_types env pat_sch subj_sch = in let error = Vars.fold - (fun lab (mut, ty) err -> + (fun lab (mut, vr, ty) err -> try - let (mut', ty') = Vars.find lab sign1.cty_vars in + let (mut', vr', ty') = Vars.find lab sign1.cty_vars in if mut = Mutable && mut' <> Mutable then CM_Non_mutable_value lab::err + else if vr = Concrete && vr' <> Concrete then + CM_Non_concrete_value lab::err else err with Not_found -> CM_Missing_value lab::err) sign2.cty_vars error in + let error = + Vars.fold + (fun lab (_,vr,_) err -> + if vr = Virtual && not (Vars.mem lab sign2.cty_vars) then + CM_Hide_virtual ("instance variable", lab) :: err + else err) + sign1.cty_vars error + in let error = List.fold_right (fun e l -> @@ -2530,8 +2536,8 @@ let rec equal_clty trace type_pairs subst env cty1 cty2 = end) pairs; Vars.iter - (fun lab (mut, ty) -> - let (mut', ty') = Vars.find lab sign1.cty_vars in + (fun lab (_, _, ty) -> + let (_, _, ty') = Vars.find lab sign1.cty_vars in try eqtype true type_pairs subst env ty ty' with Unify trace -> raise (Failure [CM_Val_type_mismatch (lab, expand_trace env trace)])) @@ -2568,7 +2574,7 @@ let match_class_declarations env patt_params patt_type subj_params subj_type = end in if Concr.mem lab sign1.cty_concr then err - else CM_Hide_virtual lab::err) + else CM_Hide_virtual ("method", lab) :: err) miss1 [] in let missing_method = List.map (fun (m, _, _) -> m) miss2 in @@ -2592,17 +2598,27 @@ let match_class_declarations env patt_params patt_type subj_params subj_type = in let error = Vars.fold - (fun lab (mut, ty) err -> + (fun lab (mut, vr, ty) err -> try - let (mut', ty') = Vars.find lab sign1.cty_vars in + let (mut', vr', ty') = Vars.find lab sign1.cty_vars in if mut = Mutable && mut' <> Mutable then CM_Non_mutable_value lab::err + else if vr = Concrete && vr' <> Concrete then + CM_Non_concrete_value lab::err else err with Not_found -> CM_Missing_value lab::err) sign2.cty_vars error in + let error = + Vars.fold + (fun lab (_,vr,_) err -> + if vr = Virtual && not (Vars.mem lab sign2.cty_vars) then + CM_Hide_virtual ("instance variable", lab) :: err + else err) + sign1.cty_vars error + in let error = List.fold_right (fun e l -> @@ -2868,7 +2884,7 @@ let rec subtype_rec env trace t1 t2 cstrs = let t1 = repr t1 in let t2 = repr t2 in if t1 == t2 then cstrs else - + begin try TypePairs.find subtypes (t1, t2); cstrs @@ -2899,7 +2915,7 @@ let rec subtype_rec env trace t1 t2 cstrs = if co then if cn then (trace, newty2 t1.level (Ttuple[t1]), - newty2 t2.level (Ttuple[t2]), !univar_pairs) :: cstrs + newty2 t2.level (Ttuple[t2]), !univar_pairs) :: cstrs else subtype_rec env ((t1, t2)::trace) t1 t2 cstrs else if cn then subtype_rec env ((t2, t1)::trace) t2 t1 cstrs @@ -3149,7 +3165,7 @@ let rec normalize_type_rec env ty = let normalize_type env ty = normalize_type_rec env ty; unmark_type ty - + (*************************) (* Remove dependencies *) @@ -3298,7 +3314,7 @@ let nondep_type_decl env mid id is_covariant decl = let nondep_class_signature env id sign = { cty_self = nondep_type_rec env id sign.cty_self; cty_vars = - Vars.map (function (m, t) -> (m, nondep_type_rec env id t)) + Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t)) sign.cty_vars; cty_concr = sign.cty_concr; cty_inher = diff --git a/typing/ctype.mli b/typing/ctype.mli index 9054d6bc..856559d3 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: ctype.mli,v 1.53 2004/12/09 12:40:53 garrigue Exp $ *) +(* $Id: ctype.mli,v 1.54 2006/04/05 02:28:13 garrigue Exp $ *) (* Operations on core types *) @@ -170,10 +170,11 @@ type class_match_failure = | CM_Val_type_mismatch of string * (type_expr * type_expr) list | CM_Meth_type_mismatch of string * (type_expr * type_expr) list | CM_Non_mutable_value of string + | CM_Non_concrete_value of string | CM_Missing_value of string | CM_Missing_method of string | CM_Hide_public of string - | CM_Hide_virtual of string + | CM_Hide_virtual of string * string | CM_Public_method of string | CM_Private_method of string | CM_Virtual_method of string diff --git a/typing/env.ml b/typing/env.ml index 095008f7..780ed8d6 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: env.ml,v 1.56 2005/08/13 20:59:37 doligez Exp $ *) +(* $Id: env.ml,v 1.58 2006/10/13 12:56:28 xleroy Exp $ *) (* Environment handling *) @@ -27,6 +27,7 @@ type error = | Corrupted_interface of string | Illegal_renaming of string * string | Inconsistent_import of string * string * string + | Need_recursive_types of string * string exception Error of error @@ -65,7 +66,7 @@ and structure_components = { mutable comp_constrs: (string, (constructor_description * int)) Tbl.t; mutable comp_labels: (string, (label_description * int)) Tbl.t; mutable comp_types: (string, (type_declaration * int)) Tbl.t; - mutable comp_modules: (string, (module_type * int)) Tbl.t; + mutable comp_modules: (string, (module_type Lazy.t * int)) Tbl.t; mutable comp_modtypes: (string, (modtype_declaration * int)) Tbl.t; mutable comp_components: (string, (module_components * int)) Tbl.t; mutable comp_classes: (string, (class_declaration * int)) Tbl.t; @@ -77,7 +78,8 @@ and functor_components = { fcomp_arg: module_type; (* Argument signature *) fcomp_res: module_type; (* Result signature *) fcomp_env: t; (* Environment in which the result signature makes sense *) - fcomp_subst: Subst.t (* Prefixing substitution for the result signature *) + fcomp_subst: Subst.t; (* Prefixing substitution for the result signature *) + fcomp_cache: (Path.t, module_components) Hashtbl.t (* For memoization *) } let empty = { @@ -122,12 +124,15 @@ let current_unit = ref "" (* Persistent structure descriptions *) +type pers_flags = Rectypes + type pers_struct = { ps_name: string; ps_sig: signature; ps_comps: module_components; ps_crcs: (string * Digest.t) list; - ps_filename: string } + ps_filename: string; + ps_flags: pers_flags list } let persistent_structures = (Hashtbl.create 17 : (string, pers_struct) Hashtbl.t) @@ -157,6 +162,7 @@ let read_pers_struct modname filename = end; let (name, sign) = input_value ic in let crcs = input_value ic in + let flags = input_value ic in close_in ic; let comps = !components_of_module' empty Subst.identity @@ -166,10 +172,16 @@ let read_pers_struct modname filename = ps_sig = sign; ps_comps = comps; ps_crcs = crcs; - ps_filename = filename } in + ps_filename = filename; + ps_flags = flags } in if ps.ps_name <> modname then raise(Error(Illegal_renaming(ps.ps_name, filename))); check_consistency filename ps.ps_crcs; + List.iter + (function Rectypes -> + if not !Clflags.recursive_types then + raise(Error(Need_recursive_types(ps.ps_name, !current_unit)))) + ps.ps_flags; Hashtbl.add persistent_structures modname ps; ps with End_of_file | Failure _ -> @@ -271,7 +283,7 @@ let find_module path env = | Pdot(p, s, pos) -> begin match Lazy.force (find_module_descr p env) with Structure_comps c -> - let (data, pos) = Tbl.find s c.comp_modules in data + let (data, pos) = Tbl.find s c.comp_modules in Lazy.force data | Functor_comps f -> raise Not_found end @@ -325,7 +337,7 @@ and lookup_module lid env = begin match Lazy.force descr with Structure_comps c -> let (data, pos) = Tbl.find s c.comp_modules in - (Pdot(p, s, pos), data) + (Pdot(p, s, pos), Lazy.force data) | Functor_comps f -> raise Not_found end @@ -503,7 +515,7 @@ let rec components_of_module env sub path mty = Tbl.add (Ident.name id) (cstr, !pos) c.comp_constrs; incr pos | Tsig_module(id, mty, _) -> - let mty' = Subst.modtype sub mty in + let mty' = lazy (Subst.modtype sub mty) in c.comp_modules <- Tbl.add (Ident.name id) (mty', !pos) c.comp_modules; let comps = components_of_module !env sub path mty in @@ -536,7 +548,8 @@ let rec components_of_module env sub path mty = (* fcomp_res is prefixed lazily, because it is interpreted in env *) fcomp_res = ty_res; fcomp_env = env; - fcomp_subst = sub } + fcomp_subst = sub; + fcomp_cache = Hashtbl.create 17 } | Tmty_ident p -> Structure_comps { comp_values = Tbl.empty; comp_constrs = Tbl.empty; @@ -610,11 +623,16 @@ and store_cltype id path desc env = (* Compute the components of a functor application in a path. *) let components_of_functor_appl f p1 p2 = - let p = Papply(p1, p2) in - let mty = - Subst.modtype (Subst.add_module f.fcomp_param p2 Subst.identity) - f.fcomp_res in - components_of_module f.fcomp_env f.fcomp_subst p mty + try + Hashtbl.find f.fcomp_cache p2 + with Not_found -> + let p = Papply(p1, p2) in + let mty = + Subst.modtype (Subst.add_module f.fcomp_param p2 Subst.identity) + f.fcomp_res in + let comps = components_of_module f.fcomp_env f.fcomp_subst p mty in + Hashtbl.add f.fcomp_cache p2 comps; + comps (* Define forward functions *) @@ -747,6 +765,8 @@ let save_signature_with_imports sg modname filename imports = let crc = Digest.file filename in let crcs = (modname, crc) :: imports in output_value oc crcs; + let flags = if !Clflags.recursive_types then [Rectypes] else [] in + output_value oc flags; close_out oc; (* Enter signature in persistent table so that imported_unit() will also return its crc *) @@ -758,7 +778,8 @@ let save_signature_with_imports sg modname filename imports = ps_sig = sg; ps_comps = comps; ps_crcs = crcs; - ps_filename = filename } in + ps_filename = filename; + ps_flags = flags } in Hashtbl.add persistent_structures modname ps; Consistbl.set crc_units modname crc filename with exn -> @@ -793,3 +814,7 @@ let report_error ppf = function "@[The files %s@ and %s@ \ make inconsistent assumptions@ over interface %s@]" source1 source2 name + | Need_recursive_types(import, export) -> + fprintf ppf + "@[Unit %s imports from %s, which uses recursive types.@ %s@]" + import export "The compilation flag -rectypes is required" diff --git a/typing/env.mli b/typing/env.mli index b8c5dbaf..e61df31e 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: env.mli,v 1.30 2005/08/13 20:59:37 doligez Exp $ *) +(* $Id: env.mli,v 1.31 2006/06/26 09:38:06 garrigue Exp $ *) (* Environment handling *) @@ -128,6 +128,7 @@ type error = | Corrupted_interface of string | Illegal_renaming of string * string | Inconsistent_import of string * string * string + | Need_recursive_types of string * string exception Error of error diff --git a/typing/includeclass.ml b/typing/includeclass.ml index 63f54e57..452e7276 100644 --- a/typing/includeclass.ml +++ b/typing/includeclass.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: includeclass.ml,v 1.7 2000/03/06 22:11:57 weis Exp $ *) +(* $Id: includeclass.ml,v 1.8 2006/04/05 02:28:13 garrigue Exp $ *) (* Inclusion checks for the class language *) @@ -78,14 +78,17 @@ let include_err ppf = | CM_Non_mutable_value lab -> fprintf ppf "@[The non-mutable instance variable %s cannot become mutable@]" lab + | CM_Non_concrete_value lab -> + fprintf ppf + "@[The virtual instance variable %s cannot become concrete@]" lab | CM_Missing_value lab -> fprintf ppf "@[The first class type has no instance variable %s@]" lab | CM_Missing_method lab -> fprintf ppf "@[The first class type has no method %s@]" lab | CM_Hide_public lab -> fprintf ppf "@[The public method %s cannot be hidden@]" lab - | CM_Hide_virtual lab -> - fprintf ppf "@[The virtual method %s cannot be hidden@]" lab + | CM_Hide_virtual (k, lab) -> + fprintf ppf "@[The virtual %s %s cannot be hidden@]" k lab | CM_Public_method lab -> fprintf ppf "@[The public method %s cannot become private" lab | CM_Virtual_method lab -> diff --git a/typing/includemod.ml b/typing/includemod.ml index 7451899d..e356d95f 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: includemod.ml,v 1.37.2.1 2006/06/23 01:22:26 garrigue Exp $ *) +(* $Id: includemod.ml,v 1.38 2006/09/20 11:14:37 doligez Exp $ *) (* Inclusion checks for the module language *) diff --git a/typing/includemod.mli b/typing/includemod.mli index 25521c12..1ea68be9 100644 --- a/typing/includemod.mli +++ b/typing/includemod.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: includemod.mli,v 1.12.42.1 2006/06/23 01:22:27 garrigue Exp $ *) +(* $Id: includemod.mli,v 1.13 2006/09/20 11:14:37 doligez Exp $ *) (* Inclusion checks for the module language *) diff --git a/typing/oprint.ml b/typing/oprint.ml index 51a2b77b..a08c67f2 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: oprint.ml,v 1.22 2005/03/23 03:08:37 garrigue Exp $ *) +(* $Id: oprint.ml,v 1.24 2006/04/21 06:17:30 garrigue Exp $ *) open Format open Outcometree @@ -250,6 +250,7 @@ let out_type = ref print_out_type let type_parameter ppf (ty, (co, cn)) = fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "") + (*if co then if cn then "!" else "+" else if cn then "-" else "?"*) ty let print_out_class_params ppf = @@ -291,8 +292,10 @@ and print_out_class_sig_item ppf = fprintf ppf "@[<2>method %s%s%s :@ %a@]" (if priv then "private " else "") (if virt then "virtual " else "") name !out_type ty - | Ocsg_value (name, mut, ty) -> - fprintf ppf "@[<2>val %s%s :@ %a@]" (if mut then "mutable " else "") + | Ocsg_value (name, mut, vr, ty) -> + fprintf ppf "@[<2>val %s%s%s :@ %a@]" + (if mut then "mutable " else "") + (if vr then "virtual " else "") name !out_type ty let out_class_type = ref print_out_class_type diff --git a/typing/outcometree.mli b/typing/outcometree.mli index 79c426de..63b53caf 100644 --- a/typing/outcometree.mli +++ b/typing/outcometree.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: outcometree.mli,v 1.14 2005/03/23 03:08:37 garrigue Exp $ *) +(* $Id: outcometree.mli,v 1.15 2006/04/05 02:28:13 garrigue Exp $ *) (* Module [Outcometree]: results displayed by the toplevel *) @@ -71,7 +71,7 @@ type out_class_type = and out_class_sig_item = | Ocsg_constraint of out_type * out_type | Ocsg_method of string * bool * bool * out_type - | Ocsg_value of string * bool * out_type + | Ocsg_value of string * bool * bool * out_type type out_module_type = | Omty_abstract diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 48046179..5772facd 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: parmatch.ml,v 1.70 2005/03/24 17:20:54 doligez Exp $ *) +(* $Id: parmatch.ml,v 1.71 2006/09/21 14:54:54 maranget Exp $ *) (* Detection of partial matches and unused match cases. *) @@ -29,6 +29,9 @@ let make_pat desc ty tenv = let omega = make_pat Tpat_any Ctype.none Env.empty +let extra_pat = + make_pat (Tpat_var (Ident.create "+")) Ctype.none Env.empty + let rec omegas i = if i <= 0 then [] else omega :: omegas (i-1) @@ -625,8 +628,7 @@ let full_match closing env = match env with | _ -> fatal_error "Parmatch.full_match" let extendable_match env = match env with -| ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _},_)},_)::_ -> false -| ({pat_desc = Tpat_construct(c,_)} as p,_) :: _ -> +| ({pat_desc = Tpat_construct({cstr_tag=(Cstr_constant _|Cstr_block _)},_)} as p,_) :: _ -> let path = get_type_path p.pat_type p.pat_env in not (Path.same path Predef.path_bool || @@ -635,6 +637,16 @@ let extendable_match env = match env with | _ -> false +let should_extend ext env = match ext with +| None -> false +| Some ext -> match env with + | ({pat_desc = + Tpat_construct({cstr_tag=(Cstr_constant _|Cstr_block _)},_)} as p,_) + :: _ -> + let path = get_type_path p.pat_type p.pat_env in + Path.same path ext + | _ -> false + (* complement constructor tags *) let complete_tags nconsts nconstrs tags = let seen_const = Array.create nconsts false @@ -705,7 +717,7 @@ let build_other_constant proj make first next p env = in the first column of env *) -let build_other env = match env with +let build_other ext env = match env with | ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _} as c,_)},_) ::_ -> make_pat @@ -716,11 +728,16 @@ let build_other env = match env with [])) Ctype.none Env.empty | ({pat_desc = Tpat_construct (_,_)} as p,_) :: _ -> - let get_tag = function - | {pat_desc = Tpat_construct (c,_)} -> c.cstr_tag - | _ -> fatal_error "Parmatch.get_tag" in - let all_tags = List.map (fun (p,_) -> get_tag p) env in - pat_of_constrs p (complete_constrs p all_tags) + begin match ext with + | Some ext when Path.same ext (get_type_path p.pat_type p.pat_env) -> + extra_pat + | _ -> + let get_tag = function + | {pat_desc = Tpat_construct (c,_)} -> c.cstr_tag + | _ -> fatal_error "Parmatch.get_tag" in + let all_tags = List.map (fun (p,_) -> get_tag p) env in + pat_of_constrs p (complete_constrs p all_tags) + end | ({pat_desc = Tpat_variant(_,_,row)} as p,_) :: _ -> let tags = List.map @@ -879,62 +896,6 @@ let rec satisfiable pss qs = match pss with let q0 = discr_pat q pss in satisfiable (filter_one q0 pss) (simple_match_args q0 q @ qs) -(* - Like satisfiable, looking for a matching value with an extra constructor. - That is, look for the situation where adding one constructor - would NOT yield a non-exhaustive matching. - *) - -let relevant_location loc r = match r with - | None -> None - | Some rloc -> - if rloc = Location.none then - Some loc - else - r - -let rec satisfiable_extra some pss qs = match qs with -| [] -> if pss = [] then some else None -| {pat_desc = Tpat_or(q1,q2,_)}::qs -> - let r1 = satisfiable_extra some pss (q1::qs) in - begin match r1 with - | Some _ -> r1 - | None -> satisfiable_extra some pss (q2::qs) - end -| {pat_desc = Tpat_alias(q,_)}::qs -> - satisfiable_extra some pss (q::qs) -| {pat_desc = (Tpat_any | Tpat_var(_))} as q::qs -> - let q0 = discr_pat omega pss in - let r = - match filter_all q0 pss with - (* first column of pss is made of variables only *) - | [] -> satisfiable_extra some (filter_extra pss) qs - | constrs -> - if extendable_match constrs then - let rloc = - satisfiable_extra (Some q.pat_loc) (filter_extra pss) qs in - match rloc with - | Some loc -> rloc - | None -> try_many_extra some qs constrs - else - try_many_extra some qs constrs in - relevant_location q.pat_loc r -| q::qs -> - let q0 = discr_pat q pss in - relevant_location - q.pat_loc - (satisfiable_extra - some (filter_one q0 pss) (simple_match_args q0 q @ qs)) - -and try_many_extra some qs = function - | [] -> None - | (p,pss)::rem -> - let rloc = satisfiable_extra some pss (simple_match_args p omega @ qs) in - match rloc with - | Some _ -> rloc - | None -> try_many_extra some qs rem - - (* Now another satisfiable function that additionally supplies an example of a matching value. @@ -954,7 +915,7 @@ let rec try_many f = function | r -> r end -let rec exhaust pss n = match pss with +let rec exhaust ext pss n = match pss with | [] -> Rsome (omegas n) | []::_ -> Rnone | pss -> @@ -962,7 +923,7 @@ let rec exhaust pss n = match pss with begin match filter_all q0 pss with (* first column of pss is made of variables only *) | [] -> - begin match exhaust (filter_extra pss) (n-1) with + begin match exhaust ext (filter_extra pss) (n-1) with | Rsome r -> Rsome (q0::r) | r -> r end @@ -972,11 +933,13 @@ let rec exhaust pss n = match pss with Rnone else match - exhaust pss (List.length (simple_match_args p omega) + n - 1) + exhaust + ext pss (List.length (simple_match_args p omega) + n - 1) with | Rsome r -> Rsome (set_args p r) | r -> r in - if full_match false constrs + if + full_match false constrs && not (should_extend ext constrs) then try_many try_non_omega constrs else @@ -988,12 +951,12 @@ let rec exhaust pss n = match pss with * D exhaustive => pss exhaustive * D non-exhaustive => we have a non-filtered value *) - let r = exhaust (filter_extra pss) (n-1) in + let r = exhaust ext (filter_extra pss) (n-1) in match r with | Rnone -> Rnone | Rsome r -> try - Rsome (build_other constrs::r) + Rsome (build_other ext constrs::r) with (* cannot occur, since constructors don't make a full signature *) | Empty -> fatal_error "Parmatch.exhaust" @@ -1419,10 +1382,7 @@ and lubs ps qs = match ps,qs with (******************************) -(* Entry points *) -(* - Variant closing *) -(* - Partial match *) -(* - Unused match case *) +(* Exported variant closing *) (******************************) (* Apply pressure to variants *) @@ -1431,9 +1391,13 @@ let pressure_variants tdefs patl = let pss = List.map (fun p -> [p;omega]) patl in ignore (pressure_variants (Some tdefs) pss) +(*****************************) +(* Utilities for diagnostics *) +(*****************************) + (* - Build up a working pattern matrix. - - Forget about guarded patterns + Build up a working pattern matrix by forgetting + about guarded patterns *) let has_guard act = match act.exp_desc with @@ -1450,13 +1414,17 @@ let rec initial_matrix = function else [pat] :: initial_matrix rem +(******************************************) +(* Look for a row that matches some value *) +(******************************************) + (* - All the following ``*_all'' functions - check whether a given value [v] is matched by some row in pss. - They are used to whether the exhaustiveness exemple is - matched by a guarded clause + Useful for seeing if the example of + non-matched value can indeed be matched + (by a guarded clause) *) - + + exception NoGuard @@ -1513,12 +1481,12 @@ let check_partial_all v casel = with | NoGuard -> None -let check_partial loc casel = - if Warnings.is_active (Warnings.Partial_match "") then begin - let pss = initial_matrix casel in - let pss = get_mins le_pats pss in - match pss with - | [] -> +(************************) +(* Exhaustiveness check *) +(************************) + +let do_check_partial loc casel pss = match pss with +| [] -> (* This can occur - For empty matches generated by ocamlp4 (no warning) @@ -1527,66 +1495,134 @@ let check_partial loc casel = Then match MUST be considered non-exhaustive, otherwise compilation of PM is broken. *) - begin match casel with - | [] -> () - | _ -> Location.prerr_warning loc Warnings.All_clauses_guarded - end ; - Partial - | ps::_ -> - begin match exhaust pss (List.length ps) with - | Rnone -> Total - | Rsome [v] -> - let errmsg = - try - let buf = Buffer.create 16 in - let fmt = formatter_of_buffer buf in - top_pretty fmt v; - begin match check_partial_all v casel with - | None -> () - | Some _ -> - (* This is ``Some l'', where l is the location of + begin match casel with + | [] -> () + | _ -> Location.prerr_warning loc Warnings.All_clauses_guarded + end ; + Partial +| ps::_ -> + begin match exhaust None pss (List.length ps) with + | Rnone -> Total + | Rsome [v] -> + let errmsg = + try + let buf = Buffer.create 16 in + let fmt = formatter_of_buffer buf in + top_pretty fmt v; + begin match check_partial_all v casel with + | None -> () + | Some _ -> + (* This is 'Some loc', where loc is the location of a possibly matching clause. - I forget about l, because printing two locations + Forget about loc, because printing two locations is a pain in the top-level *) - Buffer.add_string buf - "\n(However, some guarded clause may match this value.)" - end ; - Buffer.contents buf - with _ -> - "" in - Location.prerr_warning loc (Warnings.Partial_match errmsg) ; - Partial - | _ -> - fatal_error "Parmatch.check_partial" - end - end else - Partial + Buffer.add_string buf + "\n(However, some guarded clause may match this value.)" + end ; + Buffer.contents buf + with _ -> + "" in + Location.prerr_warning loc (Warnings.Partial_match errmsg) ; + Partial + | _ -> + fatal_error "Parmatch.check_partial" + end + + +(*****************) +(* Fragile check *) +(*****************) +(* Collect all data types in a pattern *) -let location_of_clause = function - pat :: _ -> pat.pat_loc - | _ -> fatal_error "Parmatch.location_of_clause" +let rec add_path path = function + | [] -> [path] + | x::rem as paths -> + if Path.same path x then paths + else x::add_path path rem -let seen_pat q pss = [q]::pss +let extendable_path path = + not + (Path.same path Predef.path_bool || + Path.same path Predef.path_list || + Path.same path Predef.path_option) -(* Extra check - Will this clause match if someone adds a constructor somewhere +let rec collect_paths_from_pat r p = match p.pat_desc with +| Tpat_construct({cstr_tag=(Cstr_constant _|Cstr_block _)},ps) -> + let path = get_type_path p.pat_type p.pat_env in + List.fold_left + collect_paths_from_pat + (if extendable_path path then add_path path r else r) + ps +| Tpat_any|Tpat_var _|Tpat_constant _| Tpat_variant (_,None,_) -> r +| Tpat_tuple ps | Tpat_array ps +| Tpat_construct ({cstr_tag=Cstr_exception _}, ps)-> + List.fold_left collect_paths_from_pat r ps +| Tpat_record lps -> + List.fold_left + (fun r (_,p) -> collect_paths_from_pat r p) + r lps +| Tpat_variant (_, Some p, _) | Tpat_alias (p,_) -> collect_paths_from_pat r p +| Tpat_or (p1,p2,_) -> + collect_paths_from_pat (collect_paths_from_pat r p1) p2 + + +(* + Actual fragile check + 1. Collect data types in the patterns of the match. + 2. One exhautivity check per datatype, considering that + the type is extended. *) -let warn_fragile () = Warnings.is_active (Warnings.Fragile_pat "") +let do_check_fragile loc casel pss = + let exts = + List.fold_left + (fun r (p,_) -> collect_paths_from_pat r p) + [] casel in + match exts with + | [] -> () + | _ -> match pss with + | [] -> () + | ps::_ -> + List.iter + (fun ext -> + match exhaust (Some ext) pss (List.length ps) with + | Rnone -> + Location.prerr_warning + loc + (Warnings.Fragile_match (Path.name ext)) + | Rsome _ -> ()) + exts + + +(********************************) +(* Exported exhustiveness check *) +(********************************) -let check_used_extra pss qs = - if warn_fragile () then begin - match satisfiable_extra None pss qs with - | Some location -> - Location.prerr_warning - location - (Warnings.Fragile_pat "") - | None -> () - end +(* + Fragile check is performed when required and + on exhaustive matches only. +*) + +let check_partial loc casel = + if Warnings.is_active (Warnings.Partial_match "") then begin + let pss = initial_matrix casel in + let pss = get_mins le_pats pss in + let total = do_check_partial loc casel pss in + if + total = Total && Warnings.is_active (Warnings.Fragile_match "") + then begin + do_check_fragile loc casel pss + end ; + total + end else + Partial + + +(********************************) +(* Exported unused clause check *) +(********************************) - - let check_unused tdefs casel = if Warnings.is_active Warnings.Unused_match then let rec do_rec pref = function @@ -1600,23 +1636,20 @@ let check_unused tdefs casel = match r with | Unused -> Location.prerr_warning - (location_of_clause qs) Warnings.Unused_match + q.pat_loc Warnings.Unused_match | Upartial ps -> List.iter (fun p -> Location.prerr_warning p.pat_loc Warnings.Unused_pat) ps - | Used -> - check_used_extra pss qs + | Used -> () with e -> assert false end ; if has_guard act then do_rec pref rem else - do_rec (seen_pat q pref) rem in - - + do_rec ([q]::pref) rem in do_rec [] casel diff --git a/typing/predef.ml b/typing/predef.ml index a678e19f..0afb493e 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: predef.ml,v 1.29 2004/01/04 14:32:34 doligez Exp $ *) +(* $Id: predef.ml,v 1.31 2006/10/24 20:54:58 weis Exp $ *) (* Predefined type constructors (with special typing rules in typecore) *) @@ -28,7 +28,7 @@ and ident_unit = Ident.create "unit" and ident_exn = Ident.create "exn" and ident_array = Ident.create "array" and ident_list = Ident.create "list" -and ident_format4 = Ident.create "format4" +and ident_format6 = Ident.create "format6" and ident_option = Ident.create "option" and ident_nativeint = Ident.create "nativeint" and ident_int32 = Ident.create "int32" @@ -44,7 +44,7 @@ and path_unit = Pident ident_unit and path_exn = Pident ident_exn and path_array = Pident ident_array and path_list = Pident ident_list -and path_format4 = Pident ident_format4 +and path_format6 = Pident ident_format6 and path_option = Pident ident_option and path_nativeint = Pident ident_nativeint and path_int32 = Pident ident_int32 @@ -124,13 +124,19 @@ let build_initial_env add_type add_exception empty_env = Type_variant(["[]", []; "::", [tvar; type_list tvar]], Public); type_manifest = None; type_variance = [true, false, false]} - and decl_format4 = - {type_params = [newgenvar(); newgenvar(); newgenvar(); newgenvar()]; - type_arity = 4; + and decl_format6 = + {type_params = [ + newgenvar(); newgenvar(); newgenvar(); + newgenvar(); newgenvar(); newgenvar(); + ]; + type_arity = 6; type_kind = Type_abstract; type_manifest = None; - type_variance = [true, true, true; true, true, true; - true, true, true; true, true, true]} + type_variance = [ + true, true, true; true, true, true; + true, true, true; true, true, true; + true, true, true; true, true, true; + ]} and decl_option = let tvar = newgenvar() in {type_params = [tvar]; @@ -167,7 +173,7 @@ let build_initial_env add_type add_exception empty_env = add_type ident_nativeint decl_abstr ( add_type ident_lazy_t decl_lazy_t ( add_type ident_option decl_option ( - add_type ident_format4 decl_format4 ( + add_type ident_format6 decl_format6 ( add_type ident_list decl_list ( add_type ident_array decl_array ( add_type ident_exn decl_exn ( diff --git a/typing/predef.mli b/typing/predef.mli index 02cc54b8..34ff2a7e 100644 --- a/typing/predef.mli +++ b/typing/predef.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: predef.mli,v 1.14 2003/07/05 11:13:24 xleroy Exp $ *) +(* $Id: predef.mli,v 1.16 2006/10/24 20:54:58 weis Exp $ *) (* Predefined type constructors (with special typing rules in typecore) *) @@ -40,7 +40,7 @@ val path_unit: Path.t val path_exn: Path.t val path_array: Path.t val path_list: Path.t -val path_format4: Path.t +val path_format6: Path.t val path_option: Path.t val path_nativeint: Path.t val path_int32: Path.t diff --git a/typing/printtyp.ml b/typing/printtyp.ml index f9b97d01..5bc6c62a 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: printtyp.ml,v 1.139.2.3 2006/02/09 01:19:26 garrigue Exp $ *) +(* $Id: printtyp.ml,v 1.143 2007/02/16 11:18:54 garrigue Exp $ *) (* Printing functions *) @@ -130,7 +130,7 @@ and raw_type_desc ppf = function fprintf ppf "@[Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f (safe_kind_repr [] k) raw_type t1 raw_type t2 - | Tnil -> fprintf ppf "Tnil" + | Tnil -> fprintf ppf "Tnil" | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t | Tsubst t -> fprintf ppf "@[<1>Tsubst@,%a@]" raw_type t | Tunivar -> fprintf ppf "Tunivar" @@ -180,7 +180,7 @@ let reset_names () = names := []; name_counter := 0 let new_name () = let name = if !name_counter < 26 - then String.make 1 (Char.chr(97 + !name_counter)) + then String.make 1 (Char.chr(97 + !name_counter)) else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^ string_of_int(!name_counter / 26) in incr name_counter; @@ -195,7 +195,7 @@ let name_of_type t = let check_name_of_type t = ignore(name_of_type t) let non_gen_mark sch ty = - if sch && ty.desc = Tvar && ty.level <> generic_level then "_" else "" + if sch && ty.desc = Tvar && ty.level <> generic_level then "_" else "" let print_name_of_type sch ppf t = fprintf ppf "'%s%s" (non_gen_mark sch t) (name_of_type t) @@ -456,7 +456,7 @@ and type_sch ppf ty = typexp true 0 ppf ty and type_scheme ppf ty = reset_and_mark_loops ty; typexp true 0 ppf ty (* Maxence *) -let type_scheme_max ?(b_reset_names=true) ppf ty = +let type_scheme_max ?(b_reset_names=true) ppf ty = if b_reset_names then reset_names () ; typexp true 0 ppf ty (* Fin Maxence *) @@ -515,7 +515,7 @@ let rec tree_of_type_decl id decl = in mark_loops ty; Some ty - in + in begin match decl.type_kind with | Type_abstract -> () | Type_variant ([], _) -> () @@ -564,7 +564,7 @@ let rec tree_of_type_decl id decl = begin match ty_manifest with | None -> (Otyp_abstract, Public) | Some ty -> - tree_of_typexp false ty, + tree_of_typexp false ty, (if has_constr_row ty then Private else Public) end | Type_variant(cstrs, priv) -> @@ -589,7 +589,7 @@ let type_declaration id ppf decl = (* Print an exception declaration *) let tree_of_exception_declaration id decl = - reset_and_mark_loops_list decl; + reset_and_mark_loops_list decl; let tyl = tree_of_typlist false decl in Osig_exception (Ident.name id, tyl) @@ -650,7 +650,7 @@ let rec prepare_class_type params = function Ctype.flatten_fields (Ctype.object_fields sign.cty_self) in List.iter (fun met -> mark_loops (method_type met)) fields; - Vars.iter (fun _ (_, ty) -> mark_loops ty) sign.cty_vars + Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.cty_vars | Tcty_fun (_, ty, cty) -> mark_loops ty; prepare_class_type params cty @@ -682,13 +682,15 @@ let rec tree_of_class_type sch params = csil (tree_of_constraints params) in let all_vars = - Vars.fold (fun l (m, t) all -> (l, m, t) :: all) sign.cty_vars [] in + Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.cty_vars [] + in (* Consequence of PR#3607: order of Map.fold has changed! *) let all_vars = List.rev all_vars in let csil = List.fold_left - (fun csil (l, m, t) -> - Ocsg_value (l, m = Mutable, tree_of_typexp sch t) :: csil) + (fun csil (l, m, v, t) -> + Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp sch t) + :: csil) csil all_vars in let csil = @@ -763,7 +765,9 @@ let tree_of_cltype_declaration id cl rs = List.exists (fun (lab, _, ty) -> not (lab = dummy_method || Concr.mem lab sign.cty_concr)) - fields in + fields + || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.cty_vars false + in Osig_class_type (virt, Ident.name id, @@ -816,7 +820,7 @@ and tree_of_modtype_declaration id decl = in Osig_modtype (Ident.name id, mty) -let tree_of_module id mty rs = +let tree_of_module id mty rs = Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs) let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty) @@ -922,16 +926,16 @@ let explanation unif t3 t4 ppf = "@,Self type cannot be unified with a closed object type" | Tfield (l, _, _, _), Tfield (l', _, _, _) when l = l' -> fprintf ppf "@,Types for method %s are incompatible" l - | Tfield (l, _, _, _), _ -> - fprintf ppf - "@,@[Only the first object type has a method %s@]" l | _, Tfield (l, _, _, _) -> fprintf ppf - "@,@[Only the second object type has a method %s@]" l + "@,@[The first object type has no method %s@]" l + | Tfield (l, _, _, _), _ -> + fprintf ppf + "@,@[The second object type has no method %s@]" l | Tvariant row1, Tvariant row2 -> let row1 = row_repr row1 and row2 = row_repr row2 in begin match - row1.row_fields, row1.row_closed, row2.row_fields, row1.row_closed with + row1.row_fields, row1.row_closed, row2.row_fields, row2.row_closed with | [], true, [], true -> fprintf ppf "@,These two variant types have no intersection" | [], true, fields, _ -> diff --git a/typing/printtyp.mli b/typing/printtyp.mli index ff4f318e..2e2f7189 100644 --- a/typing/printtyp.mli +++ b/typing/printtyp.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: printtyp.mli,v 1.26.10.1 2006/01/05 15:59:35 doligez Exp $ *) +(* $Id: printtyp.mli,v 1.27 2006/04/16 23:28:22 doligez Exp $ *) (* Printing functions *) diff --git a/typing/stypes.ml b/typing/stypes.ml index 36efe447..e9e96b9e 100644 --- a/typing/stypes.ml +++ b/typing/stypes.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: stypes.ml,v 1.8.20.1 2006/01/05 15:59:35 doligez Exp $ *) +(* $Id: stypes.ml,v 1.9 2006/04/16 23:28:22 doligez Exp $ *) (* Recording and dumping (partial) type information *) diff --git a/typing/subst.ml b/typing/subst.ml index 40960f8c..bd54a334 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: subst.ml,v 1.48.4.1 2005/12/05 13:18:43 garrigue Exp $ *) +(* $Id: subst.ml,v 1.50 2006/04/05 02:28:13 garrigue Exp $ *) (* Substitutions *) @@ -178,7 +178,8 @@ let type_declaration s decl = let class_signature s sign = { cty_self = typexp s sign.cty_self; - cty_vars = Vars.map (function (m, t) -> (m, typexp s t)) sign.cty_vars; + cty_vars = + Vars.map (function (m, v, t) -> (m, v, typexp s t)) sign.cty_vars; cty_concr = sign.cty_concr; cty_inher = List.map (fun (p, tl) -> (type_path s p, List.map (typexp s) tl)) diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 47ac189d..4cac45b4 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typeclass.ml,v 1.85.2.1 2006/02/21 00:58:10 garrigue Exp $ *) +(* $Id: typeclass.ml,v 1.89 2006/12/27 14:41:23 garrigue Exp $ *) open Misc open Parsetree @@ -24,7 +24,7 @@ open Format type error = Unconsistent_constraint of (type_expr * type_expr) list - | Method_type_mismatch of string * (type_expr * type_expr) list + | Field_type_mismatch of string * string * (type_expr * type_expr) list | Structure_expected of class_type | Cannot_apply of class_type | Apply_wrong_label of label @@ -36,7 +36,7 @@ type error = | Unbound_class_type_2 of Longident.t | Abbrev_type_clash of type_expr * type_expr * type_expr | Constructor_type_mismatch of string * (type_expr * type_expr) list - | Virtual_class of bool * string list + | Virtual_class of bool * string list * string list | Parameter_arity_mismatch of Longident.t * int * int | Parameter_mismatch of (type_expr * type_expr) list | Bad_parameters of Ident.t * type_expr * type_expr @@ -49,6 +49,7 @@ type error = | Non_collapsable_conjunction of Ident.t * Types.class_declaration * (type_expr * type_expr) list | Final_self_clash of (type_expr * type_expr) list + | Mutability_mismatch of string * mutable_flag exception Error of Location.t * error @@ -56,7 +57,7 @@ exception Error of Location.t * error (**********************) (* Useful constants *) (**********************) - + (* Self type have a dummy private method, thus preventing it to become @@ -74,7 +75,7 @@ let unbound_class = Path.Pident (Ident.create "") (************************************) (* Some operations on class types *) (************************************) - + (* Fully expand the head of a class type *) let rec scrape_class_type = @@ -90,7 +91,7 @@ let rec generalize_class_type = generalize_class_type cty | Tcty_signature {cty_self = sty; cty_vars = vars; cty_inher = inher} -> Ctype.generalize sty; - Vars.iter (fun _ (_, ty) -> Ctype.generalize ty) vars; + Vars.iter (fun _ (_, _, ty) -> Ctype.generalize ty) vars; List.iter (fun (_,tl) -> List.iter Ctype.generalize tl) inher | Tcty_fun (_, ty, cty) -> Ctype.generalize ty; @@ -152,7 +153,7 @@ let rec closed_class_type = | Tcty_signature sign -> Ctype.closed_schema sign.cty_self && - Vars.fold (fun _ (_, ty) cc -> Ctype.closed_schema ty && cc) + Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema ty && cc) sign.cty_vars true | Tcty_fun (_, ty, cty) -> @@ -172,7 +173,7 @@ let rec limited_generalize rv = limited_generalize rv cty | Tcty_signature sign -> Ctype.limited_generalize rv sign.cty_self; - Vars.iter (fun _ (_, ty) -> Ctype.limited_generalize rv ty) + Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty) sign.cty_vars; List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl) sign.cty_inher @@ -189,7 +190,7 @@ let rc node = (***********************************) (* Primitives for typing classes *) (***********************************) - + (* Enter a value in the method environment only *) let enter_met_env lab kind ty val_env met_env par_env = @@ -201,11 +202,25 @@ let enter_met_env lab kind ty val_env met_env par_env = Env.add_value id {val_type = ty; val_kind = Val_unbound} par_env) (* Enter an instance variable in the environment *) -let enter_val cl_num vars lab mut ty val_env met_env par_env = - let (id, val_env, met_env, par_env) as result = - enter_met_env lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env +let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc = + let (id, virt) = + try + let (id, mut', virt', ty') = Vars.find lab !vars in + if mut' <> mut then raise (Error(loc, Mutability_mismatch(lab, mut))); + Ctype.unify val_env (Ctype.instance ty) (Ctype.instance ty'); + (if not inh then Some id else None), + (if virt' = Concrete then virt' else virt) + with + Ctype.Unify tr -> + raise (Error(loc, Field_type_mismatch("instance variable", lab, tr))) + | Not_found -> None, virt + in + let (id, _, _, _) as result = + match id with Some id -> (id, val_env, met_env, par_env) + | None -> + enter_met_env lab (Val_ivar (mut, cl_num)) ty val_env met_env par_env in - vars := Vars.add lab (id, mut, ty) !vars; + vars := Vars.add lab (id, mut, virt, ty) !vars; result let inheritance self_type env concr_meths warn_meths loc parent = @@ -218,19 +233,25 @@ let inheritance self_type env concr_meths warn_meths loc parent = with Ctype.Unify trace -> match trace with _::_::_::({desc = Tfield(n, _, _, _)}, _)::rem -> - raise(Error(loc, Method_type_mismatch (n, rem))) + raise(Error(loc, Field_type_mismatch ("method", n, rem))) | _ -> assert false end; let overridings = Concr.inter cl_sig.cty_concr warn_meths in if not (Concr.is_empty overridings) then begin + let cname = + match parent with + Tcty_constr (p, _, _) -> Path.name p + | _ -> "inherited" + in Location.prerr_warning loc - (Warnings.Method_override (Concr.elements overridings)) + (Warnings.Method_override (cname :: Concr.elements overridings)) end; let concr_meths = Concr.union cl_sig.cty_concr concr_meths in - let warn_meths = Concr.union cl_sig.cty_concr warn_meths in + (* No need to warn about overriding of inherited methods! *) + (* let warn_meths = Concr.union cl_sig.cty_concr warn_meths in *) (cl_sig, concr_meths, warn_meths) @@ -243,7 +264,7 @@ let virtual_method val_env meths self_type lab priv sty loc = in let ty = transl_simple_type val_env false sty in try Ctype.unify val_env ty ty' with Ctype.Unify trace -> - raise(Error(loc, Method_type_mismatch (lab, trace))) + raise(Error(loc, Field_type_mismatch ("method", lab, trace))) let delayed_meth_specs = ref [] @@ -253,7 +274,7 @@ let declare_method val_env meths self_type lab priv sty loc = in let unif ty = try Ctype.unify val_env ty ty' with Ctype.Unify trace -> - raise(Error(loc, Method_type_mismatch (lab, trace))) + raise(Error(loc, Field_type_mismatch ("method", lab, trace))) in match sty.ptyp_desc, priv with Ptyp_poly ([],sty), Public -> @@ -279,6 +300,15 @@ let make_method cl_num expr = (*******************************) +let add_val env loc lab (mut, virt, ty) val_sig = + let virt = + try + let (mut', virt', ty') = Vars.find lab val_sig in + if virt' = Concrete then virt' else virt + with Not_found -> virt + in + Vars.add lab (mut, virt, ty) val_sig + let rec class_type_field env self_type meths (val_sig, concr_meths, inher) = function Pctf_inher sparent -> @@ -293,25 +323,12 @@ let rec class_type_field env self_type meths (val_sig, concr_meths, inher) = parent in let val_sig = - Vars.fold - (fun lab (mut, ty) val_sig -> Vars.add lab (mut, ty) val_sig) - cl_sig.cty_vars val_sig - in + Vars.fold (add_val env sparent.pcty_loc) cl_sig.cty_vars val_sig in (val_sig, concr_meths, inher) - | Pctf_val (lab, mut, sty_opt, loc) -> - let (mut, ty) = - match sty_opt with - None -> - let (mut', ty) = - try Vars.find lab val_sig with Not_found -> - raise(Error(loc, Unbound_val lab)) - in - (if mut = Mutable then mut' else Immutable), ty - | Some sty -> - mut, transl_simple_type env false sty - in - (Vars.add lab (mut, ty) val_sig, concr_meths, inher) + | Pctf_val (lab, mut, virt, sty, loc) -> + let ty = transl_simple_type env false sty in + (add_val env loc lab (mut, virt, ty) val_sig, concr_meths, inher) | Pctf_virt (lab, priv, sty, loc) -> declare_method env meths self_type lab priv sty loc; @@ -328,7 +345,7 @@ let rec class_type_field env self_type meths (val_sig, concr_meths, inher) = and class_signature env sty sign = let meths = ref Meths.empty in let self_type = transl_simple_type env false sty in - + (* Check that the binder is a correct type, and introduce a dummy method preventing self type from being closed. *) let dummy_obj = Ctype.newvar () in @@ -339,14 +356,14 @@ and class_signature env sty sign = with Ctype.Unify _ -> raise(Error(sty.ptyp_loc, Pattern_type_clash self_type)) end; - + (* Class type fields *) let (val_sig, concr_meths, inher) = List.fold_left (class_type_field env self_type meths) (Vars.empty, Concr.empty, []) sign in - + {cty_self = self_type; cty_vars = val_sig; cty_concr = concr_meths; @@ -378,7 +395,7 @@ and class_type env scty = | Pcty_signature (sty, sign) -> Tcty_signature (class_signature env sty sign) - + | Pcty_fun (l, sty, scty) -> let ty = transl_simple_type env false sty in let cty = class_type env scty in @@ -397,7 +414,7 @@ module StringSet = Set.Make(struct type t = string let compare = compare end) let rec class_field cl_num self_type meths vars (val_env, met_env, par_env, fields, concr_meths, warn_meths, - inh_vals, inher) = + warn_vals, inher) = function Pcf_inher (sparent, super) -> let parent = class_expr cl_num val_env par_env sparent in @@ -411,25 +428,30 @@ let rec class_field cl_num self_type meths vars parent.cl_type in (* Variables *) - let (val_env, met_env, par_env, inh_vars, inh_vals) = + let (val_env, met_env, par_env, inh_vars, warn_vals) = Vars.fold - (fun lab (mut, ty) (val_env, met_env, par_env, inh_vars, inh_vals) -> + (fun lab info (val_env, met_env, par_env, inh_vars, warn_vals) -> + let mut, vr, ty = info in let (id, val_env, met_env, par_env) = - enter_val cl_num vars lab mut ty val_env met_env par_env + enter_val cl_num vars true lab mut vr ty val_env met_env par_env + sparent.pcl_loc in - if StringSet.mem lab inh_vals then - Location.prerr_warning sparent.pcl_loc - (Warnings.Hide_instance_variable lab); - (val_env, met_env, par_env, (lab, id) :: inh_vars, - StringSet.add lab inh_vals)) - cl_sig.cty_vars (val_env, met_env, par_env, [], inh_vals) + let warn_vals = + if vr = Virtual then warn_vals else + if StringSet.mem lab warn_vals then + (Location.prerr_warning sparent.pcl_loc + (Warnings.Instance_variable_override lab); warn_vals) + else StringSet.add lab warn_vals + in + (val_env, met_env, par_env, (lab, id) :: inh_vars, warn_vals)) + cl_sig.cty_vars (val_env, met_env, par_env, [], warn_vals) in (* Inherited concrete methods *) - let inh_meths = + let inh_meths = Concr.fold (fun lab rem -> (lab, Ident.create lab)::rem) cl_sig.cty_concr [] in - (* Super *) + (* Super *) let (val_env, met_env, par_env) = match super with None -> @@ -443,11 +465,26 @@ let rec class_field cl_num self_type meths vars in (val_env, met_env, par_env, lazy(Cf_inher (parent, inh_vars, inh_meths))::fields, - concr_meths, warn_meths, inh_vals, inher) + concr_meths, warn_meths, warn_vals, inher) + + | Pcf_valvirt (lab, mut, styp, loc) -> + if !Clflags.principal then Ctype.begin_def (); + let ty = Typetexp.transl_simple_type val_env false styp in + if !Clflags.principal then begin + Ctype.end_def (); + Ctype.generalize_structure ty + end; + let (id, val_env, met_env', par_env) = + enter_val cl_num vars false lab mut Virtual ty + val_env met_env par_env loc + in + (val_env, met_env', par_env, + lazy(Cf_val (lab, id, None, met_env' == met_env)) :: fields, + concr_meths, warn_meths, StringSet.remove lab warn_vals, inher) | Pcf_val (lab, mut, sexp, loc) -> - if StringSet.mem lab inh_vals then - Location.prerr_warning loc (Warnings.Hide_instance_variable lab); + if StringSet.mem lab warn_vals then + Location.prerr_warning loc (Warnings.Instance_variable_override lab); if !Clflags.principal then Ctype.begin_def (); let exp = try type_exp val_env sexp with Ctype.Unify [(ty, _)] -> @@ -457,19 +494,23 @@ let rec class_field cl_num self_type meths vars Ctype.end_def (); Ctype.generalize_structure exp.exp_type end; - let (id, val_env, met_env, par_env) = - enter_val cl_num vars lab mut exp.exp_type val_env met_env par_env + let (id, val_env, met_env', par_env) = + enter_val cl_num vars false lab mut Concrete exp.exp_type + val_env met_env par_env loc in - (val_env, met_env, par_env, lazy(Cf_val (lab, id, exp)) :: fields, - concr_meths, warn_meths, inh_vals, inher) + (val_env, met_env', par_env, + lazy(Cf_val (lab, id, Some exp, met_env' == met_env)) :: fields, + concr_meths, warn_meths, StringSet.add lab warn_vals, inher) | Pcf_virt (lab, priv, sty, loc) -> virtual_method val_env meths self_type lab priv sty loc; let warn_meths = Concr.remove lab warn_meths in (val_env, met_env, par_env, fields, concr_meths, warn_meths, - inh_vals, inher) + warn_vals, inher) | Pcf_meth (lab, priv, expr, loc) -> + if Concr.mem lab warn_meths then + Location.prerr_warning loc (Warnings.Method_override [lab]); let (_, ty) = Ctype.filter_self_method val_env lab priv meths self_type in @@ -493,7 +534,7 @@ let rec class_field cl_num self_type meths vars end | _ -> assert false with Ctype.Unify trace -> - raise(Error(loc, Method_type_mismatch (lab, trace))) + raise(Error(loc, Field_type_mismatch ("method", lab, trace))) end; let meth_expr = make_method cl_num expr in (* backup variables for Pexp_override *) @@ -510,12 +551,12 @@ let rec class_field cl_num self_type meths vars Cf_meth (lab, texp) end in (val_env, met_env, par_env, field::fields, - Concr.add lab concr_meths, Concr.add lab warn_meths, inh_vals, inher) + Concr.add lab concr_meths, Concr.add lab warn_meths, warn_vals, inher) | Pcf_cstr (sty, sty', loc) -> type_constraint val_env sty sty' loc; (val_env, met_env, par_env, fields, concr_meths, warn_meths, - inh_vals, inher) + warn_vals, inher) | Pcf_let (rec_flag, sdefs, loc) -> let (defs, val_env) = @@ -545,7 +586,7 @@ let rec class_field cl_num self_type meths vars ([], met_env, par_env) in (val_env, met_env, par_env, lazy(Cf_let(rec_flag, defs, vals))::fields, - concr_meths, warn_meths, inh_vals, inher) + concr_meths, warn_meths, warn_vals, inher) | Pcf_init expr -> let expr = make_method cl_num expr in @@ -562,7 +603,7 @@ let rec class_field cl_num self_type meths vars Cf_init texp end in (val_env, met_env, par_env, field::fields, - concr_meths, warn_meths, inh_vals, inher) + concr_meths, warn_meths, warn_vals, inher) and class_structure cl_num final val_env met_env loc (spat, str) = (* Environment for substructures *) @@ -616,7 +657,7 @@ and class_structure cl_num final val_env met_env loc (spat, str) = Ctype.unify val_env self_type (Ctype.newvar ()); let sign = {cty_self = public_self; - cty_vars = Vars.map (function (id, mut, ty) -> (mut, ty)) !vars; + cty_vars = Vars.map (fun (id, mut, vr, ty) -> (mut, vr, ty)) !vars; cty_concr = concr_meths; cty_inher = inher} in let methods = get_methods self_type in @@ -628,7 +669,11 @@ and class_structure cl_num final val_env met_env loc (spat, str) = be modified after this point *) Ctype.close_object self_type; let mets = virtual_methods {sign with cty_self = self_type} in - if mets <> [] then raise(Error(loc, Virtual_class(true, mets))); + let vals = + Vars.fold + (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l) + sign.cty_vars [] in + if mets <> [] then raise(Error(loc, Virtual_class(true, mets, vals))); let self_methods = List.fold_right (fun (lab,kind,ty) rem -> @@ -694,7 +739,7 @@ and class_expr cl_num val_env met_env scl = try Ctype.unify val_env ty' ty with Ctype.Unify trace -> raise(Error(loc, Parameter_mismatch trace))) tyl params; - let cl = + let cl = rc {cl_desc = Tclass_ident path; cl_loc = scl.pcl_loc; cl_type = clty'; @@ -974,7 +1019,7 @@ let rec initial_env define_class approx let arity = List.length (fst cl.pci_params) in let (obj_params, obj_ty, env) = temp_abbrev env obj_id arity in let (cl_params, cl_ty, env) = temp_abbrev env cl_id arity in - + (* Temporary type for the class constructor *) let constr_type = approx cl.pci_expr in if !Clflags.principal then Ctype.generalize_spine constr_type; @@ -1021,7 +1066,7 @@ let class_infos define_class kind reset_type_variables (); Ctype.begin_class_def (); - + (* Introduce class parameters *) let params = try @@ -1033,7 +1078,7 @@ let class_infos define_class kind (* Allow self coercions (only for class declarations) *) let coercion_locs = ref [] in - + (* Type the class expression *) let (expr, typ) = try @@ -1045,9 +1090,9 @@ let class_infos define_class kind with exn -> Typecore.self_coercion := []; raise exn in - + Ctype.end_def (); - + let sty = Ctype.self_type typ in (* Generalize the row variable *) @@ -1077,7 +1122,7 @@ let class_infos define_class kind Abbrev_type_clash (constr, ty, Ctype.expand_head env constr))) end end; - + (* Check the other temporary abbreviation (#-type) *) begin let (cl_params', cl_type) = Ctype.instance_class params typ in @@ -1134,9 +1179,14 @@ let class_infos define_class kind in if cl.pci_virt = Concrete then begin - match virtual_methods (Ctype.signature_of_class_type typ) with - [] -> () - | mets -> raise(Error(cl.pci_loc, Virtual_class(define_class, mets))) + let sign = Ctype.signature_of_class_type typ in + let mets = virtual_methods sign in + let vals = + Vars.fold + (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l) + sign.cty_vars [] in + if mets <> [] || vals <> [] then + raise(Error(cl.pci_loc, Virtual_class(true, mets, vals))); end; (* Misc. *) @@ -1147,7 +1197,7 @@ let class_infos define_class kind in List.map (function (lab, _, _) -> lab) fields in - + (* Final definitions *) let (params', typ') = Ctype.instance_class params typ in let cltydef = @@ -1378,7 +1428,7 @@ let approx_class sdecl = let self' = { ptyp_desc = Ptyp_any; ptyp_loc = Location.none } in let clty' = - { pcty_desc = Pcty_signature(self', []); + { pcty_desc = Pcty_signature(self', []); pcty_loc = sdecl.pci_expr.pcty_loc } in { sdecl with pci_expr = clty' } @@ -1399,10 +1449,10 @@ let report_error ppf = function Printtyp.report_unification_error ppf trace (fun ppf -> fprintf ppf "Type") (fun ppf -> fprintf ppf "is not compatible with type") - | Method_type_mismatch (m, trace) -> + | Field_type_mismatch (k, m, trace) -> Printtyp.report_unification_error ppf trace (function ppf -> - fprintf ppf "The method %s@ has type" m) + fprintf ppf "The %s %s@ has type" k m) (function ppf -> fprintf ppf "but is expected to have type") | Structure_expected clty -> @@ -1450,15 +1500,20 @@ let report_error ppf = function fprintf ppf "The expression \"new %s\" has type" c) (function ppf -> fprintf ppf "but is used with type") - | Virtual_class (cl, mets) -> + | Virtual_class (cl, mets, vals) -> let print_mets ppf mets = List.iter (function met -> fprintf ppf "@ %s" met) mets in let cl_mark = if cl then "" else " type" in + let missings = + match mets, vals with + [], _ -> "variables" + | _, [] -> "methods" + | _ -> "methods and variables" + in fprintf ppf - "@[This class%s should be virtual@ \ - @[<2>The following methods are undefined :%a@] - @]" - cl_mark print_mets mets + "@[This class%s should be virtual.@ \ + @[<2>The following %s are undefined :%a@]@]" + cl_mark missings print_mets (mets @ vals) | Parameter_arity_mismatch(lid, expected, provided) -> fprintf ppf "@[The class constructor %a@ expects %i type argument(s),@ \ @@ -1484,7 +1539,7 @@ let report_error ppf = function let print_common ppf kind ty0 real lab ty = let ty1 = if real then ty0 else Btype.newgenty(Tobject(ty0, ref None)) in - Printtyp.reset_and_mark_loops_list [ty; ty1]; + Printtyp.mark_loops ty1; fprintf ppf "The %s %s@ has type@;<1 2>%a@ where@ %a@ is unbound" kind lab Printtyp.type_expr ty Printtyp.type_expr ty0 @@ -1531,3 +1586,10 @@ let report_error ppf = function fprintf ppf "This object is expected to have type") (function ppf -> fprintf ppf "but has actually type") + | Mutability_mismatch (lab, mut) -> + let mut1, mut2 = + if mut = Immutable then "mutable", "immutable" + else "immutable", "mutable" in + fprintf ppf + "@[The instance variable is %s,@ it cannot be redefined as %s@]" + mut1 mut2 diff --git a/typing/typeclass.mli b/typing/typeclass.mli index 81760965..f85f6ece 100644 --- a/typing/typeclass.mli +++ b/typing/typeclass.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typeclass.mli,v 1.18 2003/12/01 00:32:11 garrigue Exp $ *) +(* $Id: typeclass.mli,v 1.19 2006/04/05 02:28:13 garrigue Exp $ *) open Asttypes open Types @@ -49,7 +49,7 @@ val virtual_methods: Types.class_signature -> label list type error = Unconsistent_constraint of (type_expr * type_expr) list - | Method_type_mismatch of string * (type_expr * type_expr) list + | Field_type_mismatch of string * string * (type_expr * type_expr) list | Structure_expected of class_type | Cannot_apply of class_type | Apply_wrong_label of label @@ -61,7 +61,7 @@ type error = | Unbound_class_type_2 of Longident.t | Abbrev_type_clash of type_expr * type_expr * type_expr | Constructor_type_mismatch of string * (type_expr * type_expr) list - | Virtual_class of bool * string list + | Virtual_class of bool * string list * string list | Parameter_arity_mismatch of Longident.t * int * int | Parameter_mismatch of (type_expr * type_expr) list | Bad_parameters of Ident.t * type_expr * type_expr @@ -74,6 +74,7 @@ type error = | Non_collapsable_conjunction of Ident.t * Types.class_declaration * (type_expr * type_expr) list | Final_self_clash of (type_expr * type_expr) list + | Mutability_mismatch of string * mutable_flag exception Error of Location.t * error diff --git a/typing/typecore.ml b/typing/typecore.ml index d38c3a22..4d8ac807 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typecore.ml,v 1.176.2.5 2006/05/01 01:16:28 garrigue Exp $ *) +(* $Id: typecore.ml,v 1.190 2007/02/27 04:54:05 garrigue Exp $ *) (* Typechecking for the core language *) @@ -26,6 +26,7 @@ type error = Unbound_value of Longident.t | Unbound_constructor of Longident.t | Unbound_label of Longident.t + | Polymorphic_label of Longident.t | Constructor_arity_mismatch of Longident.t * int * int | Label_mismatch of Longident.t * (type_expr * type_expr) list | Pattern_type_clash of (type_expr * type_expr) list @@ -449,7 +450,9 @@ let rec type_pat env sp = Env.lookup_label lid env with Not_found -> raise(Error(sp.ppat_loc, Unbound_label lid)) in - let (_, ty_arg, ty_res) = instance_label false label in + begin_def (); + let (vars, ty_arg, ty_res) = instance_label false label in + if vars = [] then end_def (); begin try unify env ty_res ty with Unify trace -> @@ -457,6 +460,16 @@ let rec type_pat env sp = end; let arg = type_pat env sarg in unify_pat env arg ty_arg; + if vars <> [] then begin + end_def (); + generalize ty_arg; + List.iter generalize vars; + let instantiated tv = + let tv = expand_head env tv in + tv.desc <> Tvar || tv.level <> generic_level in + if List.exists instantiated vars then + raise (Error(sp.ppat_loc, Polymorphic_label lid)) + end; (label, arg) in rp { @@ -611,11 +624,11 @@ let rec is_nonexpansive exp = List.for_all (function Cf_meth _ -> true - | Cf_val (_,_,e) -> incr count; is_nonexpansive e + | Cf_val (_,_,e,_) -> incr count; is_nonexpansive_opt e | Cf_init e -> is_nonexpansive e | Cf_inher _ | Cf_let _ -> false) fields && - Vars.fold (fun _ (mut,_) b -> decr count; b && mut = Immutable) + Vars.fold (fun _ (mut,_,_) b -> decr count; b && mut = Immutable) vars true && !count = 0 | _ -> false @@ -627,6 +640,11 @@ and is_nonexpansive_opt = function (* Typing of printf formats. (Handling of * modifiers contributed by Thorsten Ohl.) *) +external string_to_format : + string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" +external format_to_string : + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string = "%identity" + let type_format loc fmt = let ty_arrow gty ty = newty (Tarrow ("", instance gty, ty, Cok)) in @@ -661,14 +679,15 @@ let type_format loc fmt = let ty_input = newvar () and ty_result = newvar () - and ty_aresult = newvar () in + and ty_aresult = newvar () + and ty_uresult = newvar () in let meta = ref 0 in let rec scan_format i = if i >= len then if !meta = 0 - then ty_aresult, ty_result + then ty_uresult, ty_result else incomplete_format fmt else match fmt.[i] with | '%' -> scan_opts i (i + 1) @@ -694,8 +713,8 @@ let type_format loc fmt = if j >= len then incomplete_format fmt else match fmt.[j] with | '*' -> - let ty_aresult, ty_result = scan i (j + 1) in - ty_aresult, ty_arrow Predef.type_int ty_result + let ty_uresult, ty_result = scan i (j + 1) in + ty_uresult, ty_arrow Predef.type_int ty_result | '-' | '+' -> scan_decimal_string scan i (j + 1) | _ -> scan_decimal_string scan i j and scan_precision i j = @@ -705,8 +724,8 @@ let type_format loc fmt = | _ -> scan_conversion i j and conversion j ty_arg = - let ty_aresult, ty_result = scan_format (j + 1) in - ty_aresult, + let ty_uresult, ty_result = scan_format (j + 1) in + ty_uresult, if skip then ty_result else ty_arrow ty_arg ty_result and scan_conversion i j = @@ -725,8 +744,13 @@ let type_format loc fmt = | 'a' -> let ty_arg = newvar () in let ty_a = ty_arrow ty_input (ty_arrow ty_arg ty_aresult) in - let ty_aresult, ty_result = conversion j ty_arg in - ty_aresult, ty_arrow ty_a ty_result + let ty_uresult, ty_result = conversion j ty_arg in + ty_uresult, ty_arrow ty_a ty_result + | 'r' -> + let ty_arg = newvar () in + let ty_r = ty_arrow ty_input ty_arg in + let ty_uresult, ty_result = conversion j ty_arg in + ty_arrow ty_r ty_uresult, ty_result | 't' -> conversion j (ty_arrow ty_input ty_aresult) | 'l' | 'n' | 'L' as c -> let j = j + 1 in @@ -745,21 +769,25 @@ let type_format loc fmt = let j = j + 1 in if j >= len then incomplete_format fmt else let sj = - Printf.sub_format incomplete_format bad_conversion c fmt j in - let sfmt = String.sub fmt j (sj - j - 1) in + Printf.CamlinternalPr.Tformat.sub_format + (fun fmt -> incomplete_format (format_to_string fmt)) + (fun fmt -> bad_conversion (format_to_string fmt)) + c (string_to_format fmt) j in + let sfmt = String.sub fmt j (sj - 2 - j) in let ty_sfmt = type_in_format sfmt in begin match c with - | '{' -> conversion sj ty_sfmt + | '{' -> conversion (sj - 1) ty_sfmt | _ -> incr meta; conversion (j - 1) ty_sfmt end | ')' when !meta > 0 -> decr meta; scan_format (j + 1) | c -> bad_conversion fmt i c in scan_flags i j in - let ty_ares, ty_res = scan_format 0 in + let ty_ureader, ty_args = scan_format 0 in newty - (Tconstr(Predef.path_format4, - [ty_res; ty_input; ty_ares; ty_result], - ref Mnil)) in + (Tconstr + (Predef.path_format6, + [ty_args; ty_input; ty_aresult; ty_ureader; ty_uresult; ty_result], + ref Mnil)) in type_in_format fmt @@ -842,11 +870,15 @@ let check_univars env kind exp ty_expected vars = Less_general(kind, [ty, ty; ty_expected, ty_expected]))) (* Check that a type is not a function *) -let check_partial_application env exp = - match expand_head env exp.exp_type with - | {desc = Tarrow _} -> +let check_application_result env statement exp = + match (expand_head env exp.exp_type).desc with + | Tarrow _ -> Location.prerr_warning exp.exp_loc Warnings.Partial_application - | _ -> () + | Tvar -> () + | Tconstr (p, _, _) when Path.same p Predef.path_unit -> () + | _ -> + if statement then + Location.prerr_warning exp.exp_loc Warnings.Statement_type (* Hack to allow coercion of self. Will clean-up later. *) let self_coercion = ref ([] : (Path.t * Location.t list ref) list) @@ -1355,7 +1387,7 @@ let rec type_exp env sexp = (path_self, _) -> let type_override (lab, snewval) = begin try - let (id, _, ty) = Vars.find lab !vars in + let (id, _, _, ty) = Vars.find lab !vars in (Path.Pident id, type_expect env snewval (instance ty)) with Not_found -> @@ -1619,7 +1651,7 @@ and type_application env funct sargs = else begin may_warn sarg0.pexp_loc (Warnings.Not_principal "using an optional argument here"); - Some (fun () -> option_some (type_argument env sarg0 + Some (fun () -> option_some (type_argument env sarg0 (extract_option_type env ty))) end with Not_found -> @@ -1659,7 +1691,7 @@ and type_application env funct sargs = | Tarrow _ -> Location.prerr_warning exp.exp_loc Warnings.Partial_application | Tvar -> - add_delayed_check (fun () -> check_partial_application env exp) + add_delayed_check (fun () -> check_application_result env false exp) | _ -> () end; ([Some exp, Required], ty_res) @@ -1717,7 +1749,7 @@ and type_expect ?in_function env sexp ty_expected = exp_type = (* Terrible hack for format strings *) begin match (repr (expand_head env ty_expected)).desc with - Tconstr(path, _, _) when Path.same path Predef.path_format4 -> + Tconstr(path, _, _) when Path.same path Predef.path_format6 -> type_format sexp.pexp_loc s | _ -> instance Predef.type_string end; @@ -1799,6 +1831,14 @@ and type_expect ?in_function env sexp ty_expected = exp_loc = sexp.pexp_loc; exp_type = newty (Tarrow(l, ty_arg, ty_res, Cok)); exp_env = env } + | Pexp_when(scond, sbody) -> + let cond = type_expect env scond (instance Predef.type_bool) in + let body = type_expect env sbody ty_expected in + re { + exp_desc = Texp_when(cond, body); + exp_loc = sexp.pexp_loc; + exp_type = body.exp_type; + exp_env = env } | Pexp_poly(sbody, sty) -> let ty = match sty with None -> repr ty_expected @@ -1846,7 +1886,7 @@ and type_statement env sexp = | Tvar when ty.level > tv.level -> Location.prerr_warning sexp.pexp_loc Warnings.Nonreturning_statement | Tvar -> - add_delayed_check (fun () -> check_partial_application env exp) + add_delayed_check (fun () -> check_application_result env true exp) | _ -> Location.prerr_warning sexp.pexp_loc Warnings.Statement_type end; @@ -1980,6 +2020,9 @@ let report_error ppf = function fprintf ppf "Unbound constructor %a" longident lid | Unbound_label lid -> fprintf ppf "Unbound record field label %a" longident lid + | Polymorphic_label lid -> + fprintf ppf "@[The record field label %a is polymorphic.@ %s@]" + longident lid "You cannot instantiate it in a pattern." | Constructor_arity_mismatch(lid, expected, provided) -> fprintf ppf "@[The constructor %a@ expects %i argument(s),@ \ diff --git a/typing/typecore.mli b/typing/typecore.mli index 62437a84..24aea7d4 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typecore.mli,v 1.37 2005/03/04 14:51:31 weis Exp $ *) +(* $Id: typecore.mli,v 1.39 2007/02/27 03:46:19 garrigue Exp $ *) (* Type inference for the core language *) @@ -38,7 +38,8 @@ val type_self_pattern: string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern -> Typedtree.pattern * (Ident.t * type_expr) Meths.t ref * - (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref * + (Ident.t * Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) + Vars.t ref * Env.t * Env.t * Env.t val type_expect: ?in_function:(Location.t * type_expr) -> @@ -63,6 +64,7 @@ type error = Unbound_value of Longident.t | Unbound_constructor of Longident.t | Unbound_label of Longident.t + | Polymorphic_label of Longident.t | Constructor_arity_mismatch of Longident.t * int * int | Label_mismatch of Longident.t * (type_expr * type_expr) list | Pattern_type_clash of (type_expr * type_expr) list diff --git a/typing/typedecl.ml b/typing/typedecl.ml index eede9b4e..0346d7b1 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typedecl.ml,v 1.75 2005/08/16 00:48:56 garrigue Exp $ *) +(* $Id: typedecl.ml,v 1.76.6.1 2007/03/05 01:24:10 garrigue Exp $ *) (**** Typing of type definitions ****) @@ -585,6 +585,20 @@ let compute_variance_decls env cldecls = {cltydef with clty_variance = variance})) decls cldecls +(* Force recursion to go through id for private types*) +let name_recursion sdecl id decl = + match decl with + { type_kind = Type_abstract; type_manifest = Some ty } + when sdecl.ptype_kind = Ptype_private -> + let ty = Ctype.repr ty in + let ty' = Btype.newty2 ty.level ty.desc in + if Ctype.deep_occur ty ty' then + let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in + Btype.link_type ty (Btype.newty2 ty.level td); + {decl with type_manifest = Some ty'} + else decl + | _ -> decl + (* Translate a set of mutually recursive type declarations *) let transl_type_decl env name_sdecl_list = (* Add dummy types for fixed rows *) @@ -646,6 +660,11 @@ let transl_type_decl env name_sdecl_list = List.iter2 (check_abbrev newenv) name_sdecl_list decls; (* Check that constraints are enforced *) List.iter2 (check_constraints newenv) name_sdecl_list decls; + (* Name recursion *) + let decls = + List.map2 (fun (_, sdecl) (id, decl) -> id, name_recursion sdecl id decl) + name_sdecl_list decls + in (* Add variances to the environment *) let required = List.map (fun (_, sdecl) -> sdecl.ptype_variance, sdecl.ptype_loc) @@ -696,7 +715,7 @@ let transl_value_decl env valdecl = (* Translate a "with" constraint -- much simplified version of transl_type_decl. *) -let transl_with_constraint env row_path sdecl = +let transl_with_constraint env id row_path sdecl = reset_type_variables(); Ctype.begin_def(); let params = @@ -732,6 +751,7 @@ let transl_with_constraint env row_path sdecl = begin match Ctype.closed_type_decl decl with None -> () | Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl))) end; + let decl = name_recursion sdecl id decl in let decl = {decl with type_variance = compute_variance_decl env false decl @@ -829,7 +849,9 @@ let report_error ppf = function let ty = Ctype.repr ty in let explain tl typ kwd lab = let ti = List.find (fun ti -> Ctype.deep_occur ty (typ ti)) tl in - Printtyp.reset_and_mark_loops_list [typ ti;ty]; + let ty0 = (* Hack to force aliasing when needed *) + Btype.newgenty (Tobject(ty, ref None)) in + Printtyp.reset_and_mark_loops_list [typ ti; ty0]; fprintf ppf ".@.@[In %s@ %s%a@;<1 -2>the variable %a is unbound@]" kwd (lab ti) Printtyp.type_expr (typ ti) Printtyp.type_expr ty diff --git a/typing/typedecl.mli b/typing/typedecl.mli index 210e17b7..9e52ec10 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typedecl.mli,v 1.29 2005/08/13 20:59:37 doligez Exp $ *) +(* $Id: typedecl.mli,v 1.30 2006/11/02 01:10:04 garrigue Exp $ *) (* Typing of type definitions and primitive definitions *) @@ -30,7 +30,8 @@ val transl_value_decl: Env.t -> Parsetree.value_description -> value_description val transl_with_constraint: - Env.t -> Path.t option -> Parsetree.type_declaration -> type_declaration + Env.t -> Ident.t -> Path.t option -> + Parsetree.type_declaration -> type_declaration val abstract_type_decl: int -> type_declaration val approx_type_decl: diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 18d400c9..d4e9e09c 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typedtree.ml,v 1.36 2003/11/25 09:20:43 garrigue Exp $ *) +(* $Id: typedtree.ml,v 1.37 2006/04/05 02:28:13 garrigue Exp $ *) (* Abstract syntax tree after typing *) @@ -106,7 +106,7 @@ and class_structure = and class_field = Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list - | Cf_val of string * Ident.t * expression + | Cf_val of string * Ident.t * expression option * bool | Cf_meth of string * expression | Cf_let of rec_flag * (pattern * expression) list * (Ident.t * expression) list @@ -140,7 +140,8 @@ and structure_item = | Tstr_recmodule of (Ident.t * module_expr) list | Tstr_modtype of Ident.t * module_type | Tstr_open of Path.t - | Tstr_class of (Ident.t * int * string list * class_expr) list + | Tstr_class of + (Ident.t * int * string list * class_expr * virtual_flag) list | Tstr_cltype of (Ident.t * cltype_declaration) list | Tstr_include of module_expr * Ident.t list diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 334a7392..981dae31 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typedtree.mli,v 1.34 2003/11/25 09:20:43 garrigue Exp $ *) +(* $Id: typedtree.mli,v 1.35 2006/04/05 02:28:13 garrigue Exp $ *) (* Abstract syntax tree after typing *) @@ -107,7 +107,8 @@ and class_structure = and class_field = Cf_inher of class_expr * (string * Ident.t) list * (string * Ident.t) list (* Inherited instance variables and concrete methods *) - | Cf_val of string * Ident.t * expression + | Cf_val of string * Ident.t * expression option * bool + (* None = virtual, true = override *) | Cf_meth of string * expression | Cf_let of rec_flag * (pattern * expression) list * (Ident.t * expression) list @@ -141,7 +142,8 @@ and structure_item = | Tstr_recmodule of (Ident.t * module_expr) list | Tstr_modtype of Ident.t * module_type | Tstr_open of Path.t - | Tstr_class of (Ident.t * int * string list * class_expr) list + | Tstr_class of + (Ident.t * int * string list * class_expr * virtual_flag) list | Tstr_cltype of (Ident.t * cltype_declaration) list | Tstr_include of module_expr * Ident.t list diff --git a/typing/typemod.ml b/typing/typemod.ml index 1396ef6e..5bd3921d 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -10,13 +10,14 @@ (* *) (***********************************************************************) -(* $Id: typemod.ml,v 1.73.2.1 2006/04/21 06:18:51 garrigue Exp $ *) +(* $Id: typemod.ml,v 1.78 2007/02/23 13:44:51 ertai Exp $ *) (* Type-checking of the module language *) open Misc open Longident open Path +open Asttypes open Parsetree open Types open Typedtree @@ -88,26 +89,27 @@ let merge_constraint initial_env loc sg lid constr = | (Tsig_type(id, decl, rs) :: rem, [s], Pwith_type ({ptype_kind = Ptype_private} as sdecl)) when Ident.name id = s -> - let decl_row = - { type_params = - List.map (fun _ -> Btype.newgenvar()) sdecl.ptype_params; - type_arity = List.length sdecl.ptype_params; - type_kind = Type_abstract; - type_manifest = None; - type_variance = - List.map (fun (c,n) -> (not n, not c, not c)) - sdecl.ptype_variance } - and id_row = Ident.create (s^"#row") in - let initial_env = Env.add_type id_row decl_row initial_env in + let decl_row = + { type_params = + List.map (fun _ -> Btype.newgenvar()) sdecl.ptype_params; + type_arity = List.length sdecl.ptype_params; + type_kind = Type_abstract; + type_manifest = None; + type_variance = + List.map (fun (c,n) -> (not n, not c, not c)) + sdecl.ptype_variance } + and id_row = Ident.create (s^"#row") in + let initial_env = Env.add_type id_row decl_row initial_env in let newdecl = Typedecl.transl_with_constraint - initial_env (Some(Pident id_row)) sdecl in + initial_env id (Some(Pident id_row)) sdecl in check_type_decl env id row_id newdecl decl rs rem; - let decl_row = {decl_row with type_params = newdecl.type_params} in + let decl_row = {decl_row with type_params = newdecl.type_params} in let rs' = if rs = Trec_first then Trec_not else rs in Tsig_type(id_row, decl_row, rs') :: Tsig_type(id, newdecl, rs) :: rem | (Tsig_type(id, decl, rs) :: rem, [s], Pwith_type sdecl) when Ident.name id = s -> - let newdecl = Typedecl.transl_with_constraint initial_env None sdecl in + let newdecl = + Typedecl.transl_with_constraint initial_env id None sdecl in check_type_decl env id row_id newdecl decl rs rem; Tsig_type(id, newdecl, rs) :: rem | (Tsig_type(id, decl, rs) :: rem, [s], Pwith_type sdecl) @@ -156,7 +158,7 @@ let approx_modtype transl_mty init_env smty = match smty.pmty_desc with Pmty_ident lid -> begin try - let (path, info) = Env.lookup_modtype lid env in + let (path, info) = Env.lookup_modtype lid env in Tmty_ident path with Not_found -> raise(Error(smty.pmty_loc, Unbound_modtype lid)) @@ -209,7 +211,7 @@ let approx_modtype transl_mty init_env smty = let sg = Subst.signature Subst.identity (extract_sig env smty.pmty_loc mty) in let newenv = Env.add_signature sg env in - sg @ approx_sig newenv srem + sg @ approx_sig newenv srem | Psig_class sdecls | Psig_class_type sdecls -> let decls = Typeclass.approx_class_declarations env sdecls in let rem = approx_sig env srem in @@ -270,7 +272,7 @@ let rec transl_modtype env smty = match smty.pmty_desc with Pmty_ident lid -> begin try - let (path, info) = Env.lookup_modtype lid env in + let (path, info) = Env.lookup_modtype lid env in Tmty_ident path with Not_found -> raise(Error(smty.pmty_loc, Unbound_modtype lid)) @@ -291,7 +293,7 @@ let rec transl_modtype env smty = merge_constraint env smty.pmty_loc sg lid sdecl) init_sg constraints in Mtype.freshen (Tmty_signature final_sg) - + and transl_signature env sg = let type_names = ref StringSet.empty and module_names = ref StringSet.empty @@ -542,7 +544,7 @@ let rec type_module anchor env smod = mod_loc = smod.pmod_loc } | _ -> raise(Error(sfunct.pmod_loc, Cannot_apply funct.mod_type)) - end + end | Pmod_constraint(sarg, smty) -> let arg = type_module anchor env sarg in let mty = transl_modtype env smty in @@ -591,7 +593,7 @@ and type_structure anchor env sstr = (fun (name, decl) -> check "type" loc type_names name) sdecls; let (decls, newenv) = Typedecl.transl_type_decl env sdecls in - let newenv' = + let newenv' = enrich_type_decls anchor decls env newenv in let (str_rem, sig_rem, final_env) = type_struct newenv' srem in (Tstr_type decls :: str_rem, @@ -668,8 +670,9 @@ and type_structure anchor env sstr = let (classes, new_env) = Typeclass.class_declarations env cl in let (str_rem, sig_rem, final_env) = type_struct new_env srem in (Tstr_class - (List.map (fun (i, _,_,_,_,_,_,_, s, m, c) -> - (i, s, m, c)) classes) :: + (List.map (fun (i, d, _,_,_,_,_,_, s, m, c) -> + let vf = if d.cty_new = None then Virtual else Concrete in + (i, s, m, c, vf)) classes) :: Tstr_cltype (List.map (fun (_,_, i, d, _,_,_,_,_,_,_) -> (i, d)) classes) :: Tstr_type @@ -828,7 +831,7 @@ let package_units objfiles cmifile modulename = let units = List.map (fun f -> - let pref = chop_extension_if_any f in + let pref = chop_extensions f in let modname = String.capitalize(Filename.basename pref) in let sg = Env.read_signature modname (pref ^ ".cmi") in if Filename.check_suffix f ".cmi" && @@ -847,7 +850,7 @@ let package_units objfiles cmifile modulename = raise(Error(Location.in_file mlifile, Interface_not_compiled mlifile)) end; let dclsig = Env.read_signature modulename cmifile in - Includemod.compunit "(obtained by packing)" sg mlifile dclsig + Includemod.compunit "(obtained by packing)" sg mlifile dclsig end else begin (* Determine imports *) let unit_names = List.map fst units in diff --git a/typing/types.ml b/typing/types.ml index a5584426..d5bafb1b 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: types.ml,v 1.25 2004/12/09 12:40:53 garrigue Exp $ *) +(* $Id: types.ml,v 1.26 2006/04/05 02:28:13 garrigue Exp $ *) (* Representation of types and declarations *) @@ -90,7 +90,8 @@ and value_kind = | Val_prim of Primitive.description (* Primitive *) | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *) | Val_self of (Ident.t * type_expr) Meths.t ref * - (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref * + (Ident.t * Asttypes.mutable_flag * + Asttypes.virtual_flag * type_expr) Vars.t ref * string * type_expr (* Self *) | Val_anc of (string * Ident.t) list * string @@ -156,7 +157,8 @@ type class_type = and class_signature = { cty_self: type_expr; - cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t; + cty_vars: + (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t; cty_concr: Concr.t; cty_inher: (Path.t * type_expr list) list } diff --git a/typing/types.mli b/typing/types.mli index d1d10862..6a0d0ca4 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: types.mli,v 1.25 2004/12/09 12:40:53 garrigue Exp $ *) +(* $Id: types.mli,v 1.26 2006/04/05 02:28:13 garrigue Exp $ *) (* Representation of types and declarations *) @@ -91,7 +91,8 @@ and value_kind = | Val_prim of Primitive.description (* Primitive *) | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *) | Val_self of (Ident.t * type_expr) Meths.t ref * - (Ident.t * Asttypes.mutable_flag * type_expr) Vars.t ref * + (Ident.t * Asttypes.mutable_flag * + Asttypes.virtual_flag * type_expr) Vars.t ref * string * type_expr (* Self *) | Val_anc of (string * Ident.t) list * string @@ -158,7 +159,8 @@ type class_type = and class_signature = { cty_self: type_expr; - cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t; + cty_vars: + (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t; cty_concr: Concr.t; cty_inher: (Path.t * type_expr list) list } diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 8c954e4f..7d60b33b 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -221,9 +221,8 @@ let rec transl_type env policy styp = row_fixed = false; row_more = newvar () } in let static = Btype.static_row row in let row = - if static then row else - { row with row_more = - if policy = Univars then new_pre_univar () else newvar () } + if static || policy <> Univars then row + else { row with row_more = new_pre_univar () } in newty (Tvariant row) | Tobject (fi, _) -> @@ -248,7 +247,7 @@ let rec transl_type env policy styp = end; ty with Not_found -> - begin_def (); + if !Clflags.principal then begin_def (); let t = newvar () in used_variables := Tbl.add alias (t, styp.ptyp_loc) !used_variables; let ty = transl_type env policy st in @@ -256,8 +255,10 @@ let rec transl_type env policy styp = let trace = swap_list trace in raise(Error(styp.ptyp_loc, Alias_type_mismatch trace)) end; - end_def (); - generalize_structure t; + if !Clflags.principal then begin + end_def (); + generalize_structure t; + end; instance t end | Ptyp_variant(fields, closed, present) -> @@ -350,13 +351,9 @@ let rec transl_type env policy styp = row_fixed = false; row_name = !name } in let static = Btype.static_row row in let row = - if static then row else - { row with row_more = - if policy = Univars then new_pre_univar () else - if policy = Fixed && not static then - raise(Error(styp.ptyp_loc, Unbound_type_variable "[..]")) - else row.row_more - } in + if static || policy <> Univars then row + else { row with row_more = new_pre_univar () } + in newty (Tvariant row) | Ptyp_poly(vars, st) -> begin_def(); diff --git a/typing/unused_var.ml b/typing/unused_var.ml index c9171479..9446f5d7 100644 --- a/typing/unused_var.ml +++ b/typing/unused_var.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: unused_var.ml,v 1.4.10.2 2005/12/28 17:27:46 doligez Exp $ *) +(* $Id: unused_var.ml,v 1.6 2006/04/05 02:28:13 garrigue Exp $ *) open Parsetree @@ -245,7 +245,7 @@ and class_field ppf tbl cf = match cf with | Pcf_inher (ce, _) -> class_expr ppf tbl ce; | Pcf_val (_, _, e, _) -> expression ppf tbl e; - | Pcf_virt _ -> () + | Pcf_virt _ | Pcf_valvirt _ -> () | Pcf_meth (_, _, e, _) -> expression ppf tbl e; | Pcf_cstr _ -> () | Pcf_let (recflag, pel, _) -> let_pel ppf tbl recflag pel None; diff --git a/typing/unused_var.mli b/typing/unused_var.mli index 6449482b..7945ef30 100644 --- a/typing/unused_var.mli +++ b/typing/unused_var.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: unused_var.mli,v 1.1.4.1 2005/11/16 16:37:20 doligez Exp $ *) +(* $Id: unused_var.mli,v 1.2 2006/01/04 16:55:50 doligez Exp $ *) val warn : Format.formatter -> Parsetree.structure -> Parsetree.structure;; (* Warn on unused variables; return the second argument. *) diff --git a/utils/ccomp.ml b/utils/ccomp.ml index 51239af5..027412b4 100644 --- a/utils/ccomp.ml +++ b/utils/ccomp.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: ccomp.ml,v 1.18 2005/03/24 17:20:54 doligez Exp $ *) +(* $Id: ccomp.ml,v 1.21 2007/02/25 14:58:21 xleroy Exp $ *) (* Compiling C files and building C libraries *) @@ -47,19 +47,6 @@ let quote_files lst = else s let compile_file name = - match Config.ccomp_type with - | "mrc" -> - let qname = Filename.quote name in - let includes = (Clflags.std_include_dir ()) @ !Clflags.include_dirs - in - let args = - Printf.sprintf " %s %s -i %s" - (String.concat " " (List.rev_map Filename.quote !Clflags.ccopts)) - (String.concat "," (List.rev_map Filename.quote includes)) - qname - in - command ("mrc " ^ args ^ " -o " ^ qname ^ ".x") - | "cc" | "msvc" -> command (Printf.sprintf "%s -c %s %s %s %s" @@ -69,14 +56,13 @@ let compile_file name = (List.rev_map (fun dir -> "-I" ^ dir) !Clflags.include_dirs)) (Clflags.std_include_flag "-I") (Filename.quote name)) - | _ -> assert false let create_archive archive file_list = Misc.remove_file archive; let quoted_archive = Filename.quote archive in match Config.ccomp_type with "msvc" -> - command(Printf.sprintf "link /lib /nologo /debugtype:cv /out:%s %s" + command(Printf.sprintf "link /lib /nologo /out:%s %s" quoted_archive (quote_files file_list)) | _ -> let r1 = @@ -97,3 +83,30 @@ let expand_libname name = with Not_found -> libname end + +(* Handling of msvc's /link options *) + +let make_link_options optlist = + let rec split linkopts otheropts = function + | [] -> String.concat " " otheropts + ^ " /link /subsystem:console " + ^ String.concat " " linkopts + | opt :: rem -> + if String.length opt >= 5 && String.sub opt 0 5 = "/link" + then split (String.sub opt 5 (String.length opt - 5) :: linkopts) + otheropts rem + else split linkopts (opt :: otheropts) rem + in split [] [] optlist + +(* Handling of Visual C++ 2005 manifest files *) + +let merge_manifest exefile = + let manfile = exefile ^ ".manifest" in + if not (Sys.file_exists manfile) then 0 else begin + let retcode = + command (Printf.sprintf "mt -nologo -outputresource:%s -manifest %s" + (Filename.quote exefile) + (Filename.quote manfile)) in + Misc.remove_file manfile; + retcode + end diff --git a/utils/ccomp.mli b/utils/ccomp.mli index e8c6b3f6..a9103da5 100644 --- a/utils/ccomp.mli +++ b/utils/ccomp.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: ccomp.mli,v 1.9 2002/04/18 07:27:47 garrigue Exp $ *) +(* $Id: ccomp.mli,v 1.11 2006/09/23 08:51:31 xleroy Exp $ *) (* Compiling C files and building C libraries *) @@ -20,3 +20,5 @@ val compile_file: string -> int val create_archive: string -> string list -> int val expand_libname: string -> string val quote_files: string list -> string +val make_link_options: string list -> string +val merge_manifest: string -> int diff --git a/utils/config.mlbuild b/utils/config.mlbuild new file mode 100644 index 00000000..c1ba9668 --- /dev/null +++ b/utils/config.mlbuild @@ -0,0 +1,124 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: config.mlbuild,v 1.2 2007/02/07 15:47:36 ertai Exp $ *) + +(* The main OCaml version string has moved to ../VERSION *) +let version = Sys.ocaml_version + +module C = Myocamlbuild_config + +let standard_library_default = C.libdir + +let standard_library = + try + Sys.getenv "OCAMLLIB" + with Not_found -> + try + Sys.getenv "CAMLLIB" + with Not_found -> + standard_library_default + +let windows = + match Sys.os_type with + | "Win32" -> true + | _ -> false + +let sf = Printf.sprintf + +let standard_runtime = + if windows then "ocamlrun" + else C.bindir^"/ocamlrun" +let ccomp_type = C.ccomptype +let bytecomp_c_compiler = sf "%s %s %s" C.bytecc C.bytecccompopts C.sharedcccompopts +let bytecomp_c_linker = sf "%s %s" C.bytecc C.bytecclinkopts +let bytecomp_c_libraries = C.bytecclibs +let native_c_compiler = sf "%s %s" C.nativecc C.nativecccompopts +let native_c_linker = sf "%s %s" C.nativecc C.nativecclinkopts +let native_c_libraries = C.nativecclibs +let native_partial_linker = + if ccomp_type = "msvc" then "link /lib /nologo" + else sf "%s %s" C.partialld C.nativecclinkopts +let native_pack_linker = + if ccomp_type = "msvc" then "link /lib /nologo /out:" + else sf "%s %s -o " C.partialld C.nativecclinkopts +let ranlib = C.ranlibcmd +let cc_profile = C.cc_profile + +let exec_magic_number = "Caml1999X008" +and cmi_magic_number = "Caml1999I010" +and cmo_magic_number = "Caml1999O006" +and cma_magic_number = "Caml1999A007" +and cmx_magic_number = "Caml1999Y011" +and cmxa_magic_number = "Caml1999Z010" +and ast_impl_magic_number = "Caml1999M011" +and ast_intf_magic_number = "Caml1999N010" + +let load_path = ref ([] : string list) + +let interface_suffix = ref ".mli" + +let max_tag = 245 +(* This is normally the same as in obj.ml, but we have to define it + separately because it can differ when we're in the middle of a + bootstrapping phase. *) +let lazy_tag = 246 + +let max_young_wosize = 256 +let stack_threshold = 256 (* see byterun/config.h *) + +let architecture = C.arch +let model = C.model +let system = C.system + +let ext_obj = C.ext_obj +let ext_asm = C.ext_asm +let ext_lib = C.ext_lib +let ext_dll = C.ext_dll + +let default_executable_name = + match Sys.os_type with + "Unix" -> "a.out" + | "Win32" | "Cygwin" -> "camlprog.exe" + | _ -> "camlprog" + +let systhread_supported = C.systhread_support;; + +let print_config oc = + let p name valu = Printf.fprintf oc "%s: %s\n" name valu in + let p_bool name valu = Printf.fprintf oc "%s: %B\n" name valu in + p "version" version; + p "standard_library_default" standard_library_default; + p "standard_library" standard_library; + p "standard_runtime" standard_runtime; + p "ccomp_type" ccomp_type; + p "bytecomp_c_compiler" bytecomp_c_compiler; + p "bytecomp_c_linker" bytecomp_c_linker; + p "bytecomp_c_libraries" bytecomp_c_libraries; + p "native_c_compiler" native_c_compiler; + p "native_c_linker" native_c_linker; + p "native_c_libraries" native_c_libraries; + p "native_partial_linker" native_partial_linker; + p "ranlib" ranlib; + p "cc_profile" cc_profile; + p "architecture" architecture; + p "model" model; + p "system" system; + p "ext_obj" ext_obj; + p "ext_asm" ext_asm; + p "ext_lib" ext_lib; + p "ext_dll" ext_dll; + p "os_type" Sys.os_type; + p "default_executable_name" default_executable_name; + p_bool "systhread_supported" systhread_supported; + flush oc; +;; diff --git a/utils/config.mlp b/utils/config.mlp index 08ab386f..0b5e28ae 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -10,9 +10,9 @@ (* *) (***********************************************************************) -(* $Id: config.mlp,v 1.198 2005/08/01 15:51:09 xleroy Exp $ *) +(* $Id: config.mlp,v 1.201 2007/02/07 14:49:42 doligez Exp $ *) -(* The main OCaml version string has moved to stdlib/sys.ml *) +(* The main OCaml version string has moved to ../VERSION *) let version = Sys.ocaml_version let standard_library_default = "%%LIBDIR%%" @@ -43,10 +43,10 @@ let exec_magic_number = "Caml1999X008" and cmi_magic_number = "Caml1999I010" and cmo_magic_number = "Caml1999O006" and cma_magic_number = "Caml1999A007" -and cmx_magic_number = "Caml1999Y010" +and cmx_magic_number = "Caml1999Y011" and cmxa_magic_number = "Caml1999Z010" -and ast_impl_magic_number = "Caml1999M010" -and ast_intf_magic_number = "Caml1999N009" +and ast_impl_magic_number = "Caml1999M011" +and ast_intf_magic_number = "Caml1999N010" let load_path = ref ([] : string list) diff --git a/utils/misc.ml b/utils/misc.ml index 5aee6bbb..0ad0c0d7 100644 --- a/utils/misc.ml +++ b/utils/misc.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: misc.ml,v 1.34 2004/07/13 12:25:20 xleroy Exp $ *) +(* $Id: misc.ml,v 1.35 2007/02/23 13:44:51 ertai Exp $ *) (* Errors *) @@ -162,6 +162,17 @@ let no_overflow_lsl a = min_int asr 1 <= a && a <= max_int asr 1 let chop_extension_if_any fname = try Filename.chop_extension fname with Invalid_argument _ -> fname +let chop_extensions file = + let dirname = Filename.dirname file and basename = Filename.basename file in + try + let pos = String.index basename '.' in + let basename = String.sub basename 0 pos in + if Filename.is_implicit file && dirname = Filename.current_dir_name then + basename + else + Filename.concat dirname basename + with Not_found -> file + let search_substring pat str start = let rec search i j = if j >= String.length pat then i diff --git a/utils/misc.mli b/utils/misc.mli index c56d3e81..2b4f7cf4 100644 --- a/utils/misc.mli +++ b/utils/misc.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: misc.mli,v 1.25 2004/07/13 12:25:20 xleroy Exp $ *) +(* $Id: misc.mli,v 1.26 2007/02/23 13:44:51 ertai Exp $ *) (* Miscellaneous useful types and functions *) @@ -86,6 +86,13 @@ val chop_extension_if_any: string -> string (* Like Filename.chop_extension but returns the initial file name if it has no extension *) +val chop_extensions: string -> string + (* Return the given file name without its extensions. The extensions + is the longest suffix starting with a period and not including + a directory separator, [.xyz.uvw] for instance. + + Return the given name if it does not contain an extension. *) + val search_substring: string -> string -> int -> int (* [search_substring pat str start] returns the position of the first occurrence of string [pat] in string [str]. Search starts diff --git a/utils/warnings.ml b/utils/warnings.ml index bc09f0f8..27910a7d 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: warnings.ml,v 1.23.2.1 2006/02/18 04:43:27 garrigue Exp $ *) +(* $Id: warnings.ml,v 1.27 2006/09/21 14:54:54 maranget Exp $ *) (* Please keep them in alphabetical order *) @@ -18,7 +18,7 @@ type t = (* A is all *) | Comment_start (* C *) | Comment_not_end | Deprecated (* D *) - | Fragile_pat of string (* E *) + | Fragile_match of string (* E *) | Partial_application (* F *) | Labels_omitted (* L *) | Method_override of string list (* M *) @@ -26,7 +26,7 @@ type t = (* A is all *) | Statement_type (* S *) | Unused_match (* U *) | Unused_pat - | Hide_instance_variable of string (* V *) + | Instance_variable_override of string (* V *) | Illegal_backslash (* X *) | Implicit_public_methods of string list | Unerasable_optional_argument @@ -46,7 +46,7 @@ let letter = function (* 'a' is all *) | Comment_start | Comment_not_end -> 'c' | Deprecated -> 'd' - | Fragile_pat _ -> 'e' + | Fragile_match _ -> 'e' | Partial_application -> 'f' | Labels_omitted -> 'l' | Method_override _ -> 'm' @@ -54,7 +54,7 @@ let letter = function (* 'a' is all *) | Statement_type -> 's' | Unused_match | Unused_pat -> 'u' - | Hide_instance_variable _ -> 'v' + | Instance_variable_override _ -> 'v' | Illegal_backslash | Implicit_public_methods _ | Unerasable_optional_argument @@ -112,23 +112,24 @@ let message = function "this pattern-matching is not exhaustive.\n\ Here is an example of a value that is not matched:\n" ^ s | Unused_match -> "this match case is unused." - | Unused_pat -> "this pattern is unused." - | Fragile_pat "" -> - "this pattern is fragile. It would hide\n\ - the addition of new constructors to the data types it matches." - | Fragile_pat s -> - "this pattern is fragile. It would hide\n\ - the addition of new constructors to the data types it matches.\n\ - Here is an example of a more robust pattern:\n" ^ s + | Unused_pat -> "this sub-pattern is unused." + | Fragile_match "" -> + "this pattern-matching is fragile." + | Fragile_match s -> + "this pattern-matching is fragile.\n\ + It will remain exhaustive when constructors are added to type " ^ s ^ "." | Labels_omitted -> "labels were omitted in the application of this function." - | Method_override slist -> + | Method_override [lab] -> + "the method " ^ lab ^ " is overriden in the same class." + | Method_override (cname :: slist) -> String.concat " " - ("the following methods are overriden \ - by the inherited class:\n " :: slist) - | Hide_instance_variable lab -> - "this definition of an instance variable " ^ lab ^ - " hides a previously\ndefined instance variable of the same name." + ("the following methods are overriden by the class" + :: cname :: ":\n " :: slist) + | Method_override [] -> assert false + | Instance_variable_override lab -> + "the instance variable " ^ lab ^ " is overriden.\n" ^ + "The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)" | Partial_application -> "this function application is partial,\n\ maybe some arguments are missing." diff --git a/utils/warnings.mli b/utils/warnings.mli index 962dd7a9..a99ea0f8 100644 --- a/utils/warnings.mli +++ b/utils/warnings.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: warnings.mli,v 1.16 2005/09/15 03:09:26 garrigue Exp $ *) +(* $Id: warnings.mli,v 1.18 2006/09/21 14:54:54 maranget Exp $ *) open Format @@ -18,7 +18,7 @@ type t = (* A is all *) | Comment_start (* C *) | Comment_not_end | Deprecated (* D *) - | Fragile_pat of string (* E *) + | Fragile_match of string (* E *) | Partial_application (* F *) | Labels_omitted (* L *) | Method_override of string list (* M *) @@ -26,7 +26,7 @@ type t = (* A is all *) | Statement_type (* S *) | Unused_match (* U *) | Unused_pat - | Hide_instance_variable of string (* V *) + | Instance_variable_override of string (* V *) | Illegal_backslash (* X *) | Implicit_public_methods of string list | Unerasable_optional_argument diff --git a/win32caml/Makefile b/win32caml/Makefile index e7392f91..967c924f 100644 --- a/win32caml/Makefile +++ b/win32caml/Makefile @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.9 2004/06/17 07:33:44 xleroy Exp $ +# $Id: Makefile,v 1.11 2006/10/03 11:53:57 xleroy Exp $ include ../config/Makefile @@ -27,12 +27,16 @@ LIBS=$(call SYSLIB,kernel32) $(call SYSLIB,advapi32) $(call SYSLIB,gdi32) \ all: ocamlwin.exe ocamlwin.exe: $(OBJS) - $(CC) $(CFLAGS) -o ocamlwin.exe $(OBJS) $(LIBS) + $(call MKEXE,ocamlwin.exe,$(OBJS) $(LIBS) $(EXTRALIBS)) ocamlres.$(O): ocaml.rc ocaml.ico ifeq ($(TOOLCHAIN),msvc) rc ocaml.rc +ifeq ($(ARCH),amd64) + cvtres /nologo /machine:amd64 /out:$@ ocaml.res +else cvtres /nologo /machine:ix86 /out:$@ ocaml.res +endif rm -f ocaml.res endif ifeq ($(TOOLCHAIN),mingw) diff --git a/win32caml/menu.c b/win32caml/menu.c index e945e627..f09c5cc6 100644 --- a/win32caml/menu.c +++ b/win32caml/menu.c @@ -15,7 +15,7 @@ /* Began 14 Sept 2003 - watford@uiuc.edu */ /***********************************************************************/ -/* $Id: menu.c,v 1.7 2004/06/17 07:33:44 xleroy Exp $ */ +/* $Id: menu.c,v 1.8 2006/05/09 16:03:48 xleroy Exp $ */ #include #include @@ -240,7 +240,7 @@ static int CallChangeFont(HWND hwnd) strcpy(CurrentFontName, CurrentFont.lfFaceName); CurrentFontFamily = lf.lfPitchAndFamily; CurrentFontStyle = lf.lfWeight; - hwndChild = (HWND) GetWindowLong(hwndSession, DWL_USER); + hwndChild = (HWND) GetWindowLongPtr(hwndSession, DWLP_USER); SendMessage(hwndChild,WM_SETFONT,(WPARAM)ProgramParams.hFont,0); ForceRepaint(); return (1); @@ -338,7 +338,7 @@ void Undo(HWND hwnd) { HWND hEdit; - hEdit = (HWND)GetWindowLong(hwnd,DWL_USER); + hEdit = (HWND)GetWindowLongPtr(hwnd,DWLP_USER); SendMessage(hEdit,EM_UNDO,0,0); } @@ -352,7 +352,7 @@ void Undo(HWND hwnd) ------------------------------------------------------------------------*/ void ForceRepaint(void) { - HWND hwndEdit = (HWND)GetWindowLong(hwndSession,DWL_USER); + HWND hwndEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER); InvalidateRect(hwndEdit,NULL,1); } @@ -365,7 +365,7 @@ void ForceRepaint(void) ------------------------------------------------------------------------*/ static void Add_Char_To_Queue(int c) { - HWND hwndEdit = (HWND)GetWindowLong(hwndSession,DWL_USER); + HWND hwndEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER); SendMessage(hwndEdit,WM_CHAR,c,1); } @@ -386,7 +386,7 @@ void AddLineToControl(char *buf) if (*buf == 0) return; - hEditCtrl = (HWND)GetWindowLong(hwndSession,DWL_USER); + hEditCtrl = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER); GotoEOF(); @@ -419,7 +419,7 @@ void AddStringToControl(char* buf) if((*buf) == 0) return; - hEditCtrl = (HWND)GetWindowLong(hwndSession, DWL_USER); + hEditCtrl = (HWND)GetWindowLongPtr(hwndSession, DWLP_USER); GotoEOF(); SendMessage(hEditCtrl ,EM_REPLACESEL, (WPARAM)FALSE, (LPARAM)buf); @@ -521,7 +521,7 @@ static BOOL CALLBACK HistoryDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPAR static void SaveText(char *fname) { int i,len; - HWND hEdit = (HWND)GetWindowLong(hwndSession,DWL_USER); + HWND hEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER); int linesCount = SendMessage(hEdit,EM_GETLINECOUNT,0,0); FILE *f; char *buf = SafeMalloc(8192); @@ -665,7 +665,7 @@ static void Add_Clipboard_To_Queue(void) ------------------------------------------------------------------------*/ static void CopyToClipboard(HWND hwnd) { - HWND hwndEdit = (HWND)GetWindowLong(hwndSession,DWL_USER); + HWND hwndEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER); SendMessage(hwndEdit,WM_COPY,0,0); } @@ -678,7 +678,7 @@ static void CopyToClipboard(HWND hwnd) ------------------------------------------------------------------------*/ int ResetText(void) { - HWND hwndEdit = (HWND) GetWindowLong(hwndSession,DWL_USER); + HWND hwndEdit = (HWND) GetWindowLongPtr(hwndSession,DWLP_USER); TEXTRANGE cr; int len = SendMessage(hwndEdit,WM_GETTEXTLENGTH,0,0); char *tmp = malloc(len+10),*p; diff --git a/win32caml/ocaml.c b/win32caml/ocaml.c index ed5cb059..17ef689e 100644 --- a/win32caml/ocaml.c +++ b/win32caml/ocaml.c @@ -14,7 +14,7 @@ /* Began 14 Sept 2003 - watford@uiuc.edu */ /***********************************************************************/ -/* $Id: ocaml.c,v 1.8 2004/08/20 17:04:35 doligez Exp $ */ +/* $Id: ocaml.c,v 1.9 2006/05/09 16:03:48 xleroy Exp $ */ /*@@ Wedit generated application. Written Sat Jun 02 18:22:38 2001 @@header: D:\lcc\inria\inriares.h @@ -329,7 +329,7 @@ static HWND CreateMdiClient(HWND hwndparent) void GotoEOF(void) { - HWND hEdit = (HWND)GetWindowLong(hwndSession,DWL_USER); + HWND hEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER); int linesCount = SendMessage(hEdit,EM_GETLINECOUNT,0,0); int lineindex = SendMessage(hEdit,EM_LINEINDEX,linesCount-1,0); int lastLineLength = SendMessage(hEdit,EM_LINELENGTH,linesCount-1,0); @@ -348,7 +348,7 @@ Errors: ------------------------------------------------------------------------*/ void GotoPrompt(void) { - HWND hEdit = (HWND)GetWindowLong(hwndSession,DWL_USER); + HWND hEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER); int lineindex = SendMessage(hEdit,EM_LINEINDEX,LastPromptPosition.line,0)+2; SendMessage(hEdit,EM_SETSEL,lineindex,lineindex); } @@ -452,7 +452,7 @@ Errors: None void RewriteCurrentEditBuffer(void) { // get the editbox's handle - HWND hEdit = (HWND)GetWindowLong(hwndSession,DWL_USER); + HWND hEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER); // calculate what to highlight int linesCount = SendMessage(hEdit,EM_GETLINECOUNT,0,0); @@ -489,7 +489,7 @@ Errors: None void RefreshCurrentEditBuffer(void) { // get the editbox's handle - HWND hEdit = (HWND)GetWindowLong(hwndSession,DWL_USER); + HWND hEdit = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER); // get the last line index int linesCount = SendMessage(hEdit,EM_GETLINECOUNT,0,0) - 1; @@ -891,9 +891,9 @@ static LRESULT CALLBACK SubClassEdit(HWND hwnd, UINT msg, WPARAM mp1, LPARAM mp2 static void SubClassEditField(HWND hwnd) { if (lpEProc == NULL) { - lpEProc = (WNDPROC) GetWindowLong(hwnd, GWL_WNDPROC); + lpEProc = (WNDPROC) GetWindowLongPtr(hwnd, GWLP_WNDPROC); } - SetWindowLong(hwnd, GWL_WNDPROC, (DWORD) SubClassEdit); + SetWindowLongPtr(hwnd, GWLP_WNDPROC, (LONG_PTR) SubClassEdit); } /*------------------------------------------------------------------------ @@ -1241,19 +1241,19 @@ static LRESULT CALLBACK MdiChildWndProc(HWND hwnd,UINT msg,WPARAM wparam,LPARAM (HMENU) EditControls++, hInst, NULL); - SetWindowLong(hwnd, DWL_USER, (DWORD) hwndChild); + SetWindowLongPtr(hwnd, DWLP_USER, (LONG_PTR) hwndChild); SendMessage(hwndChild, WM_SETFONT, (WPARAM) ProgramParams.hFont, 0L); SendMessage(hwndChild,EM_LIMITTEXT,0xffffffff,0); SubClassEditField(hwndChild); break; // Resize the edit control case WM_SIZE: - hwndChild = (HWND) GetWindowLong(hwnd, DWL_USER); + hwndChild = (HWND) GetWindowLongPtr(hwnd, DWLP_USER); MoveWindow(hwndChild, 0, 0, LOWORD(lparam), HIWORD(lparam), TRUE); break; // Always set the focus to the edit control. case WM_SETFOCUS: - hwndChild = (HWND) GetWindowLong(hwnd, DWL_USER); + hwndChild = (HWND) GetWindowLongPtr(hwnd, DWLP_USER); SetFocus(hwndChild); break; // Repainting of the edit control about to happen. @@ -1285,7 +1285,7 @@ static LRESULT CALLBACK MdiChildWndProc(HWND hwnd,UINT msg,WPARAM wparam,LPARAM if (busy) break; - hwndChild = (HWND) GetWindowLong(hwnd, DWL_USER); + hwndChild = (HWND) GetWindowLongPtr(hwnd, DWLP_USER); // add what they wrote to the edit buffer AppendToEditBuffer(hwndChild); @@ -1308,7 +1308,7 @@ static LRESULT CALLBACK MdiChildWndProc(HWND hwnd,UINT msg,WPARAM wparam,LPARAM // has written something in its end of the pipe. case WM_TIMERTICK: /** Modified by Chris Watford 21 Sept 2003 **/ - hwndChild = (HWND) GetWindowLong(hwnd, DWL_USER); + hwndChild = (HWND) GetWindowLongPtr(hwnd, DWLP_USER); if (ReadToLineBuffer()) { @@ -1509,7 +1509,7 @@ int AddLineBuffer(void) { HWND hEditCtrl; - hEditCtrl = (HWND)GetWindowLong(hwndSession,DWL_USER); + hEditCtrl = (HWND)GetWindowLongPtr(hwndSession,DWLP_USER); return SendMessage(hEditCtrl,EM_REPLACESEL,0,(LPARAM)lineBuffer); } diff --git a/yacc/Makefile b/yacc/Makefile index 70b0479b..bd153375 100644 --- a/yacc/Makefile +++ b/yacc/Makefile @@ -10,7 +10,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.9 2004/11/27 01:04:19 doligez Exp $ +# $Id: Makefile,v 1.10 2007/02/07 14:49:42 doligez Exp $ # Makefile for the parser generator. @@ -27,10 +27,8 @@ all: ocamlyacc$(EXE) ocamlyacc$(EXE): $(OBJS) $(CC) $(CFLAGS) $(CCLINKFLAGS) -o ocamlyacc $(OBJS) -version.h : ../stdlib/sys.ml - sed -n -e 's/;;//' \ - -e '/let *ocaml_version *= */s//#define OCAML_VERSION /p' \ - <../stdlib/sys.ml >version.h +version.h : ../VERSION + echo "#define OCAML_VERSION \"`head -1 ../VERSION`\"" >version.h clean: rm -f *.o ocamlyacc$(EXE) *~ version.h diff --git a/yacc/Makefile.nt b/yacc/Makefile.nt index 2514856a..b3cfbd95 100644 --- a/yacc/Makefile.nt +++ b/yacc/Makefile.nt @@ -10,7 +10,7 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.5 2005/02/02 15:51:24 xleroy Exp $ +# $Id: Makefile.nt,v 1.9 2007/02/07 14:49:42 doligez Exp $ # Makefile for the parser generator. @@ -23,12 +23,10 @@ OBJS= closure.$(O) error.$(O) lalr.$(O) lr0.$(O) main.$(O) \ all: ocamlyacc.exe ocamlyacc.exe: $(OBJS) - $(BYTECC) $(BYTECCCOMPOPTS) -o ocamlyacc.exe $(OBJS) + $(call MKEXE,ocamlyacc.exe,$(BYTECCLINKOPTS) $(OBJS) $(EXTRALIBS)) -version.h : ../stdlib/sys.ml - sed -n -e 's/;;//' \ - -e '/let *ocaml_version *= */s//#define OCAML_VERSION /p' \ - <../stdlib/sys.ml >version.h +version.h : ../VERSION + echo "#define OCAML_VERSION \"`head -1 ../VERSION`\"" >version.h clean: rm -f *.$(O) ocamlyacc.exe *~ version.h diff --git a/yacc/main.c b/yacc/main.c index 057762f9..5d79e558 100644 --- a/yacc/main.c +++ b/yacc/main.c @@ -12,7 +12,7 @@ /* Based on public-domain code from Berkeley Yacc */ -/* $Id: main.c,v 1.19.4.1 2006/01/23 17:38:43 doligez Exp $ */ +/* $Id: main.c,v 1.20 2006/04/16 23:28:22 doligez Exp $ */ #include #include