From: Stephane Glondu Date: Fri, 17 Oct 2008 10:22:34 +0000 (+0200) Subject: Imported Upstream version 3.11.0~beta1 X-Git-Tag: archive/raspbian/4.08.1-4+rpi1~3^2~63^2~30 X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=5dfb1ce8883f4b3457ae9da5c6dd1399bf132ef1;p=ocaml.git Imported Upstream version 3.11.0~beta1 --- diff --git a/.depend b/.depend index dee02ef9..57e692f3 100644 --- a/.depend +++ b/.depend @@ -1,3 +1,11 @@ +utils/ccomp.cmi: +utils/clflags.cmi: +utils/config.cmi: +utils/consistbl.cmi: +utils/misc.cmi: +utils/tbl.cmi: +utils/terminfo.cmi: +utils/warnings.cmi: utils/ccomp.cmo: utils/misc.cmi utils/config.cmi utils/clflags.cmi \ utils/ccomp.cmi utils/ccomp.cmx: utils/misc.cmx utils/config.cmx utils/clflags.cmx \ @@ -16,8 +24,11 @@ utils/terminfo.cmo: utils/terminfo.cmi utils/terminfo.cmx: utils/terminfo.cmi utils/warnings.cmo: utils/warnings.cmi utils/warnings.cmx: utils/warnings.cmi +parsing/asttypes.cmi: parsing/lexer.cmi: parsing/parser.cmi parsing/location.cmi +parsing/linenum.cmi: parsing/location.cmi: utils/warnings.cmi +parsing/longident.cmi: parsing/parse.cmi: parsing/parsetree.cmi parsing/parser.cmi: parsing/parsetree.cmi parsing/parsetree.cmi: parsing/longident.cmi parsing/location.cmi \ @@ -52,12 +63,14 @@ parsing/printast.cmx: parsing/parsetree.cmi parsing/longident.cmx \ parsing/location.cmx parsing/asttypes.cmi parsing/printast.cmi parsing/syntaxerr.cmo: parsing/location.cmi parsing/syntaxerr.cmi parsing/syntaxerr.cmx: parsing/location.cmx parsing/syntaxerr.cmi +typing/annot.cmi: parsing/location.cmi typing/btype.cmi: typing/types.cmi typing/path.cmi parsing/asttypes.cmi typing/ctype.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi \ typing/env.cmi parsing/asttypes.cmi typing/datarepr.cmi: typing/types.cmi typing/path.cmi parsing/asttypes.cmi typing/env.cmi: typing/types.cmi typing/path.cmi parsing/longident.cmi \ - typing/ident.cmi utils/consistbl.cmi + typing/ident.cmi utils/consistbl.cmi typing/annot.cmi +typing/ident.cmi: typing/includeclass.cmi: typing/types.cmi typing/typedtree.cmi typing/env.cmi \ typing/ctype.cmi typing/includecore.cmi: typing/types.cmi typing/typedtree.cmi \ @@ -72,16 +85,17 @@ typing/parmatch.cmi: typing/types.cmi typing/typedtree.cmi \ parsing/location.cmi typing/env.cmi typing/path.cmi: typing/ident.cmi typing/predef.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi +typing/primitive.cmi: typing/printtyp.cmi: typing/types.cmi typing/path.cmi typing/outcometree.cmi \ parsing/longident.cmi typing/ident.cmi -typing/stypes.cmi: typing/typedtree.cmi parsing/location.cmi +typing/stypes.cmi: typing/typedtree.cmi parsing/location.cmi typing/annot.cmi typing/subst.cmi: typing/types.cmi typing/path.cmi typing/ident.cmi typing/typeclass.cmi: typing/types.cmi typing/typedtree.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ typing/ident.cmi typing/env.cmi typing/ctype.cmi parsing/asttypes.cmi typing/typecore.cmi: typing/types.cmi typing/typedtree.cmi typing/path.cmi \ parsing/parsetree.cmi parsing/longident.cmi parsing/location.cmi \ - typing/ident.cmi typing/env.cmi parsing/asttypes.cmi + typing/ident.cmi typing/env.cmi parsing/asttypes.cmi typing/annot.cmi typing/typedecl.cmi: typing/types.cmi typing/path.cmi parsing/parsetree.cmi \ parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ typing/env.cmi @@ -112,11 +126,13 @@ 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 \ - utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/env.cmi + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/annot.cmi \ + typing/env.cmi typing/env.cmx: typing/types.cmx utils/tbl.cmx typing/subst.cmx \ typing/predef.cmx typing/path.cmx utils/misc.cmx parsing/longident.cmx \ typing/ident.cmx typing/datarepr.cmx utils/consistbl.cmx utils/config.cmx \ - utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/env.cmi + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \ + typing/env.cmi typing/ident.cmo: typing/ident.cmi typing/ident.cmx: typing/ident.cmi typing/includeclass.cmo: typing/types.cmi typing/printtyp.cmi \ @@ -139,10 +155,10 @@ typing/includemod.cmx: typing/types.cmx typing/typedtree.cmx utils/tbl.cmx \ typing/ident.cmx typing/env.cmx typing/ctype.cmx typing/includemod.cmi typing/mtype.cmo: typing/types.cmi typing/subst.cmi typing/path.cmi \ typing/ident.cmi typing/env.cmi typing/ctype.cmi typing/btype.cmi \ - typing/mtype.cmi + parsing/asttypes.cmi typing/mtype.cmi typing/mtype.cmx: typing/types.cmx typing/subst.cmx typing/path.cmx \ typing/ident.cmx typing/env.cmx typing/ctype.cmx typing/btype.cmx \ - typing/mtype.cmi + parsing/asttypes.cmi typing/mtype.cmi typing/oprint.cmo: typing/outcometree.cmi parsing/asttypes.cmi \ typing/oprint.cmi typing/oprint.cmx: typing/outcometree.cmi parsing/asttypes.cmi \ @@ -174,9 +190,9 @@ typing/printtyp.cmx: typing/types.cmx typing/primitive.cmx typing/predef.cmx \ utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ typing/printtyp.cmi typing/stypes.cmo: typing/typedtree.cmi typing/printtyp.cmi \ - parsing/location.cmi utils/clflags.cmi typing/stypes.cmi + parsing/location.cmi utils/clflags.cmi typing/annot.cmi typing/stypes.cmi typing/stypes.cmx: typing/typedtree.cmx typing/printtyp.cmx \ - parsing/location.cmx utils/clflags.cmx typing/stypes.cmi + parsing/location.cmx utils/clflags.cmx typing/annot.cmi typing/stypes.cmi typing/subst.cmo: typing/types.cmi utils/tbl.cmi typing/path.cmi \ utils/misc.cmi typing/ident.cmi typing/btype.cmi typing/subst.cmi typing/subst.cmx: typing/types.cmx utils/tbl.cmx typing/path.cmx \ @@ -201,14 +217,14 @@ typing/typecore.cmo: utils/warnings.cmi typing/typetexp.cmi typing/types.cmi \ parsing/parsetree.cmi typing/parmatch.cmi utils/misc.cmi \ parsing/longident.cmi parsing/location.cmi typing/ident.cmi \ typing/env.cmi typing/ctype.cmi utils/clflags.cmi typing/btype.cmi \ - parsing/asttypes.cmi typing/typecore.cmi + parsing/asttypes.cmi typing/annot.cmi typing/typecore.cmi typing/typecore.cmx: utils/warnings.cmx typing/typetexp.cmx typing/types.cmx \ typing/typedtree.cmx typing/stypes.cmx typing/printtyp.cmx \ typing/primitive.cmx typing/predef.cmx typing/path.cmx \ parsing/parsetree.cmi typing/parmatch.cmx utils/misc.cmx \ parsing/longident.cmx parsing/location.cmx typing/ident.cmx \ typing/env.cmx typing/ctype.cmx utils/clflags.cmx typing/btype.cmx \ - parsing/asttypes.cmi typing/typecore.cmi + parsing/asttypes.cmi typing/annot.cmi typing/typecore.cmi typing/typedecl.cmo: typing/typetexp.cmi typing/types.cmi \ typing/typedtree.cmi typing/subst.cmi typing/printtyp.cmi \ typing/primitive.cmi typing/predef.cmi typing/path.cmi \ @@ -235,7 +251,7 @@ 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 parsing/asttypes.cmi \ + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi typing/annot.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 \ @@ -243,7 +259,7 @@ typing/typemod.cmx: typing/types.cmx typing/typedtree.cmx typing/typedecl.cmx \ parsing/parsetree.cmi typing/mtype.cmx utils/misc.cmx \ parsing/longident.cmx parsing/location.cmx typing/includemod.cmx \ typing/ident.cmx typing/env.cmx typing/ctype.cmx utils/config.cmx \ - utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi typing/annot.cmi \ typing/typemod.cmi typing/types.cmo: typing/primitive.cmi typing/path.cmi utils/misc.cmi \ typing/ident.cmi parsing/asttypes.cmi typing/types.cmi @@ -264,9 +280,12 @@ typing/unused_var.cmx: utils/warnings.cmx parsing/parsetree.cmi \ parsing/longident.cmx parsing/location.cmx parsing/asttypes.cmi \ typing/unused_var.cmi bytecomp/bytegen.cmi: bytecomp/lambda.cmi bytecomp/instruct.cmi +bytecomp/bytelibrarian.cmi: bytecomp/bytelink.cmi: bytecomp/symtable.cmi bytecomp/cmo_format.cmi bytecomp/bytepackager.cmi: typing/ident.cmi +bytecomp/bytesections.cmi: bytecomp/cmo_format.cmi: bytecomp/lambda.cmi typing/ident.cmi +bytecomp/dll.cmi: bytecomp/emitcode.cmi: bytecomp/instruct.cmi bytecomp/cmo_format.cmi bytecomp/instruct.cmi: typing/types.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi @@ -274,28 +293,31 @@ bytecomp/lambda.cmi: typing/types.cmi typing/primitive.cmi typing/path.cmi \ parsing/location.cmi typing/ident.cmi typing/env.cmi parsing/asttypes.cmi bytecomp/matching.cmi: typing/typedtree.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi +bytecomp/meta.cmi: bytecomp/printinstr.cmi: bytecomp/instruct.cmi bytecomp/printlambda.cmi: bytecomp/lambda.cmi +bytecomp/runtimedef.cmi: bytecomp/simplif.cmi: bytecomp/lambda.cmi +bytecomp/switch.cmi: bytecomp/symtable.cmi: typing/ident.cmi bytecomp/cmo_format.cmi bytecomp/translclass.cmi: typing/typedtree.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi bytecomp/translcore.cmi: typing/types.cmi typing/typedtree.cmi \ typing/primitive.cmi typing/path.cmi parsing/location.cmi \ bytecomp/lambda.cmi typing/ident.cmi parsing/asttypes.cmi -bytecomp/translmod.cmi: typing/typedtree.cmi parsing/location.cmi \ - bytecomp/lambda.cmi typing/ident.cmi +bytecomp/translmod.cmi: typing/typedtree.cmi typing/primitive.cmi \ + parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi bytecomp/translobj.cmi: bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi bytecomp/typeopt.cmi: typing/typedtree.cmi typing/path.cmi \ bytecomp/lambda.cmi -bytecomp/bytegen.cmo: typing/types.cmi bytecomp/switch.cmi \ +bytecomp/bytegen.cmo: typing/types.cmi bytecomp/switch.cmi typing/stypes.cmi \ typing/primitive.cmi utils/misc.cmi bytecomp/lambda.cmi \ bytecomp/instruct.cmi typing/ident.cmi utils/config.cmi \ - parsing/asttypes.cmi bytecomp/bytegen.cmi -bytecomp/bytegen.cmx: typing/types.cmx bytecomp/switch.cmx \ + parsing/asttypes.cmi typing/annot.cmi bytecomp/bytegen.cmi +bytecomp/bytegen.cmx: typing/types.cmx bytecomp/switch.cmx typing/stypes.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 + parsing/asttypes.cmi typing/annot.cmi bytecomp/bytegen.cmi bytecomp/bytelibrarian.cmo: utils/misc.cmi utils/config.cmi \ bytecomp/cmo_format.cmi utils/clflags.cmi bytecomp/bytelink.cmi \ bytecomp/bytelibrarian.cmi @@ -326,13 +348,13 @@ 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/emitcode.cmo: bytecomp/translmod.cmi typing/primitive.cmi \ + bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi bytecomp/lambda.cmi \ bytecomp/instruct.cmi typing/env.cmi utils/config.cmi \ bytecomp/cmo_format.cmi utils/clflags.cmi typing/btype.cmi \ parsing/asttypes.cmi bytecomp/emitcode.cmi -bytecomp/emitcode.cmx: bytecomp/translmod.cmx bytecomp/opcodes.cmx \ - utils/misc.cmx bytecomp/meta.cmx bytecomp/lambda.cmx \ +bytecomp/emitcode.cmx: bytecomp/translmod.cmx typing/primitive.cmx \ + bytecomp/opcodes.cmx utils/misc.cmx bytecomp/meta.cmx bytecomp/lambda.cmx \ bytecomp/instruct.cmx typing/env.cmx utils/config.cmx \ bytecomp/cmo_format.cmi utils/clflags.cmx typing/btype.cmx \ parsing/asttypes.cmi bytecomp/emitcode.cmi @@ -348,16 +370,22 @@ bytecomp/lambda.cmx: typing/types.cmx typing/primitive.cmx typing/path.cmx \ parsing/asttypes.cmi bytecomp/lambda.cmi bytecomp/matching.cmo: typing/types.cmi bytecomp/typeopt.cmi \ typing/typedtree.cmi bytecomp/switch.cmi bytecomp/printlambda.cmi \ - typing/primitive.cmi typing/predef.cmi typing/parmatch.cmi utils/misc.cmi \ - parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi \ - typing/btype.cmi parsing/asttypes.cmi bytecomp/matching.cmi + typing/primitive.cmi typing/predef.cmi typing/path.cmi \ + typing/parmatch.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ + utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ + bytecomp/matching.cmi bytecomp/matching.cmx: typing/types.cmx bytecomp/typeopt.cmx \ typing/typedtree.cmx bytecomp/switch.cmx bytecomp/printlambda.cmx \ - typing/primitive.cmx typing/predef.cmx typing/parmatch.cmx utils/misc.cmx \ - parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx \ - typing/btype.cmx parsing/asttypes.cmi bytecomp/matching.cmi + typing/primitive.cmx typing/predef.cmx typing/path.cmx \ + typing/parmatch.cmx utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ + utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ + bytecomp/matching.cmi bytecomp/meta.cmo: bytecomp/meta.cmi bytecomp/meta.cmx: bytecomp/meta.cmi +bytecomp/opcodes.cmo: +bytecomp/opcodes.cmx: bytecomp/printinstr.cmo: bytecomp/printlambda.cmi parsing/location.cmi \ bytecomp/lambda.cmi bytecomp/instruct.cmi typing/ident.cmi \ bytecomp/printinstr.cmi @@ -400,16 +428,16 @@ bytecomp/translclass.cmx: typing/types.cmx bytecomp/typeopt.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 \ - typing/predef.cmi typing/path.cmi utils/misc.cmi bytecomp/matching.cmi \ - parsing/location.cmi bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi \ - utils/config.cmi utils/clflags.cmi typing/btype.cmi parsing/asttypes.cmi \ - bytecomp/translcore.cmi + typing/predef.cmi typing/path.cmi typing/parmatch.cmi utils/misc.cmi \ + bytecomp/matching.cmi parsing/location.cmi bytecomp/lambda.cmi \ + typing/ident.cmi typing/env.cmi utils/config.cmi utils/clflags.cmi \ + typing/btype.cmi parsing/asttypes.cmi bytecomp/translcore.cmi bytecomp/translcore.cmx: typing/types.cmx bytecomp/typeopt.cmx \ typing/typedtree.cmx bytecomp/translobj.cmx typing/primitive.cmx \ - typing/predef.cmx typing/path.cmx utils/misc.cmx bytecomp/matching.cmx \ - parsing/location.cmx bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx \ - utils/config.cmx utils/clflags.cmx typing/btype.cmx parsing/asttypes.cmi \ - bytecomp/translcore.cmi + typing/predef.cmx typing/path.cmx typing/parmatch.cmx utils/misc.cmx \ + bytecomp/matching.cmx parsing/location.cmx bytecomp/lambda.cmx \ + typing/ident.cmx typing/env.cmx utils/config.cmx utils/clflags.cmx \ + typing/btype.cmx parsing/asttypes.cmi bytecomp/translcore.cmi bytecomp/translmod.cmo: typing/types.cmi typing/typedtree.cmi \ bytecomp/translobj.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \ typing/printtyp.cmi typing/primitive.cmi typing/predef.cmi \ @@ -439,13 +467,16 @@ bytecomp/typeopt.cmx: typing/types.cmx typing/typedtree.cmx \ bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \ parsing/asttypes.cmi bytecomp/typeopt.cmi asmcomp/asmgen.cmi: bytecomp/lambda.cmi asmcomp/cmm.cmi +asmcomp/asmlibrarian.cmi: asmcomp/asmlink.cmi: asmcomp/compilenv.cmi +asmcomp/asmpackager.cmi: asmcomp/clambda.cmi: bytecomp/lambda.cmi typing/ident.cmi \ asmcomp/debuginfo.cmi parsing/asttypes.cmi asmcomp/closure.cmi: bytecomp/lambda.cmi asmcomp/clambda.cmi asmcomp/cmm.cmi: typing/ident.cmi asmcomp/debuginfo.cmi -asmcomp/cmmgen.cmi: asmcomp/cmm.cmi asmcomp/clambda.cmi +asmcomp/cmmgen.cmi: asmcomp/compilenv.cmi asmcomp/cmm.cmi asmcomp/clambda.cmi asmcomp/codegen.cmi: asmcomp/cmm.cmi +asmcomp/coloring.cmi: asmcomp/comballoc.cmi: asmcomp/mach.cmi asmcomp/compilenv.cmi: typing/ident.cmi asmcomp/clambda.cmi asmcomp/debuginfo.cmi: parsing/location.cmi bytecomp/lambda.cmi @@ -472,22 +503,24 @@ asmcomp/spill.cmi: asmcomp/mach.cmi asmcomp/split.cmi: asmcomp/mach.cmi 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 \ - asmcomp/printcmm.cmi utils/misc.cmi asmcomp/mach.cmi asmcomp/liveness.cmi \ +asmcomp/asmgen.cmo: bytecomp/translmod.cmi asmcomp/split.cmi \ + asmcomp/spill.cmi asmcomp/selection.cmi asmcomp/scheduling.cmi \ + asmcomp/reload.cmi asmcomp/reg.cmi asmcomp/proc.cmi asmcomp/printmach.cmi \ + asmcomp/printlinear.cmi asmcomp/printcmm.cmi typing/primitive.cmi \ + utils/misc.cmi asmcomp/mach.cmi asmcomp/liveness.cmi \ asmcomp/linearize.cmi asmcomp/interf.cmi asmcomp/emitaux.cmi \ - asmcomp/emit.cmi utils/config.cmi asmcomp/comballoc.cmi \ - asmcomp/coloring.cmi asmcomp/cmmgen.cmi asmcomp/cmm.cmi \ - asmcomp/closure.cmi utils/clflags.cmi asmcomp/asmgen.cmi -asmcomp/asmgen.cmx: asmcomp/split.cmx asmcomp/spill.cmx asmcomp/selection.cmx \ - asmcomp/scheduling.cmx asmcomp/reload.cmx asmcomp/reg.cmx \ - asmcomp/proc.cmx asmcomp/printmach.cmx asmcomp/printlinear.cmx \ - asmcomp/printcmm.cmx utils/misc.cmx asmcomp/mach.cmx asmcomp/liveness.cmx \ + asmcomp/emit.cmi utils/config.cmi asmcomp/compilenv.cmi \ + asmcomp/comballoc.cmi asmcomp/coloring.cmi asmcomp/cmmgen.cmi \ + asmcomp/cmm.cmi asmcomp/closure.cmi utils/clflags.cmi asmcomp/asmgen.cmi +asmcomp/asmgen.cmx: bytecomp/translmod.cmx asmcomp/split.cmx \ + asmcomp/spill.cmx asmcomp/selection.cmx asmcomp/scheduling.cmx \ + asmcomp/reload.cmx asmcomp/reg.cmx asmcomp/proc.cmx asmcomp/printmach.cmx \ + asmcomp/printlinear.cmx asmcomp/printcmm.cmx typing/primitive.cmx \ + utils/misc.cmx asmcomp/mach.cmx asmcomp/liveness.cmx \ asmcomp/linearize.cmx asmcomp/interf.cmx asmcomp/emitaux.cmx \ - asmcomp/emit.cmx utils/config.cmx asmcomp/comballoc.cmx \ - asmcomp/coloring.cmx asmcomp/cmmgen.cmx asmcomp/cmm.cmx \ - asmcomp/closure.cmx utils/clflags.cmx asmcomp/asmgen.cmi + asmcomp/emit.cmx utils/config.cmx asmcomp/compilenv.cmx \ + asmcomp/comballoc.cmx asmcomp/coloring.cmx asmcomp/cmmgen.cmx \ + asmcomp/cmm.cmx asmcomp/closure.cmx utils/clflags.cmx asmcomp/asmgen.cmi asmcomp/asmlibrarian.cmo: utils/misc.cmi utils/config.cmi \ asmcomp/compilenv.cmi utils/clflags.cmi asmcomp/clambda.cmi \ utils/ccomp.cmi asmcomp/asmlink.cmi asmcomp/asmlibrarian.cmi @@ -657,21 +690,27 @@ asmcomp/split.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ asmcomp/split.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ asmcomp/split.cmi driver/compile.cmi: typing/env.cmi +driver/errors.cmi: +driver/main.cmi: +driver/main_args.cmi: driver/optcompile.cmi: typing/env.cmi +driver/opterrors.cmi: +driver/optmain.cmi: +driver/pparse.cmi: driver/compile.cmo: utils/warnings.cmi typing/unused_var.cmi \ typing/typemod.cmi typing/typedtree.cmi bytecomp/translmod.cmi \ - bytecomp/simplif.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \ - bytecomp/printinstr.cmi parsing/printast.cmi driver/pparse.cmi \ - parsing/parse.cmi utils/misc.cmi typing/ident.cmi typing/env.cmi \ - bytecomp/emitcode.cmi utils/config.cmi utils/clflags.cmi utils/ccomp.cmi \ - bytecomp/bytegen.cmi driver/compile.cmi + typing/stypes.cmi bytecomp/simplif.cmi typing/printtyp.cmi \ + bytecomp/printlambda.cmi bytecomp/printinstr.cmi parsing/printast.cmi \ + driver/pparse.cmi parsing/parse.cmi utils/misc.cmi parsing/location.cmi \ + typing/ident.cmi typing/env.cmi bytecomp/emitcode.cmi utils/config.cmi \ + utils/clflags.cmi utils/ccomp.cmi bytecomp/bytegen.cmi driver/compile.cmi driver/compile.cmx: utils/warnings.cmx typing/unused_var.cmx \ typing/typemod.cmx typing/typedtree.cmx bytecomp/translmod.cmx \ - bytecomp/simplif.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \ - bytecomp/printinstr.cmx parsing/printast.cmx driver/pparse.cmx \ - parsing/parse.cmx utils/misc.cmx typing/ident.cmx typing/env.cmx \ - bytecomp/emitcode.cmx utils/config.cmx utils/clflags.cmx utils/ccomp.cmx \ - bytecomp/bytegen.cmx driver/compile.cmi + typing/stypes.cmx bytecomp/simplif.cmx typing/printtyp.cmx \ + bytecomp/printlambda.cmx bytecomp/printinstr.cmx parsing/printast.cmx \ + driver/pparse.cmx parsing/parse.cmx utils/misc.cmx parsing/location.cmx \ + typing/ident.cmx typing/env.cmx bytecomp/emitcode.cmx utils/config.cmx \ + utils/clflags.cmx utils/ccomp.cmx bytecomp/bytegen.cmx driver/compile.cmi driver/errors.cmo: utils/warnings.cmi typing/typetexp.cmi typing/typemod.cmi \ typing/typedecl.cmi typing/typecore.cmi typing/typeclass.cmi \ bytecomp/translmod.cmi bytecomp/translcore.cmi bytecomp/translclass.cmi \ @@ -698,18 +737,18 @@ driver/main_args.cmo: driver/main_args.cmi driver/main_args.cmx: driver/main_args.cmi driver/optcompile.cmo: utils/warnings.cmi typing/unused_var.cmi \ typing/typemod.cmi typing/typedtree.cmi bytecomp/translmod.cmi \ - bytecomp/simplif.cmi typing/printtyp.cmi bytecomp/printlambda.cmi \ - parsing/printast.cmi driver/pparse.cmi parsing/parse.cmi utils/misc.cmi \ - typing/ident.cmi typing/env.cmi utils/config.cmi asmcomp/compilenv.cmi \ - utils/clflags.cmi utils/ccomp.cmi asmcomp/asmgen.cmi \ - driver/optcompile.cmi + typing/stypes.cmi bytecomp/simplif.cmi typing/printtyp.cmi \ + bytecomp/printlambda.cmi parsing/printast.cmi driver/pparse.cmi \ + parsing/parse.cmi utils/misc.cmi parsing/location.cmi typing/ident.cmi \ + typing/env.cmi utils/config.cmi asmcomp/compilenv.cmi utils/clflags.cmi \ + utils/ccomp.cmi asmcomp/asmgen.cmi driver/optcompile.cmi driver/optcompile.cmx: utils/warnings.cmx typing/unused_var.cmx \ typing/typemod.cmx typing/typedtree.cmx bytecomp/translmod.cmx \ - bytecomp/simplif.cmx typing/printtyp.cmx bytecomp/printlambda.cmx \ - parsing/printast.cmx driver/pparse.cmx parsing/parse.cmx utils/misc.cmx \ - typing/ident.cmx typing/env.cmx utils/config.cmx asmcomp/compilenv.cmx \ - utils/clflags.cmx utils/ccomp.cmx asmcomp/asmgen.cmx \ - driver/optcompile.cmi + typing/stypes.cmx bytecomp/simplif.cmx typing/printtyp.cmx \ + bytecomp/printlambda.cmx parsing/printast.cmx driver/pparse.cmx \ + parsing/parse.cmx utils/misc.cmx parsing/location.cmx typing/ident.cmx \ + typing/env.cmx utils/config.cmx asmcomp/compilenv.cmx utils/clflags.cmx \ + utils/ccomp.cmx asmcomp/asmgen.cmx driver/optcompile.cmi driver/opterrors.cmo: utils/warnings.cmi typing/typetexp.cmi \ typing/typemod.cmi typing/typedecl.cmi typing/typecore.cmi \ typing/typeclass.cmi bytecomp/translmod.cmi bytecomp/translcore.cmi \ @@ -742,10 +781,16 @@ driver/pparse.cmx: utils/misc.cmx parsing/location.cmx utils/clflags.cmx \ utils/ccomp.cmx driver/pparse.cmi toplevel/genprintval.cmi: typing/types.cmi typing/path.cmi \ typing/outcometree.cmi typing/env.cmi +toplevel/opttopdirs.cmi: parsing/longident.cmi +toplevel/opttoploop.cmi: utils/warnings.cmi typing/types.cmi typing/path.cmi \ + parsing/parsetree.cmi typing/outcometree.cmi parsing/longident.cmi \ + parsing/location.cmi typing/env.cmi +toplevel/opttopmain.cmi: toplevel/topdirs.cmi: parsing/longident.cmi toplevel/toploop.cmi: utils/warnings.cmi typing/types.cmi typing/path.cmi \ parsing/parsetree.cmi typing/outcometree.cmi parsing/longident.cmi \ parsing/location.cmi typing/env.cmi +toplevel/topmain.cmi: toplevel/trace.cmi: typing/types.cmi typing/path.cmi parsing/longident.cmi \ typing/env.cmi toplevel/expunge.cmo: bytecomp/symtable.cmi bytecomp/runtimedef.cmi \ @@ -760,6 +805,48 @@ toplevel/genprintval.cmx: typing/types.cmx typing/printtyp.cmx \ typing/predef.cmx typing/path.cmx typing/outcometree.cmi utils/misc.cmx \ parsing/longident.cmx typing/ident.cmx typing/env.cmx typing/datarepr.cmx \ typing/ctype.cmx typing/btype.cmx toplevel/genprintval.cmi +toplevel/opttopdirs.cmo: utils/warnings.cmi typing/types.cmi \ + typing/printtyp.cmi typing/path.cmi toplevel/opttoploop.cmi \ + utils/misc.cmi parsing/longident.cmi typing/ident.cmi typing/env.cmi \ + typing/ctype.cmi utils/config.cmi utils/clflags.cmi asmcomp/asmlink.cmi \ + toplevel/opttopdirs.cmi +toplevel/opttopdirs.cmx: utils/warnings.cmx typing/types.cmx \ + typing/printtyp.cmx typing/path.cmx toplevel/opttoploop.cmx \ + utils/misc.cmx parsing/longident.cmx typing/ident.cmx typing/env.cmx \ + typing/ctype.cmx utils/config.cmx utils/clflags.cmx asmcomp/asmlink.cmx \ + toplevel/opttopdirs.cmi +toplevel/opttoploop.cmo: utils/warnings.cmi typing/unused_var.cmi \ + typing/types.cmi typing/typemod.cmi typing/typedtree.cmi \ + typing/typecore.cmi bytecomp/translmod.cmi bytecomp/simplif.cmi \ + typing/printtyp.cmi bytecomp/printlambda.cmi parsing/printast.cmi \ + typing/predef.cmi typing/path.cmi parsing/parsetree.cmi parsing/parse.cmi \ + typing/outcometree.cmi driver/opterrors.cmi driver/optcompile.cmi \ + typing/oprint.cmi utils/misc.cmi parsing/longident.cmi \ + parsing/location.cmi parsing/lexer.cmi bytecomp/lambda.cmi \ + typing/ident.cmi toplevel/genprintval.cmi typing/env.cmi utils/config.cmi \ + asmcomp/compilenv.cmi utils/clflags.cmi typing/btype.cmi \ + asmcomp/asmlink.cmi asmcomp/asmgen.cmi toplevel/opttoploop.cmi +toplevel/opttoploop.cmx: utils/warnings.cmx typing/unused_var.cmx \ + typing/types.cmx typing/typemod.cmx typing/typedtree.cmx \ + typing/typecore.cmx bytecomp/translmod.cmx bytecomp/simplif.cmx \ + typing/printtyp.cmx bytecomp/printlambda.cmx parsing/printast.cmx \ + typing/predef.cmx typing/path.cmx parsing/parsetree.cmi parsing/parse.cmx \ + typing/outcometree.cmi driver/opterrors.cmx driver/optcompile.cmx \ + typing/oprint.cmx utils/misc.cmx parsing/longident.cmx \ + parsing/location.cmx parsing/lexer.cmx bytecomp/lambda.cmx \ + typing/ident.cmx toplevel/genprintval.cmx typing/env.cmx utils/config.cmx \ + asmcomp/compilenv.cmx utils/clflags.cmx typing/btype.cmx \ + asmcomp/asmlink.cmx asmcomp/asmgen.cmx toplevel/opttoploop.cmi +toplevel/opttopmain.cmo: utils/warnings.cmi asmcomp/printmach.cmi \ + toplevel/opttoploop.cmi toplevel/opttopdirs.cmi driver/opterrors.cmi \ + utils/misc.cmi utils/config.cmi utils/clflags.cmi asmcomp/arch.cmo \ + toplevel/opttopmain.cmi +toplevel/opttopmain.cmx: utils/warnings.cmx asmcomp/printmach.cmx \ + toplevel/opttoploop.cmx toplevel/opttopdirs.cmx driver/opterrors.cmx \ + utils/misc.cmx utils/config.cmx utils/clflags.cmx asmcomp/arch.cmx \ + toplevel/opttopmain.cmi +toplevel/opttopstart.cmo: toplevel/opttopmain.cmi +toplevel/opttopstart.cmx: toplevel/opttopmain.cmx toplevel/topdirs.cmo: utils/warnings.cmi typing/types.cmi toplevel/trace.cmi \ toplevel/toploop.cmi bytecomp/symtable.cmi typing/printtyp.cmi \ typing/path.cmi bytecomp/opcodes.cmo utils/misc.cmi bytecomp/meta.cmi \ diff --git a/Changes b/Changes index 0ed6e5cd..64cfa97b 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,125 @@ +Objective Caml 3.11.0: +---------------------- + +(Changes that can break existing programs are marked with a "*" ) + +Language features: +- Addition of lazy patterns: "lazy " matches suspensions whose values, + after forcing, match the pattern . +- Introduction of private abbreviation types "type t = private ", + for abstracting the actual manifest type in type abbreviations. + +Compilers: +- The file name for a compilation unit should correspond to a valid + identifier (Otherwise dynamic linking and other things can fail, and + a warning is emitted.) +* Revised -output-obj: the output name must now be provided; its + extension must be one of .o/.obj, .so/.dll, or .c for the + bytecode compiler. The compilers can now produce a shared library + (with all the needed -ccopts/-ccobjs options) directly. +- -dtypes renamed to -annot, records (in .annot files) which function calls + are tail calls. +- All compiler error messages now include a file name and location, for + better interaction with Emacs' compilation mode. +- Optimized compilation of "lazy e" when the argument "e" is + already evaluated. +- Optimized compilation of equality tests with a variant constant constructor. +- The -dllib options recorded in libraries are no longer ignored when + -use_runtime or -use_prims is used (unless -no_auto_link is + explicitly used). +- Check that at most one of -pack, -a, -shared, -c, -output-obj is + given on the command line. +- Optimized compilation of private types as regular manifest types + (e.g. abbreviation to float, float array or record types with only + float fields). + +Native-code compiler: +- A new option "-shared" to produce a plugin that can be dynamically + loaded with the native version of Dynlink. +- A new option "-nodynlink" to enable optimizations valid only for code + that is never dynlinked (no-op except for AMD64). +- More aggressive unboxing of floats and boxed integers. +- Can select which assembler and asm options to use at configuration time. + +Run-time system: +- Changes in freelist management to reduce fragmentation. +- New implementation of the page table describing the heap (a sparse + hashtable replaces a dense bitvector), fixes issues with address + space randomization on 64-bit OS (PR#4448). +- New "generational" API for registering global memory roots with the GC, + enables faster scanning of global roots. + (The functions are caml_*_generational_global_root in .) +- New function "caml_raise_with_args" to raise an exception with several + arguments from C. +- Changes in implementation of dynamic linking of C code: + under Win32, use Alain Frisch's flexdll implementation of the dlopen + API; under MacOSX, use dlopen API instead of MacOSX bundle API. + +Standard library: +- Parsing library: new function "set_trace" to programmatically turn + on or off the printing of a trace during parsing. +- Printexc library: new functions "print_backtrace" and "get_backtrace" + to obtain a stack backtrace of the most recently raised exception. + New function "record_backtrace" to turn the exception backtrace mechanism + on or off from within a program. +- Scanf library: fine-tuning of meta format implementation; + fscanf behaviour revisited: only one input buffer is allocated for any + given input channel; + the %n conversion does not count a lookahead character as read. + +Other libraries: +- Dynlink: on some platforms, the Dynlink library is now available in + native code. The boolean Dynlink.is_native allows the program to + know whether it has been compiled in bytecode or in native code. +- Bigarrays: added "unsafe_get" and "unsafe_set" + (non-bound-checking versions of "get" and "set"). +- Bigarrays: removed limitation "array dimension < 2^31". +- Labltk: added support for TK 8.5. +- Num: added conversions between big_int and int32, nativeint, int64. + More efficient implementation of Num.quo_num and Num.mod_num. +- Threads: improved efficiency of mutex and condition variable operations; + improved interaction with Unix.fork (PR#4577). +- Unix: added getsockopt_error returning type Unix.error. + Added support for TCP_NODELAY and IPV6_ONLY socket options. +- Win32 Unix: "select" now supports all kinds of file descriptors. + Improved emulation of "lockf" (PR#4609). + +Tools: +- ocamldebug now supported under Windows (MSVC and Mingw ports), + but without the replay feature. (Contributed by Sylvain Le Gall + at OCamlCore with support from Lexifi.) +- ocamldoc: new option -no-module-constraint-filter to include functions + hidden by signature constraint in documentation. +- ocamlmklib and ocamldep.opt now available under Windows ports. +- ocamlmklib no longer supports the -implib option. +- ocamlnat: an experimental native toplevel (not built by default). + +Bug fixes: +- Major GC and heap compaction: fixed bug involving lazy values and + out-of-heap pointers. +- PR#3915: updated most man pages. +- PR#4261: type-checking of recursive modules +- PR#4308: better stack backtraces for "spontaneous" exceptions such as + Stack_overflow, Out_of_memory, etc. +- PR#4338: Str.global_substitute, Str.global_replace and the Str.*split* + functions are now tail-recursive. +- PR#4503: fixed bug in classify_float on ARM. +- PR#4512: type-checking of recursive modules +- PR#4517: crash in ocamllex-generated lexers. +- PR#4542: problem with return value of Unix.nice. +- PR#4557: type-checking of recursive modules. +- PR#4562: strange %n semantics in scanf. +- PR#4564: add note "stack is not executable" to object files generated by + ocamlopt (Linux/x86, Linux/AMD64). +- PR#4566: bug in Ratio.approx_ratio_fix and Num.approx_num_fix. +- PR#4582: weird behaviour of String.index_from and String.rindex_from. +- PR#4583: stack overflow in "ocamlopt -g" during closure conversion pass. +- PR#4585: ocamldoc and "val virtual" declarations. +- PR#4587: ocamldoc and escaped @ characters. +- PR#4605: Buffer.add_substitute was sometime wrong when target string had backslashes. +- PR#4614: Inconsistent declaration of CamlCBCmd in LablTk library. + + Objective Caml 3.10.2: ---------------------- @@ -101,6 +223,7 @@ New features: - many other small changes and bugfixes in camlp4, ocamlbuild, labltk, emacs files + Objective Caml 3.10.0: ---------------------- @@ -154,6 +277,8 @@ Standard library: - 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. +- String and Char: the function ``escaped'' now escapes all the characters + especially handled by the compiler's lexer (PR#4220). Other libraries: - Bigarray: mmap_file takes an optional argument specifying @@ -2253,4 +2378,12 @@ Caml Special Light 1.06: * First public release. -$Id: Changes,v 1.168.2.13 2008/02/29 12:17:26 doligez Exp $ +<<<<<<< Changes +<<<<<<< Changes +$Id: Changes,v 1.183.2.1 2008/10/15 13:12:58 doligez Exp $ +======= +$Id: Changes,v 1.183.2.1 2008/10/15 13:12:58 doligez Exp $ +>>>>>>> 1.168.2.7 +======= +$Id: Changes,v 1.183.2.1 2008/10/15 13:12:58 doligez Exp $ +>>>>>>> 1.168.2.13 diff --git a/INSTALL b/INSTALL index a1f06f4f..c1d84570 100644 --- a/INSTALL +++ b/INSTALL @@ -100,21 +100,38 @@ The "configure" script accepts the following options: options for finding the header files, and "-dllibs" for finding the C libraries. --binutils - This option specifies where to find the GNU binutils (objcopy - and nm) executables. +-as (default: determined automatically) + The assembler to use for assembling ocamlopt-generated code. + +-aspp (default: determined automatically> + The assembler to use for assembling the parts of the + run-time system manually written in assembly language. + This assembler must preprocess its input with the C preprocessor. -verbose Verbose output of the configuration tests. Use it if the outcome of configure is not what you were expecting. Examples: - ./configure -prefix /usr/bin + + Standard installation in /usr/{bin,lib,man} instead of /usr/local: + ./configure -prefix /usr + + Installation in /usr, man pages in section "l": ./configure -bindir /usr/bin -libdir /usr/lib/ocaml -mandir /usr/man/manl + + On a MacOSX/PowerPC host, to build a 64-bit version of OCaml: + ./configure -cc "gcc -m64" + + On a Linux x86/64 bits host, to build a 32-bit version of OCaml: + ./configure -cc "gcc -m32" -as "as --32" -aspp "gcc -m32 -c" + + For Sun Solaris with the "acc" compiler: ./configure -cc "acc -fast" -libs "-lucb" - # For Sun Solaris with the acc compiler + + For AIX 4.3 with the IBM compiler xlc: ./configure -cc "xlc_r -D_AIX43 -Wl,-bexpall,-brtl -qmaxmem=8192" - # For AIX 4.3 with the IBM compiler + If something goes wrong during the automatic configuration, or if the generated files cause errors later on, then look at the template files diff --git a/Makefile b/Makefile index a3da5f2f..8199776e 100644 --- a/Makefile +++ b/Makefile @@ -10,7 +10,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.207.4.5 2007/06/20 13:26:29 ertai Exp $ +# $Id: Makefile,v 1.222 2008/07/14 12:59:21 weis Exp $ # The main Makefile @@ -18,7 +18,7 @@ include config/Makefile include stdlib/StdlibModules CAMLC=boot/ocamlrun boot/ocamlc -nostdlib -I boot -CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib +CAMLOPT=boot/ocamlrun ./ocamlopt -nostdlib -I stdlib -I otherlibs/dynlink COMPFLAGS=-warn-error A $(INCLUDES) LINKFLAGS= @@ -102,6 +102,11 @@ TOPLIB=$(UTILS) $(PARSING) $(TYPING) $(COMP) $(BYTECOMP) $(TOPLEVEL) TOPOBJS=$(TOPLEVELLIB) $(TOPLEVELSTART) +NATTOPOBJS=$(OPTUTILS) $(PARSING) $(TYPING) $(COMP) $(ASMCOMP) \ + driver/pparse.cmo driver/opterrors.cmo driver/optcompile.cmo \ + toplevel/genprintval.cmo toplevel/opttoploop.cmo toplevel/opttopdirs.cmo \ + toplevel/opttopmain.cmo toplevel/opttopstart.cmo + OPTOBJS=$(OPTUTILS) $(PARSING) $(TYPING) $(COMP) $(ASMCOMP) $(OPTDRIVER) EXPUNGEOBJS=utils/misc.cmo utils/tbl.cmo \ @@ -126,14 +131,26 @@ defaultentry: all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml \ 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. - # Compile everything the first time -world: coldstart all +world: + $(MAKE) coldstart + $(MAKE) all # Compile also native code compiler and libraries, fast -world.opt: coldstart opt.opt +world.opt: + $(MAKE) coldstart + $(MAKE) opt.opt + +# Hard bootstrap how-to: +# (only necessary in some cases, for example if you remove some primitive) +# +# make coreboot [old system -- you were in a stable state] +# +# make core [cross-compiler] +# make partialclean [if you get "inconsistent assumptions"] +# +# make core [cross-compiler] +# make coreboot [new system -- now you are in a stable state] # Core bootstrapping cycle coreboot: @@ -157,6 +174,8 @@ coreboot: $(MAKE) compare # Bootstrap and rebuild the whole system. +# The compilation of ocaml will fail if the runtime has changed. +# Never mind, just do make bootstrap to reach fixpoint again. bootstrap: $(MAKE) coreboot $(MAKE) all @@ -178,7 +197,10 @@ coldstart: ln -s ../byterun stdlib/caml; fi # Build the core system: the minimum needed to make depend and bootstrap -core : coldstart ocamlc ocamllex ocamlyacc ocamltools library +core: coldstart ocamlc ocamllex ocamlyacc ocamltools library + +# Recompile the core system using the bootstrap compiler +coreall: ocamlc ocamllex ocamlyacc ocamltools library # Save the current bootstrap compiler MAXSAVED=boot/Saved/Saved.prev/Saved.prev/Saved.prev/Saved.prev/Saved.prev @@ -189,7 +211,8 @@ backup: mkdir boot/Saved mv boot/Saved.prev boot/Saved/Saved.prev cp boot/ocamlrun$(EXE) boot/Saved - mv boot/ocamlc boot/ocamllex boot/ocamlyacc$(EXE) boot/ocamldep boot/Saved + mv boot/ocamlc boot/ocamllex boot/ocamlyacc$(EXE) boot/ocamldep \ + boot/Saved cd boot; cp $(LIBFILES) Saved # Promote the newly compiled system to the rank of cross compiler @@ -214,7 +237,8 @@ restore: # Check if fixpoint reached compare: - @if cmp boot/ocamlc ocamlc && cmp boot/ocamllex lex/ocamllex && cmp boot/ocamldep tools/ocamldep; \ + @if cmp boot/ocamlc ocamlc && cmp boot/ocamllex lex/ocamllex \ + && cmp boot/ocamldep tools/ocamldep; \ then echo "Fixpoint reached, bootstrap succeeded."; \ else echo "Fixpoint not reached, try one more bootstrapping cycle."; \ fi @@ -224,20 +248,31 @@ cleanboot: rm -rf boot/Saved/Saved.prev/* # Compile the native-code compiler -opt-core:runtimeopt ocamlopt libraryopt -opt: runtimeopt ocamlopt libraryopt otherlibrariesopt ocamlbuildlib.native +opt-core: + $(MAKE) runtimeopt + $(MAKE) ocamlopt + $(MAKE) libraryopt + +opt: + $(MAKE) runtimeopt + $(MAKE) ocamlopt + $(MAKE) libraryopt + $(MAKE) otherlibrariesopt + $(MAKE) ocamlbuildlib.native # Native-code versions of the tools opt.opt: checkstack runtime core ocaml opt-core ocamlc.opt otherlibraries \ - ocamlbuild.byte camlp4out $(DEBUGGER) ocamldoc ocamlopt.opt otherlibrariesopt \ - ocamllex.opt ocamltoolsopt.opt ocamlbuild.native camlp4opt ocamldoc.opt + ocamlbuild.byte camlp4out $(DEBUGGER) ocamldoc ocamlopt.opt \ + otherlibrariesopt \ + ocamllex.opt ocamltoolsopt.opt ocamlbuild.native camlp4opt ocamldoc.opt # Installation -install: FORCE +install: if test -d $(BINDIR); then : ; else $(MKDIR) $(BINDIR); fi if test -d $(LIBDIR); then : ; else $(MKDIR) $(LIBDIR); fi if test -d $(STUBLIBDIR); then : ; else $(MKDIR) $(STUBLIBDIR); fi - if test -d $(MANDIR)/man$(MANEXT); then : ; else $(MKDIR) $(MANDIR)/man$(MANEXT); fi + if test -d $(MANDIR)/man$(MANEXT); then : ; \ + else $(MKDIR) $(MANDIR)/man$(MANEXT); fi cd $(LIBDIR); rm -f dllbigarray.so dlllabltk.so dllnums.so \ dllthreads.so dllunix.so dllgraphics.so dllmldbm.so dllstr.so \ dlltkanim.so @@ -251,7 +286,8 @@ install: FORCE cp expunge $(LIBDIR)/expunge$(EXE) cp typing/outcometree.cmi typing/outcometree.mli $(LIBDIR) cp toplevel/topstart.cmo $(LIBDIR) - cp toplevel/toploop.cmi toplevel/topdirs.cmi toplevel/topmain.cmi $(LIBDIR) + cp toplevel/toploop.cmi toplevel/topdirs.cmi toplevel/topmain.cmi \ + $(LIBDIR) cd tools; $(MAKE) install -cd man; $(MAKE) install for i in $(OTHERLIBRARIES); do \ @@ -262,7 +298,8 @@ install: FORCE if test -f debugger/ocamldebug; then (cd debugger; $(MAKE) install); \ else :; fi cp config/Makefile $(LIBDIR)/Makefile.config - BINDIR=$(BINDIR) LIBDIR=$(LIBDIR) PREFIX=$(PREFIX) ./build/partial-install.sh + BINDIR=$(BINDIR) LIBDIR=$(LIBDIR) PREFIX=$(PREFIX) \ + ./build/partial-install.sh # Installation of the native-code compiler installopt: @@ -270,7 +307,8 @@ installopt: cp ocamlopt $(BINDIR)/ocamlopt$(EXE) cd stdlib; $(MAKE) installopt cd ocamldoc; $(MAKE) installopt - for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i; $(MAKE) installopt) || exit $$?; done + for i in $(OTHERLIBRARIES); \ + do (cd otherlibs/$$i; $(MAKE) installopt) || exit $$?; done if test -f ocamlc.opt; \ then cp ocamlc.opt $(BINDIR)/ocamlc.opt$(EXE); else :; fi if test -f ocamlopt.opt; \ @@ -315,6 +353,17 @@ toplevel/toplevellib.cma: $(TOPLIB) partialclean:: rm -f ocaml toplevel/toplevellib.cma +# The native toplevel + +ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx) + $(CAMLOPT) $(LINKFLAGS) otherlibs/dynlink/dynlink.cmxa -o ocamlnat \ + $(NATTOPOBJS:.cmo=.cmx) -linkall + +toplevel/opttoploop.cmx: otherlibs/dynlink/dynlink.cmxa + +otherlibs/dynlink/dynlink.cmxa: otherlibs/dynlink/natdynlink.ml + cd otherlibs/dynlink && make allopt + # The configuration file utils/config.ml: utils/config.mlp config/Makefile @@ -323,11 +372,8 @@ utils/config.ml: utils/config.mlp config/Makefile -e 's|%%BYTERUN%%|$(BINDIR)/ocamlrun|' \ -e 's|%%CCOMPTYPE%%|cc|' \ -e 's|%%BYTECC%%|$(BYTECC) $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS)|' \ - -e 's|%%BYTELINK%%|$(BYTECC) $(BYTECCLINKOPTS)|' \ -e 's|%%NATIVECC%%|$(NATIVECC) $(NATIVECCCOMPOPTS)|' \ - -e 's|%%NATIVELINK%%|$(NATIVECC) $(NATIVECCLINKOPTS)|' \ - -e 's|%%PARTIALLD%%|$(PARTIALLD) $(NATIVECCLINKOPTS)|' \ - -e 's|%%PACKLD%%|$(PARTIALLD) $(NATIVECCLINKOPTS) -o |' \ + -e 's|%%PACKLD%%|$(PACKLD)|' \ -e 's|%%BYTECCLIBS%%|$(BYTECCLIBS)|' \ -e 's|%%NATIVECCLIBS%%|$(NATIVECCLIBS)|' \ -e 's|%%RANLIBCMD%%|$(RANLIBCMD)|' \ @@ -340,6 +386,10 @@ utils/config.ml: utils/config.mlp config/Makefile -e 's|%%EXT_LIB%%|.a|' \ -e 's|%%EXT_DLL%%|.so|' \ -e 's|%%SYSTHREAD_SUPPORT%%|$(SYSTHREAD_SUPPORT)|' \ + -e 's|%%ASM%%|$(ASM)|' \ + -e 's|%%MKDLL%%|$(MKDLL)|' \ + -e 's|%%MKEXE%%|$(MKEXE)|' \ + -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \ utils/config.mlp > utils/config.ml @chmod -w utils/config.ml @@ -506,10 +556,12 @@ runtime: cd byterun; $(MAKE) all if test -f stdlib/libcamlrun.a; then :; else \ ln -s ../byterun/libcamlrun.a stdlib/libcamlrun.a; fi + clean:: cd byterun; $(MAKE) clean rm -f stdlib/libcamlrun.a rm -f stdlib/caml + alldepend:: cd byterun; $(MAKE) depend @@ -519,9 +571,11 @@ runtimeopt: cd asmrun; $(MAKE) all if test -f stdlib/libasmrun.a; then :; else \ ln -s ../asmrun/libasmrun.a stdlib/libasmrun.a; fi + clean:: cd asmrun; $(MAKE) clean rm -f stdlib/libasmrun.a + alldepend:: cd asmrun; $(MAKE) depend @@ -529,12 +583,16 @@ alldepend:: library: ocamlc cd stdlib; $(MAKE) all + library-cross: cd stdlib; $(MAKE) RUNTIME=../byterun/ocamlrun all + libraryopt: cd stdlib; $(MAKE) allopt + partialclean:: cd stdlib; $(MAKE) clean + alldepend:: cd stdlib; $(MAKE) depend @@ -542,15 +600,19 @@ alldepend:: ocamllex: ocamlyacc ocamlc cd lex; $(MAKE) all + ocamllex.opt: ocamlopt cd lex; $(MAKE) allopt + partialclean:: cd lex; $(MAKE) clean + alldepend:: cd lex; $(MAKE) depend ocamlyacc: cd yacc; $(MAKE) all + clean:: cd yacc; $(MAKE) clean @@ -558,49 +620,61 @@ clean:: ocamltools: ocamlc ocamlyacc ocamllex cd tools; $(MAKE) all + ocamltoolsopt.opt: ocamlc.opt ocamlyacc ocamllex cd tools; $(MAKE) opt.opt + partialclean:: cd tools; $(MAKE) clean + alldepend:: cd tools; $(MAKE) depend # OCamldoc -ocamldoc: ocamlc ocamlyacc ocamllex +ocamldoc: ocamlc ocamlyacc ocamllex otherlibraries cd ocamldoc && $(MAKE) all + ocamldoc.opt: ocamlc.opt ocamlyacc ocamllex cd ocamldoc && $(MAKE) opt.opt + partialclean:: cd ocamldoc && $(MAKE) clean + alldepend:: cd ocamldoc && $(MAKE) depend # The extra libraries -otherlibraries: +otherlibraries: ocamltools for i in $(OTHERLIBRARIES); do \ (cd otherlibs/$$i; $(MAKE) RUNTIME=$(RUNTIME) all) || exit $$?; \ done + otherlibrariesopt: for i in $(OTHERLIBRARIES); do \ (cd otherlibs/$$i; $(MAKE) allopt) || exit $$?; \ done + partialclean:: for i in $(OTHERLIBRARIES); do \ (cd otherlibs/$$i; $(MAKE) partialclean); \ done + clean:: for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i; $(MAKE) clean); done + alldepend:: for i in $(OTHERLIBRARIES); do (cd otherlibs/$$i; $(MAKE) depend); done # The replay debugger -ocamldebugger: ocamlc ocamlyacc ocamllex +ocamldebugger: ocamlc ocamlyacc ocamllex otherlibraries cd debugger; $(MAKE) all + partialclean:: cd debugger; $(MAKE) clean + alldepend:: cd debugger; $(MAKE) depend @@ -608,6 +682,7 @@ alldepend:: 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 @@ -615,16 +690,20 @@ camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-partial-boot ocamlbuild.native ocamlbuild.byte: ocamlc otherlibraries ocamlbuild-partial-boot ./build/ocamlbuild-byte-only.sh + ocamlbuild.native: ocamlopt otherlibrariesopt ocamlbuild-partial-boot ./build/ocamlbuild-native-only.sh ocamlbuildlib.native: ocamlopt otherlibrariesopt ocamlbuild-partial-boot ./build/ocamlbuildlib-native-only.sh -.PHONY: ocamlbuild-partial-boot -ocamlbuild-partial-boot: +ocamlbuild-partial-boot: ocamlc otherlibraries ./build/partial-boot.sh + partialclean:: rm -rf _build + if test -d test; then \ + (cd test; $(MAKE) clean); \ + fi # Check that the stack limit is reasonable. @@ -637,14 +716,9 @@ checkstack: # Make MacOS X package -.PHONY: package-macosx - package-macosx: sudo rm -rf package-macosx/root - make BINDIR="`pwd`"/package-macosx/root/bin \ - LIBDIR="`pwd`"/package-macosx/root/lib/ocaml \ - MANDIR="`pwd`"/package-macosx/root/man \ - install + make PREFIX="`pwd`"/package-macosx/root install tools/make-package-macosx sudo rm -rf package-macosx/root @@ -682,6 +756,18 @@ depend: beforedepend alldepend:: depend -FORCE: +distclean: + ./build/distclean.sh + +.PHONY: all backup bootstrap camlp4opt camlp4out checkstack clean +.PHONY: partialclean beforedepend alldepend cleanboot coldstart +.PHONY: compare core coreall +.PHONY: coreboot defaultentry depend distclean install installopt +.PHONY: library library-cross libraryopt ocamlbuild-partial-boot +.PHONY: ocamlbuild.byte ocamlbuild.native ocamldebugger ocamldoc +.PHONY: ocamldoc.opt ocamllex ocamllex.opt ocamltools ocamltools.opt +.PHONY: ocamlyacc opt-core opt opt.opt otherlibraries +.PHONY: otherlibrariesopt package-macosx promote promote-cross +.PHONY: restore runtime runtimeopt world world.opt include .depend diff --git a/Makefile.nt b/Makefile.nt index bc41849b..81c97085 100644 --- a/Makefile.nt +++ b/Makefile.nt @@ -10,7 +10,7 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.102.4.4 2007/06/20 13:26:29 ertai Exp $ +# $Id: Makefile.nt,v 1.113 2008/07/29 08:31:41 xleroy Exp $ # The main Makefile @@ -18,7 +18,7 @@ include config/Makefile include stdlib/StdlibModules CAMLC=boot/ocamlrun boot/ocamlc -I boot -CAMLOPT=boot/ocamlrun ./ocamlopt -I stdlib +CAMLOPT=boot/ocamlrun ./ocamlopt -I stdlib -I otherlibs/dynlink COMPFLAGS=$(INCLUDES) LINKFLAGS= CAMLYACC=boot/ocamlyacc @@ -28,7 +28,8 @@ CAMLDEP=boot/ocamlrun tools/ocamldep DEPFLAGS=$(INCLUDES) CAMLRUN=byterun/ocamlrun -INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver -I toplevel +INCLUDES=-I utils -I parsing -I typing -I bytecomp -I asmcomp -I driver \ + -I toplevel UTILS=utils/misc.cmo utils/tbl.cmo utils/config.cmo \ utils/clflags.cmo utils/terminfo.cmo utils/ccomp.cmo utils/warnings.cmo \ @@ -98,6 +99,11 @@ TOPLIB=$(UTILS) $(PARSING) $(TYPING) $(COMP) $(BYTECOMP) $(TOPLEVEL) TOPOBJS=$(TOPLEVELLIB) $(TOPLEVELSTART) +NATTOPOBJS=$(OPTUTILS) $(PARSING) $(TYPING) $(COMP) $(ASMCOMP) \ + driver/pparse.cmo driver/opterrors.cmo driver/optcompile.cmo \ + toplevel/genprintval.cmo toplevel/opttoploop.cmo toplevel/opttopdirs.cmo \ + toplevel/opttopmain.cmo toplevel/opttopstart.cmo + OPTOBJS=$(OPTUTILS) $(PARSING) $(TYPING) $(COMP) $(ASMCOMP) $(OPTDRIVER) EXPUNGEOBJS=utils/misc.cmo utils/tbl.cmo \ @@ -114,7 +120,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 ocamlbuild.byte camlp4out win32gui +all: runtime ocamlc ocamllex ocamlyacc ocamltools library ocaml otherlibraries ocamldoc.byte ocamlbuild.byte camlp4out $(DEBUGGER) win32gui # The compilation of ocaml will fail if the runtime has changed. # Never mind, just do make bootstrap to reach fixpoint again. @@ -148,7 +154,6 @@ LIBFILES=stdlib.cma std_exit.cmo *.cmi camlheader coldstart: cd byterun ; $(MAKEREC) all cp byterun/ocamlrun.exe boot/ocamlrun.exe - cp byterun/ocamlrun.dll boot/ocamlrun.dll cd yacc ; $(MAKEREC) all cp yacc/ocamlyacc.exe boot/ocamlyacc.exe cd stdlib ; $(MAKEREC) COMPILER=../boot/ocamlc all @@ -213,8 +218,6 @@ installbyt: mkdir -p $(BINDIR) mkdir -p $(LIBDIR) cd byterun ; $(MAKEREC) install - echo "$(STUBLIBDIR)" > $(LIBDIR)/ld.conf - echo "$(LIBDIR)" >> $(LIBDIR)/ld.conf cp ocamlc $(BINDIR)/ocamlc.exe cp ocaml $(BINDIR)/ocaml.exe cd stdlib ; $(MAKEREC) install @@ -229,6 +232,8 @@ installbyt: cd ocamldoc ; $(MAKEREC) install mkdir -p $(STUBLIBDIR) for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i install; done + if test -f debugger/ocamldebug.exe; then (cd debugger; $(MAKEREC) install); \ + else :; fi cd win32caml ; $(MAKE) install ./build/partial-install.sh cp config/Makefile $(LIBDIR)/Makefile.config @@ -288,6 +293,17 @@ toplevel/toplevellib.cma: $(TOPLIB) partialclean:: rm -f ocaml +# The native toplevel + +ocamlnat: ocamlopt otherlibs/dynlink/dynlink.cmxa $(NATTOPOBJS:.cmo=.cmx) + $(CAMLOPT) $(LINKFLAGS) otherlibs/dynlink/dynlink.cmxa -o ocamlnat $(NATTOPOBJS:.cmo=.cmx) -linkall + +toplevel/opttoploop.cmx: otherlibs/dynlink/dynlink.cmxa + +otherlibs/dynlink/dynlink.cmxa: otherlibs/dynlink/natdynlink.ml + cd otherlibs/dynlink && make allopt + + # The configuration file utils/config.ml: utils/config.mlp config/Makefile @@ -296,9 +312,7 @@ utils/config.ml: utils/config.mlp config/Makefile -e "s|%%BYTERUN%%|ocamlrun|" \ -e 's|%%CCOMPTYPE%%|$(CCOMPTYPE)|' \ -e "s|%%BYTECC%%|$(BYTECC) $(BYTECCCOMPOPTS)|" \ - -e "s|%%BYTELINK%%|$(BYTECC) $(BYTECCLINKOPTS)|" \ -e "s|%%NATIVECC%%|$(NATIVECC) $(NATIVECCCOMPOPTS)|" \ - -e "s|%%NATIVELINK%%|$(NATIVECC) $(NATIVECCLINKOPTS)|" \ -e "s|%%PARTIALLD%%|$(PARTIALLD)|" \ -e "s|%%PACKLD%%|$(PACKLD)|" \ -e "s|%%BYTECCLIBS%%|$(BYTECCLIBS)|" \ @@ -314,6 +328,11 @@ utils/config.ml: utils/config.mlp config/Makefile -e "s|%%EXT_LIB%%|.$(A)|" \ -e "s|%%EXT_DLL%%|.dll|" \ -e "s|%%SYSTHREAD_SUPPORT%%|true|" \ + -e 's|%%ASM%%|$(ASM)|' \ + -e 's|%%MKDLL%%|$(MKDLL)|' \ + -e 's|%%MKEXE%%|$(MKEXE)|' \ + -e 's|%%MKMAINDLL%%|$(MKMAINDLL)|' \ + -e 's|%%CC_PROFILE%%||' \ utils/config.mlp > utils/config.ml @chmod -w utils/config.ml @@ -564,6 +583,15 @@ clean:: alldepend:: for i in $(OTHERLIBRARIES); do $(MAKEREC) -C otherlibs/$$i depend; done +# The replay debugger + +ocamldebugger: ocamlc ocamlyacc ocamllex + cd debugger; $(MAKEREC) all +partialclean:: + cd debugger; $(MAKEREC) clean +alldepend:: + cd debugger; $(MAKEREC) depend + # Camlp4 camlp4out: ocamlc otherlibraries ocamlbuild-partial-boot ocamlbuild.byte diff --git a/README.win32 b/README.win32 index bfdff2b0..7eac6f26 100644 --- a/README.win32 +++ b/README.win32 @@ -22,7 +22,7 @@ Third-party software required Speed of bytecode interpreter 70% 100% 100% -Replay debugger no no yes +Replay debugger yes (**) yes (**) yes The Unix library partial partial full @@ -37,6 +37,9 @@ the GPL. Thus, these .exe files can only be distributed under a license that is compatible with the GPL. Executables generated by MSVC or by MinGW have no such restrictions. +(**) The debugger is supported but the "replay" function of it are not enabled. +Other functions are available (step, goto, run...). + The remainder of this document gives more information on each port. ------------------------------------------------------------------------------ @@ -46,19 +49,17 @@ The remainder of this document gives more information on each port. REQUIREMENTS: -This port runs under MS Windows NT, 2000 and XP. -Windows 95, 98 and ME are no longer supported. +This port runs under MS Windows Vista, XP, and 2000. 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 Visual C++ compiler (items [1] and [2] in the section -"third-party software" below). Dynamic loading of DLLs is supported -out of the box, without additional software. +"third-party software" below) and the flexdll tool (item [5]). -The native-code compiler (ocamlopt) requires Visual C++ (items [1], [2]) -and the Microsoft assembler MASM (item [3]). +The native-code compiler (ocamlopt) requires Visual C++ (items [1], [2]), +the Microsoft assembler MASM (item [3]) and the flexdll tool (item [5]). The LablTk GUI requires Tcl/Tk 8.4 (item [4]). @@ -78,7 +79,6 @@ 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. - THIRD-PARTY SOFTWARE: [1] Visual C++ version 2005, 2003, or 6. @@ -99,6 +99,9 @@ http://www.microsoft.com/downloads/details.aspx?FamilyID=7A1C9DA0-0510-44A2-B042 [4] TCL/TK version 8.4. Windows binaries are available as part of the ActiveTCL distribution at http://www.activestate.com/products/ActiveTcl/ +[5] flexdll. + Can be downloaded from http://alain.frisch.fr/flexdll.html + RECOMPILATION FROM THE SOURCES: The command-line tools can be recompiled from the Unix source @@ -107,8 +110,9 @@ for Windows. You will need the following software components to perform the recompilation: - Windows NT, 2000, XP, or Vista. -- Items [1], [2], [3] and [4] from the list of recommended software above. +- Items [1], [2], [3], [4] and [5] from the list of recommended software above. - The Cygwin port of GNU tools, available from http://www.cygwin.com/ + Install at least the following packages: diffutils, make, ncurses. Remember to add the directory where the libraries tk84.lib and tcl84.lib were installed (by the Tcl/Tk installer) to the LIB variable @@ -149,7 +153,7 @@ Unix/GCC or Cygwin or Mingw on similar hardware. * Libraries available in this port: "num", "str", "threads", "graphics", "labltk", and large parts of "unix". -* The replay debugger is not supported. +* The replay debugger is partially supported (no reverse execution). CREDITS: @@ -167,8 +171,7 @@ by Jacob Navia, then significantly improved by Christopher A. Watford. REQUIREMENTS: -This port runs under MS Windows NT, 2000 and XP. -Windows 95, 98 and ME are also supported, but less reliably. +This port runs under MS Windows Vista, XP, and 2000. The base bytecode system (ocamlc, ocaml, ocamllex, ocamlyacc, ...) runs without any additional tools. @@ -177,6 +180,8 @@ The native-code compiler (ocamlopt), as well as static linking of Caml bytecode with C code (ocamlc -custom), require the Cygwin development tools, available at http://www.cygwin.com/ +and the flexdll tool, available at + http://alain.frisch.fr/flexdll.html You will need to install at least the following Cygwin packages (use the Setup tool from Cygwin): binutils, gcc-core, gcc-mingw-core, mingw-runtime, w32-api. @@ -210,11 +215,14 @@ RECOMPILATION FROM THE SOURCES: You will need the following software components to perform the recompilation: - Windows NT, 2000, XP, or Vista. - Cygwin: http://sourceware.cygnus.com/cygwin/ + Install at least the following packages: binutils, diffutils, + gcc-core, gcc-mingw-core, make, mingw-runtime, ncurses, w32-api. - TCL/TK version 8.4 (see above). +- The flexdll tool (see above). Do *not* install the standalone distribution of MinGW, nor the companion MSYS tools: these have problems with long command lines. -Instead, use the version of MinGW that is installed along with Cygwin. +Instead, use the version of MinGW provided by Cygwin. Start a Cygwin shell and unpack the source distribution (ocaml-X.YZ.tar.gz) with "tar xzf". Change to the top-level @@ -243,7 +251,7 @@ NOTES: * Libraries available in this port: "num", "str", "threads", "graphics", "labltk", and large parts of "unix". -* The replay debugger is not supported. +* The replay debugger is partially supported (no reverse execution). ------------------------------------------------------------------------------ @@ -256,6 +264,9 @@ This port requires the Cygwin environment from Cygnus/RedHat, which is freely available at: http://www.cygwin.com/ +It also requires the flexdll tool, available at: + http://alain.frisch.fr/flexdll.html + This port runs under all versions of MS Windows supported by Cygwin. @@ -291,11 +302,10 @@ 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. +"third-party software" below) and the flexdll tool (item [2]). The native-code compiler (ocamlopt) requires the Microsoft compiler -and the Microsoft assembler MASM64 (item [1]). +and the Microsoft assembler MASM64 (item [1]) and the flexdll tool (item [2]). INSTALLATION: @@ -311,6 +321,10 @@ THIRD-PARTY SOFTWARE: Includes all we need, namely a C compiler, the masm64 assembler, Windows libraries and include files. +[2] flexdll. + Can be downloaded from http://alain.frisch.fr/flexdll.html + + RECOMPILATION FROM THE SOURCES: @@ -322,6 +336,8 @@ 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/ + Install at least the following packages: diffutils, make, ncurses. +- The flexdll tool (see above). To recompile, start a Cygwin shell and change to the top-level directory of the OCaml distribution. Then, do @@ -354,5 +370,6 @@ 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. +* The replay debugger is partially supported (no reverse execution). +* The graphical browser ocamlbrowser is not supported. diff --git a/VERSION b/VERSION index 0c28df08..f9d9a820 100644 --- a/VERSION +++ b/VERSION @@ -1,6 +1,6 @@ -3.10.2 +3.11.0+beta1 # 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.17 2008/02/29 12:17:26 doligez Exp $ +# $Id: VERSION,v 1.26.2.2 2008/10/15 13:12:58 doligez Exp $ diff --git a/_tags b/_tags index 322973a9..111c3bf0 100644 --- a/_tags +++ b/_tags @@ -33,10 +33,10 @@ true: use_stdlib : -camlp4boot "camlp4/Camlp4_import.ml": -warn_Ale 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 + or "camlp4/camlp4lib.cma" or : use_dynlink "camlp4/Camlp4/Printers/OCaml.ml" or "camlp4/Camlp4/Printers/OCamlr.ml": warn_Alezv : include_unix -"camlp4/Camlp4/Struct/DynLoader.ml": include_dynlink +"camlp4/Camlp4/Struct/DynLoader.ml" or "camlp4/boot/Camlp4.ml": include_dynlink : include_toplevel : -debug diff --git a/asmcomp/alpha/proc.ml b/asmcomp/alpha/proc.ml index 20b81797..2688b146 100644 --- a/asmcomp/alpha/proc.ml +++ b/asmcomp/alpha/proc.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: proc.ml,v 1.6 2002/07/22 16:37:46 doligez Exp $ *) +(* $Id: proc.ml,v 1.7 2007/10/30 12:37:16 xleroy Exp $ *) (* Description of the Alpha processor *) @@ -207,11 +207,11 @@ let contains_calls = ref false let assemble_file infile outfile = let as_cmd = - if digital_asm - then if !Clflags.gprofile then "as -O2 -nocpp -pg -o " - else "as -O2 -nocpp -o " - else "as -o " in - Ccomp.command (as_cmd ^ Filename.quote outfile ^ " " ^ Filename.quote infile) + if digital_asm && !Clflags.gprofile + then Config.as ^ " -pg" + else Config.as in + Ccomp.command (as_cmd ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) open Clflags;; open Config;; diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp index d4961ac6..f3115517 100644 --- a/asmcomp/amd64/emit.mlp +++ b/asmcomp/amd64/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp,v 1.13.4.2 2007/10/23 09:09:43 xleroy Exp $ *) +(* $Id: emit.mlp,v 1.16 2008/08/01 08:04:57 xleroy Exp $ *) (* Emission of x86-64 (AMD 64) assembly code *) @@ -36,10 +36,10 @@ let frame_required () = let frame_size () = (* includes return address *) if frame_required() then begin - let sz = + let sz = (!stack_offset + 8 * (num_stack_slots.(0) + num_stack_slots.(1)) + 8) in Misc.align sz 16 - end else + end else !stack_offset + 8 let slot_offset loc cl = @@ -56,6 +56,24 @@ let slot_offset loc cl = let emit_symbol s = Emitaux.emit_symbol '$' s +let emit_call s = + if !Clflags.dlcode + then `call {emit_symbol s}@PLT` + else `call {emit_symbol s}` + +let emit_jump s = + if !Clflags.dlcode + then `jmp {emit_symbol s}@PLT` + else `jmp {emit_symbol s}` + +let load_symbol_addr s = + if !Clflags.dlcode + then `movq {emit_symbol s}@GOTPCREL(%rip)` + else if !pic_code + then `leaq {emit_symbol s}(%rip)` + else `movq ${emit_symbol s}` + + (* Output a label *) let emit_label lbl = @@ -111,7 +129,8 @@ let emit_reg32 r = emit_subreg reg_low_32_name r let emit_addressing addr r n = match addr with - Ibased(s, d) -> + | Ibased _ when !Clflags.dlcode -> assert false + | Ibased(s, d) -> `{emit_symbol s}`; if d <> 0 then ` + {emit_int d}`; `(%rip)` @@ -164,7 +183,7 @@ type gc_call = 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_lbl}: {emit_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. @@ -191,13 +210,13 @@ let bound_error_label dbg = 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_lbl}: {emit_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}: call {emit_symbol "caml_ml_array_bound_error"}\n` + `{emit_label !bound_error_call}: {emit_call "caml_ml_array_bound_error"}\n` (* Names for instructions *) @@ -326,15 +345,12 @@ let emit_instr fallthrough i = ` movlpd {emit_label lbl}(%rip), {emit_reg i.res.(0)}\n` end | Lop(Iconst_symbol s) -> - if !pic_code then - ` leaq {emit_symbol s}(%rip), {emit_reg i.res.(0)}\n` - else - ` movq ${emit_symbol s}, {emit_reg i.res.(0)}\n` + ` {load_symbol_addr s}, {emit_reg i.res.(0)}\n` | Lop(Icall_ind) -> ` call *{emit_reg i.arg.(0)}\n`; record_frame i.live i.dbg | Lop(Icall_imm(s)) -> - ` call {emit_symbol s}\n`; + ` {emit_call s}\n`; record_frame i.live i.dbg | Lop(Itailcall_ind) -> output_epilogue(); @@ -344,15 +360,15 @@ let emit_instr fallthrough i = ` jmp {emit_label !tailrec_entry_point}\n` else begin output_epilogue(); - ` jmp {emit_symbol s}\n` + ` {emit_jump s}\n` end | Lop(Iextcall(s, alloc)) -> if alloc then begin - ` leaq {emit_symbol s}(%rip), %rax\n`; - ` call {emit_symbol "caml_c_call"}\n`; + ` {load_symbol_addr s}, %rax\n`; + ` {emit_call "caml_c_call"}\n`; record_frame i.live i.dbg end else begin - ` call {emit_symbol s}\n` + ` {emit_call s}\n` end | Lop(Istackoffset n) -> if n < 0 @@ -401,7 +417,11 @@ let emit_instr fallthrough i = if !fastcode_flag then begin let lbl_redo = new_label() in `{emit_label lbl_redo}: subq ${emit_int n}, %r15\n`; - ` cmpq {emit_symbol "caml_young_limit"}(%rip), %r15\n`; + if !Clflags.dlcode then begin + ` {load_symbol_addr "caml_young_limit"}, %rax\n`; + ` cmpq (%rax), %r15\n`; + end else + ` cmpq {emit_symbol "caml_young_limit"}(%rip), %r15\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`; @@ -412,11 +432,11 @@ let emit_instr fallthrough i = 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` + 16 -> ` {emit_call "caml_alloc1"}\n` + | 24 -> ` {emit_call "caml_alloc2"}\n` + | 32 -> ` {emit_call "caml_alloc3"}\n` | _ -> ` movq ${emit_int n}, %rax\n`; - ` call {emit_symbol "caml_allocN"}\n` + ` {emit_call "caml_allocN"}\n` end; `{record_frame i.live Debuginfo.none} leaq 8(%r15), {emit_reg i.res.(0)}\n` end @@ -487,7 +507,7 @@ let emit_instr fallthrough i = | Lop(Ispecific(Istore_int(n, addr))) -> ` movq ${emit_nativeint n}, {emit_addressing addr i.arg 0}\n` | Lop(Ispecific(Istore_symbol(s, addr))) -> - assert (not !pic_code); + assert (not !pic_code && not !Clflags.dlcode); ` movq ${emit_symbol s}, {emit_addressing addr i.arg 0}\n` | Lop(Ispecific(Ioffset_loc(n, addr))) -> ` addq ${emit_int n}, {emit_addressing addr i.arg 0}\n` @@ -514,7 +534,7 @@ let emit_instr fallthrough i = ` cmpq {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; let b = name_for_cond_branch cmp in ` j{emit_string b} {emit_label lbl}\n` - | Iinttest_imm((Isigned Ceq | Isigned Cne | + | 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 @@ -548,7 +568,7 @@ let emit_instr fallthrough i = end | Lswitch jumptbl -> let lbl = new_label() in - if !pic_code then begin + if !pic_code || !Clflags.dlcode then begin (* PR#4424: r11 is known to be clobbered by the Lswitch, meaning that no variable that is live across the Lswitch is assigned to r11. However, the argument to Lswitch @@ -587,7 +607,7 @@ let emit_instr fallthrough i = stack_offset := !stack_offset - 16 | Lraise -> if !Clflags.debug then begin - ` call {emit_symbol "caml_raise_exn"}\n`; + ` {emit_call "caml_raise_exn"}\n`; record_frame Reg.Set.empty i.dbg end else begin ` movq %r14, %rsp\n`; @@ -619,7 +639,7 @@ let emit_profile () = ` pushq %r10\n`; ` movq %rsp, %rbp\n`; ` pushq %r11\n`; - ` call {emit_symbol "mcount"}\n`; + ` {emit_call "mcount"}\n`; ` popq %r11\n`; ` popq %r10\n` | _ -> @@ -693,6 +713,14 @@ let data l = (* Beginning / end of an assembly file *) let begin_assembly() = + if !Clflags.dlcode then begin + (* from amd64.S; could emit these constants on demand *) + ` .section .rodata.cst8,\"a\",@progbits\n`; + ` .align 16\n`; + `caml_negf_mask: .quad 0x8000000000000000, 0\n`; + ` .align 16\n`; + `caml_absf_mask: .quad 0x7FFFFFFFFFFFFFFF, 0xFFFFFFFFFFFFFFFF\n`; + end; let lbl_begin = Compilenv.make_symbol (Some "data_begin") in ` .data\n`; ` .globl {emit_symbol lbl_begin}\n`; @@ -724,4 +752,8 @@ let end_assembly() = 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) } + efa_string = (fun s -> emit_string_directive " .asciz " s) }; + if Config.system = "linux" then + (* Mark stack as non-executable, PR#4564 *) + ` .section .note.GNU-stack,\"\",%progbits\n` + diff --git a/asmcomp/amd64/emit_nt.mlp b/asmcomp/amd64/emit_nt.mlp index 874316b3..cbe7f122 100644 --- a/asmcomp/amd64/emit_nt.mlp +++ b/asmcomp/amd64/emit_nt.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit_nt.mlp,v 1.6.2.1 2007/10/09 14:03:01 xleroy Exp $ *) +(* $Id: emit_nt.mlp,v 1.7 2008/01/11 16:13:11 doligez Exp $ *) (* Emission of x86-64 (AMD 64) assembly code, MASM syntax *) diff --git a/asmcomp/amd64/proc.ml b/asmcomp/amd64/proc.ml index 473ef43c..f4cf2555 100644 --- a/asmcomp/amd64/proc.ml +++ b/asmcomp/amd64/proc.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: proc.ml,v 1.3 2007/01/29 12:10:50 xleroy Exp $ *) +(* $Id: proc.ml,v 1.5 2007/11/06 15:16:55 frisch Exp $ *) (* Description of the AMD64 processor *) @@ -170,7 +170,7 @@ let destroyed_at_oper = function | Iop(Istore(Single, _)) -> [| rxmm15 |] | Iop(Ialloc _ | Iintop(Icomp _) | Iintop_imm((Idiv|Imod|Icomp _), _)) -> [| rax |] - | Iswitch(_, _) when !pic_code -> [| r11 |] + | Iswitch(_, _) when !pic_code || !Clflags.dlcode -> [| r11 |] | _ -> [||] let destroyed_at_raise = all_phys_regs @@ -197,5 +197,5 @@ let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = - Ccomp.command ("as -o " ^ outfile ^ " " ^ infile) + Ccomp.command (Config.asm ^ " -o " ^ outfile ^ " " ^ infile) diff --git a/asmcomp/amd64/proc_nt.ml b/asmcomp/amd64/proc_nt.ml index 1119eebd..a8be92d7 100644 --- a/asmcomp/amd64/proc_nt.ml +++ b/asmcomp/amd64/proc_nt.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: proc_nt.ml,v 1.3 2006/05/09 16:00:57 xleroy Exp $ *) +(* $Id: proc_nt.ml,v 1.4 2007/10/30 12:37:16 xleroy Exp $ *) (* Description of the AMD64 processor with Win64 conventions *) @@ -228,10 +228,6 @@ let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = - Ccomp.command ("ml64 /nologo /Cp /c /Fo" ^ + Ccomp.command (Config.asm ^ 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 b3c1181f..dc8222a6 100644 --- a/asmcomp/amd64/reload.ml +++ b/asmcomp/amd64/reload.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: reload.ml,v 1.5 2007/01/29 12:10:50 xleroy Exp $ *) +(* $Id: reload.ml,v 1.6 2007/11/06 15:16:55 frisch Exp $ *) open Cmm open Arch @@ -93,7 +93,7 @@ method reload_operation op arg res = then (arg, res) else super#reload_operation op arg res | Iconst_symbol _ -> - if !pic_code + if !pic_code || !Clflags.dlcode then super#reload_operation op arg res else (arg, res) | _ -> (* Other operations: all args and results in registers *) diff --git a/asmcomp/amd64/selection.ml b/asmcomp/amd64/selection.ml index a20273cf..58bb8450 100644 --- a/asmcomp/amd64/selection.ml +++ b/asmcomp/amd64/selection.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: selection.ml,v 1.6 2007/02/09 13:31:14 doligez Exp $ *) +(* $Id: selection.ml,v 1.7 2007/11/06 15:16:55 frisch Exp $ *) (* Instruction selection for the AMD64 *) @@ -32,7 +32,7 @@ type addressing_expr = let rec select_addr exp = match exp with - Cconst_symbol s -> + Cconst_symbol s when not !Clflags.dlcode -> (Asymbol s, 0) | Cop((Caddi | Cadda), [arg; Cconst_int m]) -> let (a, n) = select_addr arg in (a, n + m) @@ -144,7 +144,7 @@ method select_store addr exp = (Ispecific(Istore_int(Nativeint.of_int n, addr)), Ctuple []) | Cconst_natpointer n when self#is_immediate_natint n -> (Ispecific(Istore_int(n, addr)), Ctuple []) - | Cconst_symbol s when not !pic_code -> + | Cconst_symbol s when not (!pic_code || !Clflags.dlcode) -> (Ispecific(Istore_symbol(s, addr)), Ctuple []) | _ -> super#select_store addr exp diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp index 7e017b56..73f5a38e 100644 --- a/asmcomp/arm/emit.mlp +++ b/asmcomp/arm/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp,v 1.18.18.1 2007/10/23 11:54:04 xleroy Exp $ *) +(* $Id: emit.mlp,v 1.19 2008/01/11 16:13:11 doligez Exp $ *) (* Emission of ARM assembly code *) diff --git a/asmcomp/arm/proc.ml b/asmcomp/arm/proc.ml index da1719a1..942a3a6e 100644 --- a/asmcomp/arm/proc.ml +++ b/asmcomp/arm/proc.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: proc.ml,v 1.8 2002/07/22 16:37:47 doligez Exp $ *) +(* $Id: proc.ml,v 1.9 2007/10/30 12:37:16 xleroy Exp $ *) (* Description of the ARM processor *) @@ -190,7 +190,8 @@ let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = - Sys.command ("as -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) + Ccomp.command (Config.asm ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) open Clflags;; open Config;; diff --git a/asmcomp/arm/selection.ml b/asmcomp/arm/selection.ml index aa462c81..40c100a0 100644 --- a/asmcomp/arm/selection.ml +++ b/asmcomp/arm/selection.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: selection.ml,v 1.6.36.1 2007/10/23 11:53:24 xleroy Exp $ *) +(* $Id: selection.ml,v 1.7 2008/01/11 16:13:11 doligez Exp $ *) (* Instruction selection for the ARM processor *) diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index 66d9eac8..f240ecf2 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: asmgen.ml,v 1.19 2000/04/21 08:10:25 weis Exp $ *) +(* $Id: asmgen.ml,v 1.22 2008/07/24 05:35:22 frisch Exp $ *) (* From lambda to assembly code *) @@ -83,7 +83,18 @@ let compile_phrase ppf p = | Cfunction fd -> compile_fundecl ppf fd | Cdata dl -> Emit.data dl -let compile_implementation prefixname ppf (size, lam) = + +(* For the native toplevel: generates generic functions unless + they are already available in the process *) +let compile_genfuns ppf f = + List.iter + (function + | (Cfunction {fun_name = name}) as ph when f name -> + compile_phrase ppf ph + | _ -> ()) + (Cmmgen.generic_functions true [Compilenv.current_unit_infos ()]) + +let compile_implementation ?toplevel prefixname ppf (size, lam) = let asmfile = if !keep_asm_file then prefixname ^ ext_asm @@ -95,6 +106,20 @@ let compile_implementation prefixname ppf (size, lam) = Closure.intro size lam ++ Cmmgen.compunit size ++ List.iter (compile_phrase ppf) ++ (fun () -> ()); + (match toplevel with None -> () | Some f -> compile_genfuns ppf f); + + (* We add explicit references to external primitive symbols. This + is to ensure that the object files that define these symbols, + when part of a C library, won't be discarded by the linker. + This is important if a module that uses such a symbol is later + dynlinked. *) + + compile_phrase ppf + (Cmmgen.reference_symbols + (List.filter (fun s -> s <> "" && s.[0] <> '%') + (List.map Primitive.native_name !Translmod.primitive_declarations)) + ); + Emit.end_assembly(); close_out oc with x -> diff --git a/asmcomp/asmgen.mli b/asmcomp/asmgen.mli index 94536e12..788e3263 100644 --- a/asmcomp/asmgen.mli +++ b/asmcomp/asmgen.mli @@ -10,11 +10,12 @@ (* *) (***********************************************************************) -(* $Id: asmgen.mli,v 1.7 2000/04/21 08:10:26 weis Exp $ *) +(* $Id: asmgen.mli,v 1.8 2007/11/06 15:16:55 frisch Exp $ *) (* From lambda to assembly code *) val compile_implementation : + ?toplevel:(string -> bool) -> string -> Format.formatter -> int * Lambda.lambda -> unit val compile_phrase : Format.formatter -> Cmm.phrase -> unit diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index 598722bc..8ec81f56 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: asmlink.ml,v 1.70.2.1 2007/11/10 12:23:37 xleroy Exp $ *) +(* $Id: asmlink.ml,v 1.78 2008/01/31 09:13:07 frisch Exp $ *) (* Link a set of .cmx/.o files and produce an executable *) @@ -70,14 +70,14 @@ let check_consistency file_name unit crc = with Not_found -> () end; Consistbl.set crc_implementations unit.ui_name crc file_name; - implementations_defined := + 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 -let extract_crc_implementations () = +let extract_crc_implementations () = List.fold_left (fun ncl n -> if List.mem_assoc n ncl then ncl else (n, cmx_not_found_crc) :: ncl) @@ -96,6 +96,30 @@ let add_ccobjs l = lib_ccopts := l.lib_ccopts @ !lib_ccopts end +let runtime_lib () = + let libname = + if !Clflags.gprofile + then "libasmrunp" ^ ext_lib + else "libasmrun" ^ ext_lib in + try + if !Clflags.nopervasives then [] + else [ find_in_path !load_path libname ] + with Not_found -> + raise(Error(File_not_found libname)) + +let object_file_name name = + let file_name = + try + find_in_path !load_path name + with Not_found -> + fatal_error "Asmlink.object_file_name: not found" in + if Filename.check_suffix file_name ".cmx" then + Filename.chop_suffix file_name ".cmx" ^ ext_obj + else if Filename.check_suffix file_name ".cmxa" then + Filename.chop_suffix file_name ".cmxa" ^ ext_lib + else + fatal_error "Asmlink.object_file_name: bad ext" + (* First pass: determine which units are needed *) let missing_globals = (Hashtbl.create 17 : (string, string list ref) Hashtbl.t) @@ -119,7 +143,11 @@ let extract_missing_globals () = Hashtbl.iter (fun md rq -> mg := (md, !rq) :: !mg) missing_globals; !mg -let scan_file obj_name tolink = +type file = + | Unit of string * Compilenv.unit_infos * Digest.t + | Library of string * Compilenv.library_infos + +let read_file obj_name = let file_name = try find_in_path !load_path obj_name @@ -129,45 +157,44 @@ let scan_file obj_name tolink = (* This is a .cmx file. It must be linked in any case. Read the infos to see which modules it requires. *) let (info, crc) = Compilenv.read_unit_info file_name in - remove_required info.ui_name; - List.iter (add_required file_name) info.ui_imports_cmx; - (info, file_name, crc) :: tolink + Unit (file_name,info,crc) end else if Filename.check_suffix file_name ".cmxa" then begin - (* This is an archive file. Each unit contained in it will be linked - in only if needed. *) - let ic = open_in_bin file_name in - let buffer = String.create (String.length cmxa_magic_number) in - really_input ic buffer 0 (String.length cmxa_magic_number); - if buffer <> cmxa_magic_number then - raise(Error(Not_an_object_file file_name)); - let infos = (input_value ic : library_infos) in - close_in ic; - add_ccobjs infos; - List.fold_right - (fun (info, crc) reqd -> - if info.ui_force_link - || !Clflags.link_everything - || is_required info.ui_name - then begin - remove_required info.ui_name; - List.iter (add_required (Printf.sprintf "%s(%s)" - file_name info.ui_name)) - info.ui_imports_cmx; - (info, file_name, crc) :: reqd - end else - reqd) - infos.lib_units tolink + let infos = + try Compilenv.read_library_info file_name + with Compilenv.Error(Not_a_unit_info _) -> + raise(Error(Not_an_object_file file_name)) + in + Library (file_name,infos) end else raise(Error(Not_an_object_file file_name)) -(* Second pass: generate the startup file and link it with everything else *) +let scan_file obj_name tolink = match read_file obj_name with + | Unit (file_name,info,crc) -> + (* This is a .cmx file. It must be linked in any case. *) + remove_required info.ui_name; + List.iter (add_required file_name) info.ui_imports_cmx; + (info, file_name, crc) :: tolink + | Library (file_name,infos) -> + (* This is an archive file. Each unit contained in it will be linked + in only if needed. *) + add_ccobjs infos; + List.fold_right + (fun (info, crc) reqd -> + if info.ui_force_link + || !Clflags.link_everything + || is_required info.ui_name + then begin + remove_required info.ui_name; + List.iter (add_required (Printf.sprintf "%s(%s)" + file_name info.ui_name)) + info.ui_imports_cmx; + (info, file_name, crc) :: reqd + end else + reqd) + infos.lib_units tolink -module IntSet = Set.Make( - struct - type t = int - let compare = compare - end) +(* Second pass: generate the startup file and link it with everything else *) let make_startup_file ppf filename units_list = let compile_phrase p = Asmgen.compile_phrase ppf p in @@ -179,126 +206,94 @@ let make_startup_file ppf filename units_list = let name_list = List.flatten (List.map (fun (info,_,_) -> info.ui_defines) units_list) in compile_phrase (Cmmgen.entry_point name_list); - let apply_functions = ref (IntSet.add 2 (IntSet.add 3 IntSet.empty)) in - (* The callback functions always reference caml_apply[23] *) - let send_functions = ref IntSet.empty in - let curry_functions = ref IntSet.empty in - List.iter - (fun (info,_,_) -> - List.iter - (fun n -> apply_functions := IntSet.add n !apply_functions) - info.ui_apply_fun; - List.iter - (fun n -> send_functions := IntSet.add n !send_functions) - info.ui_send_fun; - List.iter - (fun n -> curry_functions := IntSet.add n !curry_functions) - info.ui_curry_fun) - units_list; - IntSet.iter - (fun n -> compile_phrase (Cmmgen.apply_function n)) - !apply_functions; - IntSet.iter - (fun n -> compile_phrase (Cmmgen.send_function n)) - !send_functions; - IntSet.iter - (fun n -> List.iter (compile_phrase) (Cmmgen.curry_function n)) - !curry_functions; + let units = List.map (fun (info,_,_) -> info) units_list in + List.iter compile_phrase (Cmmgen.generic_functions false units); Array.iter (fun name -> compile_phrase (Cmmgen.predef_exception name)) Runtimedef.builtin_exceptions; compile_phrase (Cmmgen.global_table name_list); compile_phrase (Cmmgen.globals_map - (List.map - (fun (unit,_,_) -> - try (unit.ui_name, List.assoc unit.ui_name unit.ui_imports_cmi) - with Not_found -> assert false) - units_list)); + (List.map + (fun (unit,_,crc) -> + try (unit.ui_name, List.assoc unit.ui_name unit.ui_imports_cmi, + crc, + unit.ui_defines) + with Not_found -> assert false) + units_list)); compile_phrase(Cmmgen.data_segment_table ("_startup" :: name_list)); compile_phrase(Cmmgen.code_segment_table ("_startup" :: name_list)); compile_phrase (Cmmgen.frame_table("_startup" :: "_system" :: name_list)); + Emit.end_assembly(); close_out oc -let call_linker file_list startup_file output_name = - let libname = - if !Clflags.gprofile - then "libasmrunp" ^ ext_lib - else "libasmrun" ^ ext_lib in - let runtime_lib = - try - if !Clflags.nopervasives then None - else Some(find_in_path !load_path libname) - with Not_found -> - raise(Error(File_not_found libname)) in - let c_lib = - if !Clflags.nopervasives then "" else Config.native_c_libraries in - 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 - (if !Clflags.gprofile then Config.cc_profile else "") - (Filename.quote output_name) - (Clflags.std_include_flag "-I") - (String.concat " " (List.rev !Clflags.ccopts)) - (Filename.quote startup_file) - (Ccomp.quote_files (List.rev file_list)) - (Ccomp.quote_files - (List.map (fun dir -> if dir = "" then "" else "-L" ^ dir) - !load_path)) - (Ccomp.quote_files (List.rev !Clflags.ccobjs)) - (Ccomp.quote_optfile runtime_lib) - c_lib - else - Printf.sprintf "%s -o %s %s %s" - Config.native_partial_linker - (Filename.quote output_name) - (Filename.quote startup_file) - (Ccomp.quote_files (List.rev file_list)) - 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) - (Clflags.std_include_flag "-I") - (Filename.quote startup_file) - (Ccomp.quote_files (List.rev file_list)) - (Ccomp.quote_files - (List.rev_map Ccomp.expand_libname !Clflags.ccobjs)) - (Ccomp.quote_optfile runtime_lib) - c_lib - (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)) - in if Ccomp.command cmd <> 0 then raise(Error Linking_error) - end - | _ -> assert false +let make_shared_startup_file ppf units filename = + let compile_phrase p = Asmgen.compile_phrase ppf p in + let oc = open_out filename in + Emitaux.output_channel := oc; + Location.input_name := "caml_startup"; + Compilenv.reset "_shared_startup"; + Emit.begin_assembly(); + List.iter compile_phrase + (Cmmgen.generic_functions true (List.map fst units)); + compile_phrase (Cmmgen.plugin_header units); + compile_phrase + (Cmmgen.global_table + (List.map (fun (ui,_) -> ui.Compilenv.ui_symbol) units)); + (* this is to force a reference to all units, otherwise the linker + might drop some of them (in case of libraries) *) -let object_file_name name = - let file_name = - try - find_in_path !load_path name - with Not_found -> - fatal_error "Asmlink.object_file_name: not found" in - if Filename.check_suffix file_name ".cmx" then - Filename.chop_suffix file_name ".cmx" ^ ext_obj - else if Filename.check_suffix file_name ".cmxa" then - Filename.chop_suffix file_name ".cmxa" ^ ext_lib - else - fatal_error "Asmlink.object_file_name: bad ext" + Emit.end_assembly(); + close_out oc + + +let call_linker_shared file_list output_name = + if not (Ccomp.call_linker Ccomp.Dll output_name file_list "") + then raise(Error Linking_error) + +let link_shared ppf objfiles output_name = + let units_tolink = List.fold_right scan_file objfiles [] in + List.iter + (fun (info, file_name, crc) -> check_consistency file_name info crc) + units_tolink; + Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; + let objfiles = List.rev (List.map object_file_name objfiles) @ + !Clflags.ccobjs in + + let startup = + if !Clflags.keep_startup_file + then output_name ^ ".startup" ^ ext_asm + else Filename.temp_file "camlstartup" ext_asm in + make_shared_startup_file ppf + (List.map (fun (ui,_,crc) -> (ui,crc)) units_tolink) startup; + let startup_obj = output_name ^ ".startup" ^ ext_obj in + if Proc.assemble_file startup startup_obj <> 0 + then raise(Error(Assembler_error startup)); + if not !Clflags.keep_startup_file then remove_file startup; + call_linker_shared (startup_obj :: objfiles) output_name; + remove_file startup_obj + +let call_linker file_list startup_file output_name = + let main_dll = !Clflags.output_c_object + && Filename.check_suffix output_name Config.ext_dll + in + let files = startup_file :: (List.rev file_list) in + let files, c_lib = + if (not !Clflags.output_c_object) || main_dll then + files @ (List.rev !Clflags.ccobjs) @ runtime_lib (), + (if !Clflags.nopervasives then "" else Config.native_c_libraries) + else + files, "" + in + let mode = + if main_dll then Ccomp.MainDll + else if !Clflags.output_c_object then Ccomp.Partial + else Ccomp.Exe + in + if not (Ccomp.call_linker mode output_name files c_lib) + then raise(Error Linking_error) (* Main entry point *) @@ -322,7 +317,9 @@ let link ppf objfiles output_name = units_tolink; Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; Clflags.ccopts := !lib_ccopts @ !Clflags.ccopts; (* put user's opts first *) - let startup = Filename.temp_file "camlstartup" ext_asm in + let startup = + if !Clflags.keep_startup_file then output_name ^ ".startup" ^ ext_asm + else Filename.temp_file "camlstartup" ext_asm in make_startup_file ppf startup units_tolink; let startup_obj = Filename.temp_file "camlstartup" ext_obj in if Proc.assemble_file startup startup_obj <> 0 then diff --git a/asmcomp/asmlink.mli b/asmcomp/asmlink.mli index 90bc3674..77a0544e 100644 --- a/asmcomp/asmlink.mli +++ b/asmcomp/asmlink.mli @@ -10,14 +10,18 @@ (* *) (***********************************************************************) -(* $Id: asmlink.mli,v 1.11 2006/10/17 12:33:58 xleroy Exp $ *) +(* $Id: asmlink.mli,v 1.12 2007/11/06 15:16:55 frisch Exp $ *) -(* Link a set of .cmx/.o files and produce an executable *) +(* Link a set of .cmx/.o files and produce an executable or a plugin *) open Format val link: formatter -> string list -> string -> unit +val link_shared: formatter -> string list -> string -> unit + +val call_linker_shared: string list -> string -> unit + val check_consistency: string -> Compilenv.unit_infos -> Digest.t -> unit val extract_crc_interfaces: unit -> (string * Digest.t) list val extract_crc_implementations: unit -> (string * Digest.t) list diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index a13dc720..a4152d99 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: asmpackager.ml,v 1.24 2007/03/01 13:38:54 xleroy Exp $ *) +(* $Id: asmpackager.ml,v 1.26 2007/11/15 16:09:57 frisch Exp $ *) (* "Package" a set of .cmx/.o files into one .cmx/.o file having the original compilation units as sub-modules. *) @@ -80,10 +80,14 @@ let check_units members = (* Make the .o file for the package *) let make_package_object ppf members targetobj targetname coercion = - (* 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 + if !Clflags.keep_asm_file + then chop_extension_if_any targetobj ^ ".pack" ^ Config.ext_obj + else + (* 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 *) + Filename.temp_file (Compilenv.make_symbol (Some "")) Config.ext_obj in let components = List.map (fun m -> @@ -99,15 +103,11 @@ let make_package_object ppf members targetobj targetname coercion = List.map (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%s %s %s" - Config.native_pack_linker - (Filename.quote targetobj) - (Filename.quote objtemp) - (Ccomp.quote_files objfiles) in - let retcode = Ccomp.command ld_cmd in + let ok = + Ccomp.call_linker Ccomp.Partial targetobj (objtemp :: objfiles) "" + in remove_file objtemp; - if retcode <> 0 then raise(Error Linking_error) + if not ok then raise(Error Linking_error) (* Make the .cmx file for the package *) @@ -146,7 +146,7 @@ let build_package_cmx members cmxfile = ui_send_fun = union(List.map (fun info -> info.ui_send_fun) units); ui_force_link = - List.exists (fun info -> info.ui_force_link) units + List.exists (fun info -> info.ui_force_link) units; } in Compilenv.write_unit_info pkg_infos cmxfile diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml index 26f2208b..30405234 100644 --- a/asmcomp/closure.ml +++ b/asmcomp/closure.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: closure.ml,v 1.51 2007/02/09 13:31:14 doligez Exp $ *) +(* $Id: closure.ml,v 1.55 2008/08/01 12:52:14 xleroy Exp $ *) (* Introduction of closures, uncurrying, recognition of direct calls *) @@ -108,8 +108,8 @@ let prim_size prim args = | Parrayrefs kind -> if kind = Pgenarray then 18 else 8 | Parraysets kind -> if kind = Pgenarray then 22 else 10 | Pbittest -> 3 - | Pbigarrayref(ndims, _, _) -> 4 + ndims * 6 - | Pbigarrayset(ndims, _, _) -> 4 + ndims * 6 + | Pbigarrayref(_, ndims, _, _) -> 4 + ndims * 6 + | Pbigarrayset(_, ndims, _, _) -> 4 + ndims * 6 | _ -> 2 (* arithmetic and comparisons *) (* Very raw approximation of switch cost *) @@ -378,7 +378,7 @@ let rec is_pure = function | Lconst cst -> true | Lprim((Psetglobal _ | Psetfield _ | Psetfloatfield _ | Pduprecord _ | Pccall _ | Praise | Poffsetref _ | Pstringsetu | Pstringsets | - Parraysetu _ | Parraysets _), _) -> false + Parraysetu _ | Parraysets _ | Pbigarrayset _), _) -> false | Lprim(p, args) -> List.for_all is_pure args | Levent(lam, ev) -> is_pure lam | _ -> false @@ -492,7 +492,7 @@ let rec close fenv cenv = function end | Lfunction(kind, params, body) as funct -> close_one_function fenv cenv (Ident.create "fun") funct - | Lapply(funct, args) -> + | Lapply(funct, args, loc) -> let nargs = List.length args in begin match (close fenv cenv funct, close_list fenv cenv args) with ((ufunct, Value_closure(fundesc, approx_res)), @@ -767,7 +767,7 @@ and close_one_function fenv cenv id funct = and close_switch fenv cenv cases num_keys default = let index = Array.create num_keys 0 - and store = mk_store Pervasives.(=) in + and store = mk_store Lambda.same in (* First default case *) begin match default with diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index be89c2e3..e9041f06 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: cmmgen.ml,v 1.109 2007/02/22 12:13:00 xleroy Exp $ *) +(* $Id: cmmgen.ml,v 1.114 2008/08/05 13:35:20 xleroy Exp $ *) (* Translation from closed lambda to C-- *) @@ -180,8 +180,15 @@ let test_bool = function let box_float c = Cop(Calloc, [alloc_float_header; c]) -let unbox_float = function +let rec unbox_float = function Cop(Calloc, [header; c]) -> c + | Clet(id, exp, body) -> Clet(id, exp, unbox_float body) + | Cifthenelse(cond, e1, e2) -> + Cifthenelse(cond, unbox_float e1, unbox_float e2) + | Csequence(e1, e2) -> Csequence(e1, unbox_float e2) + | Cswitch(e, tbl, el) -> Cswitch(e, tbl, Array.map unbox_float el) + | Ccatch(n, ids, e1, e2) -> Ccatch(n, ids, unbox_float e1, unbox_float e2) + | Ctrywith(e1, id, e2) -> Ctrywith(unbox_float e1, id, unbox_float e2) | c -> Cop(Cload Double_u, [c]) (* Complex *) @@ -469,7 +476,7 @@ let box_int bi arg = Cconst_symbol(operations_boxed_int bi); arg']) -let unbox_int bi arg = +let rec unbox_int bi arg = match arg with Cop(Calloc, [hdr; ops; Cop(Clsl, [contents; Cconst_int 32])]) when bi = Pint32 && size_int = 8 && big_endian -> @@ -481,6 +488,13 @@ let unbox_int bi arg = Cop(Casr, [Cop(Clsl, [contents; Cconst_int 32]); Cconst_int 32]) | Cop(Calloc, [hdr; ops; contents]) -> contents + | Clet(id, exp, body) -> Clet(id, exp, unbox_int bi body) + | Cifthenelse(cond, e1, e2) -> + Cifthenelse(cond, unbox_int bi e1, unbox_int bi e2) + | Csequence(e1, e2) -> Csequence(e1, unbox_int bi e2) + | Cswitch(e, tbl, el) -> Cswitch(e, tbl, Array.map (unbox_int bi) el) + | Ccatch(n, ids, e1, e2) -> Ccatch(n, ids, unbox_int bi e1, unbox_int bi e2) + | Ctrywith(e1, id, e2) -> Ctrywith(unbox_int bi e1, id, unbox_int bi e2) | _ -> Cop(Cload(if bi = Pint32 then Thirtytwo_signed else Word), [Cop(Cadda, [arg; Cconst_int size_addr])]) @@ -507,23 +521,22 @@ let bigarray_elt_size = function | Pbigarray_complex32 -> 8 | Pbigarray_complex64 -> 16 -let bigarray_indexing elt_kind layout b args dbg = +let bigarray_indexing unsafe elt_kind layout b args dbg = + let check_bound a1 a2 k = + if unsafe then k else Csequence(Cop(Ccheckbound dbg, [a1;a2]), k) in let rec ba_indexing dim_ofs delta_ofs = function [] -> assert false | [arg] -> bind "idx" (untag_int arg) (fun idx -> - Csequence( - Cop(Ccheckbound dbg, [Cop(Cload Word,[field_address b dim_ofs]); idx]), - idx)) + check_bound (Cop(Cload Word,[field_address b dim_ofs])) idx idx) | arg1 :: argl -> let rem = ba_indexing (dim_ofs + delta_ofs) delta_ofs argl in bind "idx" (untag_int arg1) (fun idx -> bind "bound" (Cop(Cload Word, [field_address b dim_ofs])) (fun bound -> - Csequence(Cop(Ccheckbound dbg, [bound; idx]), - add_int (mul_int rem bound) idx))) in + check_bound bound idx (add_int (mul_int rem bound) idx))) in let offset = match layout with Pbigarray_unknown_layout -> @@ -555,33 +568,33 @@ let bigarray_word_kind = function | Pbigarray_complex32 -> Single | Pbigarray_complex64 -> Double -let bigarray_get elt_kind layout b args dbg = +let bigarray_get unsafe 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 dbg) (fun addr -> + bind "addr" (bigarray_indexing unsafe 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 dbg]) + [bigarray_indexing unsafe elt_kind layout b args dbg]) -let bigarray_set elt_kind layout b args newval dbg = +let bigarray_set unsafe 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 dbg) (fun addr -> + bind "addr" (bigarray_indexing unsafe 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 dbg; newval]) + [bigarray_indexing unsafe elt_kind layout b args dbg; newval]) (* Simplification of some primitives into C calls *) @@ -616,9 +629,9 @@ let simplif_primitive_32bits = function | Pbintcomp(Pint64, Lambda.Cgt) -> Pccall (default_prim "caml_greaterthan") | Pbintcomp(Pint64, Lambda.Cle) -> Pccall (default_prim "caml_lessequal") | Pbintcomp(Pint64, Lambda.Cge) -> Pccall (default_prim "caml_greaterequal") - | Pbigarrayref(n, Pbigarray_int64, layout) -> + | Pbigarrayref(unsafe, n, Pbigarray_int64, layout) -> Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) - | Pbigarrayset(n, Pbigarray_int64, layout) -> + | Pbigarrayset(unsafe, n, Pbigarray_int64, layout) -> Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) | p -> p @@ -626,13 +639,13 @@ let simplif_primitive p = match p with | Pduprecord _ -> Pccall (default_prim "caml_obj_dup") - | Pbigarrayref(n, Pbigarray_unknown, layout) -> + | Pbigarrayref(unsafe, n, Pbigarray_unknown, layout) -> Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) - | Pbigarrayset(n, Pbigarray_unknown, layout) -> + | Pbigarrayset(unsafe, n, Pbigarray_unknown, layout) -> Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) - | Pbigarrayref(n, kind, Pbigarray_unknown_layout) -> + | Pbigarrayref(unsafe, n, kind, Pbigarray_unknown_layout) -> Pccall (default_prim ("caml_ba_get_" ^ string_of_int n)) - | Pbigarrayset(n, kind, Pbigarray_unknown_layout) -> + | Pbigarrayset(unsafe, n, kind, Pbigarray_unknown_layout) -> Pccall (default_prim ("caml_ba_set_" ^ string_of_int n)) | p -> if size_int = 8 then p else simplif_primitive_32bits p @@ -729,11 +742,11 @@ let is_unboxed_number = function | Plslbint bi -> Boxed_integer bi | Plsrbint bi -> Boxed_integer bi | Pasrbint bi -> Boxed_integer bi - | Pbigarrayref(_, (Pbigarray_float32 | Pbigarray_float64), _) -> + | Pbigarrayref(_, _, (Pbigarray_float32 | Pbigarray_float64), _) -> Boxed_float - | Pbigarrayref(_, Pbigarray_int32, _) -> Boxed_integer Pint32 - | Pbigarrayref(_, Pbigarray_int64, _) -> Boxed_integer Pint64 - | Pbigarrayref(_, Pbigarray_native_int, _) -> Boxed_integer Pnativeint + | Pbigarrayref(_, _, Pbigarray_int32, _) -> Boxed_integer Pint32 + | Pbigarrayref(_, _, Pbigarray_int64, _) -> Boxed_integer Pint64 + | Pbigarrayref(_, _, Pbigarray_native_int, _) -> Boxed_integer Pnativeint | _ -> No_unboxing end | _ -> No_unboxing @@ -869,14 +882,9 @@ let rec transl = function box_float (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, dbg), + else + Cop(Cextcall(Primitive.native_name prim, typ_addr, prim.prim_alloc, dbg), List.map transl args) - end | (Pmakearray kind, []) -> transl_constant(Const_block(0, [])) | (Pmakearray kind, args) -> @@ -890,9 +898,9 @@ let rec transl = function make_float_alloc Obj.double_array_tag (List.map transl_unbox_float args) end - | (Pbigarrayref(num_dims, elt_kind, layout), arg1 :: argl) -> + | (Pbigarrayref(unsafe, num_dims, elt_kind, layout), arg1 :: argl) -> let elt = - bigarray_get elt_kind layout + bigarray_get unsafe elt_kind layout (transl arg1) (List.map transl argl) dbg in begin match elt_kind with Pbigarray_float32 | Pbigarray_float64 -> box_float elt @@ -903,9 +911,9 @@ let rec transl = function | Pbigarray_caml_int -> force_tag_int elt | _ -> tag_int elt end - | (Pbigarrayset(num_dims, elt_kind, layout), arg1 :: argl) -> + | (Pbigarrayset(unsafe, num_dims, elt_kind, layout), arg1 :: argl) -> let (argidx, argnewval) = split_last argl in - return_unit(bigarray_set elt_kind layout + return_unit(bigarray_set unsafe elt_kind layout (transl arg1) (List.map transl argidx) (match elt_kind with @@ -1927,6 +1935,36 @@ let curry_function arity = then intermediate_curry_functions arity 0 else [tuplify_function (-arity)] + +module IntSet = Set.Make( + struct + type t = int + let compare = compare + end) + +let default_apply = IntSet.add 2 (IntSet.add 3 IntSet.empty) + (* These apply funs are always present in the main program. + TODO: add more, and do the same for send and curry funs + (maybe up to 10-15?). *) + +let generic_functions shared units = + let (apply,send,curry) = + List.fold_left + (fun (apply,send,curry) ui -> + List.fold_right IntSet.add ui.Compilenv.ui_apply_fun apply, + List.fold_right IntSet.add ui.Compilenv.ui_send_fun send, + List.fold_right IntSet.add ui.Compilenv.ui_curry_fun curry) + (IntSet.empty,IntSet.empty,IntSet.empty) + units + in + let apply = + if shared then IntSet.diff apply default_apply + else IntSet.union apply default_apply + in + let accu = IntSet.fold (fun n accu -> apply_function n :: accu) apply [] in + let accu = IntSet.fold (fun n accu -> send_function n :: accu) send accu in + IntSet.fold (fun n accu -> curry_function n @ accu) curry accu + (* Generate the entry point *) let entry_point namelist = @@ -1961,10 +1999,16 @@ let global_table namelist = List.map mksym namelist @ [cint_zero]) -let globals_map namelist = - Cdata(Cglobal_symbol "caml_globals_map" :: - emit_constant "caml_globals_map" - (Const_base (Const_string (Marshal.to_string namelist []))) []) +let reference_symbols namelist = + let mksym name = Csymbol_address name in + Cdata(List.map mksym namelist) + +let global_data name v = + Cdata(Cglobal_symbol name :: + emit_constant name + (Const_base (Const_string (Marshal.to_string v []))) []) + +let globals_map v = global_data "caml_globals_map" v (* Generate the master table of frame descriptors *) @@ -2006,3 +2050,33 @@ let predef_exception name = Cint(block_header 0 1); Cdefine_symbol bucketname; Csymbol_address symname ]) + +(* Header for a plugin *) + +let mapflat f l = List.flatten (List.map f l) + +type dynunit = { + name: string; + crc: Digest.t; + imports_cmi: (string * Digest.t) list; + imports_cmx: (string * Digest.t) list; + defines: string list; +} + +type dynheader = { + magic: string; + units: dynunit list; +} + +let dyn_magic_number = "Caml2007D001" + +let plugin_header units = + let mk (ui,crc) = + { name = ui.Compilenv.ui_name; + crc = crc; + imports_cmi = ui.Compilenv.ui_imports_cmi; + imports_cmx = ui.Compilenv.ui_imports_cmx; + defines = ui.Compilenv.ui_defines + } in + global_data "caml_plugin_header" + { magic = dyn_magic_number; units = List.map mk units } diff --git a/asmcomp/cmmgen.mli b/asmcomp/cmmgen.mli index 4c6fb0d4..a1804f50 100644 --- a/asmcomp/cmmgen.mli +++ b/asmcomp/cmmgen.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: cmmgen.mli,v 1.14 2007/02/15 18:36:08 frisch Exp $ *) +(* $Id: cmmgen.mli,v 1.16 2008/01/31 09:13:08 frisch Exp $ *) (* Translation from closed lambda to C-- *) @@ -19,10 +19,14 @@ val compunit: int -> Clambda.ulambda -> Cmm.phrase list val apply_function: int -> Cmm.phrase val send_function: int -> Cmm.phrase val curry_function: int -> Cmm.phrase list +val generic_functions: bool -> Compilenv.unit_infos list -> Cmm.phrase list val entry_point: string list -> Cmm.phrase val global_table: string list -> Cmm.phrase -val globals_map: (string * string) list -> Cmm.phrase +val reference_symbols: string list -> Cmm.phrase +val globals_map: (string * Digest.t * Digest.t * string list) list -> + Cmm.phrase val frame_table: string list -> Cmm.phrase val data_segment_table: string list -> Cmm.phrase val code_segment_table: string list -> Cmm.phrase val predef_exception: string -> Cmm.phrase +val plugin_header: (Compilenv.unit_infos * Digest.t) list -> Cmm.phrase diff --git a/asmcomp/compilenv.ml b/asmcomp/compilenv.ml index 447a46fb..35b327c7 100644 --- a/asmcomp/compilenv.ml +++ b/asmcomp/compilenv.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: compilenv.ml,v 1.23 2006/10/17 12:33:58 xleroy Exp $ *) +(* $Id: compilenv.ml,v 1.24 2007/11/06 15:16:55 frisch Exp $ *) (* Compilation environments for compilation units *) @@ -126,6 +126,17 @@ let read_unit_info filename = close_in ic; raise(Error(Corrupted_unit_info(filename))) +let read_library_info filename = + let ic = open_in_bin filename in + let buffer = String.create (String.length cmxa_magic_number) in + really_input ic buffer 0 (String.length cmxa_magic_number); + if buffer <> cmxa_magic_number then + raise(Error(Not_a_unit_info filename)); + let infos = (input_value ic : library_infos) in + close_in ic; + infos + + (* Read and cache info on global identifiers *) let cmx_not_found_crc = @@ -160,10 +171,18 @@ let cache_unit_info ui = (* Return the approximation of a global identifier *) +let toplevel_approx = Hashtbl.create 16 + +let record_global_approx_toplevel id = + Hashtbl.add toplevel_approx current_unit.ui_name current_unit.ui_approx + let global_approx id = - match get_global_info id with - | None -> Value_unknown - | Some ui -> ui.ui_approx + if Ident.is_predef_exn id then Value_unknown + else try Hashtbl.find toplevel_approx (Ident.name id) + with Not_found -> + match get_global_info id with + | None -> Value_unknown + | Some ui -> ui.ui_approx (* Return the symbol used to refer to a global identifier *) diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli index 425f4e14..5d47fc3d 100644 --- a/asmcomp/compilenv.mli +++ b/asmcomp/compilenv.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: compilenv.mli,v 1.16 2006/10/17 12:33:58 xleroy Exp $ *) +(* $Id: compilenv.mli,v 1.17 2007/11/06 15:16:55 frisch Exp $ *) (* Compilation environments for compilation units *) @@ -70,6 +70,9 @@ val global_approx: Ident.t -> Clambda.value_approximation (* Return the approximation for the given global identifier *) val set_global_approx: Clambda.value_approximation -> unit (* Record the approximation of the unit being compiled *) +val record_global_approx_toplevel: unit -> unit + (* Record the current approximation for the current toplevel phrase *) + val need_curry_fun: int -> unit val need_apply_fun: int -> unit @@ -77,6 +80,7 @@ val need_send_fun: int -> unit (* Record the need of a currying (resp. application, message sending) function with the given arity *) + val read_unit_info: string -> unit_infos * Digest.t (* Read infos and CRC from a [.cmx] file. *) val write_unit_info: unit_infos -> string -> unit @@ -92,6 +96,8 @@ val cmx_not_found_crc: Digest.t (* Special digest used in the [ui_imports_cmx] list to signal that no [.cmx] file was found and used for the imported unit *) +val read_library_info: string -> library_infos + type error = Not_a_unit_info of string | Corrupted_unit_info of string @@ -100,3 +106,5 @@ type error = exception Error of error val report_error: Format.formatter -> error -> unit + + diff --git a/asmcomp/hppa/proc.ml b/asmcomp/hppa/proc.ml index 58b07743..02a76499 100644 --- a/asmcomp/hppa/proc.ml +++ b/asmcomp/hppa/proc.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: proc.ml,v 1.7 2004/05/09 15:19:16 xleroy Exp $ *) +(* $Id: proc.ml,v 1.8 2007/10/30 12:37:16 xleroy Exp $ *) (* Description of the HP PA-RISC processor *) @@ -217,7 +217,8 @@ let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = - Ccomp.command ("as -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) + Ccomp.command (Config.asm ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) open Clflags;; open Config;; diff --git a/asmcomp/hppa/reload.ml b/asmcomp/hppa/reload.ml index 056f8494..0016a90a 100644 --- a/asmcomp/hppa/reload.ml +++ b/asmcomp/hppa/reload.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: reload.ml,v 1.3.38.1 2007/12/20 08:53:03 xleroy Exp $ *) +(* $Id: reload.ml,v 1.4 2008/01/11 16:13:11 doligez Exp $ *) (* Reloading for the HPPA *) diff --git a/asmcomp/hppa/selection.ml b/asmcomp/hppa/selection.ml index 8efdd3d2..1119730b 100644 --- a/asmcomp/hppa/selection.ml +++ b/asmcomp/hppa/selection.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: selection.ml,v 1.5.38.1 2007/10/25 09:08:20 xleroy Exp $ *) +(* $Id: selection.ml,v 1.6 2008/01/11 16:13:11 doligez Exp $ *) (* Instruction selection for the HPPA processor *) diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp index ba6e795d..2ce4edca 100644 --- a/asmcomp/i386/emit.mlp +++ b/asmcomp/i386/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp,v 1.38.4.2 2007/10/09 13:54:27 xleroy Exp $ *) +(* $Id: emit.mlp,v 1.41 2008/08/01 08:04:57 xleroy Exp $ *) (* Emission of Intel 386 assembly code *) @@ -35,7 +35,7 @@ let stack_offset = ref 0 (* Layout of the stack frame *) let frame_size () = (* includes return address *) - let sz = + let sz = !stack_offset + 4 * num_stack_slots.(0) + 8 * num_stack_slots.(1) + 4 in Misc.align sz stack_alignment @@ -116,12 +116,12 @@ let emit_align = (fun n -> ` .align {emit_int n}\n`) | _ -> (fun n -> ` .align {emit_int(Misc.log2 n)}\n`) - + let emit_Llabel fallthrough lbl = if not fallthrough && !fastcode_flag then emit_align 16 ; emit_label lbl - + (* Output a pseudo-register *) let emit_reg = function @@ -299,7 +299,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 = @@ -737,7 +737,7 @@ let emit_instr fallthrough i = ` cmpl {emit_reg i.arg.(1)}, {emit_reg i.arg.(0)}\n`; let b = name_for_cond_branch cmp in ` j{emit_string b} {emit_label lbl}\n` - | Iinttest_imm((Isigned Ceq | Isigned Cne | + | 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 @@ -986,4 +986,7 @@ let end_assembly() = if use_ascii_dir then emit_string_directive " .ascii " s else emit_bytes_directive " .byte " s) }; - if macosx then emit_external_symbols () + if macosx then emit_external_symbols (); + if Config.system = "linux_elf" then + (* Mark stack as non-executable, PR#4564 *) + `\n .section .note.GNU-stack,\"\",%progbits\n` diff --git a/asmcomp/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp index 80d874d1..8cf816ac 100644 --- a/asmcomp/i386/emit_nt.mlp +++ b/asmcomp/i386/emit_nt.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit_nt.mlp,v 1.27.4.1 2007/10/09 14:04:05 xleroy Exp $ *) +(* $Id: emit_nt.mlp,v 1.28 2008/01/11 16:13:11 doligez Exp $ *) (* Emission of Intel 386 assembly code, MASM syntax. *) diff --git a/asmcomp/i386/proc.ml b/asmcomp/i386/proc.ml index a27b1802..b4a7dda5 100644 --- a/asmcomp/i386/proc.ml +++ b/asmcomp/i386/proc.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: proc.ml,v 1.13 2007/02/09 13:31:14 doligez Exp $ *) +(* $Id: proc.ml,v 1.14 2007/10/30 12:37:16 xleroy Exp $ *) (* Description of the Intel 386 processor *) @@ -181,7 +181,8 @@ let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = - Ccomp.command ("as -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) + Ccomp.command (Config.asm ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) open Clflags;; open Config;; diff --git a/asmcomp/i386/proc_nt.ml b/asmcomp/i386/proc_nt.ml index 9d690513..45b360ee 100644 --- a/asmcomp/i386/proc_nt.ml +++ b/asmcomp/i386/proc_nt.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: proc_nt.ml,v 1.5.26.1 2007/10/09 14:11:26 xleroy Exp $ *) +(* $Id: proc_nt.ml,v 1.8 2008/01/11 16:13:11 doligez Exp $ *) (* Description of the Intel 386 processor, for Windows NT *) @@ -181,9 +181,6 @@ let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = - Ccomp.command ("ml /nologo /coff /Cp /c /Fo" ^ - Filename.quote outfile ^ " " ^ Filename.quote infile ^ ">NUL") - (* /Cp preserve case of all used identifiers - /c assemble only - /Fo output file name *) - + Ccomp.command (Config.asm ^ + Filename.quote outfile ^ " " ^ Filename.quote infile ^ + (if !Clflags.verbose then "" else ">NUL")) diff --git a/asmcomp/ia64/proc.ml b/asmcomp/ia64/proc.ml index 6c0738c2..ba773d46 100644 --- a/asmcomp/ia64/proc.ml +++ b/asmcomp/ia64/proc.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: proc.ml,v 1.5 2002/07/22 16:37:52 doligez Exp $ *) +(* $Id: proc.ml,v 1.6 2007/10/30 12:37:16 xleroy Exp $ *) (* Description of the IA64 processor *) @@ -210,7 +210,8 @@ let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = - Ccomp.command ("as -xexplicit -o " ^ Filename.quote outfile ^ " " ^ Filename.quote infile) + Ccomp.command (Config.asm ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) open Clflags;; open Config;; diff --git a/asmcomp/mips/proc.ml b/asmcomp/mips/proc.ml index 16acfc99..96221140 100644 --- a/asmcomp/mips/proc.ml +++ b/asmcomp/mips/proc.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: proc.ml,v 1.6 2002/07/22 16:37:52 doligez Exp $ *) +(* $Id: proc.ml,v 1.7 2007/10/30 12:37:16 xleroy Exp $ *) (* Description of the Mips processor *) @@ -202,10 +202,9 @@ let contains_calls = ref false (* Calling the assembler *) -let asm_command = "as -n32 -O2 -nocpp -g0 -o " - let assemble_file infile outfile = - Ccomp.command (asm_command ^ Filename.quote outfile ^ " " ^ Filename.quote infile) + Ccomp.command (Config.asm ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) open Clflags;; open Config;; diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp index d1d397ec..e9c12fee 100644 --- a/asmcomp/power/emit.mlp +++ b/asmcomp/power/emit.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emit.mlp,v 1.23.4.1 2007/05/10 16:41:12 xleroy Exp $ *) +(* $Id: emit.mlp,v 1.26 2007/11/09 15:06:57 frisch Exp $ *) (* Emission of PowerPC assembly code *) diff --git a/asmcomp/power/proc.ml b/asmcomp/power/proc.ml index 75dea545..5b540d94 100644 --- a/asmcomp/power/proc.ml +++ b/asmcomp/power/proc.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: proc.ml,v 1.13 2006/05/31 08:16:34 xleroy Exp $ *) +(* $Id: proc.ml,v 1.14 2007/10/30 12:37:16 xleroy Exp $ *) (* Description of the Power PC *) @@ -234,16 +234,8 @@ let contains_calls = ref false (* Calling the assembler *) let assemble_file infile outfile = - let infile = Filename.quote infile - and outfile = Filename.quote outfile in - match Config.system with - | "elf" -> - Ccomp.command ("as -u -m ppc -o " ^ outfile ^ " " ^ infile) - | "rhapsody" -> - Ccomp.command ("as -arch " ^ Config.model ^ " -o " ^ outfile ^ " " ^ infile) - | "bsd" -> - Ccomp.command ("as -o " ^ outfile ^ " " ^ infile) - | _ -> assert false + Ccomp.command (Config.asm ^ " -o " ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) open Clflags;; open Config;; diff --git a/asmcomp/power/selection.ml b/asmcomp/power/selection.ml index 141d348a..622e84c2 100644 --- a/asmcomp/power/selection.ml +++ b/asmcomp/power/selection.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: selection.ml,v 1.6 2004/06/19 16:13:33 xleroy Exp $ *) +(* $Id: selection.ml,v 1.8 2007/11/09 15:06:57 frisch Exp $ *) (* Instruction selection for the Power PC processor *) diff --git a/asmcomp/sparc/proc.ml b/asmcomp/sparc/proc.ml index 82131d73..8127fc45 100644 --- a/asmcomp/sparc/proc.ml +++ b/asmcomp/sparc/proc.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: proc.ml,v 1.7 2002/11/29 15:03:08 xleroy Exp $ *) +(* $Id: proc.ml,v 1.8 2007/10/30 12:37:16 xleroy Exp $ *) (* Description of the Sparc processor *) @@ -206,9 +206,10 @@ let contains_calls = ref false (* Calling the assembler and the archiver *) let assemble_file infile outfile = - let asprefix = begin match !arch_version with - SPARC_V7 -> "as -o " - | SPARC_V8 -> "as -xarch=v8 -o " - | SPARC_V9 -> "as -xarch=v8plus -o " + let asflags = begin match !arch_version with + SPARC_V7 -> " -o " + | SPARC_V8 -> " -xarch=v8 -o " + | SPARC_V9 -> " -xarch=v8plus -o " end in - Ccomp.command (asprefix ^ Filename.quote outfile ^ " " ^ Filename.quote infile) + Ccomp.command (Config.asm ^ asflags ^ + Filename.quote outfile ^ " " ^ Filename.quote infile) diff --git a/asmrun/.depend b/asmrun/.depend index ec447ee7..25c67763 100644 --- a/asmrun/.depend +++ b/asmrun/.depend @@ -16,9 +16,10 @@ array.o: array.c ../byterun/alloc.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 -backtrace.o: backtrace.c ../byterun/backtrace.h ../byterun/mlvalues.h \ +backtrace.o: backtrace.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/backtrace.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 \ @@ -117,8 +118,10 @@ 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 + ../byterun/gc_ctrl.h ../byterun/misc.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h gc_ctrl.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ @@ -137,7 +140,9 @@ globroots.o: globroots.c ../byterun/memory.h ../byterun/config.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 + ../byterun/mlvalues.h ../byterun/roots.h ../byterun/misc.h \ + ../byterun/memory.h ../byterun/globroots.h ../byterun/mlvalues.h \ + ../byterun/roots.h hash.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/config.h ../byterun/custom.h ../byterun/mlvalues.h \ @@ -260,6 +265,17 @@ misc.o: misc.c ../byterun/config.h ../byterun/../config/m.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 +natdynlink.o: natdynlink.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/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 \ + ../byterun/callback.h ../byterun/mlvalues.h ../byterun/alloc.h \ + ../byterun/misc.h ../byterun/mlvalues.h natdynlink.h \ + ../byterun/osdeps.h ../byterun/misc.h ../byterun/fail.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 \ @@ -293,7 +309,7 @@ roots.o: roots.c ../byterun/finalise.h ../byterun/roots.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 + ../byterun/roots.h stack.h signals.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ @@ -322,9 +338,13 @@ startup.o: startup.c ../byterun/callback.h ../byterun/mlvalues.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/misc.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/osdeps.h ../byterun/misc.h \ ../byterun/printexc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/sys.h ../byterun/misc.h + ../byterun/sys.h ../byterun/misc.h natdynlink.h str.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ @@ -384,9 +404,10 @@ array.d.o: array.c ../byterun/alloc.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 -backtrace.d.o: backtrace.c ../byterun/backtrace.h ../byterun/mlvalues.h \ +backtrace.d.o: backtrace.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/backtrace.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 \ @@ -485,8 +506,10 @@ 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 + ../byterun/gc_ctrl.h ../byterun/misc.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h gc_ctrl.d.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ @@ -505,7 +528,9 @@ globroots.d.o: globroots.c ../byterun/memory.h ../byterun/config.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 + ../byterun/mlvalues.h ../byterun/roots.h ../byterun/misc.h \ + ../byterun/memory.h ../byterun/globroots.h ../byterun/mlvalues.h \ + ../byterun/roots.h hash.d.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/config.h ../byterun/custom.h ../byterun/mlvalues.h \ @@ -628,6 +653,17 @@ misc.d.o: misc.c ../byterun/config.h ../byterun/../config/m.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 +natdynlink.d.o: natdynlink.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/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 \ + ../byterun/callback.h ../byterun/mlvalues.h ../byterun/alloc.h \ + ../byterun/misc.h ../byterun/mlvalues.h natdynlink.h \ + ../byterun/osdeps.h ../byterun/misc.h ../byterun/fail.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 \ @@ -661,7 +697,7 @@ roots.d.o: roots.c ../byterun/finalise.h ../byterun/roots.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 + ../byterun/roots.h stack.h signals.d.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ @@ -690,9 +726,13 @@ startup.d.o: startup.c ../byterun/callback.h ../byterun/mlvalues.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/misc.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/osdeps.h ../byterun/misc.h \ ../byterun/printexc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/sys.h ../byterun/misc.h + ../byterun/sys.h ../byterun/misc.h natdynlink.h str.d.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ @@ -752,9 +792,10 @@ array.p.o: array.c ../byterun/alloc.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 -backtrace.p.o: backtrace.c ../byterun/backtrace.h ../byterun/mlvalues.h \ +backtrace.p.o: backtrace.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ - ../byterun/misc.h ../byterun/config.h ../byterun/memory.h \ + ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ + ../byterun/backtrace.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 \ @@ -853,8 +894,10 @@ 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 + ../byterun/gc_ctrl.h ../byterun/misc.h ../byterun/memory.h \ + ../byterun/config.h ../byterun/gc.h ../byterun/major_gc.h \ + ../byterun/freelist.h ../byterun/misc.h ../byterun/minor_gc.h \ + ../byterun/misc.h ../byterun/misc.h ../byterun/mlvalues.h gc_ctrl.p.o: gc_ctrl.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ @@ -873,7 +916,9 @@ globroots.p.o: globroots.c ../byterun/memory.h ../byterun/config.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 + ../byterun/mlvalues.h ../byterun/roots.h ../byterun/misc.h \ + ../byterun/memory.h ../byterun/globroots.h ../byterun/mlvalues.h \ + ../byterun/roots.h hash.p.o: hash.c ../byterun/mlvalues.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/misc.h \ ../byterun/config.h ../byterun/custom.h ../byterun/mlvalues.h \ @@ -996,6 +1041,17 @@ misc.p.o: misc.c ../byterun/config.h ../byterun/../config/m.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 +natdynlink.p.o: natdynlink.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/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 \ + ../byterun/callback.h ../byterun/mlvalues.h ../byterun/alloc.h \ + ../byterun/misc.h ../byterun/mlvalues.h natdynlink.h \ + ../byterun/osdeps.h ../byterun/misc.h ../byterun/fail.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 \ @@ -1029,7 +1085,7 @@ roots.p.o: roots.c ../byterun/finalise.h ../byterun/roots.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 + ../byterun/roots.h stack.h signals.p.o: signals.c ../byterun/alloc.h ../byterun/misc.h \ ../byterun/config.h ../byterun/../config/m.h ../byterun/../config/s.h \ ../byterun/mlvalues.h ../byterun/config.h ../byterun/misc.h \ @@ -1058,9 +1114,13 @@ startup.p.o: startup.c ../byterun/callback.h ../byterun/mlvalues.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/misc.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/osdeps.h ../byterun/misc.h \ ../byterun/printexc.h ../byterun/misc.h ../byterun/mlvalues.h \ - ../byterun/sys.h ../byterun/misc.h + ../byterun/sys.h ../byterun/misc.h natdynlink.h str.p.o: str.c ../byterun/alloc.h ../byterun/misc.h ../byterun/config.h \ ../byterun/../config/m.h ../byterun/../config/s.h ../byterun/mlvalues.h \ ../byterun/config.h ../byterun/misc.h ../byterun/fail.h \ diff --git a/asmrun/Makefile b/asmrun/Makefile index 27e9a9fc..bc7cca2b 100644 --- a/asmrun/Makefile +++ b/asmrun/Makefile @@ -11,13 +11,13 @@ # # ######################################################################### -# $Id: Makefile,v 1.56 2007/02/23 09:29:45 xleroy Exp $ +# $Id: Makefile,v 1.59 2007/11/15 13:21:15 frisch Exp $ include ../config/Makefile CC=$(NATIVECC) FLAGS=-I../byterun -DCAML_NAME_SPACE -DNATIVE_CODE \ - -DTARGET_$(ARCH) -DSYS_$(SYSTEM) + -DTARGET_$(ARCH) -DSYS_$(SYSTEM) $(IFLEXDIR) CFLAGS=$(FLAGS) -O $(NATIVECCCOMPOPTS) DFLAGS=$(FLAGS) -g -DDEBUG $(NATIVECCCOMPOPTS) PFLAGS=$(FLAGS) -pg -O -DPROFILING $(NATIVECCPROFOPTS) @@ -26,7 +26,7 @@ COBJS=startup.o main.o fail.o roots.o globroots.o signals.o signals_asm.o \ misc.o freelist.o major_gc.o minor_gc.o memory.o alloc.o compare.o ints.o \ floats.o str.o array.o io.o extern.o intern.o hash.o sys.o parsing.o \ gc_ctrl.o terminfo.o md5.o obj.o lexing.o printexc.o callback.o weak.o \ - compact.o finalise.o custom.o unix.o backtrace.o + compact.o finalise.o custom.o unix.o backtrace.o natdynlink.o ASMOBJS=$(ARCH).o @@ -155,11 +155,11 @@ clean:: .SUFFIXES: .S .d.o .p.o .S.o: - $(ASPP) $(ASPPFLAGS) -o $*.o $*.S || \ + $(ASPP) -DSYS_$(SYSTEM) -o $*.o $*.S || \ { echo "If your assembler produced syntax errors, it is probably unhappy with the"; echo "preprocessor. Check your assembler, or try producing $*.o by hand."; exit 2; } .S.p.o: - $(ASPP) $(ASPPFLAGS) $(ASPPPROFFLAGS) -o $*.p.o $*.S + $(ASPP) -DSYS_$(SYSTEM) $(ASPPPROFFLAGS) -o $*.p.o $*.S .c.d.o: @ if test -f $*.o; then mv $*.o $*.f.o; else :; fi @@ -174,10 +174,10 @@ clean:: @ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi .s.o: - $(ASPP) $(ASPPFLAGS) -o $*.o $*.s + $(ASPP) -DSYS_$(SYSTEM) -o $*.o $*.s .s.p.o: - $(ASPP) $(ASPPFLAGS) $(ASPPPROFFLAGS) -o $*.p.o $*.s + $(ASPP) -DSYS_$(SYSTEM) $(ASPPPROFFLAGS) -o $*.p.o $*.s clean:: rm -f *.o *.a *~ diff --git a/asmrun/Makefile.nt b/asmrun/Makefile.nt index 8bfce2ff..c9b6061e 100644 --- a/asmrun/Makefile.nt +++ b/asmrun/Makefile.nt @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.23 2007/02/23 09:29:45 xleroy Exp $ +# $Id: Makefile.nt,v 1.28 2007/11/15 13:21:15 frisch Exp $ include ../config/Makefile @@ -24,7 +24,7 @@ COBJS=startup.$(O) main.$(O) fail.$(O) roots.$(O) signals.$(O) signals_asm.$(O) intern.$(O) hash.$(O) sys.$(O) parsing.$(O) gc_ctrl.$(O) terminfo.$(O) \ md5.$(O) obj.$(O) lexing.$(O) win32.$(O) printexc.$(O) callback.$(O) \ weak.$(O) compact.$(O) finalise.$(O) custom.$(O) globroots.$(O) \ - backtrace.$(O) + backtrace.$(O) natdynlink.$(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 \ @@ -46,10 +46,10 @@ libasmrun.$(A): $(OBJS) $(call MKLIB,libasmrun.$(A), $(OBJS)) i386nt.obj: i386nt.asm - ml /nologo /coff /Cp /c /Foi386nt.obj i386nt.asm + $(ASM)i386nt.obj i386nt.asm amd64nt.obj: amd64nt.asm - ml64 /nologo /Cp /c /Foamd64nt.obj amd64nt.asm + $(ASM)amd64nt.obj amd64nt.asm i386.o: i386.S $(CC) -c -DSYS_$(SYSTEM) i386.S @@ -62,7 +62,7 @@ $(LINKEDFILES): %.c: ../byterun/%.c # Need special compilation rule so as not to do -I../byterun win32.$(O): ../byterun/win32.c - $(CC) -c $(NATIVECCCOMPOPTS) -DNATIVE_CODE ../byterun/win32.c + $(CC) -c $(NATIVECCCOMPOPTS) -DNATIVE_CODE $(IFLEXDIR) ../byterun/win32.c .SUFFIXES: .c .$(O) diff --git a/asmrun/amd64.S b/asmrun/amd64.S index 8707e9de..6af0c54c 100644 --- a/asmrun/amd64.S +++ b/asmrun/amd64.S @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: amd64.S,v 1.11 2007/01/29 12:10:52 xleroy Exp $ */ +/* $Id: amd64.S,v 1.12 2008/08/01 08:04:57 xleroy Exp $ */ /* Asm part of the runtime system, AMD64 processor */ /* Must be preprocessed by cpp */ @@ -366,3 +366,8 @@ caml_negf_mask: .align 16 caml_absf_mask: .quad 0x7FFFFFFFFFFFFFFF, 0xFFFFFFFFFFFFFFFF + +#if defined(SYS_linux) + /* Mark stack as non-executable, PR#4564 */ + .section .note.GNU-stack,"",%progbits +#endif diff --git a/asmrun/arm.S b/asmrun/arm.S index da036506..985868eb 100644 --- a/asmrun/arm.S +++ b/asmrun/arm.S @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: arm.S,v 1.15.18.1 2008/02/20 12:25:17 xleroy Exp $ */ +/* $Id: arm.S,v 1.16 2008/02/29 14:21:21 doligez Exp $ */ /* Asm part of the runtime system, ARM processor */ diff --git a/asmrun/backtrace.c b/asmrun/backtrace.c index 07d7f6f7..61e8d360 100644 --- a/asmrun/backtrace.c +++ b/asmrun/backtrace.c @@ -11,11 +11,12 @@ /* */ /***********************************************************************/ -/* $Id: backtrace.c,v 1.2.4.1 2007/10/10 08:34:34 xleroy Exp $ */ +/* $Id: backtrace.c,v 1.4 2008/03/14 13:47:13 xleroy Exp $ */ /* Stack backtrace for uncaught exceptions */ #include +#include "alloc.h" #include "backtrace.h" #include "memory.h" #include "misc.h" @@ -28,12 +29,29 @@ code_t * caml_backtrace_buffer = NULL; value caml_backtrace_last_exn = Val_unit; #define BACKTRACE_BUFFER_SIZE 1024 -/* Initialize the backtrace machinery */ +/* Start or stop the backtrace machinery */ -void caml_init_backtrace(void) +CAMLprim value caml_record_backtrace(value vflag) { - caml_backtrace_active = 1; - caml_register_global_root(&caml_backtrace_last_exn); + int flag = Int_val(vflag); + + if (flag != caml_backtrace_active) { + caml_backtrace_active = flag; + caml_backtrace_pos = 0; + if (flag) { + caml_register_global_root(&caml_backtrace_last_exn); + } else { + caml_remove_global_root(&caml_backtrace_last_exn); + } + } + return Val_unit; +} + +/* Return the status of the backtrace machinery */ + +CAMLprim value caml_backtrace_status(value vunit) +{ + return Val_bool(caml_backtrace_active); } /* Store the return addresses contained in the given stack fragment @@ -95,18 +113,31 @@ void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp) } } -/* Print a backtrace */ +/* Extract location information for the given frame descriptor */ -static void print_location(int index, frame_descr * d) +struct loc_info { + int loc_valid; + int loc_is_raise; + char * loc_filename; + int loc_lnum; + int loc_startchr; + int loc_endchr; +}; + +static void extract_location_info(frame_descr * d, + /*out*/ struct loc_info * li) { uintnat infoptr; - uint32 info1, info2, k, n, l, a, b; - char * kind; + uint32 info1, info2; /* 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; + if ((d->frame_size & 1) == 0) { + li->loc_valid = 0; + li->loc_is_raise = 1; + return; + } /* Recover debugging info */ infoptr = ((uintnat) d + sizeof(char *) + sizeof(short) + sizeof(short) + @@ -123,27 +154,72 @@ static void print_location(int index, frame_descr * d) 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); + li->loc_valid = 1; + li->loc_is_raise = (info1 & 3) != 0; + li->loc_filename = (char *) infoptr + (info1 & 0x3FFFFFC); + li->loc_lnum = info2 >> 12; + li->loc_startchr = (info2 >> 4) & 0xFF; + li->loc_endchr = ((info2 & 0xF) << 6) | (info1 >> 26); +} + +static void print_location(struct loc_info * li, int index) +{ + char * info; + + /* Ignore compiler-inserted raise */ + if (!li->loc_valid) return; if (index == 0) - kind = "Raised at"; - else if (k == 1) - kind = "Re-raised at"; + info = "Raised at"; + else if (li->loc_is_raise) + info = "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); + info = "Called from"; + fprintf (stderr, "%s file \"%s\", line %d, characters %d-%d\n", + info, li->loc_filename, li->loc_lnum, + li->loc_startchr, li->loc_endchr); } +/* Print a backtrace */ + void caml_print_exception_backtrace(void) { int i; + struct loc_info li; + + for (i = 0; i < caml_backtrace_pos; i++) { + extract_location_info((frame_descr *) (caml_backtrace_buffer[i]), &li); + print_location(&li, i); + } +} - for (i = 0; i < caml_backtrace_pos; i++) - print_location(i, (frame_descr *) caml_backtrace_buffer[i]); +/* Convert the backtrace to a data structure usable from Caml */ + +CAMLprim value caml_get_exception_backtrace(value unit) +{ + CAMLparam0(); + CAMLlocal4(res, arr, p, fname); + int i; + struct loc_info li; + + arr = caml_alloc(caml_backtrace_pos, 0); + for (i = 0; i < caml_backtrace_pos; i++) { + extract_location_info((frame_descr *) (caml_backtrace_buffer[i]), &li); + if (li.loc_valid) { + fname = caml_copy_string(li.loc_filename); + p = caml_alloc_small(5, 0); + Field(p, 0) = Val_bool(li.loc_is_raise); + Field(p, 1) = fname; + Field(p, 2) = Val_int(li.loc_lnum); + Field(p, 3) = Val_int(li.loc_startchr); + Field(p, 4) = Val_int(li.loc_endchr); + } else { + p = caml_alloc_small(1, 1); + Field(p, 0) = Val_bool(li.loc_is_raise); + } + caml_modify(&Field(arr, i), p); + } + res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ + CAMLreturn(res); } + diff --git a/asmrun/fail.c b/asmrun/fail.c index 954ab667..9cc5db24 100644 --- a/asmrun/fail.c +++ b/asmrun/fail.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: fail.c,v 1.38 2006/11/28 15:45:24 doligez Exp $ */ +/* $Id: fail.c,v 1.40 2008/09/18 11:23:28 xleroy Exp $ */ /* Raising exceptions from C. */ @@ -94,6 +94,21 @@ void caml_raise_with_arg(value tag, value arg) CAMLnoreturn; } +void caml_raise_with_args(value tag, int nargs, value args[]) +{ + CAMLparam1 (tag); + CAMLxparamN (args, nargs); + value bucket; + int i; + + Assert(1 + nargs <= Max_young_wosize); + bucket = caml_alloc_small (1 + nargs, 0); + Field(bucket, 0) = tag; + for (i = 0; i < nargs; i++) Field(bucket, 1 + i) = args[i]; + caml_raise(bucket); + CAMLnoreturn; +} + void caml_raise_with_string(value tag, char const *msg) { caml_raise_with_arg(tag, caml_copy_string(msg)); @@ -170,14 +185,23 @@ static struct { char data[BOUND_MSG_LEN + sizeof(value)]; } array_bound_error_msg = { 0, BOUND_MSG }; +static int array_bound_error_bucket_inited = 0; + void caml_array_bound_error(void) { - mlsize_t wosize = (BOUND_MSG_LEN + sizeof(value)) / sizeof(value); - mlsize_t offset_index = Bsize_wsize(wosize) - 1; - array_bound_error_msg.hdr = Make_header(wosize, String_tag, Caml_white); - array_bound_error_msg.data[offset_index] = offset_index - BOUND_MSG_LEN; - array_bound_error_bucket.hdr = Make_header(2, 0, Caml_white); - array_bound_error_bucket.exn = (value) caml_exn_Invalid_argument; - array_bound_error_bucket.arg = (value) array_bound_error_msg.data; + if (! array_bound_error_bucket_inited) { + mlsize_t wosize = (BOUND_MSG_LEN + sizeof(value)) / sizeof(value); + mlsize_t offset_index = Bsize_wsize(wosize) - 1; + array_bound_error_msg.hdr = Make_header(wosize, String_tag, Caml_white); + array_bound_error_msg.data[offset_index] = offset_index - BOUND_MSG_LEN; + array_bound_error_bucket.hdr = Make_header(2, 0, Caml_white); + array_bound_error_bucket.exn = (value) caml_exn_Invalid_argument; + array_bound_error_bucket.arg = (value) array_bound_error_msg.data; + array_bound_error_bucket_inited = 1; + caml_page_table_add(In_static_data, + &array_bound_error_msg, + &array_bound_error_msg + 1); + array_bound_error_bucket_inited = 1; + } caml_raise((value) &array_bound_error_bucket.exn); } diff --git a/asmrun/i386.S b/asmrun/i386.S index c34f17a3..8aecc504 100644 --- a/asmrun/i386.S +++ b/asmrun/i386.S @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: i386.S,v 1.48.4.1 2007/10/09 13:32:25 xleroy Exp $ */ +/* $Id: i386.S,v 1.50 2008/08/01 08:04:57 xleroy Exp $ */ /* Asm part of the runtime system, Intel 386 processor */ /* Must be preprocessed by cpp */ @@ -424,3 +424,8 @@ Lmcount$stub: hlt ; hlt ; hlt ; hlt ; hlt .subsections_via_symbols #endif + +#if defined(SYS_linux_elf) + /* Mark stack as non-executable, PR#4564 */ + .section .note.GNU-stack,"",%progbits +#endif diff --git a/asmrun/natdynlink.c b/asmrun/natdynlink.c new file mode 100644 index 00000000..84cfb590 --- /dev/null +++ b/asmrun/natdynlink.c @@ -0,0 +1,126 @@ +#include "misc.h" +#include "mlvalues.h" +#include "memory.h" +#include "stack.h" +#include "callback.h" +#include "alloc.h" +#include "natdynlink.h" +#include "osdeps.h" +#include "fail.h" + +#include +#include + +static void *getsym(void *handle, char *module, char *name){ + char *fullname = malloc(strlen(module) + strlen(name) + 5); + void *sym; + sprintf(fullname, "caml%s%s", module, name); + sym = caml_dlsym (handle, fullname); + /* printf("%s => %lx\n", fullname, (uintnat) sym); */ + free(fullname); + return sym; +} + +extern char caml_globals_map[]; + +CAMLprim value caml_natdynlink_getmap(value unit) +{ + return (value)caml_globals_map; +} + +CAMLprim value caml_natdynlink_globals_inited(value unit) +{ + return Val_int(caml_globals_inited); +} + +CAMLprim value caml_natdynlink_open(value filename, value global) +{ + CAMLparam1 (filename); + CAMLlocal1 (res); + void *sym; + void *handle; + + /* TODO: dlclose in case of error... */ + + handle = caml_dlopen(String_val(filename), 1, Int_val(global)); + + if (NULL == handle) + CAMLreturn(caml_copy_string(caml_dlerror())); + + sym = caml_dlsym(handle, "caml_plugin_header"); + if (NULL == sym) + CAMLreturn(caml_copy_string("not an OCaml plugin")); + + res = caml_alloc_tuple(2); + Field(res, 0) = (value) handle; + Field(res, 1) = (value) (sym); + CAMLreturn(res); +} + +CAMLprim value caml_natdynlink_run(void *handle, value symbol) { + CAMLparam1 (symbol); + CAMLlocal1 (result); + void *sym,*sym2; + +#define optsym(n) getsym(handle,unit,n) + char *unit; + void (*entrypoint)(void); + + unit = String_val(symbol); + + sym = optsym("__frametable"); + if (NULL != sym) caml_register_frametable(sym); + + sym = optsym(""); + if (NULL != sym) caml_register_dyn_global(sym); + + sym = optsym("__data_begin"); + sym2 = optsym("__data_end"); + if (NULL != sym && NULL != sym2) + caml_page_table_add(In_static_data, sym, sym2); + + sym = optsym("__code_begin"); + sym2 = optsym("__code_end"); + if (NULL != sym && NULL != sym2) + caml_page_table_add(In_code_area, sym, sym2); + + entrypoint = optsym("__entry"); + if (NULL != entrypoint) result = caml_callback((value)(&entrypoint), 0); + else result = Val_unit; + +#undef optsym + + CAMLreturn (result); +} + +CAMLprim value caml_natdynlink_run_toplevel(value filename, value symbol) +{ + CAMLparam2 (filename, symbol); + CAMLlocal2 (res, v); + void *handle; + + /* TODO: dlclose in case of error... */ + + handle = caml_dlopen(String_val(filename), 1, 1); + + if (NULL == handle) { + res = caml_alloc(1,1); + v = caml_copy_string(caml_dlerror()); + Store_field(res, 0, v); + } else { + res = caml_alloc(1,0); + v = caml_natdynlink_run(handle, symbol); + Store_field(res, 0, v); + } + CAMLreturn(res); +} + +CAMLprim value caml_natdynlink_loadsym(value symbol) +{ + CAMLparam1 (symbol); + CAMLlocal1 (sym); + + sym = (value) caml_globalsym(String_val(symbol)); + if (!sym) caml_failwith(String_val(symbol)); + CAMLreturn(sym); +} diff --git a/asmrun/natdynlink.h b/asmrun/natdynlink.h new file mode 100644 index 00000000..e69de29b diff --git a/asmrun/roots.c b/asmrun/roots.c index d35e7634..b375cf43 100644 --- a/asmrun/roots.c +++ b/asmrun/roots.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: roots.c,v 1.41.2.2 2008/02/20 12:18:13 xleroy Exp $ */ +/* $Id: roots.c,v 1.45 2008/03/10 19:56:39 xleroy Exp $ */ /* To walk the memory roots for garbage collection */ @@ -24,6 +24,8 @@ #include "mlvalues.h" #include "stack.h" #include "roots.h" +#include +#include /* Roots registered from C functions */ @@ -36,6 +38,37 @@ void (*caml_scan_roots_hook) (scanning_action) = NULL; frame_descr ** caml_frame_descriptors = NULL; int caml_frame_descriptors_mask; +/* Linked-list */ + +typedef struct link { + void *data; + struct link *next; +} link; + +static link *cons(void *data, link *tl) { + link *lnk = caml_stat_alloc(sizeof(link)); + lnk->data = data; + lnk->next = tl; + return lnk; +} + +#define iter_list(list,lnk) \ + for (lnk = list; lnk != NULL; lnk = lnk->next) + +/* Linked-list of frametables */ + +static link *frametables = NULL; + +void caml_register_frametable(intnat *table) { + frametables = cons(table,frametables); + + if (NULL != caml_frame_descriptors) { + caml_stat_free(caml_frame_descriptors); + caml_frame_descriptors = NULL; + /* force caml_init_frame_descriptors to be called */ + } +} + void caml_init_frame_descriptors(void) { intnat num_descr, tblsize, i, j, len; @@ -43,11 +76,21 @@ void caml_init_frame_descriptors(void) frame_descr * d; uintnat nextd; uintnat h; + link *lnk; + + static int inited = 0; + + if (!inited) { + for (i = 0; caml_frametable[i] != 0; i++) + caml_register_frametable(caml_frametable[i]); + inited = 1; + } /* Count the frame descriptors */ num_descr = 0; - for (i = 0; caml_frametable[i] != 0; i++) - num_descr += *(caml_frametable[i]); + iter_list(frametables,lnk) { + num_descr += *((intnat*) lnk->data); + } /* The size of the hashtable is a power of 2 greater or equal to 2 times the number of descriptors */ @@ -61,8 +104,8 @@ void caml_init_frame_descriptors(void) caml_frame_descriptors_mask = tblsize - 1; /* Fill the hash table */ - for (i = 0; caml_frametable[i] != 0; i++) { - tbl = caml_frametable[i]; + iter_list(frametables,lnk) { + tbl = (intnat*) lnk->data; len = *tbl; d = (frame_descr *)(tbl + 1); for (j = 0; j < len; j++) { @@ -89,6 +132,11 @@ uintnat caml_last_return_address = 1; /* not in Caml code initially */ value * caml_gc_regs; intnat caml_globals_inited = 0; static intnat caml_globals_scanned = 0; +static link * caml_dyn_globals = NULL; + +void caml_register_dyn_global(void *v) { + caml_dyn_globals = cons((void*) v,caml_dyn_globals); +} /* Call [caml_oldify_one] on (at least) all the roots that point to the minor heap. */ @@ -107,8 +155,8 @@ void caml_oldify_local_roots (void) #endif value glob; value * root; - struct global_root * gr; struct caml__roots_block *lr; + link *lnk; /* The global roots */ for (i = caml_globals_scanned; @@ -121,6 +169,14 @@ void caml_oldify_local_roots (void) } caml_globals_scanned = caml_globals_inited; + /* Dynamic global roots */ + iter_list(caml_dyn_globals, lnk) { + glob = (value) lnk->data; + for (j = 0; j < Wosize_val(glob); j++){ + Oldify (&Field (glob, j)); + } + } + /* The stack and local roots */ if (caml_frame_descriptors == NULL) caml_init_frame_descriptors(); sp = caml_bottom_of_stack; @@ -181,13 +237,11 @@ void caml_oldify_local_roots (void) } } /* Global C roots */ - for (gr = caml_global_roots.forward[0]; gr != NULL; gr = gr->forward[0]) { - Oldify (gr->root); - } + caml_scan_global_young_roots(&caml_oldify_one); /* Finalised values */ caml_final_do_young_roots (&caml_oldify_one); /* Hook */ - if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(caml_oldify_one); + if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(&caml_oldify_one); } /* Call [darken] on all roots */ @@ -201,7 +255,7 @@ void caml_do_roots (scanning_action f) { int i, j; value glob; - struct global_root * gr; + link *lnk; /* The global roots */ for (i = 0; caml_globals[i] != 0; i++) { @@ -209,14 +263,21 @@ void caml_do_roots (scanning_action f) for (j = 0; j < Wosize_val(glob); j++) f (Field (glob, j), &Field (glob, j)); } + + /* Dynamic global roots */ + iter_list(caml_dyn_globals, lnk) { + glob = (value) lnk->data; + for (j = 0; j < Wosize_val(glob); j++){ + f (Field (glob, j), &Field (glob, j)); + } + } + /* The stack and local roots */ 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 */ - for (gr = caml_global_roots.forward[0]; gr != NULL; gr = gr->forward[0]) { - f(*(gr->root), gr->root); - } + caml_scan_global_roots(f); /* Finalised values */ caml_final_do_strong_roots (f); /* Hook */ diff --git a/asmrun/signals_asm.c b/asmrun/signals_asm.c index 4e51a9ed..d0b6e9cf 100644 --- a/asmrun/signals_asm.c +++ b/asmrun/signals_asm.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: signals_asm.c,v 1.2.2.1 2007/11/06 12:26:15 xleroy Exp $ */ +/* $Id: signals_asm.c,v 1.6 2008/01/11 16:13:11 doligez Exp $ */ /* Signal handling, code specific to the native-code compiler */ @@ -47,9 +47,10 @@ extern void caml_win32_overflow_detection(); 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) +#define Is_in_code_area(pc) \ + ( ((char *)(pc) >= caml_code_area_start && \ + (char *)(pc) <= caml_code_area_end) \ + || (Classify_addr(pc) & In_code_area) ) /* This routine is the common entry point for garbage collection and signal handling. It can trigger a callback to Caml code. @@ -84,7 +85,7 @@ DECLARE_SIGNAL_HANDLER(handle_signal) 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)) + if (Is_in_code_area(CONTEXT_PC)) CONTEXT_YOUNG_LIMIT = (context_reg) caml_young_limit; #endif } @@ -190,7 +191,7 @@ DECLARE_SIGNAL_HANDLER(segv_handler) && fault_addr < system_stack_top && fault_addr >= system_stack_top - limit.rlim_cur - 0x2000 #ifdef CONTEXT_PC - && In_code_area(CONTEXT_PC) + && Is_in_code_area(CONTEXT_PC) #endif ) { /* Turn this into a Stack_overflow exception */ diff --git a/asmrun/signals_osdep.h b/asmrun/signals_osdep.h index 95c33adc..7f32583c 100644 --- a/asmrun/signals_osdep.h +++ b/asmrun/signals_osdep.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: signals_osdep.h,v 1.8.4.5 2007/11/26 16:58:51 doligez Exp $ */ +/* $Id: signals_osdep.h,v 1.11 2008/01/11 16:13:11 doligez Exp $ */ /* Processor- and OS-dependent signal interface */ @@ -124,26 +124,26 @@ static void name(int sig, siginfo_t * info, void * context) #include - #include + #include #ifdef __LP64__ #define SET_SIGACT(sigact,name) \ sigact.sa_sigaction = (name); \ sigact.sa_flags = SA_SIGINFO | SA_64REGSET - + typedef unsigned long long context_reg; - + #define CONTEXT_MCONTEXT (((ucontext64_t *)context)->uc_mcontext64) #else #define SET_SIGACT(sigact,name) \ sigact.sa_sigaction = (name); \ sigact.sa_flags = SA_SIGINFO - + typedef unsigned long context_reg; - + #define CONTEXT_MCONTEXT (((ucontext_t *)context)->uc_mcontext) #endif - + #if !defined(MAC_OS_X_VERSION_10_5) || MAC_OS_X_VERSION_MIN_REQUIRED < MAC_OS_X_VERSION_10_5 #define CONTEXT_REG(r) r #else diff --git a/asmrun/stack.h b/asmrun/stack.h index fca1faf2..82b41758 100644 --- a/asmrun/stack.h +++ b/asmrun/stack.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: stack.h,v 1.34 2007/02/15 18:35:20 frisch Exp $ */ +/* $Id: stack.h,v 1.35 2007/11/06 15:16:55 frisch Exp $ */ /* Machine-dependent interface with the asm code */ @@ -114,6 +114,8 @@ extern int caml_frame_descriptors_mask; (((uintnat)(addr) >> 3) & caml_frame_descriptors_mask) extern void caml_init_frame_descriptors(void); +extern void caml_register_frametable(intnat *); +extern void caml_register_dyn_global(void *); /* Declaration of variables used in the asm code */ extern char * caml_bottom_of_stack; @@ -124,5 +126,4 @@ extern value caml_globals[]; extern intnat caml_globals_inited; extern intnat * caml_frametable[]; - #endif /* CAML_STACK_H */ diff --git a/asmrun/startup.c b/asmrun/startup.c index 9155b5bb..19eda78f 100644 --- a/asmrun/startup.c +++ b/asmrun/startup.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: startup.c,v 1.33 2007/01/29 12:10:52 xleroy Exp $ */ +/* $Id: startup.c,v 1.36 2008/03/14 13:47:13 xleroy Exp $ */ /* Start-up code */ @@ -23,44 +23,52 @@ #include "fail.h" #include "gc.h" #include "gc_ctrl.h" +#include "memory.h" #include "misc.h" #include "mlvalues.h" #include "osdeps.h" #include "printexc.h" #include "sys.h" +#include "natdynlink.h" #ifdef HAS_UI #include "ui.h" #endif extern int caml_parser_trace; -header_t caml_atom_table[256]; -char * caml_static_data_start, * caml_static_data_end; +CAMLexport header_t caml_atom_table[256]; char * caml_code_area_start, * caml_code_area_end; /* Initialize the atom table and the static data and code area limits. */ struct segment { char * begin; char * end; }; -static void minmax_table(struct segment *table, char **min, char **max) -{ - int i; - *min = table[0].begin; - *max = table[0].end; - for (i = 1; table[i].begin != 0; i++) { - if (table[i].begin < *min) *min = table[i].begin; - if (table[i].end > *max) *max = table[i].end; - } -} - static void init_atoms(void) { - int i; extern struct segment caml_data_segments[], caml_code_segments[]; + int i; - for (i = 0; i < 256; i++) caml_atom_table[i] = Make_header(0, i, Caml_white); - minmax_table(caml_data_segments, - &caml_static_data_start, &caml_static_data_end); - minmax_table(caml_code_segments, &caml_code_area_start, &caml_code_area_end); + for (i = 0; i < 256; i++) { + caml_atom_table[i] = Make_header(0, i, Caml_white); + } + if (caml_page_table_add(In_static_data, + caml_atom_table, caml_atom_table + 256) != 0) + caml_fatal_error("Fatal error: not enough memory for the initial page table"); + + for (i = 0; caml_data_segments[i].begin != 0; i++) { + if (caml_page_table_add(In_static_data, + caml_data_segments[i].begin, + caml_data_segments[i].end) != 0) + caml_fatal_error("Fatal error: not enough memory for the initial page table"); + } + + caml_code_area_start = caml_code_segments[0].begin; + caml_code_area_end = caml_code_segments[0].end; + for (i = 1; caml_code_segments[i].begin != 0; i++) { + if (caml_code_segments[i].begin < caml_code_area_start) + caml_code_area_start = caml_code_segments[i].begin; + if (caml_code_segments[i].end > caml_code_area_end) + caml_code_area_end = caml_code_segments[i].end; + } } /* Configuration parameters and flags */ @@ -111,7 +119,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 'b': caml_record_backtrace(Val_true); break; case 'p': caml_parser_trace = 1; break; } } diff --git a/boot/ocamlc b/boot/ocamlc index 29b8cdeb..9246af41 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamldep b/boot/ocamldep index b5c48aa1..61bbe7d5 100755 Binary files a/boot/ocamldep and b/boot/ocamldep differ diff --git a/boot/ocamllex b/boot/ocamllex index 2897bf2a..8be5a7bf 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 index fb9120fe..fd428724 100755 --- a/build/boot-c-parts-windows.sh +++ b/build/boot-c-parts-windows.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id: boot-c-parts-windows.sh,v 1.2.4.3 2007/03/12 11:58:48 pouillar Exp $ +# $Id: boot-c-parts-windows.sh,v 1.3 2007/10/08 14:19:34 doligez Exp $ cd `dirname $0`/.. set -ex diff --git a/build/boot-c-parts.sh b/build/boot-c-parts.sh index eacb4488..9cb0262a 100755 --- a/build/boot-c-parts.sh +++ b/build/boot-c-parts.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id: boot-c-parts.sh,v 1.1.4.3 2007/03/12 11:58:48 pouillar Exp $ +# $Id: boot-c-parts.sh,v 1.2 2007/10/08 14:19:34 doligez Exp $ cd `dirname $0`/.. set -ex diff --git a/build/boot.sh b/build/boot.sh index ffbfc336..ee910808 100755 --- a/build/boot.sh +++ b/build/boot.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id: boot.sh,v 1.1.4.3 2007/05/14 13:59:36 pouillar Exp $ +# $Id: boot.sh,v 1.2 2007/10/08 14:19:34 doligez Exp $ cd `dirname $0`/.. set -ex TAGLINE='true: -use_stdlib' diff --git a/build/camlp4-bootstrap.sh b/build/camlp4-bootstrap.sh index f931f14a..10475dfb 100755 --- a/build/camlp4-bootstrap.sh +++ b/build/camlp4-bootstrap.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id: camlp4-bootstrap.sh,v 1.2.2.2 2007/03/26 12:55:33 pouillar Exp $ +# $Id: camlp4-bootstrap.sh,v 1.3 2007/10/08 14:19:34 doligez Exp $ set -e cd `dirname $0`/.. diff --git a/build/camlp4-byte-only.sh b/build/camlp4-byte-only.sh index 220e51bf..2caf64c6 100755 --- a/build/camlp4-byte-only.sh +++ b/build/camlp4-byte-only.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id: camlp4-byte-only.sh,v 1.2.4.3 2007/03/12 11:58:48 pouillar Exp $ +# $Id: camlp4-byte-only.sh,v 1.3 2007/10/08 14:19:34 doligez Exp $ set -e OCAMLBUILD_PARTIAL="true" export OCAMLBUILD_PARTIAL diff --git a/build/camlp4-native-only.sh b/build/camlp4-native-only.sh index e3d49e9b..8ad48048 100755 --- a/build/camlp4-native-only.sh +++ b/build/camlp4-native-only.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id: camlp4-native-only.sh,v 1.2.4.4 2007/03/12 11:58:48 pouillar Exp $ +# $Id: camlp4-native-only.sh,v 1.3 2007/10/08 14:19:34 doligez Exp $ set -e OCAMLBUILD_PARTIAL="true" export OCAMLBUILD_PARTIAL diff --git a/build/camlp4-targets.sh b/build/camlp4-targets.sh index 53edde4a..b158d19e 100644 --- a/build/camlp4-targets.sh +++ b/build/camlp4-targets.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id: camlp4-targets.sh,v 1.1.4.2 2007/03/12 11:58:48 pouillar Exp $ +# $Id: camlp4-targets.sh,v 1.2 2007/10/08 14:19:34 doligez Exp $ CAMLP4_COMMON="\ camlp4/Camlp4/Camlp4Ast.partial.ml \ camlp4/boot/camlp4boot.byte" diff --git a/build/distclean.sh b/build/distclean.sh index e564efa7..16c9b20f 100755 --- a/build/distclean.sh +++ b/build/distclean.sh @@ -1,5 +1,19 @@ #!/bin/sh -# $Id: distclean.sh,v 1.4.2.6 2007/12/18 09:03:12 ertai Exp $ + +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2007 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +# $Id: distclean.sh,v 1.7 2008/01/11 16:13:16 doligez Exp $ + cd `dirname $0`/.. set -ex (cd byterun && make clean) || : @@ -18,7 +32,7 @@ rm -f driver/main.byte driver/optmain.byte lex/main.byte \ camlp4/build/location.mli \ tools/myocamlbuild_config.ml camlp4/build/linenum.mli \ camlp4/build/linenum.mll \ - camlp4/build/terminfo.mli camlp4/build/terminfo.ml + camlp4/build/terminfo.mli camlp4/build/terminfo.ml # from ocamlbuild bootstrap rm -f ocamlbuild/_log ocamlbuild/,ocamlbuild.byte.start \ diff --git a/build/fastworld.sh b/build/fastworld.sh index 7d1d7bd3..4a82407e 100755 --- a/build/fastworld.sh +++ b/build/fastworld.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id: fastworld.sh,v 1.2.4.2 2007/03/12 11:58:48 pouillar Exp $ +# $Id: fastworld.sh,v 1.3 2007/10/08 14:19:34 doligez Exp $ cd `dirname $0` set -e ./mkconfig.sh diff --git a/build/install.sh b/build/install.sh index 5d2a100a..34d63845 100755 --- a/build/install.sh +++ b/build/install.sh @@ -1,5 +1,19 @@ #!/bin/sh -# $Id: install.sh,v 1.6.2.16 2007/11/27 13:27:48 ertai Exp $ + +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2007 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +# $Id: install.sh,v 1.11 2008/08/05 13:05:23 ertai Exp $ + set -e cd `dirname $0`/.. @@ -153,6 +167,7 @@ installdir \ stdlib/arrayLabels.cmi stdlib/arrayLabels.mli \ stdlib/buffer.cmi stdlib/buffer.mli \ stdlib/callback.cmi stdlib/callback.mli \ + stdlib/camlinternalLazy.cmi stdlib/camlinternalLazy.mli \ stdlib/camlinternalMod.cmi stdlib/camlinternalMod.mli \ stdlib/camlinternalOO.cmi stdlib/camlinternalOO.mli \ stdlib/char.cmi stdlib/char.mli \ @@ -196,6 +211,7 @@ installdir \ stdlib/arrayLabels.cmx stdlib/arrayLabels.p.cmx stdlib/arrayLabels.$O stdlib/arrayLabels.p.$O \ stdlib/buffer.cmx stdlib/buffer.p.cmx stdlib/buffer.$O stdlib/buffer.p.$O \ stdlib/callback.cmx stdlib/callback.p.cmx stdlib/callback.$O stdlib/callback.p.$O \ + stdlib/camlinternalLazy.cmx stdlib/camlinternalLazy.p.cmx stdlib/camlinternalLazy.$O stdlib/camlinternalLazy.p.$O \ stdlib/camlinternalMod.cmx stdlib/camlinternalMod.p.cmx stdlib/camlinternalMod.$O stdlib/camlinternalMod.p.$O \ stdlib/camlinternalOO.cmx stdlib/camlinternalOO.p.cmx stdlib/camlinternalOO.$O stdlib/camlinternalOO.p.$O \ stdlib/char.cmx stdlib/char.p.cmx stdlib/char.$O stdlib/char.p.$O \ diff --git a/build/mkconfig.sh b/build/mkconfig.sh index 00730de9..41dc2ab8 100755 --- a/build/mkconfig.sh +++ b/build/mkconfig.sh @@ -1,10 +1,11 @@ #!/bin/sh -# $Id: mkconfig.sh,v 1.1.4.4 2007/05/14 12:01:32 xleroy Exp $ +# $Id: mkconfig.sh,v 1.3 2007/11/06 15:16:56 frisch Exp $ cd `dirname $0`/.. sed -e 's/^\(.*\$([0-9]).*\)$/# \1/' \ -e 's/\$(\([^)]*\))/${\1}/g' \ + -e 's/^FLEX.*$//g' \ -e 's/^\([^#=]*\)=\([^"]*\)$/if [ "x$\1" = "x" ]; then \1="\2"; fi/' \ config/Makefile > config/config.sh diff --git a/build/mkmyocamlbuild_config.sh b/build/mkmyocamlbuild_config.sh index 3668353c..f64e954f 100755 --- a/build/mkmyocamlbuild_config.sh +++ b/build/mkmyocamlbuild_config.sh @@ -1,9 +1,23 @@ #!/bin/sh -# $Id: mkmyocamlbuild_config.sh,v 1.5.2.3 2007/05/28 09:26:51 pouillar Exp $ + +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2007 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +# $Id: mkmyocamlbuild_config.sh,v 1.10 2008/01/11 16:13:16 doligez Exp $ cd `dirname $0`/.. sed \ + -e 's/^.*FLEXDIR.*$//g' \ -e 's/^#ml \(.*\)/\1/' \ -e 's/^\(#.*\)$/(* \1 *)/' \ -e 's/^\(.*\$([0-9]).*\)$/(* \1 *)/' \ diff --git a/build/mkruntimedef.sh b/build/mkruntimedef.sh index 3023dcbf..0fa63b24 100755 --- a/build/mkruntimedef.sh +++ b/build/mkruntimedef.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id: mkruntimedef.sh,v 1.1.2.2 2007/03/12 11:58:48 pouillar Exp $ +# $Id: mkruntimedef.sh,v 1.2 2007/10/08 14:19:34 doligez Exp $ echo 'let builtin_exceptions = [|'; \ sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$| \1;|p' byterun/fail.h | \ sed -e '$s/;$//'; \ diff --git a/build/myocamlbuild.sh b/build/myocamlbuild.sh index d8ba7728..6b2a3b09 100755 --- a/build/myocamlbuild.sh +++ b/build/myocamlbuild.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id: myocamlbuild.sh,v 1.2.2.4 2007/03/12 11:58:48 pouillar Exp $ +# $Id: myocamlbuild.sh,v 1.3 2007/10/08 14:19:34 doligez Exp $ cd `dirname $0`/.. set -xe if [ ! -x _build/ocamlbuild/ocamlbuildlight.byte ]; then diff --git a/build/ocamlbuild-byte-only.sh b/build/ocamlbuild-byte-only.sh index 3e7a5bf9..19b0b98f 100755 --- a/build/ocamlbuild-byte-only.sh +++ b/build/ocamlbuild-byte-only.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id: ocamlbuild-byte-only.sh,v 1.2.4.3 2007/03/12 11:58:48 pouillar Exp $ +# $Id: ocamlbuild-byte-only.sh,v 1.3 2007/10/08 14:19:34 doligez Exp $ set -e OCAMLBUILD_PARTIAL="true" export OCAMLBUILD_PARTIAL diff --git a/build/ocamlbuild-native-only.sh b/build/ocamlbuild-native-only.sh index 17c0509f..f0f75bfc 100755 --- a/build/ocamlbuild-native-only.sh +++ b/build/ocamlbuild-native-only.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id: ocamlbuild-native-only.sh,v 1.2.4.4 2007/03/12 11:58:48 pouillar Exp $ +# $Id: ocamlbuild-native-only.sh,v 1.3 2007/10/08 14:19:34 doligez Exp $ set -e OCAMLBUILD_PARTIAL="true" export OCAMLBUILD_PARTIAL diff --git a/build/ocamlbuildlib-native-only.sh b/build/ocamlbuildlib-native-only.sh index 007da913..f7f700ae 100755 --- a/build/ocamlbuildlib-native-only.sh +++ b/build/ocamlbuildlib-native-only.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id: ocamlbuildlib-native-only.sh,v 1.1.2.1 2007/06/20 13:34:03 ertai Exp $ +# $Id: ocamlbuildlib-native-only.sh,v 1.2 2007/11/27 12:21:53 ertai Exp $ set -e OCAMLBUILD_PARTIAL="true" export OCAMLBUILD_PARTIAL diff --git a/build/otherlibs-targets.sh b/build/otherlibs-targets.sh index c2dc801a..6bf04dcf 100644 --- a/build/otherlibs-targets.sh +++ b/build/otherlibs-targets.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id: otherlibs-targets.sh,v 1.2.4.1 2007/03/12 11:58:48 pouillar Exp $ +# $Id: otherlibs-targets.sh,v 1.4 2007/11/29 10:32:38 ertai Exp $ OTHERLIBS_BYTE="" OTHERLIBS_NATIVE="" OTHERLIBS_UNIX_NATIVE="" @@ -93,7 +93,9 @@ for lib in $OTHERLIBRARIES; do add_ocaml_lib dbm add_c_lib mldbm;; dynlink) - add_byte $lib.cmi $lib.cma extract_crc;; + add_ocaml_lib dynlink + add_native dynlink.cmx + add_file $lib.cmi extract_crc;; win32unix) UNIXDIR="otherlibs/win32unix" add_file unixsupport.h cst2constr.h socketaddr.h diff --git a/build/partial-boot.sh b/build/partial-boot.sh index 6af42249..79e0d629 100755 --- a/build/partial-boot.sh +++ b/build/partial-boot.sh @@ -1,5 +1,19 @@ #!/bin/sh -# $Id: partial-boot.sh,v 1.2.4.9 2007/05/22 10:54:59 pouillar Exp $ + +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2007 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +# $Id: partial-boot.sh,v 1.5 2008/01/11 16:13:16 doligez Exp $ + set -ex cd `dirname $0`/.. OCAMLBUILD_PARTIAL="true" diff --git a/build/partial-install.sh b/build/partial-install.sh index b7c68496..7240fff2 100755 --- a/build/partial-install.sh +++ b/build/partial-install.sh @@ -1,5 +1,18 @@ #!/bin/sh -# $Id: partial-install.sh,v 1.5.2.11 2007/11/22 18:45:18 ertai Exp $ + +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2007 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +# $Id: partial-install.sh,v 1.9 2008/01/11 16:13:16 doligez Exp $ ###################################### ######### Copied from build/install.sh diff --git a/build/targets.sh b/build/targets.sh index ec18a2f6..4154f498 100644 --- a/build/targets.sh +++ b/build/targets.sh @@ -1,4 +1,17 @@ -# $Id: targets.sh,v 1.2.4.7 2007/06/20 13:26:29 ertai Exp $ +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2007 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +# $Id: targets.sh,v 1.5 2008/01/11 16:13:16 doligez Exp $ + . config/config.sh . build/otherlibs-targets.sh . build/camlp4-targets.sh diff --git a/build/world.all.sh b/build/world.all.sh index 632e06b0..579f297f 100755 --- a/build/world.all.sh +++ b/build/world.all.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id: world.all.sh,v 1.2.4.1 2007/03/12 11:58:48 pouillar Exp $ +# $Id: world.all.sh,v 1.3 2007/10/08 14:19:34 doligez Exp $ set -e cd `dirname $0`/.. . build/targets.sh diff --git a/build/world.byte.sh b/build/world.byte.sh index 61258e02..379a8104 100755 --- a/build/world.byte.sh +++ b/build/world.byte.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id: world.byte.sh,v 1.2.4.1 2007/03/12 11:58:48 pouillar Exp $ +# $Id: world.byte.sh,v 1.3 2007/10/08 14:19:34 doligez Exp $ set -e cd `dirname $0`/.. . build/targets.sh diff --git a/build/world.native.sh b/build/world.native.sh index 31e2a0a7..d8066352 100755 --- a/build/world.native.sh +++ b/build/world.native.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id: world.native.sh,v 1.2.4.1 2007/03/12 11:58:48 pouillar Exp $ +# $Id: world.native.sh,v 1.3 2007/10/08 14:19:34 doligez Exp $ set -e cd `dirname $0`/.. . build/targets.sh diff --git a/build/world.sh b/build/world.sh index 4f959ec2..925e2d23 100755 --- a/build/world.sh +++ b/build/world.sh @@ -1,5 +1,5 @@ #!/bin/sh -# $Id: world.sh,v 1.2.4.1 2007/03/12 11:58:48 pouillar Exp $ +# $Id: world.sh,v 1.3 2007/10/08 14:19:34 doligez Exp $ cd `dirname $0` set -ex ./mkconfig.sh diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index 14364a80..0a5fab87 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: bytegen.ml,v 1.69 2007/02/09 13:31:15 doligez Exp $ *) +(* $Id: bytegen.ml,v 1.72 2008/10/03 15:02:55 maranget Exp $ *) (* bytegen.ml : translation of lambda terms to lists of instructions. *) @@ -373,17 +373,12 @@ 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("caml_ba_get_" ^ string_of_int n, n + 1) - | Pbigarrayset(n, _, _) -> Kccall("caml_ba_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 -let explode_isout arg l h = - Lprim - (Psequor, - [Lprim (Pintcomp Clt,[arg ; Lconst (Const_base (Const_int 0))]) ; - Lprim (Pintcomp Cgt,[arg ; Lconst (Const_base (Const_int h))])]) (* Compile an expression. The value of the expression is left in the accumulator. @@ -414,13 +409,15 @@ let rec comp_expr env exp sz cont = end | Lconst cst -> Kconst cst :: cont - | Lapply(func, args) -> + | Lapply(func, args, loc) -> let nargs = List.length args in - if is_tailcall cont then + if is_tailcall cont then begin + Stypes.record (Stypes.An_call (loc, Annot.Tail)); comp_args env args sz (Kpush :: comp_expr env func (sz + nargs) (Kappterm(nargs, sz + nargs) :: discard_dead_code cont)) - else + end else begin + Stypes.record (Stypes.An_call (loc, Annot.Stack)); if nargs < 4 then comp_args env args sz (Kpush :: comp_expr env func (sz + nargs) (Kapply nargs :: cont)) @@ -431,6 +428,7 @@ let rec comp_expr env exp sz cont = (Kpush :: comp_expr env func (sz + 3 + nargs) (Kapply nargs :: cont1)) end + end | Lsend(kind, met, obj, args) -> let args = if kind = Cached then List.tl args else args in let nargs = List.length args + 1 in @@ -746,7 +744,7 @@ let rec comp_expr env exp sz cont = | Lev_after ty -> let info = match lam with - Lapply(_, args) -> Event_return (List.length args) + Lapply(_, args, _) -> Event_return (List.length args) | Lsend(_, _, _, args) -> Event_return (List.length args + 1) | _ -> Event_other in diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index 83add82d..63fd5850 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: bytelink.ml,v 1.90 2006/09/28 21:36:38 xleroy Exp $ *) +(* $Id: bytelink.ml,v 1.95 2007/11/15 15:18:28 frisch Exp $ *) (* Link a set of .cmo files and produce a bytecode executable. *) @@ -45,13 +45,15 @@ let lib_ccopts = ref [] let lib_dllibs = ref [] let add_ccobjs l = - if not !Clflags.no_auto_link - && String.length !Clflags.use_runtime = 0 + if not !Clflags.no_auto_link then begin + if + String.length !Clflags.use_runtime = 0 && String.length !Clflags.use_prims = 0 - then begin - if l.lib_custom then Clflags.custom_runtime := true; - lib_ccobjs := l.lib_ccobjs @ !lib_ccobjs; - lib_ccopts := l.lib_ccopts @ !lib_ccopts; + then begin + if l.lib_custom then Clflags.custom_runtime := true; + lib_ccobjs := l.lib_ccobjs @ !lib_ccobjs; + lib_ccopts := l.lib_ccopts @ !lib_ccopts; + end; lib_dllibs := l.lib_dllibs @ !lib_dllibs end @@ -429,43 +431,9 @@ void caml_startup(char ** argv) (* Build a custom runtime *) let build_custom_runtime prim_name exec_name = - match Config.ccomp_type with - "cc" -> - Ccomp.command - (Printf.sprintf - "%s -o %s %s %s %s %s %s -lcamlrun %s" - !Clflags.c_linker - (Filename.quote exec_name) - (Clflags.std_include_flag "-I") - (String.concat " " (List.rev !Clflags.ccopts)) - prim_name - (Ccomp.quote_files - (List.map (fun dir -> if dir = "" then "" else "-L" ^ dir) - !load_path)) - (Ccomp.quote_files (List.rev !Clflags.ccobjs)) - Config.bytecomp_c_libraries) - | "msvc" -> - let retcode = - Ccomp.command - (Printf.sprintf - "%s /Fe%s %s %s %s %s %s %s" - !Clflags.c_linker - (Filename.quote exec_name) - (Clflags.std_include_flag "-I") - prim_name - (Ccomp.quote_files - (List.rev_map Ccomp.expand_libname !Clflags.ccobjs)) - (Filename.quote (Ccomp.expand_libname "-lcamlrun")) - Config.bytecomp_c_libraries - (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"); - if retcode <> 0 - then retcode - else Ccomp.merge_manifest exec_name - | _ -> assert false + Ccomp.call_linker Ccomp.Exe exec_name + ([prim_name] @ List.rev !Clflags.ccobjs @ ["-lcamlrun"]) + Config.bytecomp_c_libraries let append_bytecode_and_cleanup bytecode_name exec_name prim_name = let oc = open_out_gen [Open_wronly; Open_append; Open_binary] 0 exec_name in @@ -507,7 +475,7 @@ let link objfiles output_name = Symtable.output_primitive_table poc; close_out poc; let exec_name = fix_exec_name output_name in - if build_custom_runtime prim_name exec_name <> 0 + if not (build_custom_runtime prim_name exec_name) then raise(Error Custom_runtime); if !Clflags.make_runtime then (remove_file bytecode_name; remove_file prim_name) @@ -517,17 +485,28 @@ let link objfiles output_name = remove_file prim_name; raise x end else begin - let c_file = - Filename.chop_suffix output_name Config.ext_obj ^ ".c" in + let basename = Filename.chop_extension output_name in + let c_file = basename ^ ".c" + and obj_file = basename ^ Config.ext_obj in if Sys.file_exists c_file then raise(Error(File_exists c_file)); + let temps = ref [] in try link_bytecode_as_c tolink c_file; - if Ccomp.compile_file c_file <> 0 - then raise(Error Custom_runtime); - remove_file c_file + if not (Filename.check_suffix output_name ".c") then begin + temps := c_file :: !temps; + if Ccomp.compile_file c_file <> 0 then raise(Error Custom_runtime); + if not (Filename.check_suffix output_name Config.ext_obj) then begin + temps := obj_file :: !temps; + if not ( + Ccomp.call_linker Ccomp.MainDll output_name + ([obj_file] @ List.rev !Clflags.ccobjs @ ["-lcamlrun"]) + Config.bytecomp_c_libraries + ) then raise (Error Custom_runtime); + end + end; + List.iter remove_file !temps with x -> - remove_file c_file; - remove_file output_name; + List.iter remove_file !temps; raise x end diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index 0201ba6a..f607e7c0 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: emitcode.ml,v 1.33 2006/05/11 15:50:53 xleroy Exp $ *) +(* $Id: emitcode.ml,v 1.34 2008/07/24 05:35:22 frisch Exp $ *) (* Generation of bytecode + relocation information *) @@ -373,7 +373,7 @@ let to_file outchan unit_name code = cu_codesize = !out_position; cu_reloc = List.rev !reloc_info; cu_imports = Env.imported_units(); - cu_primitives = !Translmod.primitive_declarations; + cu_primitives = List.map Primitive.byte_name !Translmod.primitive_declarations; cu_force_link = false; cu_debug = pos_debug; cu_debugsize = size_debug } in diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml index 38a86300..121f8898 100644 --- a/bytecomp/lambda.ml +++ b/bytecomp/lambda.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: lambda.ml,v 1.45 2007/02/09 13:31:15 doligez Exp $ *) +(* $Id: lambda.ml,v 1.48 2008/08/01 16:57:10 mauny Exp $ *) open Misc open Path @@ -29,6 +29,8 @@ type primitive = | Pfloatfield of int | Psetfloatfield of int | Pduprecord of Types.record_representation * int + (* Force lazy values *) + | Plazyforce (* External call *) | Pccall of Primitive.description (* Exceptions *) @@ -79,9 +81,9 @@ type primitive = | Plsrbint of boxed_integer | Pasrbint of boxed_integer | Pbintcomp of boxed_integer * comparison - (* Operations on big arrays *) - | Pbigarrayref of int * bigarray_kind * bigarray_layout - | Pbigarrayset of int * bigarray_kind * bigarray_layout + (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) + | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout + | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge @@ -124,7 +126,7 @@ type shared_code = (int * int) list type lambda = Lvar of Ident.t | Lconst of structured_constant - | Lapply of lambda * lambda list + | Lapply of lambda * lambda list * Location.t | Lfunction of function_kind * Ident.t list * lambda | Llet of let_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda @@ -170,7 +172,7 @@ let rec same l1 l2 = Ident.same v1 v2 | Lconst c1, Lconst c2 -> c1 = c2 - | Lapply(a1, bl1), Lapply(a2, bl2) -> + | Lapply(a1, bl1, _), Lapply(a2, bl2, _) -> same a1 a2 && samelist same bl1 bl2 | Lfunction(k1, idl1, a1), Lfunction(k2, idl2, a2) -> k1 = k2 && samelist Ident.same idl1 idl2 && same a1 a2 @@ -240,7 +242,7 @@ let name_lambda_list args fn = let rec iter f = function Lvar _ | Lconst _ -> () - | Lapply(fn, args) -> + | Lapply(fn, args, _) -> f fn; List.iter f args | Lfunction(kind, params, body) -> f body @@ -374,7 +376,7 @@ let subst_lambda s lam = Lvar id as l -> begin try Ident.find_same id s with Not_found -> l end | Lconst sc as l -> l - | Lapply(fn, args) -> Lapply(subst fn, List.map subst args) + | Lapply(fn, args, loc) -> Lapply(subst fn, List.map subst args, loc) | Lfunction(kind, params, body) -> Lfunction(kind, params, subst body) | Llet(str, id, arg, body) -> Llet(str, id, subst arg, subst body) | Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body) diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli index c44260dc..0476b874 100644 --- a/bytecomp/lambda.mli +++ b/bytecomp/lambda.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: lambda.mli,v 1.43 2007/02/09 13:31:15 doligez Exp $ *) +(* $Id: lambda.mli,v 1.46 2008/08/01 16:57:10 mauny Exp $ *) (* The "lambda" intermediate code *) @@ -29,6 +29,8 @@ type primitive = | Pfloatfield of int | Psetfloatfield of int | Pduprecord of Types.record_representation * int + (* Force lazy values *) + | Plazyforce (* External call *) | Pccall of Primitive.description (* Exceptions *) @@ -79,9 +81,9 @@ type primitive = | Plsrbint of boxed_integer | Pasrbint of boxed_integer | Pbintcomp of boxed_integer * comparison - (* Operations on big arrays *) - | Pbigarrayref of int * bigarray_kind * bigarray_layout - | Pbigarrayset of int * bigarray_kind * bigarray_layout + (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) + | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout + | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge @@ -133,7 +135,7 @@ type shared_code = (int * int) list (* stack size -> code label *) type lambda = Lvar of Ident.t | Lconst of structured_constant - | Lapply of lambda * lambda list + | Lapply of lambda * lambda list * Location.t | Lfunction of function_kind * Ident.t list * lambda | Llet of let_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index 11b443c7..a9fbc46b 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: matching.ml,v 1.67.12.1 2007/06/08 08:03:16 garrigue Exp $ *) +(* $Id: matching.ml,v 1.71 2008/08/01 16:57:10 mauny Exp $ *) (* Compilation of pattern matching *) @@ -203,7 +203,11 @@ let ctx_matcher p = let l' = all_record_args l' in p, List.fold_right (fun (_,p) r -> p::r) l' rem | _ -> p,List.fold_right (fun (_,p) r -> p::r) l rem) - | _ -> fatal_error "Matching.ctx_matcher" + | Tpat_lazy omega -> + (fun q rem -> match q.pat_desc with + | Tpat_lazy arg -> p, (arg::rem) + | _ -> p, (omega::rem)) + | _ -> fatal_error "Matching.ctx_matcher" @@ -616,6 +620,7 @@ let rec extract_vars r p = match p.pat_desc with | Tpat_array pats -> List.fold_left extract_vars r pats | Tpat_variant (_,Some p, _) -> extract_vars r p +| Tpat_lazy p -> extract_vars r p | Tpat_or (p,_,_) -> extract_vars r p | Tpat_constant _|Tpat_any|Tpat_variant (_,None,_) -> r @@ -683,6 +688,10 @@ and group_array = function | {pat_desc=Tpat_array _} -> true | _ -> false +and group_lazy = function + | {pat_desc = Tpat_lazy _} -> true + | _ -> false + let get_group p = match p.pat_desc with | Tpat_any -> group_var | Tpat_constant _ -> group_constant @@ -691,6 +700,7 @@ let get_group p = match p.pat_desc with | Tpat_record _ -> group_record | Tpat_array _ -> group_array | Tpat_variant (_,_,_) -> group_variant +| Tpat_lazy _ -> group_lazy | _ -> fatal_error "Matching.get_group" @@ -1287,6 +1297,119 @@ let make_var_matching def = function let divide_var ctx pm = divide_line ctx_lshift make_var_matching get_args_var omega ctx pm +(* Matching and forcing a lazy value *) + +let get_arg_lazy p rem = match p with +| {pat_desc = Tpat_any} -> omega :: rem +| {pat_desc = Tpat_lazy arg} -> arg :: rem +| _ -> assert false + +let matcher_lazy p rem = match p.pat_desc with +| Tpat_or (_,_,_) -> raise OrPat +| Tpat_var _ -> get_arg_lazy omega rem +| _ -> get_arg_lazy p rem + +(* Inlining the tag tests before calling the primitive that works on + lazy blocks. This is alse used in translcore.ml. + No call other than Obj.tag when the value has been forced before. +*) + +let prim_obj_tag = + {prim_name = "caml_obj_tag"; + prim_arity = 1; prim_alloc = false; + prim_native_name = ""; + prim_native_float = false} + +let get_mod_field modname field = + lazy ( + try + let mod_ident = Ident.create_persistent modname in + let env = Env.open_pers_signature modname Env.initial in + let p = try + match Env.lookup_value (Longident.Lident field) env with + | (Path.Pdot(_,_,i), _) -> i + | _ -> fatal_error ("Primitive "^modname^"."^field^" not found.") + with Not_found -> fatal_error ("Primitive "^modname^"."^field^" not found.") + in + Lprim(Pfield p, [Lprim(Pgetglobal mod_ident, [])]) + with Not_found -> fatal_error ("Module "^modname^" unavailable.") + ) + +let code_force_lazy_block = + get_mod_field "CamlinternalLazy" "force_lazy_block" +;; + +(* inline_lazy_force inlines the beginning of the code of Lazy.force. When + the value argument is tagged as: + - forward, take field 0 + - lazy, call the primitive that forces (without testing again the tag) + - anything else, return it + + Using Lswitch below relies on the fact that the GC does not shortcut + Forward(val_out_of_heap). +*) + +let inline_lazy_force_cond arg loc = + let idarg = Ident.create "lzarg" in + let varg = Lvar idarg in + let tag = Ident.create "tag" in + let force_fun = Lazy.force code_force_lazy_block in + Llet(Strict, idarg, arg, + Llet(Alias, tag, Lprim(Pccall prim_obj_tag, [varg]), + Lifthenelse( + (* if (tag == Obj.forward_tag) then varg.(0) else ... *) + Lprim(Pintcomp Ceq, + [Lvar tag; Lconst(Const_base(Const_int Obj.forward_tag))]), + Lprim(Pfield 0, [varg]), + Lifthenelse( + (* ... if (tag == Obj.lazy_tag) then Lazy.force varg else ... *) + Lprim(Pintcomp Ceq, + [Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))]), + Lapply(force_fun, [varg], loc), + (* ... arg *) + varg)))) + +let inline_lazy_force_switch arg loc = + let idarg = Ident.create "lzarg" in + let varg = Lvar idarg in + let force_fun = Lazy.force code_force_lazy_block in + Llet(Strict, idarg, arg, + Lifthenelse( + Lprim(Pisint, [varg]), varg, + (Lswitch + (varg, + { sw_numconsts = 0; sw_consts = []; + sw_numblocks = (max Obj.lazy_tag Obj.forward_tag) + 1; + sw_blocks = + [ (Obj.forward_tag, Lprim(Pfield 0, [varg])); + (Obj.lazy_tag, + Lapply(force_fun, [varg], loc)) ]; + sw_failaction = Some varg } )))) + +let inline_lazy_force = + if !Clflags.native_code then + (* Lswitch generates compact and efficient native code *) + inline_lazy_force_switch + else + (* generating bytecode: Lswitch would generate too many rather big + tables (~ 250 elts); conditionals are better *) + inline_lazy_force_cond + +let make_lazy_matching def = function + [] -> fatal_error "Matching.make_lazy_matching" + | (arg,mut) :: argl -> + { cases = []; + args = + (inline_lazy_force arg Location.none, Strict) :: argl; + default = make_default matcher_lazy def } + +let divide_lazy p ctx pm = + divide_line + (filter_ctx p) + make_lazy_matching + get_arg_lazy + p ctx pm + (* Matching against a tuple pattern *) @@ -2335,6 +2458,10 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with compile_test (compile_match repr partial) partial (divide_array kind) (combine_array arg kind partial) ctx pm + | Tpat_lazy _ -> + compile_no_test + (divide_lazy (normalize_pat pat)) + ctx_combine repr partial ctx pm | Tpat_variant(lab, _, row) -> compile_test (compile_match repr partial) partial (divide_variant !row) @@ -2577,4 +2704,3 @@ let for_multiple_match loc paraml pat_act_list partial = end with Unused -> assert false (* ; partial_function loc () *) - diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli index 96a26a88..41b35963 100644 --- a/bytecomp/matching.mli +++ b/bytecomp/matching.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: matching.mli,v 1.12 2004/05/26 11:10:50 garrigue Exp $ *) +(* $Id: matching.mli,v 1.13 2008/08/01 16:57:10 mauny Exp $ *) (* Compilation of pattern-matching *) @@ -39,3 +39,5 @@ val flatten_pattern: int -> pattern -> pattern list val make_test_sequence: lambda option -> primitive -> primitive -> lambda -> (Asttypes.constant * lambda) list -> lambda + +val inline_lazy_force : lambda -> Location.t -> lambda diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index 40e0c3bf..edb32d07 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: printlambda.ml,v 1.52 2007/02/09 13:31:15 doligez Exp $ *) +(* $Id: printlambda.ml,v 1.55 2008/08/01 16:57:10 mauny Exp $ *) open Format open Asttypes @@ -61,9 +61,9 @@ let boxed_integer_mark name = function let print_boxed_integer name ppf bi = fprintf ppf "%s" (boxed_integer_mark name bi);; -let print_bigarray name kind ppf layout = +let print_bigarray name unsafe kind ppf layout = fprintf ppf "Bigarray.%s[%s,%s]" - name + (if unsafe then "unsafe_"^ name else name) (match kind with | Pbigarray_unknown -> "generic" | Pbigarray_float32 -> "float32" @@ -103,6 +103,7 @@ let primitive ppf = function | 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 + | Plazyforce -> fprintf ppf "force" | Pccall p -> fprintf ppf "%s" p.prim_name | Praise -> fprintf ppf "raise" | Psequand -> fprintf ppf "&&" @@ -177,15 +178,17 @@ let primitive ppf = function | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi - | Pbigarrayref(n, kind, layout) -> print_bigarray "get" kind ppf layout - | Pbigarrayset(n, kind, layout) -> print_bigarray "set" kind ppf layout + | Pbigarrayref(unsafe, n, kind, layout) -> + print_bigarray "get" unsafe kind ppf layout + | Pbigarrayset(unsafe, n, kind, layout) -> + print_bigarray "set" unsafe kind ppf layout let rec lam ppf = function | Lvar id -> Ident.print ppf id | Lconst cst -> struct_const ppf cst - | Lapply(lfun, largs) -> + | Lapply(lfun, largs, _) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml index 4faa9155..3db3d489 100644 --- a/bytecomp/simplif.ml +++ b/bytecomp/simplif.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: simplif.ml,v 1.23 2004/05/26 11:10:50 garrigue Exp $ *) +(* $Id: simplif.ml,v 1.25 2008/03/19 10:26:56 maranget Exp $ *) (* Elimination of useless Llet(Alias) bindings. Also transform let-bound references into variables. *) @@ -26,8 +26,8 @@ let rec eliminate_ref id = function Lvar v as lam -> if Ident.same v id then raise Real_reference else lam | Lconst cst as lam -> lam - | Lapply(e1, el) -> - Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el) + | Lapply(e1, el, loc) -> + Lapply(eliminate_ref id e1, List.map (eliminate_ref id) el, loc) | Lfunction(kind, params, body) as lam -> if IdentSet.mem id (free_variables lam) then raise Real_reference @@ -104,7 +104,7 @@ let simplify_exits lam = let rec count = function | (Lvar _| Lconst _) -> () - | Lapply(l1, ll) -> count l1; List.iter count ll + | Lapply(l1, ll, _) -> count l1; List.iter count ll | Lfunction(kind, params, l) -> count l | Llet(str, v, l1, l2) -> count l2; count l1 @@ -185,7 +185,7 @@ let simplify_exits lam = let rec simplif = function | (Lvar _|Lconst _) as l -> l - | Lapply(l1, ll) -> Lapply(simplif l1, List.map simplif ll) + | Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc) | Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l) | Llet(kind, v, l1, l2) -> Llet(kind, v, simplif l1, simplif l2) | Lletrec(bindings, body) -> @@ -209,7 +209,7 @@ let simplify_exits lam = with | Not_found -> l end - | Lstaticraise (i,ls) as l -> + | Lstaticraise (i,ls) -> let ls = List.map simplif ls in begin try let xs,handler = Hashtbl.find subst i in @@ -222,7 +222,7 @@ let simplify_exits lam = (fun y l r -> Llet (Alias, y, l, r)) ys ls (Lambda.subst_lambda env handler) with - | Not_found -> l + | Not_found -> Lstaticraise (i,ls) end | Lstaticcatch (l1,(i,[]),(Lstaticraise (j,[]) as l2)) -> Hashtbl.add subst i ([],simplif l2) ; @@ -276,7 +276,7 @@ let simplify_lets lam = let rec count = function | Lvar v -> incr_var v | Lconst cst -> () - | Lapply(l1, ll) -> count l1; List.iter count ll + | Lapply(l1, ll, _) -> count l1; List.iter count ll | Lfunction(kind, params, l) -> count l | Llet(str, v, Lvar w, l2) when not !Clflags.debug -> (* v will be replaced by w in l2, so each occurrence of v in l2 @@ -346,7 +346,7 @@ let simplify_lets lam = l end | Lconst cst as l -> l - | Lapply(l1, ll) -> Lapply(simplif l1, List.map simplif ll) + | Lapply(l1, ll, loc) -> Lapply(simplif l1, List.map simplif ll, loc) | Lfunction(kind, params, l) -> Lfunction(kind, params, simplif l) | Llet(str, v, Lvar w, l2) when not !Clflags.debug -> Hashtbl.add subst v (simplif (Lvar w)); diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 2e268f8c..c883e188 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: translclass.ml,v 1.41.8.4 2007/10/29 06:56:26 garrigue Exp $ *) +(* $Id: translclass.ml,v 1.43.4.1 2008/10/08 13:07:13 doligez Exp $ *) open Misc open Asttypes @@ -34,12 +34,14 @@ let lfunction params body = | _ -> Lfunction (Curried, params, body) -let lapply func args = +let lapply func args loc = match func with - Lapply(func', args') -> - Lapply(func', args' @ args) + Lapply(func', args', _) -> + Lapply(func', args' @ args, loc) | _ -> - Lapply(func, args) + Lapply(func, args, loc) + +let mkappl (func, args) = Lapply (func, args, Location.none);; let lsequence l1 l2 = if l2 = lambda_unit then l1 else Lsequence(l1, l2) @@ -68,7 +70,7 @@ let copy_inst_var obj id expr templ offset = Lvar offset])])])) let transl_val tbl create name = - Lapply (oo_prim (if create then "new_variable" else "get_variable"), + mkappl (oo_prim (if create then "new_variable" else "get_variable"), [Lvar tbl; transl_label name]) let transl_vals tbl create strict vals rem = @@ -82,7 +84,7 @@ let meths_super tbl meths inh_meths = (fun (nm, id) rem -> try (nm, id, - Lapply(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)])) + mkappl(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)])) :: rem with Not_found -> rem) inh_meths [] @@ -97,16 +99,16 @@ let create_object cl obj init = let (inh_init, obj_init, has_init) = init obj' in if obj_init = lambda_unit then (inh_init, - Lapply (oo_prim (if has_init then "create_object_and_run_initializers" + mkappl (oo_prim (if has_init then "create_object_and_run_initializers" else"create_object_opt"), [obj; Lvar cl])) else begin (inh_init, Llet(Strict, obj', - Lapply (oo_prim "create_object_opt", [obj; Lvar cl]), + mkappl (oo_prim "create_object_opt", [obj; Lvar cl]), Lsequence(obj_init, if not has_init then Lvar obj' else - Lapply (oo_prim "run_initializers_opt", + mkappl (oo_prim "run_initializers_opt", [obj; Lvar obj'; Lvar cl])))) end @@ -120,7 +122,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = | Some envs -> [Lprim(Pfield (List.length inh_init + 1), [Lvar envs])] in ((envs, (obj_init, path)::inh_init), - Lapply(Lvar obj_init, env @ [obj])) + mkappl(Lvar obj_init, env @ [obj])) | Tclass_structure str -> create_object cl_table obj (fun obj -> let (inh_init, obj_init, has_init) = @@ -177,7 +179,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = let (inh_init, obj_init) = build_object_init cl_table obj params inh_init obj_init cl in - (inh_init, transl_apply obj_init oexprs) + (inh_init, transl_apply obj_init oexprs Location.none) | Tclass_let (rec_flag, defs, vals, cl) -> let (inh_init, obj_init) = build_object_init cl_table obj (vals @ params) inh_init obj_init cl @@ -203,7 +205,7 @@ let rec build_object_init_0 cl_table params cl copy_env subst_env top ids = let bind_method tbl lab id cl_init = - Llet(Strict, id, Lapply (oo_prim "get_method_label", + Llet(Strict, id, mkappl (oo_prim "get_method_label", [Lvar tbl; transl_label lab]), cl_init) @@ -219,7 +221,7 @@ let bind_methods tbl meths vals cl_init = "new_methods_variables", [transl_meth_list (List.map fst vals)] in Llet(Strict, ids, - Lapply (oo_prim getter, + mkappl (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)) @@ -229,9 +231,9 @@ let output_methods tbl methods lam = match methods with [] -> lam | [lab; code] -> - lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam + lsequence (mkappl(oo_prim "set_method", [Lvar tbl; lab; code])) lam | _ -> - lsequence (Lapply(oo_prim "set_methods", + lsequence (mkappl(oo_prim "set_methods", [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)])) lam @@ -256,7 +258,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = let lpath = transl_path path in (inh_init, Llet (Strict, obj_init, - Lapply(Lprim(Pfield 1, [lpath]), Lvar cla :: + mkappl(Lprim(Pfield 1, [lpath]), Lvar cla :: if top then [Lprim(Pfield 3, [lpath])] else []), bind_super cla super cl_init)) | _ -> @@ -297,7 +299,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = (inh_init, cl_init, methods, vals @ values) | Cf_init exp -> (inh_init, - Lsequence(Lapply (oo_prim "add_initializer", + Lsequence(mkappl (oo_prim "add_initializer", Lvar cla :: msubst false (transl_exp exp)), cl_init), methods, values)) @@ -350,7 +352,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = cl_init valids in (inh_init, Llet (Strict, inh, - Lapply(oo_prim "inherits", narrow_args @ + mkappl(oo_prim "inherits", narrow_args @ [lpath; Lconst(Const_pointer(if top then 1 else 0))]), Llet(StrictOpt, obj_init, lfield inh 0, cl_init))) | _ -> @@ -359,10 +361,11 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = in if cstr then core cl_init else let (inh_init, cl_init) = - core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]), cl_init)) + core (Lsequence (mkappl (oo_prim "widen", [Lvar cla]), cl_init)) in (inh_init, - Lsequence(Lapply (oo_prim "narrow", narrow_args), cl_init)) + Lsequence(mkappl (oo_prim "narrow", narrow_args), + cl_init)) end let rec build_class_lets cl = @@ -409,7 +412,7 @@ let rec transl_class_rebind obj_init cl vf = | rem -> build [] rem) | Tclass_apply (cl, oexprs) -> let path, obj_init = transl_class_rebind obj_init cl vf in - (path, transl_apply obj_init oexprs) + (path, transl_apply obj_init oexprs Location.none) | Tclass_let (rec_flag, defs, vals, cl) -> let path, obj_init = transl_class_rebind obj_init cl vf in (path, Translcore.transl_let rec_flag defs obj_init) @@ -437,7 +440,7 @@ 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 obj_init0 = lapply (Lvar obj_init) [Lvar self] Location.none 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)); @@ -454,13 +457,13 @@ let transl_class_rebind ids cl vf = Llet( Alias, cla, transl_path path, Lprim(Pmakeblock(0, Immutable), - [Lapply(Lvar new_init, [lfield cla 0]); + [mkappl(Lvar new_init, [lfield cla 0]); lfunction [table] (Llet(Strict, env_init, - Lapply(lfield cla 1, [Lvar table]), + mkappl(lfield cla 1, [Lvar table]), lfunction [envs] - (Lapply(Lvar new_init, - [Lapply(Lvar env_init, [Lvar envs])])))); + (mkappl(Lvar new_init, + [mkappl(Lvar env_init, [Lvar envs])])))); lfield cla 2; lfield cla 3]))) with Exit -> @@ -499,12 +502,12 @@ let rec builtin_meths self env env2 body = match body with | Llet(_, s', Lvar s, body) when List.mem s self -> builtin_meths (s'::self) env env2 body - | Lapply(f, [arg]) when const_path f -> + | Lapply(f, [arg], _) when const_path f -> let s, args = conv arg in ("app_"^s, f :: args) - | Lapply(f, [arg; p]) when const_path f && const_path p -> + | Lapply(f, [arg; p], _) when const_path f && const_path p -> let s, args = conv arg in ("app_"^s^"_const", f :: args @ [p]) - | Lapply(f, [p; arg]) when const_path f && const_path p -> + | Lapply(f, [p; arg], _) when const_path f && const_path p -> let s, args = conv arg in ("app_const_"^s, f :: p :: args) | Lsend(Self, Lvar n, Lvar s, [arg]) when List.mem s self -> @@ -535,7 +538,7 @@ module M = struct open CamlinternalOO 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 [mkappl(oo_prim builtin, args)] else *) let tag = match builtin with "get_const" -> GetConst | "get_var" -> GetVar @@ -604,12 +607,20 @@ let transl_class ids cl_id arity pub_meths cl vflag = let meth_ids = get_class_meths cl in let subst env lam i0 new_ids' = let fv = free_variables lam in + (* prerr_ids "cl_id =" [cl_id]; prerr_ids "fv =" (IdentSet.elements fv); *) let fv = List.fold_right IdentSet.remove !new_ids' fv in - let fv = IdentSet.filter (fun id -> List.mem id new_ids) fv in - (* need to handle methods specially (PR#3576) *) - let fm = IdentSet.diff (free_methods lam) meth_ids in - let fv = IdentSet.union fv fm in + (* We need to handle method ids specially, as they do not appear + in the typing environment (PR#3576, PR#4560) *) + (* very hacky: we add and remove free method ids on the fly, + depending on the visit order... *) + method_ids := + IdentSet.diff (IdentSet.union (free_methods lam) !method_ids) meth_ids; + (* prerr_ids "meth_ids =" (IdentSet.elements meth_ids); + prerr_ids "method_ids =" (IdentSet.elements !method_ids); *) + let new_ids = List.fold_right IdentSet.add new_ids !method_ids in + let fv = IdentSet.inter fv new_ids in new_ids' := !new_ids' @ IdentSet.elements fv; + (* prerr_ids "new_ids' =" !new_ids'; *) let i = ref (i0-1) in List.fold_left (fun subst id -> @@ -681,11 +692,11 @@ let transl_class ids cl_id arity pub_meths cl vflag = tags pub_meths; let ltable table lam = Llet(Strict, table, - Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam) + mkappl (oo_prim "create_table", [transl_meth_list pub_meths]), lam) and ldirect obj_init = Llet(Strict, obj_init, cl_init, - Lsequence(Lapply (oo_prim "init_class", [Lvar cla]), - Lapply(Lvar obj_init, [lambda_unit]))) + Lsequence(mkappl (oo_prim "init_class", [Lvar cla]), + mkappl (Lvar obj_init, [lambda_unit]))) in (* Simplest case: an object defined at toplevel (ids=[]) *) if top && ids = [] then llets (ltable cla (ldirect obj_init)) else @@ -696,16 +707,16 @@ let transl_class ids cl_id arity pub_meths cl vflag = 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; + mkappl (oo_prim "make_class",[transl_meth_list pub_meths; Lvar class_init]) else ltable table ( Llet( - Strict, env_init, Lapply(Lvar class_init, [Lvar table]), + Strict, env_init, mkappl (Lvar class_init, [Lvar table]), Lsequence( - Lapply (oo_prim "init_class", [Lvar table]), + mkappl (oo_prim "init_class", [Lvar table]), Lprim(Pmakeblock(0, Immutable), - [Lapply(Lvar env_init, [lambda_unit]); + [mkappl (Lvar env_init, [lambda_unit]); Lvar class_init; Lvar env_init; lambda_unit])))) and lbody_virt lenvs = Lprim(Pmakeblock(0, Immutable), @@ -741,7 +752,7 @@ let transl_class ids cl_id arity pub_meths cl vflag = lam) and def_ids cla lam = Llet(StrictOpt, env2, - Lapply (oo_prim "new_variable", [Lvar cla; transl_label ""]), + mkappl (oo_prim "new_variable", [Lvar cla; transl_label ""]), lam) in let inh_paths = @@ -755,7 +766,7 @@ let transl_class ids cl_id arity pub_meths cl vflag = and lcache lam = if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else Llet(Strict, cached, - Lapply(oo_prim "lookup_tables", + mkappl (oo_prim "lookup_tables", [Lvar tables; Lprim(Pmakeblock(0, Immutable), inh_keys)]), lam) and lset cached i lam = @@ -764,7 +775,7 @@ let transl_class ids cl_id arity pub_meths cl vflag = let ldirect () = ltable cla (Llet(Strict, env_init, def_ids cla cl_init, - Lsequence(Lapply (oo_prim "init_class", [Lvar cla]), + Lsequence(mkappl (oo_prim "init_class", [Lvar cla]), lset cached 0 (Lvar env_init)))) and lclass_virt () = lset cached 0 (Lfunction(Curried, [cla], def_ids cla cl_init)) @@ -776,14 +787,14 @@ let transl_class ids cl_id arity pub_meths cl vflag = if ids = [] then ldirect () else if not concrete then lclass_virt () else lclass ( - Lapply (oo_prim "make_class_store", + mkappl (oo_prim "make_class_store", [transl_meth_list pub_meths; Lvar class_init; Lvar cached]))), make_envs ( - if ids = [] then Lapply(lfield cached 0, [lenvs]) else + if ids = [] then mkappl (lfield cached 0, [lenvs]) else Lprim(Pmakeblock(0, Immutable), if concrete then - [Lapply(lfield cached 0, [lenvs]); + [mkappl (lfield cached 0, [lenvs]); lfield cached 1; lfield cached 0; lenvs] diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index d1135063..d4be9aa9 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: translcore.ml,v 1.102 2007/02/09 13:31:15 doligez Exp $ *) +(* $Id: translcore.ml,v 1.110 2008/08/27 10:23:21 garrigue Exp $ *) (* Translation from typed abstract syntax to lambda terms, for the core language *) @@ -202,6 +202,7 @@ let primitives_table = create_hashtable 57 [ "%obj_field", Parrayrefu Pgenarray; "%obj_set_field", Parraysetu Pgenarray; "%obj_is_int", Pisint; + "%lazy_force", Plazyforce; "%nativeint_of_int", Pbintofint Pnativeint; "%nativeint_to_int", Pintofbint Pnativeint; "%nativeint_neg", Pnegbint Pnativeint; @@ -250,12 +251,30 @@ let primitives_table = create_hashtable 57 [ "%int64_to_int32", Pcvtbint(Pint64, Pint32); "%int64_of_nativeint", Pcvtbint(Pnativeint, Pint64); "%int64_to_nativeint", Pcvtbint(Pint64, Pnativeint); - "%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) + "%caml_ba_ref_1", + Pbigarrayref(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout); + "%caml_ba_ref_2", + Pbigarrayref(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout); + "%caml_ba_ref_3", + Pbigarrayref(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout); + "%caml_ba_set_1", + Pbigarrayset(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout); + "%caml_ba_set_2", + Pbigarrayset(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout); + "%caml_ba_set_3", + Pbigarrayset(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout); + "%caml_ba_unsafe_ref_1", + Pbigarrayref(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout); + "%caml_ba_unsafe_ref_2", + Pbigarrayref(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout); + "%caml_ba_unsafe_ref_3", + Pbigarrayref(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout); + "%caml_ba_unsafe_set_1", + Pbigarrayset(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout); + "%caml_ba_unsafe_set_2", + Pbigarrayset(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout); + "%caml_ba_unsafe_set_3", + Pbigarrayset(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout) ] let prim_makearray = @@ -279,6 +298,12 @@ let transl_prim prim args = | [{exp_desc = Texp_construct({cstr_tag = Cstr_constant _}, _)}; arg2] when simplify_constant_constructor -> intcomp + | [arg1; {exp_desc = Texp_variant(_, None)}] + when simplify_constant_constructor -> + intcomp + | [{exp_desc = Texp_variant(_, None)}; exp2] + when simplify_constant_constructor -> + intcomp | [arg1; arg2] when has_base_type arg1 Predef.path_int || has_base_type arg1 Predef.path_char -> intcomp @@ -306,12 +331,14 @@ let transl_prim prim args = | (Parraysetu Pgenarray, arg1 :: _) -> Parraysetu(array_kind arg1) | (Parrayrefs Pgenarray, arg1 :: _) -> Parrayrefs(array_kind arg1) | (Parraysets Pgenarray, arg1 :: _) -> Parraysets(array_kind arg1) - | (Pbigarrayref(n, Pbigarray_unknown, _), arg1 :: _) -> + | (Pbigarrayref(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout), + arg1 :: _) -> let (k, l) = bigarray_kind_and_layout arg1 in - Pbigarrayref(n, k, l) - | (Pbigarrayset(n, Pbigarray_unknown, _), arg1 :: _) -> + Pbigarrayref(unsafe, n, k, l) + | (Pbigarrayset(unsafe, n, Pbigarray_unknown, Pbigarray_unknown_layout), + arg1 :: _) -> let (k, l) = bigarray_kind_and_layout arg1 in - Pbigarrayset(n, k, l) + Pbigarrayset(unsafe, n, k, l) | _ -> p end with Not_found -> @@ -331,10 +358,15 @@ let transl_primitive p = Hashtbl.find primitives_table p.prim_name with Not_found -> Pccall p in - let rec make_params n = - if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in - let params = make_params p.prim_arity in - Lfunction(Curried, params, Lprim(prim, List.map (fun id -> Lvar id) params)) + match prim with + Plazyforce -> + let parm = Ident.create "prim" in + Lfunction(Curried, [parm], Matching.inline_lazy_force (Lvar parm) Location.none) + | _ -> + let rec make_params n = + if n <= 0 then [] else Ident.create "prim" :: make_params (n-1) in + let params = make_params p.prim_arity in + Lfunction(Curried, params, Lprim(prim, List.map (fun id -> Lvar id) params)) (* To check the well-formedness of r.h.s. of "let rec" definitions *) @@ -564,12 +596,15 @@ and transl_exp0 e = transl_function e.exp_loc !Clflags.native_code repr partial pl) in Lfunction(kind, params, body) - | Texp_apply({exp_desc = Texp_ident(path, {val_kind = Val_prim p})}, args) - when List.length args >= p.prim_arity - && List.for_all (fun (arg,_) -> arg <> None) args -> - let args, args' = cut p.prim_arity args in + | Texp_apply({exp_desc = Texp_ident(path, {val_kind = Val_prim p})}, oargs) + when List.length oargs >= p.prim_arity + && List.for_all (fun (arg,_) -> arg <> None) oargs -> + let args, args' = cut p.prim_arity oargs in let wrap f = - event_after e (if args' = [] then f else transl_apply f args') in + if args' = [] + then event_after e f + else event_after e (transl_apply f args' e.exp_loc) + in let wrap0 f = if args' = [] then f else wrap f in let args = List.map (function Some x, _ -> x | _ -> assert false) args in @@ -590,11 +625,16 @@ and transl_exp0 e = (Praise, [arg1]) -> wrap0 (Lprim(Praise, [event_after arg1 (List.hd argl)])) | (_, _) -> - let p = Lprim(prim, argl) in - if primitive_is_ccall prim then wrap p else wrap0 p + begin match (prim, argl) with + | (Plazyforce, [a]) -> + wrap (Matching.inline_lazy_force a e.exp_loc) + | (Plazyforce, _) -> assert false + |_ -> let p = Lprim(prim, argl) in + if primitive_is_ccall prim then wrap p else wrap0 p + end end | Texp_apply(funct, oargs) -> - event_after e (transl_apply (transl_exp funct) oargs) + event_after e (transl_apply (transl_exp funct) oargs e.exp_loc) | Texp_match({exp_desc = Texp_tuple argl}, pat_expr_list, partial) -> Matching.for_multiple_match e.exp_loc (transl_list argl) (transl_cases pat_expr_list) partial @@ -705,7 +745,7 @@ and transl_exp0 e = in event_after e lam | Texp_new (cl, _) -> - Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit]) + Lapply(Lprim(Pfield 0, [transl_path cl]), [lambda_unit], Location.none) | Texp_instvar(path_self, path) -> Lprim(Parrayrefu Paddrarray, [transl_path path_self; transl_path path]) | Texp_setinstvar(path_self, path, expr) -> @@ -713,7 +753,8 @@ and transl_exp0 e = | Texp_override(path_self, modifs) -> let cpy = Ident.create "copy" in Llet(Strict, cpy, - Lapply(Translobj.oo_prim "copy", [transl_path path_self]), + Lapply(Translobj.oo_prim "copy", [transl_path path_self], + Location.none), List.fold_right (fun (path, expr) rem -> Lsequence(transl_setinstvar (Lvar cpy) path expr, rem)) @@ -727,8 +768,54 @@ and transl_exp0 e = else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e.exp_loc) | Texp_assertfalse -> assert_failed e.exp_loc | Texp_lazy e -> - let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in - Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn]) + (* when e needs no computation (constants, identifiers, ...), we + optimize the translation just as Lazy.lazy_from_val would + do *) + begin match e.exp_desc with + (* a constant expr of type <> float gets compiled as itself *) + | Texp_constant + ( Const_int _ | Const_char _ | Const_string _ + | Const_int32 _ | Const_int64 _ | Const_nativeint _ ) + | Texp_function(_, _) + | Texp_construct ({cstr_arity = 0}, _) + -> transl_exp e + | Texp_constant(Const_float _) -> + Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e]) + | Texp_ident(_, _) -> (* according to the type *) + begin match e.exp_type.desc with + (* the following may represent a float/forward/lazy: need a + forward_tag *) + | Tvar | Tlink _ | Tsubst _ | Tunivar + | Tpoly(_,_) | Tfield(_,_,_,_) -> + Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e]) + (* the following cannot be represented as float/forward/lazy: + optimize *) + | Tarrow(_,_,_,_) | Ttuple _ | Tobject(_,_) | Tnil | Tvariant _ + -> transl_exp e + (* optimize predefined types (excepted float) *) + | Tconstr(_,_,_) -> + if has_base_type e Predef.path_int + || has_base_type e Predef.path_char + || has_base_type e Predef.path_string + || has_base_type e Predef.path_bool + || has_base_type e Predef.path_unit + || has_base_type e Predef.path_exn + || has_base_type e Predef.path_array + || has_base_type e Predef.path_list + || has_base_type e Predef.path_format6 + || has_base_type e Predef.path_option + || has_base_type e Predef.path_nativeint + || has_base_type e Predef.path_int32 + || has_base_type e Predef.path_int64 + then transl_exp e + else + Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e]) + end + (* other cases compile to a lazy block holding a function *) + | _ -> + let fn = Lfunction (Curried, [Ident.create "param"], transl_exp e) in + Lprim(Pmakeblock(Config.lazy_tag, Immutable), [fn]) + end | Texp_object (cs, cty, meths) -> let cl = Ident.create "class" in !transl_object cl meths @@ -748,17 +835,17 @@ and transl_cases pat_expr_list = and transl_tupled_cases patl_expr_list = List.map (fun (patl, expr) -> (patl, transl_exp expr)) patl_expr_list -and transl_apply lam sargs = +and transl_apply lam sargs loc = let lapply funct args = match funct with Lsend(k, lmet, lobj, largs) -> Lsend(k, lmet, lobj, largs @ args) | Levent(Lsend(k, lmet, lobj, largs), _) -> Lsend(k, lmet, lobj, largs @ args) - | Lapply(lexp, largs) -> - Lapply(lexp, largs @ args) + | Lapply(lexp, largs, _) -> + Lapply(lexp, largs @ args, loc) | lexp -> - Lapply(lexp, args) + Lapply(lexp, args, loc) in let rec build_apply lam args = function (None, optional) :: l -> @@ -800,7 +887,8 @@ and transl_apply lam sargs = and transl_function loc untuplify_fn repr partial pat_expr_list = match pat_expr_list with - [pat, ({exp_desc = Texp_function(pl,partial')} as exp)] -> + [pat, ({exp_desc = Texp_function(pl,partial')} as exp)] + when Parmatch.fluid pat -> let param = name_pattern "param" pat_expr_list in let ((_, params), body) = transl_function exp.exp_loc false repr partial' pl in diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli index c7609879..761c9e81 100644 --- a/bytecomp/translcore.mli +++ b/bytecomp/translcore.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: translcore.mli,v 1.18 2003/11/25 09:20:43 garrigue Exp $ *) +(* $Id: translcore.mli,v 1.19 2007/05/16 08:21:40 doligez Exp $ *) (* Translation from typed abstract syntax to lambda terms, for the core language *) @@ -23,7 +23,8 @@ open Lambda val name_pattern: string -> (pattern * 'a) list -> Ident.t val transl_exp: expression -> lambda -val transl_apply: lambda -> (expression option * optional) list -> lambda +val transl_apply: lambda -> (expression option * optional) list + -> Location.t -> lambda val transl_let: rec_flag -> (pattern * expression) list -> lambda -> lambda val transl_primitive: Primitive.description -> lambda diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index 24aa6343..4a7a9700 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: translmod.ml,v 1.52.8.1 2007/11/10 14:32:43 xleroy Exp $ *) +(* $Id: translmod.ml,v 1.56 2008/07/24 05:35:22 frisch Exp $ *) (* Translation from typed abstract syntax to lambda terms, for the module language *) @@ -47,7 +47,8 @@ let rec apply_coercion restr arg = name_lambda arg (fun id -> Lfunction(Curried, [param], apply_coercion cc_res - (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)])))) + (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)], + Location.none)))) | Tcoerce_primitive p -> transl_primitive p @@ -79,8 +80,11 @@ let rec compose_coercions c1 c2 = (* Record the primitive declarations occuring in the module compiled *) -let primitive_declarations = ref ([] : string list) - +let primitive_declarations = ref ([] : Primitive.description list) +let record_primitive = function + | {val_kind=Val_prim p} -> primitive_declarations := p :: !primitive_declarations + | _ -> () + (* Keep track of the root path (from the root of the namespace to the currently compiled module expression). Useful for naming exceptions. *) @@ -202,7 +206,7 @@ let eval_rec_bindings bindings cont = | (id, None, rhs) :: rem -> bind_inits rem | (id, Some(loc, shape), rhs) :: rem -> - Llet(Strict, id, Lapply(mod_prim "init_mod", [loc; shape]), + Llet(Strict, id, Lapply(mod_prim "init_mod", [loc; shape], Location.none), bind_inits rem) and bind_strict = function [] -> @@ -217,7 +221,8 @@ let eval_rec_bindings bindings cont = | (id, None, rhs) :: rem -> patch_forwards rem | (id, Some(loc, shape), rhs) :: rem -> - Lsequence(Lapply(mod_prim "update_mod", [shape; Lvar id; rhs]), + Lsequence(Lapply(mod_prim "update_mod", [shape; Lvar id; rhs], + Location.none), patch_forwards rem) in bind_inits bindings @@ -258,7 +263,7 @@ let rec transl_module cc rootpath mexp = oo_wrap mexp.mod_env true (apply_coercion cc) (Lapply(transl_module Tcoerce_none None funct, - [transl_module ccarg None arg])) + [transl_module ccarg None arg], mexp.mod_loc)) | Tmod_constraint(arg, mty, ccarg) -> transl_module (compose_coercions cc ccarg) rootpath arg @@ -287,11 +292,7 @@ and transl_structure fields cc rootpath = function transl_let rec_flag pat_expr_list (transl_structure ext_fields cc rootpath rem) | Tstr_primitive(id, descr) :: rem -> - begin match descr.val_kind with - Val_prim p -> primitive_declarations := - p.Primitive.prim_name :: !primitive_declarations - | _ -> () - end; + record_primitive descr; transl_structure fields cc rootpath rem | Tstr_type(decls) :: rem -> transl_structure fields cc rootpath rem @@ -359,9 +360,21 @@ let transl_implementation module_name (str, cc) = "map" is a table from defined idents to (pos in global block, coercion). "prim" is a list of (pos in global block, primitive declaration). *) +let transl_store_subst = ref Ident.empty + (** In the native toplevel, this reference is threaded through successive + calls of transl_store_structure *) + +let nat_toplevel_name id = + try match Ident.find_same id !transl_store_subst with + | Lprim(Pfield pos, [Lprim(Pgetglobal glob, [])]) -> (glob,pos) + | _ -> raise Not_found + with Not_found -> + fatal_error("Translmod.nat_toplevel_name: " ^ Ident.unique_name id) + let transl_store_structure glob map prims str = let rec transl_store subst = function [] -> + transl_store_subst := subst; lambda_unit | Tstr_eval expr :: rem -> Lsequence(subst_lambda subst (transl_exp expr), @@ -372,11 +385,7 @@ let transl_store_structure glob map prims str = Lsequence(subst_lambda subst lam, transl_store (add_idents false ids subst) rem) | Tstr_primitive(id, descr) :: rem -> - begin match descr.val_kind with - Val_prim p -> primitive_declarations := - p.Primitive.prim_name :: !primitive_declarations - | _ -> () - end; + record_primitive descr; transl_store subst rem | Tstr_type(decls) :: rem -> transl_store subst rem @@ -466,7 +475,7 @@ let transl_store_structure glob map prims str = [Lprim(Pgetglobal glob, []); transl_primitive prim]), cont) - in List.fold_right store_primitive prims (transl_store Ident.empty str) + in List.fold_right store_primitive prims (transl_store !transl_store_subst str) (* Build the list of value identifiers defined by a toplevel structure (excluding primitive declarations). *) @@ -525,18 +534,32 @@ let build_ident_map restr idlist = | _ -> fatal_error "Translmod.build_ident_map" -(* Compile an implementation using transl_store_structure +(* Compile an implementation using transl_store_structure (for the native-code compiler). *) -let transl_store_implementation module_name (str, restr) = +let transl_store_gen module_name (str, restr) topl = reset_labels (); primitive_declarations := []; let module_id = Ident.create_persistent module_name in let (map, prims, size) = build_ident_map restr (defined_idents str) in - transl_store_label_init module_id size - (transl_store_structure module_id map prims) str + let f = function + | [ Tstr_eval expr ] when topl -> + assert (size = 0); + subst_lambda !transl_store_subst (transl_exp expr) + | str -> transl_store_structure module_id map prims str in + transl_store_label_init module_id size f str (*size, transl_label_init (transl_store_structure module_id map prims str)*) +let transl_store_phrases module_name str = + transl_store_gen module_name (str,Tcoerce_none) true + +let transl_store_implementation module_name (str, restr) = + let s = !transl_store_subst in + transl_store_subst := Ident.empty; + let r = transl_store_gen module_name (str, restr) false in + transl_store_subst := s; + r + (* Compile a toplevel phrase *) let toploop_ident = Ident.create_persistent "Toploop" @@ -556,12 +579,14 @@ let toplevel_name id = let toploop_getvalue id = Lapply(Lprim(Pfield toploop_getvalue_pos, [Lprim(Pgetglobal toploop_ident, [])]), - [Lconst(Const_base(Const_string (toplevel_name id)))]) + [Lconst(Const_base(Const_string (toplevel_name id)))], + Location.none) let toploop_setvalue id lam = Lapply(Lprim(Pfield toploop_setvalue_pos, [Lprim(Pgetglobal toploop_ident, [])]), - [Lconst(Const_base(Const_string (toplevel_name id))); lam]) + [Lconst(Const_base(Const_string (toplevel_name id))); lam], + Location.none) let toploop_setvalue_id id = toploop_setvalue id (Lvar id) @@ -635,7 +660,7 @@ let transl_toplevel_definition str = let get_component = function None -> Lconst const_unit - | Some id -> Lprim(Pgetglobal id, []) + | Some id -> Lprim(Pgetglobal id, []) let transl_package component_names target_name coercion = let components = diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli index 95ddffad..b292c34c 100644 --- a/bytecomp/translmod.mli +++ b/bytecomp/translmod.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: translmod.mli,v 1.12 2004/04/09 13:32:27 xleroy Exp $ *) +(* $Id: translmod.mli,v 1.14 2008/07/24 05:35:22 frisch Exp $ *) (* Translation from typed abstract syntax to lambda terms, for the module language *) @@ -19,6 +19,7 @@ open Typedtree open Lambda val transl_implementation: string -> structure * module_coercion -> lambda +val transl_store_phrases: string -> structure -> int * lambda val transl_store_implementation: string -> structure * module_coercion -> int * lambda val transl_toplevel_definition: structure -> lambda @@ -28,8 +29,9 @@ val transl_store_package: Ident.t option list -> Ident.t -> module_coercion -> int * lambda val toplevel_name: Ident.t -> string +val nat_toplevel_name: Ident.t -> Ident.t * int -val primitive_declarations: string list ref +val primitive_declarations: Primitive.description list ref type error = Circular_dependency of Ident.t diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml index 5554ad1a..9133784f 100644 --- a/bytecomp/translobj.ml +++ b/bytecomp/translobj.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: translobj.ml,v 1.9 2004/05/26 11:10:51 garrigue Exp $ *) +(* $Id: translobj.ml,v 1.9.26.1 2008/10/08 13:07:13 doligez Exp $ *) open Misc open Primitive @@ -123,6 +123,7 @@ let transl_store_label_init glob size f arg = let wrapping = ref false let top_env = ref Env.empty let classes = ref [] +let method_ids = ref IdentSet.empty let oo_add_class id = classes := id :: !classes; @@ -138,6 +139,7 @@ let oo_wrap env req f x = cache_required := req; top_env := env; classes := []; + method_ids := IdentSet.empty; let lambda = f x in let lambda = List.fold_left diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli index 9d324364..7146d5ef 100644 --- a/bytecomp/translobj.mli +++ b/bytecomp/translobj.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: translobj.mli,v 1.6 2004/05/26 11:10:51 garrigue Exp $ *) +(* $Id: translobj.mli,v 1.6.26.1 2008/10/08 13:07:13 doligez Exp $ *) open Lambda @@ -24,5 +24,7 @@ val transl_label_init: lambda -> lambda val transl_store_label_init: Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda +val method_ids: IdentSet.t ref (* reset when starting a new wrapper *) + val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda val oo_add_class: Ident.t -> Env.t * bool diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml index 627f94f1..366bb3e9 100644 --- a/bytecomp/typeopt.ml +++ b/bytecomp/typeopt.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typeopt.ml,v 1.10.20.1 2008/01/18 03:54:57 garrigue Exp $ *) +(* $Id: typeopt.ml,v 1.13 2008/02/29 14:21:22 doligez Exp $ *) (* Auxiliaries for type-based optimizations, e.g. array kinds *) @@ -24,22 +24,22 @@ open Lambda let has_base_type exp base_ty_path = let exp_ty = - Ctype.expand_head exp.exp_env (Ctype.correct_levels exp.exp_type) in + Ctype.expand_head_opt exp.exp_env (Ctype.correct_levels exp.exp_type) in match Ctype.repr exp_ty with {desc = Tconstr(p, _, _)} -> Path.same p base_ty_path | _ -> false let maybe_pointer exp = let exp_ty = - Ctype.expand_head exp.exp_env (Ctype.correct_levels exp.exp_type) in + Ctype.expand_head_opt exp.exp_env (Ctype.correct_levels exp.exp_type) in match (Ctype.repr exp_ty).desc with Tconstr(p, args, abbrev) -> not (Path.same p Predef.path_int) && not (Path.same p Predef.path_char) && begin try match Env.find_type p exp.exp_env with - {type_kind = Type_variant([], _)} -> true (* type exn *) - | {type_kind = Type_variant(cstrs, _)} -> + {type_kind = Type_variant []} -> true (* type exn *) + | {type_kind = Type_variant cstrs} -> List.exists (fun (name, args) -> args <> []) cstrs | _ -> true with Not_found -> true @@ -50,7 +50,7 @@ let maybe_pointer exp = | _ -> true let array_element_kind env ty = - let ty = Ctype.repr (Ctype.expand_head env ty) in + let ty = Ctype.repr (Ctype.expand_head_opt env ty) in match ty.desc with Tvar | Tunivar -> Pgenarray @@ -70,7 +70,7 @@ let array_element_kind env ty = match Env.find_type p env with {type_kind = Type_abstract} -> Pgenarray - | {type_kind = Type_variant(cstrs, _)} + | {type_kind = Type_variant cstrs} when List.for_all (fun (name, args) -> args = []) cstrs -> Pintarray | {type_kind = _} -> @@ -85,7 +85,7 @@ let array_element_kind env ty = Paddrarray let array_kind_gen ty env = - let array_ty = Ctype.expand_head env (Ctype.correct_levels ty) in + let array_ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in match (Ctype.repr array_ty).desc with Tconstr(p, [elt_ty], _) | Tpoly({desc = Tconstr(p, [elt_ty], _)}, _) when Path.same p Predef.path_array -> @@ -125,7 +125,7 @@ let layout_table = "fortran_layout", Pbigarray_fortran_layout] let bigarray_kind_and_layout exp = - let ty = Ctype.repr (Ctype.expand_head exp.exp_env exp.exp_type) in + let ty = Ctype.repr (Ctype.expand_head_opt exp.exp_env exp.exp_type) in match ty.desc with Tconstr(p, [caml_type; elt_type; layout_type], abbrev) -> (bigarray_decode_type elt_type kind_table Pbigarray_unknown, diff --git a/byterun/.cvsignore b/byterun/.cvsignore index 90636dc1..9020f408 100644 --- a/byterun/.cvsignore +++ b/byterun/.cvsignore @@ -14,3 +14,4 @@ ocamlrun.dbg interp.a.lst *.[sd]obj *.lib +.gdb_history diff --git a/byterun/.depend b/byterun/.depend index 3ce28b10..dce39f11 100644 --- a/byterun/.depend +++ b/byterun/.depend @@ -6,8 +6,8 @@ array.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ minor_gc.h backtrace.o: backtrace.c config.h ../config/m.h ../config/s.h \ compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ - fix_code.h exec.h startup.h stacks.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h sys.h backtrace.h + fix_code.h exec.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + startup.h stacks.h sys.h backtrace.h callback.o: callback.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h @@ -43,14 +43,15 @@ floats.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h reverse.h stacks.h freelist.o: freelist.c config.h ../config/m.h ../config/s.h \ - compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h major_gc.h + compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h memory.h \ + major_gc.h minor_gc.h gc_ctrl.o: gc_ctrl.c alloc.h compatibility.h misc.h config.h \ ../config/m.h ../config/s.h mlvalues.h compact.h custom.h finalise.h \ roots.h memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h \ stacks.h globroots.o: globroots.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 \ - globroots.h + roots.h globroots.h hash.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h @@ -141,8 +142,8 @@ array.d.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ minor_gc.h backtrace.d.o: backtrace.c config.h ../config/m.h ../config/s.h \ compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ - fix_code.h exec.h startup.h stacks.h memory.h gc.h major_gc.h \ - freelist.h minor_gc.h sys.h backtrace.h + fix_code.h exec.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + startup.h stacks.h sys.h backtrace.h callback.d.o: callback.c callback.h compatibility.h mlvalues.h config.h \ ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h @@ -178,14 +179,15 @@ floats.d.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h reverse.h stacks.h freelist.d.o: freelist.c config.h ../config/m.h ../config/s.h \ - compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h major_gc.h + compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h memory.h \ + major_gc.h minor_gc.h gc_ctrl.d.o: gc_ctrl.c alloc.h compatibility.h misc.h config.h \ ../config/m.h ../config/s.h mlvalues.h compact.h custom.h finalise.h \ roots.h memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h \ stacks.h globroots.d.o: globroots.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 \ - globroots.h + roots.h globroots.h hash.d.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ minor_gc.h @@ -270,3 +272,139 @@ unix.d.o: unix.c config.h ../config/m.h ../config/s.h compatibility.h \ weak.d.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \ ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ minor_gc.h +alloc.pic.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 +array.pic.o: array.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h +backtrace.pic.o: backtrace.c config.h ../config/m.h ../config/s.h \ + compatibility.h mlvalues.h misc.h alloc.h io.h instruct.h intext.h \ + fix_code.h exec.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + startup.h stacks.h sys.h backtrace.h +callback.pic.o: callback.c callback.h compatibility.h mlvalues.h config.h \ + ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h interp.h instruct.h fix_code.h stacks.h +compact.pic.o: compact.c config.h ../config/m.h ../config/s.h compatibility.h \ + finalise.h roots.h misc.h memory.h gc.h mlvalues.h major_gc.h \ + freelist.h minor_gc.h gc_ctrl.h weak.h +compare.pic.o: compare.c custom.h compatibility.h mlvalues.h config.h \ + ../config/m.h ../config/s.h misc.h fail.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h +custom.pic.o: custom.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h custom.h fail.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h +debugger.pic.o: debugger.c config.h ../config/m.h ../config/s.h \ + compatibility.h debugger.h misc.h mlvalues.h fail.h fix_code.h \ + instruct.h intext.h io.h stacks.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h sys.h +dynlink.pic.o: dynlink.c config.h ../config/m.h ../config/s.h compatibility.h \ + alloc.h misc.h mlvalues.h dynlink.h fail.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h osdeps.h prims.h +extern.pic.o: extern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \ + memory.h major_gc.h freelist.h minor_gc.h reverse.h +fail.pic.o: fail.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h fail.h io.h gc.h memory.h major_gc.h \ + freelist.h minor_gc.h printexc.h signals.h stacks.h +finalise.pic.o: finalise.c callback.h compatibility.h mlvalues.h config.h \ + ../config/m.h ../config/s.h misc.h fail.h roots.h memory.h gc.h \ + major_gc.h freelist.h minor_gc.h signals.h +fix_code.pic.o: fix_code.c config.h ../config/m.h ../config/s.h \ + compatibility.h debugger.h misc.h mlvalues.h fix_code.h instruct.h \ + md5.h io.h memory.h gc.h major_gc.h freelist.h minor_gc.h reverse.h +floats.pic.o: floats.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h fail.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h reverse.h stacks.h +freelist.pic.o: freelist.c config.h ../config/m.h ../config/s.h \ + compatibility.h freelist.h misc.h mlvalues.h gc.h gc_ctrl.h memory.h \ + major_gc.h minor_gc.h +gc_ctrl.pic.o: gc_ctrl.c alloc.h compatibility.h misc.h config.h \ + ../config/m.h ../config/s.h mlvalues.h compact.h custom.h finalise.h \ + roots.h memory.h gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h \ + stacks.h +globroots.pic.o: globroots.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 \ + roots.h globroots.h +hash.pic.o: hash.c mlvalues.h compatibility.h config.h ../config/m.h \ + ../config/s.h misc.h custom.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h +instrtrace.pic.o: instrtrace.c +intern.pic.o: intern.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h custom.h fail.h gc.h intext.h io.h fix_code.h \ + memory.h major_gc.h freelist.h minor_gc.h reverse.h +interp.pic.o: interp.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h backtrace.h callback.h debugger.h fail.h \ + fix_code.h instrtrace.h instruct.h interp.h major_gc.h freelist.h \ + memory.h gc.h minor_gc.h prims.h signals.h stacks.h jumptbl.h +ints.pic.o: ints.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h custom.h fail.h intext.h io.h fix_code.h \ + memory.h gc.h major_gc.h freelist.h minor_gc.h int64_native.h +io.pic.o: io.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ + misc.h mlvalues.h custom.h fail.h io.h memory.h gc.h major_gc.h \ + freelist.h minor_gc.h signals.h sys.h +lexing.pic.o: lexing.c fail.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h stacks.h memory.h gc.h major_gc.h freelist.h \ + minor_gc.h +main.pic.o: main.c misc.h compatibility.h config.h ../config/m.h \ + ../config/s.h mlvalues.h sys.h +major_gc.pic.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.pic.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 memory.h gc.h major_gc.h \ + freelist.h minor_gc.h reverse.h +memory.pic.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 +meta.pic.o: meta.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h fail.h fix_code.h interp.h intext.h io.h \ + major_gc.h freelist.h memory.h gc.h minor_gc.h prims.h stacks.h +minor_gc.pic.o: minor_gc.c config.h ../config/m.h ../config/s.h \ + compatibility.h fail.h misc.h mlvalues.h finalise.h roots.h memory.h \ + gc.h major_gc.h freelist.h minor_gc.h gc_ctrl.h signals.h weak.h +misc.pic.o: misc.c config.h ../config/m.h ../config/s.h compatibility.h \ + misc.h memory.h gc.h mlvalues.h major_gc.h freelist.h minor_gc.h +obj.pic.o: obj.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h fail.h gc.h interp.h major_gc.h freelist.h \ + memory.h minor_gc.h prims.h +parsing.pic.o: parsing.c config.h ../config/m.h ../config/s.h compatibility.h \ + mlvalues.h misc.h memory.h gc.h major_gc.h freelist.h minor_gc.h \ + alloc.h +prims.pic.o: prims.c mlvalues.h compatibility.h config.h ../config/m.h \ + ../config/s.h misc.h prims.h +printexc.pic.o: printexc.c backtrace.h mlvalues.h compatibility.h config.h \ + ../config/m.h ../config/s.h misc.h callback.h debugger.h fail.h \ + printexc.h +roots.pic.o: roots.c finalise.h roots.h misc.h compatibility.h config.h \ + ../config/m.h ../config/s.h memory.h gc.h mlvalues.h major_gc.h \ + freelist.h minor_gc.h globroots.h stacks.h +signals.pic.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.pic.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.pic.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 +startup.pic.o: startup.c config.h ../config/m.h ../config/s.h compatibility.h \ + alloc.h misc.h mlvalues.h backtrace.h callback.h custom.h debugger.h \ + dynlink.h exec.h fail.h fix_code.h gc_ctrl.h instrtrace.h interp.h \ + intext.h io.h memory.h gc.h major_gc.h freelist.h minor_gc.h osdeps.h \ + prims.h printexc.h reverse.h signals.h stacks.h sys.h startup.h \ + version.h +str.pic.o: str.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h fail.h +sys.pic.o: sys.c config.h ../config/m.h ../config/s.h compatibility.h alloc.h \ + misc.h mlvalues.h debugger.h fail.h instruct.h osdeps.h signals.h \ + stacks.h memory.h gc.h major_gc.h freelist.h minor_gc.h sys.h +terminfo.pic.o: terminfo.c config.h ../config/m.h ../config/s.h \ + compatibility.h alloc.h misc.h mlvalues.h fail.h io.h +unix.pic.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.pic.o: weak.c alloc.h compatibility.h misc.h config.h ../config/m.h \ + ../config/s.h mlvalues.h fail.h major_gc.h freelist.h memory.h gc.h \ + minor_gc.h diff --git a/byterun/Makefile b/byterun/Makefile index e76fab32..1a56dd10 100644 --- a/byterun/Makefile +++ b/byterun/Makefile @@ -11,55 +11,33 @@ # # ######################################################################### -# $Id: Makefile,v 1.56 2007/02/23 09:29:45 xleroy Exp $ +# $Id: Makefile,v 1.64 2008/09/10 05:51:11 weis Exp $ -include ../config/Makefile +include Makefile.common -CC=$(BYTECC) -CFLAGS=-DCAML_NAME_SPACE -O $(BYTECCCOMPOPTS) +CFLAGS=-DCAML_NAME_SPACE -O $(BYTECCCOMPOPTS) $(IFLEXDIR) 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 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 \ - dynlink.o unix.o - +OBJS=$(COMMONOBJS) unix.o main.o DOBJS=$(OBJS:.o=.d.o) instrtrace.d.o +PICOBJS=$(OBJS:.o=.pic.o) + +#ifeq ($(SUPPORTS_SHARED_LIBRARIES),true) -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 \ - signals.c str.c sys.c terminfo.c callback.c weak.c finalise.c stacks.c \ - dynlink.c +all:: libcamlrun_shared.so -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 +install:: + cp libcamlrun_shared.so $(LIBDIR)/libcamlrun_shared.so -all: ocamlrun$(EXE) ld.conf +#endif ocamlrun$(EXE): libcamlrun.a prims.o - $(BYTECC) $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) -o ocamlrun$(EXE) \ - prims.o libcamlrun.a $(BYTECCLIBS) + $(MKEXE) $(BYTECCLINKOPTS) -o ocamlrun$(EXE) \ + prims.o libcamlrun.a $(BYTECCLIBS) ocamlrund$(EXE): libcamlrund.a prims.o - $(BYTECC) -g $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) -o ocamlrund$(EXE) \ - prims.o libcamlrund.a $(BYTECCLIBS) - -install: - cp ocamlrun$(EXE) $(BINDIR)/ocamlrun$(EXE) - cp libcamlrun.a $(LIBDIR)/libcamlrun.a - cd $(LIBDIR); $(RANLIB) libcamlrun.a - if test -d $(LIBDIR)/caml; then : ; else mkdir $(LIBDIR)/caml; fi - for i in $(PUBLIC_INCLUDES); do \ - sed -f ../tools/cleanup-header $$i > $(LIBDIR)/caml/$$i; \ - done - cp ld.conf $(LIBDIR)/ld.conf - -ld.conf: ../config/Makefile - echo "$(STUBLIBDIR)" >ld.conf - echo "$(LIBDIR)" >>ld.conf + $(MKEXE) -g $(BYTECCLINKOPTS) -o ocamlrund$(EXE) \ + prims.o libcamlrund.a $(BYTECCLIBS) libcamlrun.a: $(OBJS) ar rc libcamlrun.a $(OBJS) @@ -69,42 +47,10 @@ libcamlrund.a: $(DOBJS) ar rc libcamlrund.a $(DOBJS) $(RANLIB) libcamlrund.a -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" \ - $(PRIMS) > primitives - -prims.c : primitives - (echo '#include "mlvalues.h"'; \ - echo '#include "prims.h"'; \ - sed -e 's/.*/extern value &();/' primitives; \ - echo 'c_primitive caml_builtin_cprim[] = {'; \ - sed -e 's/.*/ &,/' primitives; \ - echo ' 0 };'; \ - echo 'char * caml_names_of_builtin_cprim[] = {'; \ - sed -e 's/.*/ "&",/' primitives; \ - echo ' 0 };') > prims.c - -opnames.h : instruct.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 : ../VERSION - echo "#define OCAML_VERSION \"`head -1 ../VERSION`\"" >version.h - -.SUFFIXES: .d.o +libcamlrun_shared.so: $(PICOBJS) + $(MKDLL) -o libcamlrun_shared.so $(PICOBJS) + +.SUFFIXES: .d.o .pic.o .c.d.o: @ if test -f $*.o; then mv $*.o $*.f.o; else :; fi @@ -112,8 +58,16 @@ version.h : ../VERSION mv $*.o $*.d.o @ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi +.c.pic.o: + @ if test -f $*.o; then mv $*.o $*.f.o; else :; fi + $(CC) -c $(CFLAGS) $(SHAREDCCCOMPOPTS) $< + mv $*.o $*.pic.o + @ if test -f $*.f.o; then mv $*.f.o $*.o; else :; fi + 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 | sed -e 's/\.o/.pic.o/' >> .depend +.PHONY: depend include .depend diff --git a/byterun/Makefile.common b/byterun/Makefile.common new file mode 100755 index 00000000..75f80564 --- /dev/null +++ b/byterun/Makefile.common @@ -0,0 +1,93 @@ +######################################################################### +# # +# 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.common,v 1.6 2008/09/10 05:51:11 weis Exp $ + +include ../config/Makefile + +CC=$(BYTECC) + +COMMONOBJS=\ + interp.o misc.o stacks.o fix_code.o startup.o \ + freelist.o major_gc.o minor_gc.o memory.o alloc.o roots.o globroots.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 \ + dynlink.o + +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 \ + signals.c str.c sys.c terminfo.c callback.c weak.c finalise.c stacks.c \ + dynlink.c backtrace.c + +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 + + +all:: ocamlrun$(EXE) ld.conf libcamlrun.$(A) +.PHONY: all + +ld.conf: ../config/Makefile + echo "$(STUBLIBDIR)" > ld.conf + echo "$(LIBDIR)" >> ld.conf + +install:: + cp ocamlrun$(EXE) $(BINDIR)/ocamlrun$(EXE) + cp libcamlrun.$(A) $(LIBDIR)/libcamlrun.$(A) + cd $(LIBDIR); $(RANLIB) libcamlrun.$(A) + if test -d $(LIBDIR)/caml; then : ; else mkdir $(LIBDIR)/caml; fi + for i in $(PUBLIC_INCLUDES); do \ + sed -f ../tools/cleanup-header $$i > $(LIBDIR)/caml/$$i; \ + done + cp ld.conf $(LIBDIR)/ld.conf +.PHONY: install + + +primitives : $(PRIMS) + sed -n -e "s/CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p" \ + $(PRIMS) > primitives + +prims.c : primitives + (echo '#include "mlvalues.h"'; \ + echo '#include "prims.h"'; \ + sed -e 's/.*/extern value &();/' primitives; \ + echo 'c_primitive caml_builtin_cprim[] = {'; \ + sed -e 's/.*/ &,/' primitives; \ + echo ' 0 };'; \ + echo 'char * caml_names_of_builtin_cprim[] = {'; \ + sed -e 's/.*/ "&",/' primitives; \ + echo ' 0 };') > prims.c + +opnames.h : instruct.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 : ../VERSION + echo "#define OCAML_VERSION \"`head -1 ../VERSION`\"" > version.h + +clean: + rm -f ocamlrun$(EXE) ocamlrund$(EXE) *.$(O) *.$(A) *.$(SO) + rm -f primitives prims.c opnames.h jumptbl.h ld.conf + rm -f version.h +.PHONY: clean diff --git a/byterun/Makefile.nt b/byterun/Makefile.nt index 3e4fcfca..f4729c17 100644 --- a/byterun/Makefile.nt +++ b/byterun/Makefile.nt @@ -11,107 +11,44 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.44 2007/02/23 09:29:45 xleroy Exp $ +# $Id: Makefile.nt,v 1.48 2008/07/29 08:31:41 xleroy Exp $ -include ../config/Makefile +include Makefile.common -CC=$(BYTECC) -CFLAGS=-DIN_OCAMLRUN -DOCAML_STDLIB_DIR='"$(LIBDIR)"' +CFLAGS=-DOCAML_STDLIB_DIR='"$(LIBDIR)"' $(IFLEXDIR) -COMMONOBJS=interp.o misc.o stacks.o fix_code.o startup.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 \ - win32.o printexc.o callback.o debugger.o weak.o compact.o \ - finalise.o custom.o backtrace.o globroots.o dynlink.o +DBGO=d.$(O) +OBJS=$(COMMONOBJS:.o=.$(O)) win32.$(O) main.$(O) +DOBJS=$(OBJS:.$(O)=.$(DBGO)) instrtrace.$(DBGO) -DOBJS=$(COMMONOBJS:.o=.$(DO)) prims.$(DO) -SOBJS=$(COMMONOBJS:.o=.$(SO)) main.$(SO) -DBGOBJS=$(COMMONOBJS:.o=.$(DBGO)) prims.$(DBGO) main.$(DBGO) instrtrace.$(DBGO) +ocamlrun$(EXE): libcamlrun.$(A) prims.$(O) + $(MKEXE) -o ocamlrun$(EXE) prims.$(O) $(call SYSLIB,ws2_32) libcamlrun.$(A) +ocamlrund$(EXE): libcamlrund.$(A) prims.$(O) main.$(O) + $(MKEXE) -o ocamlrun$(EXE) $(BYTECCDBGCOMPOPTS) prims.$(O) $(call SYSLIB,ws2_32) libcamlrund.$(A) -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 \ - signals.c str.c sys.c terminfo.c callback.c weak.c finalise.c stacks.c \ - dynlink.c +libcamlrun.$(A): $(OBJS) + $(call MKLIB,libcamlrun.$(A),$(OBJS)) -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 +libcamlrund.$(A): $(DOBJS) + $(call MKLIB,libcamlrund.$(A),$(DOBJS)) -all: ocamlrun.exe libcamlrun.$(A) +.SUFFIXES: .$(O) .$(DBGO) -ocamlrun.exe: ocamlrun.dll main.$(DO) - $(call MKEXE,ocamlrun.exe,main.$(DO) ocamlrun.$(A)) - -ocamlrun.dll: $(DOBJS) - $(call MKDLL,ocamlrun.dll,ocamlrun.$(A),$(DOBJS) $(BYTECCLIBS)) - -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 - cp ocamlrun.$(A) $(LIBDIR)/ocamlrun.$(A) - cp libcamlrun.$(A) $(LIBDIR)/libcamlrun.$(A) - test -d $(LIBDIR)/caml || mkdir -p $(LIBDIR)/caml - for i in $(PUBLIC_INCLUDES); do sed -f ../tools/cleanup-header $$i > $(LIBDIR)/caml/$$i; done - -clean: - rm -f *.exe *.dll *.$(O) *.$(A) - rm -f primitives prims.c opnames.h jumptbl.h - -primitives : $(PRIMS) - sed -n -e "s/CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p" \ - $(PRIMS) > primitives - -prims.c : primitives - (echo '#include "mlvalues.h"'; \ - echo '#include "prims.h"'; \ - sed -e 's/.*/extern value &();/' primitives; \ - echo 'c_primitive caml_builtin_cprim[] = {'; \ - sed -e 's/.*/ &,/' primitives; \ - echo ' 0 };'; \ - echo 'char * caml_names_of_builtin_cprim[] = {'; \ - sed -e 's/.*/ "&",/' primitives; \ - echo ' 0 };') > prims.c - -opnames.h : instruct.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 : ../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) .$(DBGO) - -.c.$(DO): - $(CC) $(CFLAGS) $(DLLCCCOMPOPTS) -c $< - mv $*.$(O) $*.$(DO) -.c.$(SO): +.c.$(O): $(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) \1.$$(DBGO):/' .depend > .depend.nt + rm -f .depend.win32 + echo "win32.o: win32.c fail.h compatibility.h misc.h config.h \\" >> .depend.win32 + echo " ../config/m.h ../config/s.h mlvalues.h memory.h gc.h \\" >> .depend.win32 + echo " major_gc.h freelist.h minor_gc.h osdeps.h signals.h" >> .depend.win32 + cat .depend >> .depend.win32 + sed -e '/\.d\.o/q' -e 's/^\(.*\)\.o:/\1.$$(O) \1.$$(DBGO):/' .depend.win32 > .depend.nt + rm -f .depend.win32 include .depend.nt diff --git a/byterun/array.c b/byterun/array.c index d2b98c82..88f16229 100644 --- a/byterun/array.c +++ b/byterun/array.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: array.c,v 1.23 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: array.c,v 1.26 2008/09/08 09:43:28 frisch Exp $ */ /* Operations on arrays */ @@ -21,8 +21,6 @@ #include "misc.h" #include "mlvalues.h" -#ifndef NATIVE_CODE - CAMLprim value caml_array_get_addr(value array, value index) { intnat idx = Long_val(index); @@ -125,8 +123,6 @@ CAMLprim value caml_array_unsafe_set(value array, value index, value newval) return caml_array_unsafe_set_addr(array, index, newval); } -#endif - CAMLprim value caml_make_vect(value len, value init) { CAMLparam2 (len, init); @@ -139,7 +135,7 @@ CAMLprim value caml_make_vect(value len, value init) res = Atom(0); } else if (Is_block(init) - && (Is_atom(init) || Is_young(init) || Is_in_heap(init)) + && Is_in_value_area(init) && Tag_val(init) == Double_tag) { d = Double_val(init); wsize = size * Double_wosize; @@ -181,7 +177,7 @@ CAMLprim value caml_make_array(value init) } else { v = Field(init, 0); if (Is_long(v) - || (!Is_atom(v) && !Is_young(v) && !Is_in_heap(v)) + || ! Is_in_value_area(v) || Tag_val(v) != Double_tag) { CAMLreturn (init); } else { diff --git a/byterun/backtrace.c b/byterun/backtrace.c index dd35361b..eb240fc3 100644 --- a/byterun/backtrace.c +++ b/byterun/backtrace.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: backtrace.c,v 1.24 2007/01/29 12:11:15 xleroy Exp $ */ +/* $Id: backtrace.c,v 1.25 2008/03/14 13:47:24 xleroy Exp $ */ /* Stack backtrace for uncaught exceptions */ @@ -29,6 +29,7 @@ #include "intext.h" #include "exec.h" #include "fix_code.h" +#include "memory.h" #include "startup.h" #include "stacks.h" #include "sys.h" @@ -59,14 +60,32 @@ enum { POS_CNUM = 3 }; -/* Initialize the backtrace machinery */ +/* Start or stop the backtrace machinery */ -void caml_init_backtrace(void) +CAMLprim value caml_record_backtrace(value vflag) { - caml_backtrace_active = 1; - caml_register_global_root(&caml_backtrace_last_exn); - /* Note: lazy initialization of caml_backtrace_buffer in caml_stash_backtrace - to simplify the interface with the thread libraries */ + int flag = Int_val(vflag); + + if (flag != caml_backtrace_active) { + caml_backtrace_active = flag; + caml_backtrace_pos = 0; + if (flag) { + caml_register_global_root(&caml_backtrace_last_exn); + } else { + caml_remove_global_root(&caml_backtrace_last_exn); + } + /* Note: lazy initialization of caml_backtrace_buffer in + caml_stash_backtrace to simplify the interface with the thread + libraries */ + } + return Val_unit; +} + +/* Return the status of the backtrace machinery */ + +CAMLprim value caml_backtrace_status(value vunit) +{ + return Val_bool(caml_backtrace_active); } /* Store the return addresses contained in the given stack fragment @@ -166,18 +185,50 @@ static value event_for_location(value events, code_t pc) return Val_false; } -/* Print the location corresponding to the given PC */ +/* Extract location information for the given PC */ + +struct loc_info { + int loc_valid; + int loc_is_raise; + char * loc_filename; + int loc_lnum; + int loc_startchr; + int loc_endchr; +}; -static void print_location(value events, int index) +static void extract_location_info(value events, code_t pc, + /*out*/ struct loc_info * li) { - code_t pc = caml_backtrace_buffer[index]; - char * info; - value ev; + value ev, ev_start; ev = event_for_location(events, pc); - if (caml_is_instruction(*pc, RAISE)) { - /* Ignore compiler-inserted raise */ - if (ev == Val_false) return; + li->loc_is_raise = caml_is_instruction(*pc, RAISE); + if (ev == Val_false) { + li->loc_valid = 0; + return; + } + li->loc_valid = 1; + ev_start = Field (Field (ev, EV_LOC), LOC_START); + li->loc_filename = String_val (Field (ev_start, POS_FNAME)); + li->loc_lnum = Int_val (Field (ev_start, POS_LNUM)); + li->loc_startchr = + Int_val (Field (ev_start, POS_CNUM)) + - Int_val (Field (ev_start, POS_BOL)); + li->loc_endchr = + Int_val (Field (Field (Field (ev, EV_LOC), LOC_END), POS_CNUM)) + - Int_val (Field (ev_start, POS_BOL)); +} + +/* Print location information */ + +static void print_location(struct loc_info * li, int index) +{ + char * info; + + /* Ignore compiler-inserted raise */ + if (!li->loc_valid && li->loc_is_raise) return; + + if (li->loc_is_raise) { /* Initial raise if index == 0, re-raise otherwise */ if (index == 0) info = "Raised at"; @@ -189,18 +240,12 @@ static void print_location(value events, int index) else info = "Called from"; } - if (ev == Val_false) { + if (! li->loc_valid) { fprintf(stderr, "%s unknown location\n", info); } else { - value ev_start = Field (Field (ev, EV_LOC), LOC_START); - char *fname = String_val (Field (ev_start, POS_FNAME)); - int lnum = Int_val (Field (ev_start, POS_LNUM)); - int startchr = Int_val (Field (ev_start, POS_CNUM)) - - Int_val (Field (ev_start, POS_BOL)); - int endchr = Int_val (Field (Field (Field (ev, EV_LOC), LOC_END), POS_CNUM)) - - Int_val (Field (ev_start, POS_BOL)); - fprintf (stderr, "%s file \"%s\", line %d, characters %d-%d\n", info, fname, - lnum, startchr, endchr); + fprintf (stderr, "%s file \"%s\", line %d, characters %d-%d\n", + info, li->loc_filename, li->loc_lnum, + li->loc_startchr, li->loc_endchr); } } @@ -210,6 +255,7 @@ CAMLexport void caml_print_exception_backtrace(void) { value events; int i; + struct loc_info li; events = read_debug_info(); if (events == Val_false) { @@ -217,6 +263,44 @@ CAMLexport void caml_print_exception_backtrace(void) "(Program not linked with -g, cannot print stack backtrace)\n"); return; } - for (i = 0; i < caml_backtrace_pos; i++) - print_location(events, i); + for (i = 0; i < caml_backtrace_pos; i++) { + extract_location_info(events, caml_backtrace_buffer[i], &li); + print_location(&li, i); + } +} + +/* Convert the backtrace to a data structure usable from Caml */ + +CAMLprim value caml_get_exception_backtrace(value unit) +{ + CAMLparam0(); + CAMLlocal5(events, res, arr, p, fname); + int i; + struct loc_info li; + + events = read_debug_info(); + if (events == Val_false) { + res = Val_int(0); /* None */ + } else { + arr = caml_alloc(caml_backtrace_pos, 0); + for (i = 0; i < caml_backtrace_pos; i++) { + extract_location_info(events, caml_backtrace_buffer[i], &li); + if (li.loc_valid) { + fname = caml_copy_string(li.loc_filename); + p = caml_alloc_small(5, 0); + Field(p, 0) = Val_bool(li.loc_is_raise); + Field(p, 1) = fname; + Field(p, 2) = Val_int(li.loc_lnum); + Field(p, 3) = Val_int(li.loc_startchr); + Field(p, 4) = Val_int(li.loc_endchr); + } else { + p = caml_alloc_small(1, 1); + Field(p, 0) = Val_bool(li.loc_is_raise); + } + caml_modify(&Field(arr, i), p); + } + res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ + } + CAMLreturn(res); } + diff --git a/byterun/backtrace.h b/byterun/backtrace.h index f962ad7b..25fbfb21 100644 --- a/byterun/backtrace.h +++ b/byterun/backtrace.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: backtrace.h,v 1.7 2007/01/29 12:11:15 xleroy Exp $ */ +/* $Id: backtrace.h,v 1.8 2008/03/14 13:47:24 xleroy Exp $ */ #ifndef CAML_BACKTRACE_H #define CAML_BACKTRACE_H @@ -23,7 +23,7 @@ CAMLextern int caml_backtrace_pos; CAMLextern code_t * caml_backtrace_buffer; CAMLextern value caml_backtrace_last_exn; -extern void caml_init_backtrace(void); +CAMLprim value caml_record_backtrace(value vflag); #ifndef NATIVE_CODE extern void caml_stash_backtrace(value exn, code_t pc, value * sp); #endif diff --git a/byterun/compact.c b/byterun/compact.c index 6759d53f..710c0969 100644 --- a/byterun/compact.c +++ b/byterun/compact.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: compact.c,v 1.24 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: compact.c,v 1.26 2008/02/29 12:56:15 doligez Exp $ */ #include @@ -38,7 +38,7 @@ extern void caml_shrink_heap (char *); /* memory.c */ 1: integer or (unencoded) infix header 2: inverted pointer for infix header 3: integer or encoded (noninfix) header - + XXX Should be fixed: XXX The above assumes that all roots are aligned on a 4-byte boundary, XXX which is not always guaranteed by C. @@ -60,7 +60,7 @@ static void invert_pointer_at (word *p) /* Use Ecolor (q) == 0 instead of Is_block (q) because q could be an inverted pointer for an infix header (with Ecolor == 2). */ - if (Ecolor (q) == 0 && Is_in_heap (q)){ + if (Ecolor (q) == 0 && (Classify_addr (q) & In_heap)){ switch (Ecolor (Hd_val (q))){ case 0: case 3: /* Pointer or header: insert in inverted list. */ @@ -203,7 +203,7 @@ void caml_compact_heap (void) while (Ecolor (q) == 0) q = * (word *) q; sz = Whsize_ehd (q); t = Tag_ehd (q); - + if (t == Infix_tag){ /* Get the original header of this block. */ infixes = p + sz; @@ -252,18 +252,18 @@ void caml_compact_heap (void) ch = caml_heap_start; while (ch != NULL){ word *p = (word *) ch; - + chend = ch + Chunk_size (ch); while ((char *) p < chend){ word q = *p; - + if (Ecolor (q) == 0 || Tag_ehd (q) == Infix_tag){ /* There were (normal or infix) pointers to this block. */ size_t sz; tag_t t; char *newadr; word *infixes = NULL; - + while (Ecolor (q) == 0) q = * (word *) q; sz = Whsize_ehd (q); t = Tag_ehd (q); @@ -393,7 +393,7 @@ void caml_compact_heap (void) caml_gc_message (0x10, "done.\n", 0); } -uintnat caml_percent_max; /* used in gc_ctrl.c */ +uintnat caml_percent_max; /* used in gc_ctrl.c and memory.c */ void caml_compact_heap_maybe (void) { @@ -408,7 +408,7 @@ void caml_compact_heap_maybe (void) float fw, fp; Assert (caml_gc_phase == Phase_idle); if (caml_percent_max >= 1000000) return; - if (caml_stat_major_collections < 5 || caml_stat_heap_chunks < 2) return; + if (caml_stat_major_collections < 3 || caml_stat_heap_chunks < 3) return; fw = 3.0 * caml_fl_cur_size - 2.0 * caml_fl_size_at_phase_change; if (fw < 0) fw = caml_fl_cur_size; diff --git a/byterun/compare.c b/byterun/compare.c index 8f4a5d75..c49316f3 100644 --- a/byterun/compare.c +++ b/byterun/compare.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: compare.c,v 1.36.4.1 2008/01/03 09:54:17 xleroy Exp $ */ +/* $Id: compare.c,v 1.39 2008/01/11 16:13:16 doligez Exp $ */ #include #include @@ -104,7 +104,7 @@ static intnat compare_val(value v1, value v2, int total) if (Is_long(v2)) return Long_val(v1) - Long_val(v2); /* Subtraction above cannot overflow and cannot result in UNORDERED */ - if ((Is_atom(v2) || Is_young(v2) || Is_in_heap(v2)) && + if (Is_in_value_area(v2) && Tag_val(v2) == Forward_tag) { v2 = Forward_val(v2); continue; @@ -112,7 +112,7 @@ static intnat compare_val(value v1, value v2, int total) return LESS; /* v1 long < v2 block */ } if (Is_long(v2)) { - if ((Is_atom(v1) || Is_young(v1) || Is_in_heap(v1)) && + if (Is_in_value_area(v1) && Tag_val(v1) == Forward_tag) { v1 = Forward_val(v1); continue; @@ -122,8 +122,7 @@ static intnat compare_val(value v1, value v2, int total) /* If one of the objects is outside the heap (but is not an atom), use address comparison. Since both addresses are 2-aligned, shift lsb off to avoid overflow in subtraction. */ - if ((!Is_atom(v1) && !Is_young(v1) && !Is_in_heap(v1)) || - (!Is_atom(v2) && !Is_young(v2) && !Is_in_heap(v2))) { + if (! Is_in_value_area(v1) || ! Is_in_value_area(v2)) { if (v1 == v2) goto next_item; return (v1 >> 1) - (v2 >> 1); /* Subtraction above cannot result in UNORDERED */ diff --git a/byterun/compatibility.h b/byterun/compatibility.h index f005bfd0..3c2d775c 100644 --- a/byterun/compatibility.h +++ b/byterun/compatibility.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: compatibility.h,v 1.15.6.1 2008/01/21 14:09:05 doligez Exp $ */ +/* $Id: compatibility.h,v 1.17 2008/07/28 11:59:55 doligez Exp $ */ /* definitions for compatibility with old identifiers */ @@ -211,7 +211,6 @@ /* **** major_gc.c */ #define heap_start caml_heap_start -#define heap_end caml_heap_end #define page_table caml_page_table /* **** md5.c */ diff --git a/byterun/config.h b/byterun/config.h index 53801d9c..2c4eb0aa 100644 --- a/byterun/config.h +++ b/byterun/config.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: config.h,v 1.40.6.1 2007/05/10 09:57:29 xleroy Exp $ */ +/* $Id: config.h,v 1.42 2008/01/03 09:37:09 xleroy Exp $ */ #ifndef CAML_CONFIG_H #define CAML_CONFIG_H @@ -107,7 +107,7 @@ typedef struct { uint32 l, h; } uint64, int64; /* Memory model parameters */ /* The size of a page for memory management (in bytes) is [1 << Page_log]. - It must be a multiple of [sizeof (value)]. */ + It must be a multiple of [sizeof (value)] and >= 8. */ #define Page_log 12 /* A page is 4 kilobytes. */ /* Initial size of stack (bytes). */ @@ -143,12 +143,13 @@ typedef struct { uint32 l, h; } uint64, int64; #define Heap_chunk_min (2 * Page_size / sizeof (value)) /* Default size increment when growing the heap. (words) - Must be a multiple of [Page_size / sizeof (value)]. */ -#define Heap_chunk_def (15 * Page_size) + Must be a multiple of [Page_size / sizeof (value)]. + (Approx 512 Kb for a 32-bit platform, 1 Mb for a 64-bit platform.) */ +#define Heap_chunk_def (31 * Page_size) /* Default initial size of the major heap (words); same constraints as for Heap_chunk_def. */ -#define Init_heap_def (15 * Page_size) +#define Init_heap_def (31 * Page_size) /* Default speed setting for the major GC. The heap will grow until diff --git a/byterun/debugger.c b/byterun/debugger.c index 125a9bf3..dd201fe0 100644 --- a/byterun/debugger.c +++ b/byterun/debugger.c @@ -11,10 +11,14 @@ /* */ /***********************************************************************/ -/* $Id: debugger.c,v 1.29 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: debugger.c,v 1.31 2008/07/29 08:31:41 xleroy Exp $ */ /* Interface with the debugger */ +#ifdef _WIN32 +#include +#endif /* _WIN32 */ + #include #include "config.h" @@ -32,7 +36,7 @@ int caml_debugger_in_use = 0; uintnat caml_event_count; -#if !defined(HAS_SOCKETS) || defined(_WIN32) +#if !defined(HAS_SOCKETS) void caml_debugger_init(void) { @@ -47,18 +51,28 @@ void caml_debugger(enum event_kind event) #ifdef HAS_UNISTD #include #endif +#include #include +#ifndef _WIN32 #include #include #include #include #include #include +#else +#define ATOM ATOM_WS +#include +#undef ATOM +#include +#endif static int sock_domain; /* Socket domain for the debugger */ static union { /* Socket address for the debugger */ struct sockaddr s_gen; +#ifndef _WIN32 struct sockaddr_un s_unix; +#endif struct sockaddr_in s_inet; } sock_addr; static int sock_addr_len; /* Length of sock_addr */ @@ -67,16 +81,50 @@ static int dbg_socket = -1; /* The socket connected to the debugger */ static struct channel * dbg_in; /* Input channel on the socket */ static struct channel * dbg_out;/* Output channel on the socket */ +static char *dbg_addr = "(none)"; + static void open_connection(void) { +#ifdef _WIN32 + /* Set socket to synchronous mode so that file descriptor-oriented + functions (read()/write() etc.) can be used */ + + int oldvalue, oldvaluelen, newvalue, retcode; + oldvaluelen = sizeof(oldvalue); + retcode = getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + (char *) &oldvalue, &oldvaluelen); + if (retcode == 0) { + newvalue = SO_SYNCHRONOUS_NONALERT; + setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + (char *) &newvalue, sizeof(newvalue)); + } +#endif dbg_socket = socket(sock_domain, SOCK_STREAM, 0); +#ifdef _WIN32 + if (retcode == 0) { + /* Restore initial mode */ + setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, + (char *) &oldvalue, oldvaluelen); + } +#endif if (dbg_socket == -1 || - connect(dbg_socket, &sock_addr.s_gen, sock_addr_len) == -1) - caml_fatal_error("cannot connect to debugger"); + connect(dbg_socket, &sock_addr.s_gen, sock_addr_len) == -1){ + caml_fatal_error_arg2 ("cannot connect to debugger at %s", dbg_addr, + "error: %s\n", strerror (errno)); + } +#ifdef _WIN32 + dbg_socket = _open_osfhandle(dbg_socket, 0); + if (dbg_socket == -1) + caml_fatal_error("_open_osfhandle failed"); +#endif dbg_in = caml_open_descriptor_in(dbg_socket); dbg_out = caml_open_descriptor_out(dbg_socket); if (!caml_debugger_in_use) caml_putword(dbg_out, -1); /* first connection */ +#ifdef _WIN32 + caml_putword(dbg_out, _getpid()); +#else caml_putword(dbg_out, getpid()); +#endif caml_flush(dbg_out); } @@ -87,6 +135,20 @@ static void close_connection(void) dbg_socket = -1; /* was closed by caml_close_channel */ } +#ifdef _WIN32 +static void winsock_startup(void) +{ + WSADATA wsaData; + int err = WSAStartup(MAKEWORD(2, 0), &wsaData); + if (err) caml_fatal_error("WSAStartup failed"); +} + +static void winsock_cleanup(void) +{ + WSACleanup(); +} +#endif + void caml_debugger_init(void) { char * address; @@ -96,21 +158,30 @@ void caml_debugger_init(void) address = getenv("CAML_DEBUG_SOCKET"); if (address == NULL) return; + dbg_addr = address; +#ifdef _WIN32 + winsock_startup(); + (void)atexit(winsock_cleanup); +#endif /* Parse the address */ port = NULL; for (p = address; *p != 0; p++) { if (*p == ':') { *p = 0; port = p+1; break; } } if (port == NULL) { +#ifndef _WIN32 /* Unix domain */ sock_domain = PF_UNIX; sock_addr.s_unix.sun_family = AF_UNIX; strncpy(sock_addr.s_unix.sun_path, address, sizeof(sock_addr.s_unix.sun_path)); - sock_addr_len = + sock_addr_len = ((char *)&(sock_addr.s_unix.sun_path) - (char *)&(sock_addr.s_unix)) + strlen(address); +#else + caml_fatal_error("Unix sockets not supported"); +#endif } else { /* Internet domain */ sock_domain = PF_INET; @@ -211,7 +282,7 @@ void caml_debugger(enum event_kind event) caml_flush(dbg_out); command_loop: - + /* Read and execute the commands sent by the debugger */ while(1) { switch(getch(dbg_in)) { @@ -235,6 +306,7 @@ void caml_debugger(enum event_kind event) caml_set_instruction(caml_start_code + pos, caml_saved_code[pos]); break; case REQ_CHECKPOINT: +#ifndef _WIN32 i = fork(); if (i == 0) { close_connection(); /* Close parent connection. */ @@ -243,6 +315,10 @@ void caml_debugger(enum event_kind event) caml_putword(dbg_out, i); caml_flush(dbg_out); } +#else + caml_fatal_error("error: REQ_CHECKPOINT command"); + exit(-1); +#endif break; case REQ_GO: caml_event_count = caml_getword(dbg_in); @@ -251,7 +327,12 @@ void caml_debugger(enum event_kind event) exit(0); break; case REQ_WAIT: +#ifndef _WIN32 wait(NULL); +#else + caml_fatal_error("Fatal error: REQ_WAIT command"); + exit(-1); +#endif break; case REQ_INITIAL_FRAME: frame = caml_extern_sp + 1; diff --git a/byterun/dynlink.c b/byterun/dynlink.c index 601e4cc2..ef8dcc07 100644 --- a/byterun/dynlink.c +++ b/byterun/dynlink.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: dynlink.c,v 1.17 2006/10/03 11:52:15 xleroy Exp $ */ +/* $Id: dynlink.c,v 1.18 2008/04/22 12:24:10 frisch 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, 1); + handle = caml_dlopen(realname, 1, 1); if (handle == NULL) caml_fatal_error_arg2("Fatal error: cannot load shared library %s\n", name, "Reason: %s\n", caml_dlerror()); @@ -201,7 +201,7 @@ CAMLprim value caml_dynlink_open_lib(value mode, value filename) caml_gc_message(0x100, "Opening shared library %s\n", (uintnat) String_val(filename)); - handle = caml_dlopen(String_val(filename), Int_val(mode)); + handle = caml_dlopen(String_val(filename), Int_val(mode), 1); 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 111d04d8..24c58336 100644 --- a/byterun/extern.c +++ b/byterun/extern.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: extern.c,v 1.61 2006/09/20 11:14:36 doligez Exp $ */ +/* $Id: extern.c,v 1.64 2008/08/04 11:45:58 xleroy Exp $ */ /* Structured output */ @@ -306,16 +306,16 @@ static void extern_rec(value v) writecode32(CODE_INT32, n); return; } - if (Is_young(v) || Is_in_heap(v) || Is_atom(v)) { + if (Is_in_value_area(v)) { header_t hd = Hd_val(v); tag_t tag = Tag_hd(hd); mlsize_t sz = Wosize_hd(hd); if (tag == Forward_tag) { value f = Forward_val (v); - if (Is_block (f) && (Is_young (f) || Is_in_heap (f)) - && (Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag - || Tag_val (f) == Double_tag)){ + if (Is_block (f) + && (!Is_in_value_area(f) || Tag_val (f) == Forward_tag + || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag)){ /* Do not short-circuit the pointer. */ }else{ v = f; @@ -639,7 +639,7 @@ CAMLexport void caml_serialize_float_4(float f) CAMLexport void caml_serialize_float_8(double f) { - caml_serialize_block_8(&f, 1); + caml_serialize_block_float_8(&f, 1); } CAMLexport void caml_serialize_block_1(void * data, intnat len) diff --git a/byterun/fail.c b/byterun/fail.c index ed185760..11146f46 100644 --- a/byterun/fail.c +++ b/byterun/fail.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: fail.c,v 1.31 2006/11/24 14:40:11 doligez Exp $ */ +/* $Id: fail.c,v 1.32 2008/09/18 11:23:28 xleroy Exp $ */ /* Raising exceptions from C. */ @@ -60,6 +60,21 @@ CAMLexport void caml_raise_with_arg(value tag, value arg) CAMLnoreturn; } +CAMLexport void caml_raise_with_args(value tag, int nargs, value args[]) +{ + CAMLparam1 (tag); + CAMLxparamN (args, nargs); + value bucket; + int i; + + Assert(1 + nargs <= Max_young_wosize); + bucket = caml_alloc_small (1 + nargs, 0); + Field(bucket, 0) = tag; + for (i = 0; i < nargs; i++) Field(bucket, 1 + i) = args[i]; + caml_raise(bucket); + CAMLnoreturn; +} + CAMLexport void caml_raise_with_string(value tag, char const *msg) { CAMLparam1 (tag); diff --git a/byterun/fail.h b/byterun/fail.h index 2cc3c3be..ab7b1908 100644 --- a/byterun/fail.h +++ b/byterun/fail.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: fail.h,v 1.26 2006/11/24 14:40:11 doligez Exp $ */ +/* $Id: fail.h,v 1.27 2008/09/18 11:23:28 xleroy Exp $ */ #ifndef CAML_FAIL_H #define CAML_FAIL_H @@ -60,6 +60,7 @@ 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_args (value tag, int nargs, value arg[]) 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; diff --git a/byterun/finalise.c b/byterun/finalise.c index 9408c9eb..980866a6 100644 --- a/byterun/finalise.c +++ b/byterun/finalise.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: finalise.c,v 1.19.10.2 2008/01/17 15:57:23 doligez Exp $ */ +/* $Id: finalise.c,v 1.23 2008/07/28 12:03:55 doligez Exp $ */ /* Handling of finalised values. */ @@ -88,9 +88,9 @@ void caml_final_update (void) value fv; Assert (final_table[i].offset == 0); fv = Forward_val (final_table[i].val); - if (Is_block (fv) && (Is_young (fv) || Is_in_heap (fv)) - && (Tag_val (fv) == Forward_tag || Tag_val (fv) == Lazy_tag - || Tag_val (fv) == Double_tag)){ + if (Is_block (fv) + && (!Is_in_value_area(fv) || Tag_val (fv) == Forward_tag + || Tag_val (fv) == Lazy_tag || Tag_val (fv) == Double_tag)){ /* Do not short-circuit the pointer. */ }else{ final_table[i].val = fv; @@ -209,7 +209,7 @@ void caml_final_empty_young (void) /* Put (f,v) in the recent set. */ CAMLprim value caml_final_register (value f, value v) { - if (!(Is_block (v) && (Is_in_heap (v) || Is_young (v)))){ + if (!(Is_block (v) && Is_in_heap_or_young(v))) { caml_invalid_argument ("Gc.finalise"); } Assert (old <= young); diff --git a/byterun/floats.c b/byterun/floats.c index e7a3018f..cdaff761 100644 --- a/byterun/floats.c +++ b/byterun/floats.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: floats.c,v 1.49 2005/10/12 14:50:03 xleroy Exp $ */ +/* $Id: floats.c,v 1.50 2008/08/02 11:02:28 xleroy Exp $ */ /* The interface of this file is in "mlvalues.h" and "alloc.h" */ @@ -394,7 +394,7 @@ CAMLprim value caml_classify_float(value vd) #else union { double d; -#ifdef ARCH_BIG_ENDIAN +#if defined(ARCH_BIG_ENDIAN) || (defined(__arm__) && !defined(__ARM_EABI__)) struct { uint32 h; uint32 l; } i; #else struct { uint32 l; uint32 h; } i; diff --git a/byterun/freelist.c b/byterun/freelist.c index 91c9d7cd..e8f111a8 100644 --- a/byterun/freelist.c +++ b/byterun/freelist.c @@ -11,12 +11,15 @@ /* */ /***********************************************************************/ -/* $Id: freelist.c,v 1.17.10.3 2008/02/19 13:36:49 doligez Exp $ */ +/* $Id: freelist.c,v 1.20 2008/02/29 14:21:22 doligez Exp $ */ + +#include #include "config.h" #include "freelist.h" #include "gc.h" #include "gc_ctrl.h" +#include "memory.h" #include "major_gc.h" #include "misc.h" #include "mlvalues.h" @@ -40,7 +43,6 @@ static struct { } sentinel = {0, Make_header (0, 0, Caml_blue), 0, 0}; #define Fl_head ((char *) (&(sentinel.first_bp))) -static char *fl_prev = Fl_head; /* Current allocation pointer. */ static char *fl_last = NULL; /* Last block in the list. Only valid just after [caml_fl_allocate] returns NULL. */ char *caml_fl_merge = Fl_head; /* Current insertion pointer. Managed @@ -48,30 +50,41 @@ char *caml_fl_merge = Fl_head; /* Current insertion pointer. Managed asize_t caml_fl_cur_size = 0; /* Number of words in the free list, including headers but not fragments. */ +#define FLP_MAX 1000 +static char *flp [FLP_MAX]; +static int flp_size = 0; +static char *beyond = NULL; + #define Next(b) (((block *) (b))->next_bp) #ifdef DEBUG static void fl_check (void) { char *cur, *prev; - int prev_found = 0, merge_found = 0; + int merge_found = 0; uintnat size_found = 0; + int flp_found = 0; + int sz = 0; prev = Fl_head; cur = Next (prev); while (cur != NULL){ size_found += Whsize_bp (cur); Assert (Is_in_heap (cur)); - if (cur == fl_prev) prev_found = 1; - if (cur == caml_fl_merge){ - merge_found = 1; - Assert (cur <= caml_gc_sweep_hp); - Assert (Next (cur) == NULL || Next (cur) > caml_gc_sweep_hp); + if (Wosize_bp (cur) > sz){ + sz = Wosize_bp (cur); + if (flp_found < flp_size){ + Assert (Next (flp[flp_found]) == cur); + ++ flp_found; + }else{ + Assert (beyond == NULL || cur >= Next (beyond)); + } } + if (cur == caml_fl_merge) merge_found = 1; prev = cur; cur = Next (prev); } - Assert (prev_found || fl_prev == Fl_head); + Assert (flp_found == flp_size); Assert (merge_found || caml_fl_merge == Fl_head); Assert (size_found == caml_fl_cur_size); } @@ -92,7 +105,7 @@ static void fl_check (void) it is located in the high-address words of the free block. This way, the linking of the free-list does not change in case 2. */ -static char *allocate_block (mlsize_t wh_sz, char *prev, char *cur) +static char *allocate_block (mlsize_t wh_sz, int flpi, char *prev, char *cur) { header_t h = Hd_bp (cur); Assert (Whsize_hd (h) >= wh_sz); @@ -108,11 +121,16 @@ static char *allocate_block (mlsize_t wh_sz, char *prev, char *cur) In case 0, it gives an invalid header to the block. The function calling [caml_fl_allocate] will overwrite it. */ Hd_op (cur) = Make_header (0, 0, Caml_white); + if (flpi + 1 < flp_size && flp[flpi + 1] == cur){ + flp[flpi + 1] = prev; + }else if (flpi == flp_size - 1){ + beyond = (prev == Fl_head) ? NULL : prev; + -- flp_size; + } }else{ /* Case 2. */ caml_fl_cur_size -= wh_sz; Hd_op (cur) = Make_header (Wosize_hd (h) - wh_sz, 0, Caml_blue); } - fl_prev = prev; return cur + Bosize_hd (h) - Bsize_wsize (wh_sz); } @@ -122,33 +140,129 @@ static char *allocate_block (mlsize_t wh_sz, char *prev, char *cur) */ char *caml_fl_allocate (mlsize_t wo_sz) { - char *cur, *prev; + char *cur = NULL, *prev, *result; + int i; + mlsize_t sz, prevsz; Assert (sizeof (char *) == sizeof (value)); - Assert (fl_prev != NULL); Assert (wo_sz >= 1); - /* Search from [fl_prev] to the end of the list. */ - prev = fl_prev; - cur = Next (prev); - while (cur != NULL){ Assert (Is_in_heap (cur)); - if (Wosize_bp (cur) >= wo_sz){ - return allocate_block (Whsize_wosize (wo_sz), prev, cur); + /* Search in the flp array. */ + for (i = 0; i < flp_size; i++){ + sz = Wosize_bp (Next (flp[i])); + if (sz >= wo_sz){ + result = allocate_block (Whsize_wosize (wo_sz), i, flp[i], Next (flp[i])); + goto update_flp; } - prev = cur; + } + /* Extend the flp array. */ + if (flp_size == 0){ + prev = Fl_head; + prevsz = 0; + }else{ + prev = Next (flp[flp_size - 1]); + prevsz = Wosize_bp (prev); + if (beyond != NULL) prev = beyond; + } + while (flp_size < FLP_MAX){ cur = Next (prev); + if (cur == NULL){ + fl_last = prev; + beyond = (prev == Fl_head) ? NULL : prev; + return NULL; + }else{ + sz = Wosize_bp (cur); + if (sz > prevsz){ + flp[flp_size] = prev; + ++ flp_size; + if (sz >= wo_sz){ + beyond = cur; + i = flp_size - 1; + result = allocate_block (Whsize_wosize (wo_sz), flp_size - 1, prev, + cur); + goto update_flp; + } + prevsz = sz; + } + } + prev = cur; } - fl_last = prev; - /* Search from the start of the list to [fl_prev]. */ - prev = Fl_head; + beyond = cur; + + /* The flp table is full. Do a slow first-fit search. */ + + if (beyond != NULL){ + prev = beyond; + }else{ + prev = flp[flp_size - 1]; + } + prevsz = Wosize_bp (Next (flp[FLP_MAX-1])); + Assert (prevsz < wo_sz); cur = Next (prev); - while (prev != fl_prev){ - if (Wosize_bp (cur) >= wo_sz){ - return allocate_block (Whsize_wosize (wo_sz), prev, cur); + while (cur != NULL){ + Assert (Is_in_heap (cur)); + sz = Wosize_bp (cur); + if (sz < prevsz){ + beyond = cur; + }else if (sz >= wo_sz){ + return allocate_block (Whsize_wosize (wo_sz), flp_size, prev, cur); } prev = cur; cur = Next (prev); } - /* No suitable block was found. */ + fl_last = prev; return NULL; + + update_flp: /* (i, sz) */ + /* The block at [i] was removed or reduced. Update the table. */ + Assert (0 <= i && i < flp_size + 1); + if (i < flp_size){ + if (i > 0){ + prevsz = Wosize_bp (Next (flp[i-1])); + }else{ + prevsz = 0; + } + if (i == flp_size - 1){ + if (Wosize_bp (Next (flp[i])) <= prevsz){ + beyond = Next (flp[i]); + -- flp_size; + }else{ + beyond = NULL; + } + }else{ + char *buf [FLP_MAX]; + int j = 0; + mlsize_t oldsz = sz; + + prev = flp[i]; + while (prev != flp[i+1]){ + cur = Next (prev); + sz = Wosize_bp (cur); + if (sz > prevsz){ + buf[j++] = prev; + prevsz = sz; + if (sz >= oldsz){ + Assert (sz == oldsz); + break; + } + } + prev = cur; + } + if (FLP_MAX >= flp_size + j - 1){ + memmove (&flp[i+j], &flp[i+1], sizeof (block *) * (flp_size - i - 1)); + memmove (&flp[i], &buf[0], sizeof (block *) * j); + flp_size += j - 1; + }else{ + if (FLP_MAX > i + j){ + memmove (&flp[i+j], &flp[i+1], sizeof (block *) * (FLP_MAX - i - j)); + memmove (&flp[i], &buf[0], sizeof (block *) * j); + }else{ + memmove (&flp[i], &buf[0], sizeof (block *) * (FLP_MAX - i)); + } + flp_size = FLP_MAX - 1; + beyond = Next (flp[FLP_MAX - 1]); + } + } + } + return result; } static char *last_fragment; @@ -162,11 +276,22 @@ void caml_fl_init_merge (void) #endif } +static void truncate_flp (char *changed) +{ + if (changed == Fl_head){ + flp_size = 0; + beyond = NULL; + }else{ + while (flp_size > 0 && Next (flp[flp_size - 1]) >= changed) -- flp_size; + if (beyond >= changed) beyond = NULL; + } +} + /* This is called by caml_compact_heap. */ void caml_fl_reset (void) { - Next (Fl_head) = 0; - fl_prev = Fl_head; + Next (Fl_head) = NULL; + truncate_flp (Fl_head); caml_fl_cur_size = 0; caml_fl_init_merge (); } @@ -191,6 +316,8 @@ char *caml_fl_merge_block (char *bp) Assert (prev < bp || prev == Fl_head); Assert (cur > bp || cur == NULL); + truncate_flp (prev); + /* If [last_fragment] and [bp] are adjacent, merge them. */ if (last_fragment == Hp_bp (bp)){ mlsize_t bp_whsz = Whsize_bp (bp); @@ -211,7 +338,6 @@ char *caml_fl_merge_block (char *bp) if (Wosize_hd (hd) + cur_whsz <= Max_wosize){ Next (prev) = next_cur; - if (fl_prev == cur) fl_prev = prev; hd = Make_header (Wosize_hd (hd) + cur_whsz, 0, Caml_blue); Hd_bp (bp) = hd; adj = bp + Bosize_hd (hd); @@ -269,12 +395,14 @@ void caml_fl_add_blocks (char *bp) if (fl_last == caml_fl_merge && bp < caml_gc_sweep_hp){ caml_fl_merge = (char *) Field (bp, 1); } + if (flp_size < FLP_MAX) flp [flp_size++] = fl_last; }else{ char *cur, *prev; prev = Fl_head; cur = Next (prev); while (cur != NULL && cur < bp){ Assert (prev < bp || prev == Fl_head); + /* XXX TODO: extend flp on the fly */ prev = cur; cur = Next (prev); } Assert (prev < bp || prev == Fl_head); @@ -287,6 +415,7 @@ void caml_fl_add_blocks (char *bp) if (prev == caml_fl_merge && bp < caml_gc_sweep_hp){ caml_fl_merge = (char *) Field (bp, 1); } + truncate_flp (bp); } } diff --git a/byterun/freelist.h b/byterun/freelist.h index ad745b07..ad84a338 100644 --- a/byterun/freelist.h +++ b/byterun/freelist.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: freelist.h,v 1.12.20.1 2008/02/12 21:26:29 doligez Exp $ */ +/* $Id: freelist.h,v 1.13 2008/02/29 12:56:15 doligez Exp $ */ /* Free lists of heap blocks. */ diff --git a/byterun/gc_ctrl.c b/byterun/gc_ctrl.c index 7f0a04d0..d87912bb 100644 --- a/byterun/gc_ctrl.c +++ b/byterun/gc_ctrl.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: gc_ctrl.c,v 1.50.10.2 2008/02/12 13:30:16 doligez Exp $ */ +/* $Id: gc_ctrl.c,v 1.53 2008/02/29 12:56:15 doligez Exp $ */ #include "alloc.h" #include "compact.h" @@ -457,6 +457,7 @@ void caml_init_gc (uintnat minor_size, uintnat major_size, { uintnat major_heap_size = Bsize_wsize (norm_heapincr (major_size)); + caml_page_table_initialize(Bsize_wsize(minor_size) + major_heap_size); caml_set_minor_heap_size (Bsize_wsize (norm_minsize (minor_size))); caml_major_heap_increment = Bsize_wsize (norm_heapincr (major_incr)); caml_percent_free = norm_pfree (percent_fr); diff --git a/byterun/globroots.c b/byterun/globroots.c index d2f0666b..f2372c1c 100644 --- a/byterun/globroots.c +++ b/byterun/globroots.c @@ -11,19 +11,33 @@ /* */ /***********************************************************************/ -/* $Id: globroots.c,v 1.8.10.1 2007/03/26 18:01:20 doligez Exp $ */ +/* $Id: globroots.c,v 1.11 2008/07/14 06:28:27 xleroy Exp $ */ /* Registration of global memory roots */ #include "memory.h" #include "misc.h" #include "mlvalues.h" +#include "roots.h" #include "globroots.h" -/* The set of global memory roots is represented as a skip list +/* The sets of global memory roots are represented as skip lists (see William Pugh, "Skip lists: a probabilistic alternative to balanced binary trees", Comm. ACM 33(6), 1990). */ +struct global_root { + value * root; /* the address of the root */ + struct global_root * forward[1]; /* variable-length array */ +}; + +#define NUM_LEVELS 17 + +struct global_root_list { + value * root; /* dummy value for layout compatibility */ + struct global_root * forward[NUM_LEVELS]; /* forward chaining */ + int level; /* max used level */ +}; + /* Generate a random level for a new node: 0 with probability 3/4, 1 with probability 3/16, 2 with probability 3/64, etc. We use a simple linear congruential PRNG (see Knuth vol 2) instead @@ -49,24 +63,19 @@ static int random_level(void) return level; } -/* The initial global root list */ - -struct global_root_list caml_global_roots = { NULL, { NULL, }, 0 }; - -/* Register a global C root */ +/* Insertion in a global root list */ -CAMLexport void caml_register_global_root(value *r) +static void caml_insert_global_root(struct global_root_list * rootlist, + value * r) { struct global_root * update[NUM_LEVELS]; struct global_root * e, * f; int i, new_level; - Assert (((intnat) r & 3) == 0); /* compact.c demands this (for now) */ - /* Init "cursor" to list head */ - e = (struct global_root *) &caml_global_roots; + e = (struct global_root *) rootlist; /* Find place to insert new node */ - for (i = caml_global_roots.level; i >= 0; i--) { + for (i = rootlist->level; i >= 0; i--) { while (1) { f = e->forward[i]; if (f == NULL || f->root >= r) break; @@ -79,10 +88,10 @@ CAMLexport void caml_register_global_root(value *r) if (e != NULL && e->root == r) return; /* Insert additional element, updating list level if necessary */ new_level = random_level(); - if (new_level > caml_global_roots.level) { - for (i = caml_global_roots.level + 1; i <= new_level; i++) - update[i] = (struct global_root *) &caml_global_roots; - caml_global_roots.level = new_level; + if (new_level > rootlist->level) { + for (i = rootlist->level + 1; i <= new_level; i++) + update[i] = (struct global_root *) rootlist; + rootlist->level = new_level; } e = caml_stat_alloc(sizeof(struct global_root) + new_level * sizeof(struct global_root *)); @@ -93,18 +102,19 @@ CAMLexport void caml_register_global_root(value *r) } } -/* Un-register a global C root */ +/* Deletion in a global root list */ -CAMLexport void caml_remove_global_root(value *r) +static void caml_delete_global_root(struct global_root_list * rootlist, + value * r) { struct global_root * update[NUM_LEVELS]; struct global_root * e, * f; int i; /* Init "cursor" to list head */ - e = (struct global_root *) &caml_global_roots; + e = (struct global_root *) rootlist; /* Find element in list */ - for (i = caml_global_roots.level; i >= 0; i--) { + for (i = rootlist->level; i >= 0; i--) { while (1) { f = e->forward[i]; if (f == NULL || f->root >= r) break; @@ -116,14 +126,136 @@ CAMLexport void caml_remove_global_root(value *r) /* If not found, nothing to do */ if (e == NULL || e->root != r) return; /* Rebuild list without node */ - for (i = 0; i <= caml_global_roots.level; i++) { + for (i = 0; i <= rootlist->level; i++) { if (update[i]->forward[i] == e) update[i]->forward[i] = e->forward[i]; } /* Reclaim list element */ caml_stat_free(e); /* Down-correct list level */ - while (caml_global_roots.level > 0 && - caml_global_roots.forward[caml_global_roots.level] == NULL) - caml_global_roots.level--; + while (rootlist->level > 0 && + rootlist->forward[rootlist->level] == NULL) + rootlist->level--; +} + +/* Iterate over a global root list */ + +static void caml_iterate_global_roots(scanning_action f, + struct global_root_list * rootlist) +{ + struct global_root * gr; + + for (gr = rootlist->forward[0]; gr != NULL; gr = gr->forward[0]) { + f(*(gr->root), gr->root); + } +} + +/* Empty a global root list */ + +static void caml_empty_global_roots(struct global_root_list * rootlist) +{ + struct global_root * gr, * next; + int i; + + for (gr = rootlist->forward[0]; gr != NULL; /**/) { + next = gr->forward[0]; + caml_stat_free(gr); + gr = next; + } + for (i = 0; i <= rootlist->level; i++) rootlist->forward[i] = NULL; + rootlist->level = 0; +} + +/* The three global root lists */ + +struct global_root_list caml_global_roots = { NULL, { NULL, }, 0 }; + /* mutable roots, don't know whether old or young */ +struct global_root_list caml_global_roots_young = { NULL, { NULL, }, 0 }; + /* generational roots pointing to minor or major heap */ +struct global_root_list caml_global_roots_old = { NULL, { NULL, }, 0 }; + /* generational roots pointing to major heap */ + +/* Register a global C root of the mutable kind */ + +CAMLexport void caml_register_global_root(value *r) +{ + Assert (((intnat) r & 3) == 0); /* compact.c demands this (for now) */ + caml_insert_global_root(&caml_global_roots, r); +} + +/* Un-register a global C root of the mutable kind */ + +CAMLexport void caml_remove_global_root(value *r) +{ + caml_delete_global_root(&caml_global_roots, r); +} + +/* Register a global C root of the generational kind */ + +CAMLexport void caml_register_generational_global_root(value *r) +{ + value v = *r; + Assert (((intnat) r & 3) == 0); /* compact.c demands this (for now) */ + if (Is_block(v)) { + if (Is_young(v)) + caml_insert_global_root(&caml_global_roots_young, r); + else if (Is_in_heap(v)) + caml_insert_global_root(&caml_global_roots_old, r); + } +} + +/* Un-register a global C root of the generational kind */ + +CAMLexport void caml_remove_generational_global_root(value *r) +{ + value v = *r; + if (Is_block(v)) { + if (Is_young(v)) + caml_delete_global_root(&caml_global_roots_young, r); + else if (Is_in_heap(v)) + caml_delete_global_root(&caml_global_roots_old, r); + } +} + +/* Modify the value of a global C root of the generational kind */ + +CAMLexport void caml_modify_generational_global_root(value *r, value newval) +{ + value oldval = *r; + + /* It is OK to have a root in roots_young that suddenly points to + the old generation -- the next minor GC will take care of that. + What needs corrective action is a root in roots_old that suddenly + points to the young generation. */ + if (Is_block(newval) && Is_young(newval) && + Is_block(oldval) && Is_in_heap(oldval)) { + caml_delete_global_root(&caml_global_roots_old, r); + caml_insert_global_root(&caml_global_roots_young, r); + } + *r = newval; +} + +/* Scan all global roots */ + +void caml_scan_global_roots(scanning_action f) +{ + caml_iterate_global_roots(f, &caml_global_roots); + caml_iterate_global_roots(f, &caml_global_roots_young); + caml_iterate_global_roots(f, &caml_global_roots_old); +} + +/* Scan global roots for a minor collection */ + +void caml_scan_global_young_roots(scanning_action f) +{ + struct global_root * gr; + + caml_iterate_global_roots(f, &caml_global_roots); + caml_iterate_global_roots(f, &caml_global_roots_young); + /* Move young roots to old roots */ + for (gr = caml_global_roots_young.forward[0]; + gr != NULL; gr = gr->forward[0]) { + caml_insert_global_root(&caml_global_roots_old, gr->root); + } + caml_empty_global_roots(&caml_global_roots_young); } diff --git a/byterun/globroots.h b/byterun/globroots.h index f7e6cc18..faa23032 100644 --- a/byterun/globroots.h +++ b/byterun/globroots.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: globroots.h,v 1.3.20.1 2007/03/26 18:01:20 doligez Exp $ */ +/* $Id: globroots.h,v 1.5 2008/03/10 19:56:39 xleroy Exp $ */ /* Registration of global memory roots */ @@ -19,22 +19,9 @@ #define CAML_GLOBROOTS_H #include "mlvalues.h" +#include "roots.h" -/* Skip list structure */ - -struct global_root { - value * root; /* the address of the root */ - struct global_root * forward[1]; /* variable-length array */ -}; - -#define NUM_LEVELS 17 - -struct global_root_list { - value * root; /* dummy value for layout compatibility */ - struct global_root * forward[NUM_LEVELS]; /* forward chaining */ - int level; /* max used level */ -}; - -extern struct global_root_list caml_global_roots; +void caml_scan_global_roots(scanning_action f); +void caml_scan_global_young_roots(scanning_action f); #endif /* CAML_GLOBROOTS_H */ diff --git a/byterun/hash.c b/byterun/hash.c index 99e2061e..dc0d58dc 100644 --- a/byterun/hash.c +++ b/byterun/hash.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: hash.c,v 1.23 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: hash.c,v 1.26 2008/08/01 14:10:36 xleroy Exp $ */ /* The generic hashing primitive */ @@ -62,7 +62,7 @@ static void hash_aux(value obj) We can inspect the block contents. */ Assert (Is_block (obj)); - if (Is_atom(obj) || Is_young(obj) || Is_in_heap(obj)) { + if (Is_in_value_area(obj)) { tag = Tag_val(obj); switch (tag) { case String_tag: @@ -142,7 +142,7 @@ static void hash_aux(value obj) /* Hashing variant tags */ -CAMLexport value caml_hash_variant(char * tag) +CAMLexport value caml_hash_variant(char const * tag) { value accu; /* Same hashing algorithm as in ../typing/btype.ml, function hash_variant */ diff --git a/byterun/instrtrace.c b/byterun/instrtrace.c index dbdbfdc2..fbff0013 100644 --- a/byterun/instrtrace.c +++ b/byterun/instrtrace.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: instrtrace.c,v 1.21 2005/10/18 14:04:13 xleroy Exp $ */ +/* $Id: instrtrace.c,v 1.22 2008/01/03 09:37:09 xleroy Exp $ */ /* Trace the instructions executed */ @@ -181,9 +181,7 @@ caml_trace_value_file (value v, code_t prog, int proglen, FILE * f) fprintf (f, "%#lx", v); if (!v) return; - if (Is_atom (v)) - fprintf (f, "=atom%ld", v - Atom (0)); - else if (prog && v % sizeof (int) == 0 + if (prog && v % sizeof (int) == 0 && (code_t) v >= prog && (code_t) v < (code_t) ((char *) prog + proglen)) fprintf (f, "=code@%d", (code_t) v - prog); diff --git a/byterun/intern.c b/byterun/intern.c index fbc4fe14..8cb25e6c 100644 --- a/byterun/intern.c +++ b/byterun/intern.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: intern.c,v 1.60.10.1 2007/10/09 12:48:54 xleroy Exp $ */ +/* $Id: intern.c,v 1.61 2008/01/11 16:13:16 doligez Exp $ */ /* Structured input, compact format */ diff --git a/byterun/interp.c b/byterun/interp.c index 58d81fd6..c8626504 100644 --- a/byterun/interp.c +++ b/byterun/interp.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: interp.c,v 1.96 2006/08/18 14:51:59 xleroy Exp $ */ +/* $Id: interp.c,v 1.97 2008/08/01 11:52:31 xleroy Exp $ */ /* The bytecode interpreter */ #include @@ -66,9 +66,12 @@ sp is a local copy of the global variable caml_extern_sp. */ #define Setup_for_gc \ { sp -= 2; sp[0] = accu; sp[1] = env; caml_extern_sp = sp; } -#define Restore_after_gc { accu = sp[0]; env = sp[1]; sp += 2; } -#define Setup_for_c_call { saved_pc = pc; *--sp = env; caml_extern_sp = sp; } -#define Restore_after_c_call { sp = caml_extern_sp; env = *sp++; } +#define Restore_after_gc \ + { accu = sp[0]; env = sp[1]; sp += 2; } +#define Setup_for_c_call \ + { saved_pc = pc; *--sp = env; caml_extern_sp = sp; } +#define Restore_after_c_call \ + { sp = caml_extern_sp; env = *sp++; saved_pc = NULL; } /* An event frame must look like accu + a C_CALL frame + a RETURN 1 frame */ #define Setup_for_event \ @@ -211,7 +214,7 @@ value caml_interprete(code_t prog, asize_t prog_size) /* volatile ensures that initial_local_roots and saved_pc will keep correct value across longjmp */ struct caml__roots_block * volatile initial_local_roots; - volatile code_t saved_pc; + volatile code_t saved_pc = NULL; struct longjmp_buffer raise_buf; value * modify_dest, modify_newval; #ifndef THREADED_CODE @@ -245,7 +248,9 @@ value caml_interprete(code_t prog, asize_t prog_size) caml_local_roots = initial_local_roots; sp = caml_extern_sp; accu = caml_exn_bucket; - pc = saved_pc + 2; /* +2 adjustement for the sole purpose of backtraces */ + pc = saved_pc; saved_pc = NULL; + if (pc != NULL) pc += 2; + /* +2 adjustement for the sole purpose of backtraces */ goto raise_exception; } caml_external_raise = &raise_buf; diff --git a/byterun/ints.c b/byterun/ints.c index d953374b..f6448c84 100644 --- a/byterun/ints.c +++ b/byterun/ints.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: ints.c,v 1.50.6.1 2007/10/25 11:39:45 xleroy Exp $ */ +/* $Id: ints.c,v 1.51 2008/01/11 16:13:16 doligez Exp $ */ #include #include diff --git a/byterun/io.h b/byterun/io.h index 749027aa..e0c5b367 100644 --- a/byterun/io.h +++ b/byterun/io.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: io.h,v 1.30.6.1 2007/05/21 13:17:47 doligez Exp $ */ +/* $Id: io.h,v 1.32 2008/09/27 21:16:29 weis Exp $ */ /* Buffered input/output */ @@ -102,6 +102,8 @@ CAMLextern void (*caml_channel_mutex_lock) (struct channel *); CAMLextern void (*caml_channel_mutex_unlock) (struct channel *); CAMLextern void (*caml_channel_mutex_unlock_exn) (void); +CAMLextern struct channel * caml_all_opened_channels; + #define Lock(channel) \ if (caml_channel_mutex_lock != NULL) (*caml_channel_mutex_lock)(channel) #define Unlock(channel) \ diff --git a/byterun/main.c b/byterun/main.c index 71b989d3..199b5085 100644 --- a/byterun/main.c +++ b/byterun/main.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: main.c,v 1.36.20.1 2008/02/12 13:30:16 doligez Exp $ */ +/* $Id: main.c,v 1.37 2008/02/29 12:56:15 doligez Exp $ */ /* Main entry point (can be overridden by a user-provided main() function that calls caml_main() later). */ diff --git a/byterun/major_gc.c b/byterun/major_gc.c index c97e493a..5f2863f8 100644 --- a/byterun/major_gc.c +++ b/byterun/major_gc.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: major_gc.c,v 1.58.10.3 2008/01/21 14:09:05 doligez Exp $ */ +/* $Id: major_gc.c,v 1.62 2008/07/28 12:03:55 doligez Exp $ */ #include @@ -31,9 +31,7 @@ uintnat caml_percent_free; intnat caml_major_heap_increment; -CAMLexport char *caml_heap_start, *caml_heap_end; -CAMLexport page_table_entry *caml_page_table; -asize_t caml_page_low, caml_page_high; +CAMLexport char *caml_heap_start; char *caml_gc_sweep_hp; int caml_gc_phase; /* always Phase_mark, Phase_sweep, or Phase_idle */ static value *gray_vals; @@ -146,9 +144,9 @@ static void mark_slice (intnat work) hd = Hd_val (child); if (Tag_hd (hd) == Forward_tag){ value f = Forward_val (child); - if (Is_block (f) && (Is_young (f) || Is_in_heap (f)) - && (Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag - || Tag_val (f) == Double_tag)){ + if (Is_block (f) + && (!Is_in_value_area(f) || Tag_val (f) == Forward_tag + || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag)){ /* Do not short-circuit the pointer. */ }else{ Field (v, i) = f; @@ -217,9 +215,9 @@ static void mark_slice (intnat work) && Is_block (curfield) && Is_in_heap (curfield)){ if (Tag_val (curfield) == Forward_tag){ value f = Forward_val (curfield); - if (Is_block (f) && (Is_young (f) || Is_in_heap (f))){ - if (Tag_val (f) == Forward_tag || Tag_val (f) == Lazy_tag - || Tag_val (f) == Double_tag){ + if (Is_block (f)) { + if (!Is_in_value_area(f) || Tag_val (f) == Forward_tag + || Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag){ /* Do not short-circuit the pointer. */ }else{ Field (cur, i) = curfield = f; @@ -469,10 +467,6 @@ asize_t caml_round_heap_chunk_size (asize_t request) void caml_init_major_heap (asize_t heap_size) { - asize_t i; - asize_t page_table_size; - page_table_entry *page_table_block; - caml_stat_heap_size = clip_heap_chunk_size (heap_size); caml_stat_top_heap_size = caml_stat_heap_size; Assert (caml_stat_heap_size % Page_size == 0); @@ -480,23 +474,11 @@ void caml_init_major_heap (asize_t heap_size) if (caml_heap_start == NULL) caml_fatal_error ("Fatal error: not enough memory for the initial heap.\n"); Chunk_next (caml_heap_start) = NULL; - caml_heap_end = caml_heap_start + caml_stat_heap_size; - Assert ((uintnat) caml_heap_end % Page_size == 0); - caml_stat_heap_chunks = 1; - caml_page_low = Page (caml_heap_start); - caml_page_high = Page (caml_heap_end); - - page_table_size = caml_page_high - caml_page_low; - page_table_block = - (page_table_entry *) malloc (page_table_size * sizeof (page_table_entry)); - if (page_table_block == NULL){ - caml_fatal_error ("Fatal error: not enough memory for the initial heap.\n"); - } - caml_page_table = page_table_block - caml_page_low; - for (i = Page (caml_heap_start); i < Page (caml_heap_end); i++){ - caml_page_table [i] = In_heap; + if (caml_page_table_add(In_heap, caml_heap_start, + caml_heap_start + caml_stat_heap_size) != 0) { + caml_fatal_error ("Fatal error: not enough memory for the initial page table.\n"); } caml_fl_init_merge (); @@ -506,7 +488,7 @@ void caml_init_major_heap (asize_t heap_size) gray_vals_size = 2048; gray_vals = (value *) malloc (gray_vals_size * sizeof (value)); if (gray_vals == NULL) - caml_fatal_error ("Fatal error: not enough memory for the initial heap.\n"); + caml_fatal_error ("Fatal error: not enough memory for the gray cache.\n"); gray_vals_cur = gray_vals; gray_vals_end = gray_vals + gray_vals_size; heap_is_pure = 1; diff --git a/byterun/major_gc.h b/byterun/major_gc.h index 1bcf45f6..bb31a6a9 100644 --- a/byterun/major_gc.h +++ b/byterun/major_gc.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: major_gc.h,v 1.21.10.1 2008/01/21 14:09:05 doligez Exp $ */ +/* $Id: major_gc.h,v 1.23 2008/01/11 11:55:36 doligez Exp $ */ #ifndef CAML_MAJOR_GC_H #define CAML_MAJOR_GC_H @@ -47,27 +47,10 @@ extern uintnat caml_fl_size_at_phase_change; #define Subphase_weak2 12 #define Subphase_final 13 -#ifdef __alpha -typedef int page_table_entry; -#else -typedef char page_table_entry; -#endif - CAMLextern char *caml_heap_start; -CAMLextern char *caml_heap_end; extern uintnat total_heap_size; -CAMLextern page_table_entry *caml_page_table; -extern asize_t caml_page_low, caml_page_high; extern char *caml_gc_sweep_hp; -#define In_heap 1 -#define Not_in_heap 0 -#define Page(p) ((uintnat) (p) >> Page_log) -#define Is_in_heap(p) \ - (Assert (Is_block ((value) (p))), \ - (addr)(p) >= (addr)caml_heap_start && (addr)(p) < (addr)caml_heap_end \ - && caml_page_table [Page (p)]) - void caml_init_major_heap (asize_t); /* size in bytes */ asize_t caml_round_heap_chunk_size (asize_t); /* size in bytes */ void caml_darken (value, value *); diff --git a/byterun/memory.c b/byterun/memory.c index 5337b637..9fdf706c 100644 --- a/byterun/memory.c +++ b/byterun/memory.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: memory.c,v 1.43.10.3 2008/02/12 21:26:29 doligez Exp $ */ +/* $Id: memory.c,v 1.46 2008/02/29 12:56:15 doligez Exp $ */ #include #include @@ -29,10 +29,159 @@ extern uintnat caml_percent_free; /* major_gc.c */ -#ifdef USE_MMAP_INSTEAD_OF_MALLOC -extern char * caml_aligned_mmap (asize_t size, int modulo, void ** block); -extern void caml_aligned_munmap (char * addr, asize_t size); +/* Page table management */ + +#define Page(p) ((uintnat) (p) >> Page_log) +#define Page_mask ((uintnat) -1 << Page_log) + +/* The page table is represented sparsely as a hash table + with linear probing */ + +struct page_table { + mlsize_t size; /* size == 1 << (wordsize - shift) */ + int shift; + mlsize_t mask; /* mask == size - 1 */ + mlsize_t occupancy; + uintnat * entries; /* [size] */ +}; + +static struct page_table caml_page_table; + +/* Page table entries are the logical 'or' of + - the key: address of a page (low Page_log bits = 0) + - the data: a 8-bit integer */ + +#define Page_entry_matches(entry,addr) \ + ((((entry) ^ (addr)) & Page_mask) == 0) + +/* Multiplicative Fibonacci hashing + (Knuth, TAOCP vol 3, section 6.4, page 518). + HASH_FACTOR is (sqrt(5) - 1) / 2 * 2^wordsize. */ +#ifdef ARCH_SIXTYFOUR +#define HASH_FACTOR 11400714819323198486UL +#else +#define HASH_FACTOR 2654435769UL #endif +#define Hash(v) (((v) * HASH_FACTOR) >> caml_page_table.shift) + +int caml_page_table_lookup(void * addr) +{ + uintnat h, e; + + h = Hash(Page(addr)); + /* The first hit is almost always successful, so optimize for this case */ + e = caml_page_table.entries[h]; + if (Page_entry_matches(e, (uintnat)addr)) return e & 0xFF; + while(1) { + if (e == 0) return 0; + h = (h + 1) & caml_page_table.mask; + e = caml_page_table.entries[h]; + if (Page_entry_matches(e, (uintnat)addr)) return e & 0xFF; + } +} + +int caml_page_table_initialize(mlsize_t bytesize) +{ + uintnat pagesize = Page(bytesize); + + caml_page_table.size = 1; + caml_page_table.shift = 8 * sizeof(uintnat); + /* Aim for initial load factor between 1/4 and 1/2 */ + while (caml_page_table.size < 2 * pagesize) { + caml_page_table.size <<= 1; + caml_page_table.shift -= 1; + } + caml_page_table.mask = caml_page_table.size - 1; + caml_page_table.occupancy = 0; + caml_page_table.entries = calloc(caml_page_table.size, sizeof(uintnat)); + if (caml_page_table.entries == NULL) + return -1; + else + return 0; +} + +static int caml_page_table_resize(void) +{ + struct page_table old = caml_page_table; + uintnat * new_entries; + uintnat i, h; + + caml_gc_message (0x08, "Growing page table to %lu entries\n", + caml_page_table.size); + + new_entries = calloc(2 * old.size, sizeof(uintnat)); + if (new_entries == NULL) { + caml_gc_message (0x08, "No room for growing page table\n", 0); + return -1; + } + + caml_page_table.size = 2 * old.size; + caml_page_table.shift = old.shift - 1; + caml_page_table.mask = caml_page_table.size - 1; + caml_page_table.occupancy = old.occupancy; + caml_page_table.entries = new_entries; + + for (i = 0; i < old.size; i++) { + uintnat e = old.entries[i]; + if (e == 0) continue; + h = Hash(Page(e)); + while (caml_page_table.entries[h] != 0) + h = (h + 1) & caml_page_table.mask; + caml_page_table.entries[h] = e; + } + + free(old.entries); + return 0; +} + +static int caml_page_table_modify(uintnat page, int toclear, int toset) +{ + uintnat h; + + Assert ((page & ~Page_mask) == 0); + + /* Resize to keep load factor below 1/2 */ + if (caml_page_table.occupancy * 2 >= caml_page_table.size) { + if (caml_page_table_resize() != 0) return -1; + } + h = Hash(Page(page)); + while (1) { + if (caml_page_table.entries[h] == 0) { + caml_page_table.entries[h] = page | toset; + caml_page_table.occupancy++; + break; + } + if (Page_entry_matches(caml_page_table.entries[h], page)) { + caml_page_table.entries[h] = + (caml_page_table.entries[h] & ~toclear) | toset; + break; + } + h = (h + 1) & caml_page_table.mask; + } + return 0; +} + +int caml_page_table_add(int kind, void * start, void * end) +{ + uintnat pstart = (uintnat) start & Page_mask; + uintnat pend = ((uintnat) end - 1) & Page_mask; + uintnat p; + + for (p = pstart; p <= pend; p += Page_size) + if (caml_page_table_modify(p, 0, kind) != 0) return -1; + return 0; +} + +int caml_page_table_remove(int kind, void * start, void * end) +{ + uintnat pstart = (uintnat) start & Page_mask; + uintnat pend = ((uintnat) end - 1) & Page_mask; + uintnat p; + + for (p = pstart; p <= pend; p += Page_size) + if (caml_page_table_modify(p, kind, 0) != 0) return -1; + return 0; +} /* Allocate a block of the requested size, to be passed to [caml_add_to_heap] later. @@ -46,13 +195,8 @@ char *caml_alloc_for_heap (asize_t request) char *mem; void *block; Assert (request % Page_size == 0); -#ifdef USE_MMAP_INSTEAD_OF_MALLOC - mem = caml_aligned_mmap (request + sizeof (heap_chunk_head), - sizeof (heap_chunk_head), &block); -#else mem = caml_aligned_malloc (request + sizeof (heap_chunk_head), sizeof (heap_chunk_head), &block); -#endif if (mem == NULL) return NULL; mem += sizeof (heap_chunk_head); Chunk_size (mem) = request; @@ -65,12 +209,7 @@ char *caml_alloc_for_heap (asize_t request) */ void caml_free_for_heap (char *mem) { -#ifdef USE_MMAP_INSTEAD_OF_MALLOC - caml_aligned_munmap (Chunk_block (mem), - Chunk_size (mem) + sizeof (heap_chunk_head)); -#else free (Chunk_block (mem)); -#endif } /* Take a chunk of memory as argument, which must be the result of a @@ -78,13 +217,12 @@ void caml_free_for_heap (char *mem) The contents of the chunk must be a sequence of valid blocks and fragments: no space between blocks and no trailing garbage. If some blocks are blue, they must be added to the free list by the - caller. All other blocks must have the color [caml_allocation_color(mem)]. + caller. All other blocks must have the color [caml_allocation_color(m)]. The caller must update [caml_allocated_words] if applicable. Return value: 0 if no error; -1 in case of error. */ int caml_add_to_heap (char *m) { - asize_t i; Assert (Chunk_size (m) % Page_size == 0); #ifdef DEBUG /* Should check the contents of the block. */ @@ -93,56 +231,9 @@ int caml_add_to_heap (char *m) caml_gc_message (0x04, "Growing heap to %luk bytes\n", (caml_stat_heap_size + Chunk_size (m)) / 1024); - /* Extend the page table as needed. */ - if (Page (m) < caml_page_low){ - page_table_entry *block, *new_page_table; - asize_t new_page_low = Page (m); - asize_t new_size = caml_page_high - new_page_low; - - caml_gc_message (0x08, "Growing page table to %lu entries\n", new_size); - block = malloc (new_size * sizeof (page_table_entry)); - if (block == NULL){ - caml_gc_message (0x08, "No room for growing page table\n", 0); - return -1; - } - new_page_table = block - new_page_low; - for (i = new_page_low; i < caml_page_low; i++){ - new_page_table [i] = Not_in_heap; - } - for (i = caml_page_low; i < caml_page_high; i++){ - new_page_table [i] = caml_page_table [i]; - } - free (caml_page_table + caml_page_low); - caml_page_table = new_page_table; - caml_page_low = new_page_low; - } - if (Page (m + Chunk_size (m)) > caml_page_high){ - page_table_entry *block, *new_page_table; - asize_t new_page_high = Page (m + Chunk_size (m)); - asize_t new_size = new_page_high - caml_page_low; - - caml_gc_message (0x08, "Growing page table to %lu entries\n", new_size); - block = malloc (new_size * sizeof (page_table_entry)); - if (block == NULL){ - caml_gc_message (0x08, "No room for growing page table\n", 0); - return -1; - } - new_page_table = block - caml_page_low; - for (i = caml_page_low; i < caml_page_high; i++){ - new_page_table [i] = caml_page_table [i]; - } - for (i = caml_page_high; i < new_page_high; i++){ - new_page_table [i] = Not_in_heap; - } - free (caml_page_table + caml_page_low); - caml_page_table = new_page_table; - caml_page_high = new_page_high; - } - - /* Mark the pages as being in the heap. */ - for (i = Page (m); i < Page (m + Chunk_size (m)); i++){ - caml_page_table [i] = In_heap; - } + /* Register block in page table */ + if (caml_page_table_add(In_heap, m, m + Chunk_size(m)) != 0) + return -1; /* Chain this heap chunk. */ { @@ -159,10 +250,6 @@ int caml_add_to_heap (char *m) ++ caml_stat_heap_chunks; } - /* Update the heap bounds as needed. */ - /* already done: if (m < caml_heap_start) heap_start = m; */ - if (m + Chunk_size (m) > caml_heap_end) caml_heap_end = m + Chunk_size (m); - caml_stat_heap_size += Chunk_size (m); if (caml_stat_heap_size > caml_stat_top_heap_size){ caml_stat_top_heap_size = caml_stat_heap_size; @@ -230,7 +317,6 @@ static char *expand_heap (mlsize_t request) void caml_shrink_heap (char *chunk) { char **cp; - asize_t i; /* Never deallocate the first block, because caml_heap_start is both the first block and the base address for page numbers, and we don't @@ -242,7 +328,7 @@ void caml_shrink_heap (char *chunk) caml_stat_heap_size -= Chunk_size (chunk); caml_gc_message (0x04, "Shrinking heap to %luk bytes\n", - caml_stat_heap_size / 1024); + (unsigned long) caml_stat_heap_size / 1024); #ifdef DEBUG { @@ -261,9 +347,7 @@ void caml_shrink_heap (char *chunk) *cp = Chunk_next (chunk); /* Remove the pages of [chunk] from the page table. */ - for (i = Page (chunk); i < Page (chunk + Chunk_size (chunk)); i++){ - caml_page_table [i] = Not_in_heap; - } + caml_page_table_remove(In_heap, chunk, chunk + Chunk_size (chunk)); /* Free the [malloc] block that contains [chunk]. */ caml_free_for_heap (chunk); diff --git a/byterun/memory.h b/byterun/memory.h index b830ba5b..f17903d0 100644 --- a/byterun/memory.h +++ b/byterun/memory.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: memory.h,v 1.56.4.1 2008/01/21 14:09:05 doligez Exp $ */ +/* $Id: memory.h,v 1.59 2008/03/10 19:56:39 xleroy Exp $ */ /* Allocation macros and functions */ @@ -49,6 +49,23 @@ color_t caml_allocation_color (void *hp); /* */ +#define Not_in_heap 0 +#define In_heap 1 +#define In_young 2 +#define In_static_data 4 +#define In_code_area 8 + +#define Classify_addr(a) (caml_page_table_lookup((void *)(a))) +#define Is_in_value_area(a) \ + (Classify_addr(a) & (In_heap | In_young | In_static_data)) +#define Is_in_heap(a) (Classify_addr(a) & In_heap) +#define Is_in_heap_or_young(a) (Classify_addr(a) & (In_heap | In_young)) + +int caml_page_table_lookup(void * addr); +int caml_page_table_add(int kind, void * start, void * end); +int caml_page_table_remove(int kind, void * start, void * end); +int caml_page_table_initialize(mlsize_t bytesize); + #ifdef DEBUG #define DEBUG_clear(result, wosize) do{ \ uintnat caml__DEBUG_i; \ @@ -389,5 +406,33 @@ CAMLextern void caml_register_global_root (value *); CAMLextern void caml_remove_global_root (value *); +/* [caml_register_generational_global_root] registers a global C + variable as a memory root for the duration of the program, or until + [caml_remove_generational_global_root] is called. + The program guarantees that the value contained in this variable + will not be assigned directly. If the program needs to change + the value of this variable, it must do so by calling + [caml_modify_generational_global_root]. The [value *] pointer + passed to [caml_register_generational_global_root] must contain + a valid Caml value before the call. + In return for these constraints, scanning of memory roots during + minor collection is made more efficient. */ + +CAMLextern void caml_register_generational_global_root (value *); + +/* [caml_remove_generational_global_root] removes a memory root + registered on a global C variable with + [caml_register_generational_global_root]. */ + +CAMLextern void caml_remove_generational_global_root (value *); + +/* [caml_modify_generational_global_root(r, newval)] + modifies the value contained in [r], storing [newval] inside. + In other words, the assignment [*r = newval] is performed, + but in a way that is compatible with the optimized scanning of + generational global roots. [r] must be a global memory root + previously registered with [caml_register_generational_global_root]. */ + +CAMLextern void caml_modify_generational_global_root(value *r, value newval); #endif /* CAML_MEMORY_H */ diff --git a/byterun/meta.c b/byterun/meta.c index c0e38efd..d3b0d94b 100644 --- a/byterun/meta.c +++ b/byterun/meta.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: meta.c,v 1.32 2007/01/29 12:11:15 xleroy Exp $ */ +/* $Id: meta.c,v 1.33 2008/01/31 09:13:19 frisch Exp $ */ /* Primitives for the toplevel */ @@ -155,6 +155,12 @@ value caml_invoke_traced_function(value codeptr, value env, value arg) return Val_unit; /* not reached */ } +value caml_reify_bytecode(value prog, value len) +{ + caml_invalid_argument("Meta.reify_bytecode"); + return Val_unit; /* not reached */ +} + value * caml_stack_low; value * caml_stack_high; value * caml_stack_threshold; diff --git a/byterun/minor_gc.c b/byterun/minor_gc.c index b262830e..f20411c4 100644 --- a/byterun/minor_gc.c +++ b/byterun/minor_gc.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: minor_gc.c,v 1.43.10.2 2008/01/21 14:09:05 doligez Exp $ */ +/* $Id: minor_gc.c,v 1.47 2008/07/28 12:03:55 doligez Exp $ */ #include #include "config.h" @@ -29,6 +29,7 @@ #include "weak.h" asize_t caml_minor_heap_size; +static void *caml_young_base = NULL; CAMLexport char *caml_young_start = NULL, *caml_young_end = NULL; CAMLexport char *caml_young_ptr = NULL, *caml_young_limit = NULL; @@ -75,16 +76,23 @@ static void clear_table (struct caml_ref_table *tbl) void caml_set_minor_heap_size (asize_t size) { char *new_heap; + void *new_heap_base; Assert (size >= Minor_heap_min); Assert (size <= Minor_heap_max); Assert (size % sizeof (value) == 0); if (caml_young_ptr != caml_young_end) caml_minor_collection (); Assert (caml_young_ptr == caml_young_end); - new_heap = (char *) caml_stat_alloc (size); + new_heap = caml_aligned_malloc(size, 0, &new_heap_base); + if (new_heap == NULL) caml_raise_out_of_memory(); + if (caml_page_table_add(In_young, new_heap, new_heap + size) != 0) + caml_raise_out_of_memory(); + if (caml_young_start != NULL){ - caml_stat_free (caml_young_start); + caml_page_table_remove(In_young, caml_young_start, caml_young_end); + free (caml_young_base); } + caml_young_base = new_heap_base; caml_young_start = new_heap; caml_young_end = new_heap + size; caml_young_limit = caml_young_start; @@ -148,12 +156,16 @@ void caml_oldify_one (value v, value *p) }else{ value f = Forward_val (v); tag_t ft = 0; + int vv = 1; Assert (tag == Forward_tag); - if (Is_block (f) && (Is_young (f) || Is_in_heap (f))){ - ft = Tag_val (Hd_val (f) == 0 ? Field (f, 0) : f); + if (Is_block (f)){ + vv = Is_in_value_area(f); + if (vv) { + ft = Tag_val (Hd_val (f) == 0 ? Field (f, 0) : f); + } } - if (ft == Forward_tag || ft == Lazy_tag || ft == Double_tag){ + if (!vv || ft == Forward_tag || ft == Lazy_tag || ft == Double_tag){ /* Do not short-circuit the pointer. Copy as a normal block. */ Assert (Wosize_hd (hd) == 1); result = caml_alloc_shr (1, Forward_tag); diff --git a/byterun/minor_gc.h b/byterun/minor_gc.h index dc1f12bb..e3e9d8ab 100644 --- a/byterun/minor_gc.h +++ b/byterun/minor_gc.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: minor_gc.h,v 1.17.20.1 2008/01/21 14:09:05 doligez Exp $ */ +/* $Id: minor_gc.h,v 1.18 2007/05/04 14:05:13 doligez Exp $ */ #ifndef CAML_MINOR_GC_H #define CAML_MINOR_GC_H diff --git a/byterun/misc.c b/byterun/misc.c index 8e937a2a..be9e54b4 100644 --- a/byterun/misc.c +++ b/byterun/misc.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: misc.c,v 1.28.10.1 2008/02/12 13:30:16 doligez Exp $ */ +/* $Id: misc.c,v 1.29 2008/02/29 12:56:15 doligez Exp $ */ #include #include "config.h" diff --git a/byterun/misc.h b/byterun/misc.h index aeb7b3b1..8d82025b 100644 --- a/byterun/misc.h +++ b/byterun/misc.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: misc.h,v 1.31.10.1 2008/02/12 13:30:16 doligez Exp $ */ +/* $Id: misc.h,v 1.33 2008/02/29 12:56:15 doligez Exp $ */ /* Miscellaneous macros and variables. */ @@ -49,19 +49,9 @@ typedef char * addr; /* Export control (to mark primitives and to handle Windows DLL) */ -#if defined(_WIN32) && defined(CAML_DLL) -# define CAMLexport __declspec(dllexport) -# define CAMLprim __declspec(dllexport) -# if defined(IN_OCAMLRUN) -# define CAMLextern __declspec(dllexport) extern -# else -# define CAMLextern __declspec(dllimport) extern -# endif -#else -# define CAMLexport -# define CAMLprim -# define CAMLextern extern -#endif +#define CAMLexport +#define CAMLprim +#define CAMLextern extern /* Assertions */ @@ -76,8 +66,8 @@ CAMLextern int caml_failed_assert (char *, char *, int); CAMLextern void caml_fatal_error (char *msg) Noreturn; CAMLextern void caml_fatal_error_arg (char *fmt, char *arg) Noreturn; -CAMLextern void caml_fatal_error_arg2 (char *fmt1, char *arg1, - char *fmt2, char *arg2) Noreturn; +CAMLextern void caml_fatal_error_arg2 (char *fmt1, char *arg1, + char *fmt2, char *arg2) Noreturn; /* Data structures */ diff --git a/byterun/mlvalues.h b/byterun/mlvalues.h index f25e85e7..90635630 100644 --- a/byterun/mlvalues.h +++ b/byterun/mlvalues.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: mlvalues.h,v 1.53 2007/02/09 13:31:15 doligez Exp $ */ +/* $Id: mlvalues.h,v 1.58 2008/08/01 14:10:36 xleroy Exp $ */ #ifndef CAML_MLVALUES_H #define CAML_MLVALUES_H @@ -188,7 +188,11 @@ typedef opcode_t * code_t; #define Class_val(val) Field((val), 0) #define Oid_val(val) Long_val(Field((val), 1)) CAMLextern value caml_get_public_method (value obj, value tag); -/* called as: callback(caml_get_public_method(obj, hash_variant(name)), obj) */ +/* Called as: + caml_callback(caml_get_public_method(obj, caml_hash_variant(name)), obj) */ +/* caml_get_public_method returns 0 if tag not in the table. + Note however that tags being hashed, same tag does not necessarily mean + same method name. */ /* Special case of tuples of fields: closures */ #define Closure_tag 247 @@ -199,7 +203,7 @@ CAMLextern value caml_get_public_method (value obj, value tag); #define Lazy_tag 246 /* Another special case: variants */ -CAMLextern value caml_hash_variant(char * tag); +CAMLextern value caml_hash_variant(char const * tag); /* 2- If tag >= No_scan_tag : a sequence of bytes. */ @@ -267,22 +271,6 @@ CAMLextern int64 caml_Int64_val(value v); CAMLextern header_t caml_atom_table[]; #define Atom(tag) (Val_hp (&(caml_atom_table [(tag)]))) -/* Is_atom tests whether a well-formed block is statically allocated - outside the heap. For the bytecode system, only zero-sized block (Atoms) - fall in this class. For the native-code generator, data - emitted by the code generator (as described in the table - caml_data_segments) are also atoms. */ - -#ifndef NATIVE_CODE -#define Is_atom(v) ((v) >= Atom(0) && (v) <= Atom(255)) -#else -CAMLextern char * caml_static_data_start, * caml_static_data_end; -#define Is_atom(v) \ - ((((char *)(v) >= caml_static_data_start \ - && (char *)(v) < caml_static_data_end) \ - || ((v) >= Atom(0) && (v) <= Atom(255)))) -#endif - /* Booleans are integers 0 or 1 */ #define Val_bool(x) Val_int((x) != 0) diff --git a/byterun/obj.c b/byterun/obj.c index f846363a..f2c4b374 100644 --- a/byterun/obj.c +++ b/byterun/obj.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: obj.c,v 1.39.12.2 2008/01/29 13:14:57 doligez Exp $ */ +/* $Id: obj.c,v 1.42 2008/01/29 13:11:15 doligez Exp $ */ /* Operations on objects */ @@ -66,11 +66,13 @@ CAMLprim value caml_obj_is_block(value arg) CAMLprim value caml_obj_tag(value arg) { if (Is_long (arg)){ - return Val_int (1000); - }else if (Is_young (arg) || Is_in_heap (arg) || Is_atom (arg)){ + return Val_int (1000); /* int_tag */ + }else if ((long) arg & (sizeof (value) - 1)){ + return Val_int (1002); /* unaligned_tag */ + }else if (Is_in_value_area (arg)){ return Val_int(Tag_val(arg)); }else{ - return Val_int (1001); + return Val_int (1001); /* out_of_heap_tag */ } } @@ -171,7 +173,7 @@ CAMLprim value caml_obj_truncate (value v, value newsize) CAMLprim value caml_lazy_follow_forward (value v) { - if (Is_block (v) && (Is_young (v) || Is_in_heap (v)) + if (Is_block (v) && Is_in_value_area(v) && Tag_val (v) == Forward_tag){ return Forward_val (v); }else{ @@ -189,7 +191,7 @@ CAMLprim value caml_lazy_make_forward (value v) CAMLreturn (res); } -/* For camlinternalOO.ml +/* For mlvalues.h and camlinternalOO.ml See also GETPUBMET in interp.c */ @@ -202,7 +204,8 @@ CAMLprim value caml_get_public_method (value obj, value tag) if (tag < Field(meths,mi)) hi = mi-2; else li = mi; } - return Field (meths, li-1); + /* return 0 if tag is not there */ + return (tag == Field(meths,li) ? Field (meths, li-1) : 0); } /* these two functions might be useful to an hypothetical JIT */ diff --git a/byterun/osdeps.h b/byterun/osdeps.h index 2357f195..494e188b 100644 --- a/byterun/osdeps.h +++ b/byterun/osdeps.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: osdeps.h,v 1.10 2006/09/28 21:36:38 xleroy Exp $ */ +/* $Id: osdeps.h,v 1.12 2008/04/22 12:24:10 frisch Exp $ */ /* Operating system - specific stuff */ @@ -41,8 +41,10 @@ extern char * caml_search_dll_in_path(struct ext_table * path, char * name); 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. + If [global] is true, symbols from the shared library can be used + to resolve for other libraries to be opened later on. Return [NULL] on error. */ -extern void * caml_dlopen(char * libname, int for_execution); +extern void * caml_dlopen(char * libname, int for_execution, int global); /* Close a shared library handle */ extern void caml_dlclose(void * handle); @@ -51,6 +53,8 @@ extern void caml_dlclose(void * handle); Return [NULL] if not found, or symbol value if found. */ extern void * caml_dlsym(void * handle, char * name); +extern void * caml_globalsym(char * name); + /* Return an error message describing the most recent dynlink failure. */ extern char * caml_dlerror(void); diff --git a/byterun/parsing.c b/byterun/parsing.c index 37e00db2..49050672 100644 --- a/byterun/parsing.c +++ b/byterun/parsing.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: parsing.c,v 1.20 2004/05/17 17:09:59 doligez Exp $ */ +/* $Id: parsing.c,v 1.21 2008/08/06 09:38:25 xleroy Exp $ */ /* The PDA automaton for parsers generated by camlyacc */ @@ -291,3 +291,12 @@ CAMLprim value caml_parse_engine(struct parser_tables *tables, } } + +/* Control printing of debugging info */ + +CAMLprim value caml_set_parser_trace(value flag) +{ + value oldflag = Val_bool(caml_parser_trace); + caml_parser_trace = Bool_val(flag); + return oldflag; +} diff --git a/byterun/roots.c b/byterun/roots.c index ec9ca9f6..dabb0016 100644 --- a/byterun/roots.c +++ b/byterun/roots.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: roots.c,v 1.29 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: roots.c,v 1.30 2008/03/10 19:56:39 xleroy Exp $ */ /* To walk the memory roots for garbage collection */ @@ -36,7 +36,6 @@ CAMLexport void (*caml_scan_roots_hook) (scanning_action f) = NULL; void caml_oldify_local_roots (void) { register value * sp; - struct global_root * gr; struct caml__roots_block *lr; intnat i, j; @@ -54,9 +53,7 @@ void caml_oldify_local_roots (void) } } /* Global C roots */ - for (gr = caml_global_roots.forward[0]; gr != NULL; gr = gr->forward[0]) { - caml_oldify_one(*(gr->root), gr->root); - } + caml_scan_global_young_roots(&caml_oldify_one); /* Finalised values */ caml_final_do_young_roots (&caml_oldify_one); /* Hook */ @@ -72,18 +69,12 @@ void caml_darken_all_roots (void) void caml_do_roots (scanning_action f) { - struct global_root * gr; - /* Global variables */ f(caml_global_data, &caml_global_data); - /* The stack and the local C roots */ caml_do_local_roots(f, caml_extern_sp, caml_stack_high, caml_local_roots); - /* Global C roots */ - for (gr = caml_global_roots.forward[0]; gr != NULL; gr = gr->forward[0]) { - f(*(gr->root), gr->root); - } + caml_scan_global_roots(f); /* Finalised values */ caml_final_do_strong_roots (f); /* Hook */ diff --git a/byterun/startup.c b/byterun/startup.c index e08a06ed..bb4d882b 100644 --- a/byterun/startup.c +++ b/byterun/startup.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: startup.c,v 1.68 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: startup.c,v 1.70 2008/03/14 13:47:24 xleroy Exp $ */ /* Start-up code */ @@ -72,6 +72,10 @@ static void init_atoms(void) { int i; for(i = 0; i < 256; i++) caml_atom_table[i] = Make_header(0, i, Caml_white); + if (caml_page_table_add(In_static_data, + caml_atom_table, caml_atom_table + 256) != 0) { + caml_fatal_error("Fatal error: not enough memory for the initial page table"); + } } /* Read the trailer of a bytecode file */ @@ -254,7 +258,7 @@ static int parse_command_line(char **argv) exit(0); break; case 'b': - caml_init_backtrace(); + caml_record_backtrace(Val_true); break; case 'I': if (argv[i + 1] != NULL) { @@ -307,7 +311,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 'b': caml_record_backtrace(Val_true); break; case 'p': caml_parser_trace = 1; break; } } diff --git a/byterun/unix.c b/byterun/unix.c index d8466d3a..5cc18d0d 100644 --- a/byterun/unix.c +++ b/byterun/unix.c @@ -11,10 +11,13 @@ /* */ /***********************************************************************/ -/* $Id: unix.c,v 1.28.4.1 2007/11/20 15:47:41 xleroy Exp $ */ +/* $Id: unix.c,v 1.35 2008/04/22 12:40:14 frisch Exp $ */ /* Unix-specific stuff */ +#define _GNU_SOURCE + /* Helps finding RTLD_DEFAULT in glibc */ + #include #include #include @@ -23,8 +26,8 @@ #include #include "config.h" #ifdef SUPPORT_DYNAMIC_LINKING -#ifdef HAS_NSLINKMODULE -#include +#ifdef __CYGWIN32__ +#include "flexdll.h" #else #include #endif @@ -165,112 +168,34 @@ char * caml_search_dll_in_path(struct ext_table * path, char * name) } #ifdef SUPPORT_DYNAMIC_LINKING -#ifdef HAS_NSLINKMODULE -/* Use MacOSX bundles */ - -static char *dlerror_string = "No error"; - -/* Need to emulate dlopen behaviour by caching open libraries */ -typedef struct bundle_entry { - struct bundle_entry *next; - char *name; - void *handle; - int count; -} entry_t; - -entry_t bundle_list = {NULL,NULL,NULL,0}; +#ifdef __CYGWIN32__ +/* Use flexdll */ -entry_t *caml_lookup_bundle(const char *name) +void * caml_dlopen(char * libname, int for_execution, int global) { - entry_t *current = bundle_list.next, *last = &bundle_list; - - while (current !=NULL) { - if (!strcmp(name,current->name)) - return current; - last = current; - current = current->next; - } - current = (entry_t*) malloc(sizeof(entry_t)+strlen(name)+1); - current->name = (char*)(current+1); - strcpy(current->name, name); - current->count = 0; - current->next = NULL; - last->next = current; - return current; + int flags = (global ? FLEXDLL_RTLD_GLOBAL : 0); + if (!for_execution) flags |= FLEXDLL_RTLD_NOEXEC; + return flexdll_dlopen(libname, flags); } -void * caml_dlopen(char * libname, int for_execution) +void caml_dlclose(void * handle) { - NSObjectFileImage image; - entry_t *bentry = caml_lookup_bundle(libname); - NSObjectFileImageReturnCode retCode; - void *result = NULL; - - if (bentry->count > 0) - return bentry->handle; - - retCode = NSCreateObjectFileImageFromFile(libname, &image); - switch (retCode) { - case NSObjectFileImageSuccess: - dlerror_string = NULL; - result = (void*)NSLinkModule(image, libname, NSLINKMODULE_OPTION_BINDNOW - | NSLINKMODULE_OPTION_RETURN_ON_ERROR); - if (result != NULL) { - bentry->count++; - bentry->handle = result; - } - else NSDestroyObjectFileImage(image); - break; - case NSObjectFileImageAccess: - dlerror_string = "cannot access this bundle"; break; - case NSObjectFileImageArch: - dlerror_string = "this bundle has wrong CPU architecture"; break; - case NSObjectFileImageFormat: - case NSObjectFileImageInappropriateFile: - dlerror_string = "this file is not a proper bundle"; break; - default: - dlerror_string = "could not read object file"; break; - } - return result; + flexdll_dlclose(handle); } -void caml_dlclose(void * handle) +void * caml_dlsym(void * handle, char * name) { - entry_t *current = bundle_list.next; - int close = 1; - - dlerror_string = NULL; - while (current != NULL) { - if (current->handle == handle) { - current->count--; - close = (current->count == 0); - break; - } - current = current->next; - } - if (close) - NSUnLinkModule((NSModule)handle, NSUNLINKMODULE_OPTION_NONE); + return flexdll_dlsym(handle, name); } -void * caml_dlsym(void * handle, char * name) +void * caml_globalsym(char * name) { - NSSymbol sym; - char _name[1000] = "_"; - strncat (_name, name, 998); - dlerror_string = NULL; - sym = NSLookupSymbolInModule((NSModule)handle, _name); - if (sym != NULL) return NSAddressOfSymbol(sym); - else return NULL; + return flexdll_dlsym(flexdll_dlopen(NULL,0,1), name); } char * caml_dlerror(void) { - NSLinkEditErrors c; - int errnum; - const char *fileName, *errorString; - if (dlerror_string != NULL) return dlerror_string; - NSLinkEditError(&c,&errnum,&fileName,&errorString); - return (char *) errorString; + return flexdll_dlerror(); } #else @@ -283,9 +208,9 @@ char * caml_dlerror(void) #define RTLD_NODELETE 0 #endif -void * caml_dlopen(char * libname, int for_execution) +void * caml_dlopen(char * libname, int for_execution, int global) { - return dlopen(libname, RTLD_NOW | RTLD_GLOBAL | RTLD_NODELETE); + return dlopen(libname, RTLD_NOW | (global ? RTLD_GLOBAL : 0) | RTLD_NODELETE); /* Could use RTLD_LAZY if for_execution == 0, but needs testing */ } @@ -304,15 +229,24 @@ void * caml_dlsym(void * handle, char * name) return dlsym(handle, name); } +void * caml_globalsym(char * name) +{ +#ifdef RTLD_DEFAULT + return caml_dlsym(RTLD_DEFAULT, name); +#else + return NULL; +#endif +} + char * caml_dlerror(void) { - return dlerror(); + return (char*) dlerror(); } #endif #else -void * caml_dlopen(char * libname, int for_execution) +void * caml_dlopen(char * libname, int for_execution, int global) { return NULL; } @@ -326,60 +260,14 @@ void * caml_dlsym(void * handle, char * name) return NULL; } -char * caml_dlerror(void) +void * caml_globalsym(char * name) { - return "dynamic loading not supported on this platform"; -} - -#endif - -#ifdef USE_MMAP_INSTEAD_OF_MALLOC - -/* The code below supports the use of mmap() rather than malloc() - for allocating the chunks composing the major heap. - This code is needed for the IA64 under Linux, where the native - malloc() implementation can return pointers several *exabytes* apart, - (some coming from mmap(), other from sbrk()); this makes the - page table *way* too large. - No other tested platform requires this hack so far. However, it could - be useful for other 64-bit platforms in the future. */ - -#include - -char *caml_aligned_mmap (asize_t size, int modulo, void **block) -{ - char *raw_mem; - uintnat aligned_mem; - static char * last_addr = NULL; /* hint, see PR#4448 */ - - Assert (modulo < Page_size); - raw_mem = (char *) mmap(last_addr, size + Page_size, PROT_READ | PROT_WRITE, - MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); - if (raw_mem == MAP_FAILED) return NULL; - last_addr = raw_mem + size + 2 * Page_size; - *block = raw_mem; - raw_mem += modulo; /* Address to be aligned */ - aligned_mem = (((uintnat) raw_mem / Page_size + 1) * Page_size); -#ifdef DEBUG - { - uintnat *p; - uintnat *p0 = (void *) *block, - *p1 = (void *) (aligned_mem - modulo), - *p2 = (void *) (aligned_mem - modulo + size), - *p3 = (void *) ((char *) *block + size + Page_size); - - for (p = p0; p < p1; p++) *p = Debug_filler_align; - for (p = p1; p < p2; p++) *p = Debug_uninit_align; - for (p = p2; p < p3; p++) *p = Debug_filler_align; - } -#endif - return (char *) (aligned_mem - modulo); + return NULL; } -void caml_aligned_munmap (char * addr, asize_t size) +char * caml_dlerror(void) { - int retcode = munmap (addr, size + Page_size); - Assert(retcode == 0); + return "dynamic loading not supported on this platform"; } #endif diff --git a/byterun/weak.c b/byterun/weak.c index 19252300..09a10f9c 100644 --- a/byterun/weak.c +++ b/byterun/weak.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: weak.c,v 1.25.6.1 2008/01/21 14:09:05 doligez Exp $ */ +/* $Id: weak.c,v 1.29 2008/09/17 14:55:30 doligez Exp $ */ /* Operations on weak arrays */ @@ -70,7 +70,7 @@ CAMLprim value caml_weak_set (value ar, value n, value el) if (offset < 1 || offset >= Wosize_val (ar)){ caml_invalid_argument ("Weak.set"); } - if (el != None_val){ + if (el != None_val && Is_block (el)){ Assert (Wosize_val (el) == 1); do_set (ar, offset, Field (el, 0)); }else{ @@ -120,7 +120,7 @@ CAMLprim value caml_weak_get_copy (value ar, value n) v = Field (ar, offset); if (v == caml_weak_none) CAMLreturn (None_val); - if (Is_block (v) && (Is_young (v) || Is_in_heap (v))){ + if (Is_block (v) && Is_in_heap_or_young(v)) { elt = caml_alloc (Wosize_val (v), Tag_val (v)); /* The GC may erase or move v during this call to caml_alloc. */ v = Field (ar, offset); diff --git a/byterun/win32.c b/byterun/win32.c index acfbbd12..418104d0 100644 --- a/byterun/win32.c +++ b/byterun/win32.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: win32.c,v 1.33 2007/03/01 13:37:39 xleroy Exp $ */ +/* $Id: win32.c,v 1.36 2008/04/22 12:24:10 frisch Exp $ */ /* Win32-specific stuff */ @@ -31,6 +31,9 @@ #include "misc.h" #include "osdeps.h" #include "signals.h" +#include "sys.h" + +#include "flexdll.h" #ifndef S_ISREG #define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG) @@ -121,42 +124,37 @@ char * caml_search_dll_in_path(struct ext_table * path, char * name) return res; } -void * caml_dlopen(char * libname, int for_execution) +void * caml_dlopen(char * libname, int for_execution, int global) { - 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 *handle; + int flags = (global ? FLEXDLL_RTLD_GLOBAL : 0); + if (!for_execution) flags |= FLEXDLL_RTLD_NOEXEC; + handle = flexdll_dlopen(libname, flags); + if ((handle != NULL) && ((caml_verb_gc & 0x100) != 0)) { + flexdll_dump_exports(handle); + fflush(stdout); + } + return handle; } void caml_dlclose(void * handle) { - FreeLibrary((HMODULE) handle); + flexdll_dlclose(handle); } void * caml_dlsym(void * handle, char * name) { - return (void *) GetProcAddress((HMODULE) handle, name); + return flexdll_dlsym(handle, name); +} + +void * caml_globalsym(char * name) +{ + return flexdll_dlsym(flexdll_dlopen(NULL,0), name); } char * caml_dlerror(void) { - static char dlerror_buffer[256]; - DWORD msglen = - FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, - NULL, /* message source */ - GetLastError(), /* error number */ - 0, /* default language */ - dlerror_buffer, /* destination */ - sizeof(dlerror_buffer), /* size of destination */ - NULL); /* no inserts */ - if (msglen == 0) - return "unknown error"; - else - return dlerror_buffer; + return flexdll_dlerror(); } /* Proper emulation of signal(), including ctrl-C and ctrl-break */ @@ -486,10 +484,12 @@ static void caml_reset_stack (void *faulting_address) } extern char * caml_code_area_start, * caml_code_area_end; +CAMLextern int caml_is_in_code(void *); -#define In_code_area(pc) \ - ((char *)(pc) >= caml_code_area_start && \ - (char *)(pc) <= caml_code_area_end) +#define Is_in_code_area(pc) \ + ( ((char *)(pc) >= caml_code_area_start && \ + (char *)(pc) <= caml_code_area_end) \ + || (Classify_addr(pc) & In_code_area) ) static LONG CALLBACK caml_UnhandledExceptionFilter (EXCEPTION_POINTERS* exn_info) @@ -499,7 +499,7 @@ static LONG CALLBACK DWORD *ctx_ip = &(ctx->Eip); DWORD *ctx_sp = &(ctx->Esp); - if (code == EXCEPTION_STACK_OVERFLOW && In_code_area (*ctx_ip)) + if (code == EXCEPTION_STACK_OVERFLOW && Is_in_code_area (*ctx_ip)) { uintnat faulting_address; uintnat * alt_esp; diff --git a/camlp4/Camlp4/Camlp4Ast.partial.ml b/camlp4/Camlp4/Camlp4Ast.partial.ml index 5d9da823..ba941d7a 100644 --- a/camlp4/Camlp4/Camlp4Ast.partial.ml +++ b/camlp4/Camlp4/Camlp4Ast.partial.ml @@ -86,7 +86,8 @@ | PaTup of loc and patt (* ( p ) *) | PaTyc of loc and patt and ctyp (* (p : t) *) | PaTyp of loc and ident (* #i *) - | PaVrn of loc and string (* `s *) ] + | PaVrn of loc and string (* `s *) + | PaLaz of loc and patt (* lazy p *) ] and expr = [ ExNil of loc | ExId of loc and ident (* i *) diff --git a/camlp4/Camlp4/OCamlInitSyntax.ml b/camlp4/Camlp4/OCamlInitSyntax.ml index e36dc24d..8a70d712 100644 --- a/camlp4/Camlp4/OCamlInitSyntax.ml +++ b/camlp4/Camlp4/OCamlInitSyntax.ml @@ -93,6 +93,7 @@ module Make (Ast : Sig.Camlp4Ast) value expr = Gram.Entry.mk "expr"; value expr_eoi = Gram.Entry.mk "expr_eoi"; value field_expr = Gram.Entry.mk "field_expr"; + value field_expr_list = Gram.Entry.mk "field_expr_list"; value fun_binding = Gram.Entry.mk "fun_binding"; value fun_def = Gram.Entry.mk "fun_def"; value ident = Gram.Entry.mk "ident"; @@ -102,13 +103,18 @@ module Make (Ast : Sig.Camlp4Ast) value ipatt_tcon = Gram.Entry.mk "ipatt_tcon"; value label = Gram.Entry.mk "label"; value label_declaration = Gram.Entry.mk "label_declaration"; + value label_declaration_list = Gram.Entry.mk "label_declaration_list"; value label_expr = Gram.Entry.mk "label_expr"; + value label_expr_list = Gram.Entry.mk "label_expr_list"; value label_ipatt = Gram.Entry.mk "label_ipatt"; + value label_ipatt_list = Gram.Entry.mk "label_ipatt_list"; value label_longident = Gram.Entry.mk "label_longident"; value label_patt = Gram.Entry.mk "label_patt"; + value label_patt_list = Gram.Entry.mk "label_patt_list"; value labeled_ipatt = Gram.Entry.mk "labeled_ipatt"; value let_binding = Gram.Entry.mk "let_binding"; value meth_list = Gram.Entry.mk "meth_list"; + value meth_decl = Gram.Entry.mk "meth_decl"; value module_binding = Gram.Entry.mk "module_binding"; value module_binding0 = Gram.Entry.mk "module_binding0"; value module_declaration = Gram.Entry.mk "module_declaration"; diff --git a/camlp4/Camlp4/PreCast.ml b/camlp4/Camlp4/PreCast.ml index 69f494e2..1b191f02 100644 --- a/camlp4/Camlp4/PreCast.ml +++ b/camlp4/Camlp4/PreCast.ml @@ -19,7 +19,7 @@ module Id = struct value name = "Camlp4.PreCast"; - value version = "$Id: PreCast.ml,v 1.4.4.1 2007/03/30 15:50:12 pouillar Exp $"; + value version = "$Id: PreCast.ml,v 1.5 2007/10/08 14:19:34 doligez Exp $"; end; type camlp4_token = Sig.camlp4_token == diff --git a/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml b/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml index b9438a22..77e661da 100644 --- a/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml +++ b/camlp4/Camlp4/Printers/DumpCamlp4Ast.ml @@ -19,7 +19,7 @@ module Id = struct value name = "Camlp4Printers.DumpCamlp4Ast"; - value version = "$Id: DumpCamlp4Ast.ml,v 1.5.4.2 2007/05/22 09:05:39 pouillar Exp $"; + value version = "$Id: DumpCamlp4Ast.ml,v 1.7 2007/11/21 17:53:10 ertai Exp $"; end; module Make (Syntax : Sig.Syntax) diff --git a/camlp4/Camlp4/Printers/DumpOCamlAst.ml b/camlp4/Camlp4/Printers/DumpOCamlAst.ml index 02091fd1..f82d659c 100644 --- a/camlp4/Camlp4/Printers/DumpOCamlAst.ml +++ b/camlp4/Camlp4/Printers/DumpOCamlAst.ml @@ -19,7 +19,7 @@ module Id : Sig.Id = struct value name = "Camlp4Printers.DumpOCamlAst"; - value version = "$Id: DumpOCamlAst.ml,v 1.5.4.2 2007/05/22 09:05:39 pouillar Exp $"; + value version = "$Id: DumpOCamlAst.ml,v 1.7 2007/11/21 17:53:10 ertai Exp $"; end; module Make (Syntax : Sig.Camlp4Syntax) diff --git a/camlp4/Camlp4/Printers/OCaml.ml b/camlp4/Camlp4/Printers/OCaml.ml index 593cd276..1df25583 100644 --- a/camlp4/Camlp4/Printers/OCaml.ml +++ b/camlp4/Camlp4/Printers/OCaml.ml @@ -20,7 +20,7 @@ open Format; module Id = struct value name = "Camlp4.Printers.OCaml"; - value version = "$Id: OCaml.ml,v 1.21.2.24 2007/11/27 14:35:12 ertai Exp $"; + value version = "$Id: OCaml.ml,v 1.39 2008/10/05 16:25:28 ertai Exp $"; end; module Make (Syntax : Sig.Camlp4Syntax) = struct @@ -321,7 +321,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | [e] -> pp f "[ %a ]" o#under_semi#expr e | el -> pp f "@[<2>[ %a@] ]" (list o#under_semi#expr ";@ ") el ]; - method expr_list_cons simple f e = + 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 @@ -331,11 +331,11 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct 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; + in pp f "%a@ ->@ %a" (list o#simple_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; + in pp f "%a =@]@ %a" (list o#simple_patt "@ ") [p::pl] o#class_expr ce; method constrain f (t1, t2) = pp f "@[<2>constraint@ %a =@ %a@]" o#ctyp t1 o#ctyp t2; @@ -466,6 +466,14 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:expr< assert $e$ >> -> pp f "@[<2>assert@ %a@]" o#dot_expr e | <:expr< let module $s$ = $me$ in $e$ >> -> pp f "@[<2>let module %a =@ %a@]@ @[<2>in@ %a@]" o#var s o#module_expr me o#reset_semi#expr e + | <:expr< object $cst$ end >> -> + pp f "@[@[object@ %a@]@ end@]" o#class_str_item cst + | <:expr< object ($p$ : $t$) $cst$ end >> -> + pp f "@[@[object @[<1>(%a :@ %a)@]@ %a@]@ end@]" + o#patt p o#ctyp t o#class_str_item cst + | <:expr< object ($p$) $cst$ end >> -> + pp f "@[@[object @[<2>(%a)@]@ %a@]@ end@]" + o#patt p o#class_str_item cst | e -> o#apply_expr f e ]; method apply_expr f e = @@ -496,7 +504,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:expr< ( $tup:e$ ) >> -> pp f "@[<1>(%a)@]" o#expr e | <:expr< [| $e$ |] >> -> - pp f "@[<0>@[<2>[|@ %a@]@ |]@]" o#under_semi#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$) >> -> @@ -529,14 +537,6 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <: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< $e1$, $e2$ >> -> pp f "%a,@ %a" o#simple_expr e1 o#simple_expr e2 | <:expr< $e1$; $e2$ >> -> @@ -550,7 +550,8 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct <:expr< let $rec:_$ $_$ in $_$ >> | <:expr< let module $_$ = $_$ in $_$ >> | <:expr< assert $_$ >> | <:expr< assert False >> | - <:expr< lazy $_$ >> | <:expr< new $_$ >> -> + <:expr< lazy $_$ >> | <:expr< new $_$ >> | + <:expr< object ($_$) $_$ end >> -> pp f "(%a)" o#reset#expr e ]; method direction_flag f b = @@ -589,6 +590,8 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct method patt5 f = fun [ <:patt< [$_$ :: $_$] >> as p -> o#simple_patt f p + | <:patt< lazy $p$ >> -> + pp f "@[<2>lazy %a@]" o#simple_patt p | <:patt< $x$ $y$ >> -> let (a, al) = get_patt_args x [y] in if not (Ast.is_patt_constructor a) then @@ -637,8 +640,9 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct pp f "@[<2>?%s:@,@[<1>(%a =@ %a)@]@]" s o#patt_tycon p o#expr e | <:patt< $_$ $_$ >> | <:patt< ($_$ as $_$) >> | <:patt< $_$ | $_$ >> | <:patt< $_$ .. $_$ >> | <:patt< $_$, $_$ >> | - <:patt< $_$; $_$ >> | <:patt< $_$ = $_$ >> as p -> - pp f "@[<1>(%a)@]" o#patt p ]; + <:patt< $_$; $_$ >> | <:patt< $_$ = $_$ >> | <:patt< lazy $_$ >> as p -> + pp f "@[<1>(%a)@]" o#patt p + ]; method patt_tycon f = fun @@ -818,7 +822,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:str_item< $exp:e$ >> -> pp f "@[<2>let _ =@ %a%(%)@]" o#expr e semisep | <:str_item< include $me$ >> -> - pp f "@[<2>include@ %a%(%)@]" o#module_expr me semisep + pp f "@[<2>include@ %a%(%)@]" o#simple_module_expr me semisep | <:str_item< class type $ct$ >> -> pp f "@[<2>class type %a%(%)@]" o#class_type ct semisep | <:str_item< class $ce$ >> -> @@ -860,6 +864,15 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct let () = o#node f me Ast.loc_of_module_expr in match me with [ <:module_expr<>> -> assert False + | <:module_expr< ( struct $st$ end : sig $sg$ end ) >> -> + pp f "@[<2>@[struct@ %a@]@ end :@ @[sig@ %a@]@ end@]" + o#str_item st o#sig_item sg + | _ -> o#simple_module_expr f me ]; + + method simple_module_expr f me = + let () = o#node f me Ast.loc_of_module_expr in + match me with + [ <:module_expr<>> -> assert False | <:module_expr< $id:i$ >> -> o#ident f i | <:module_expr< $anti:s$ >> -> o#anti f s | <:module_expr< $me1$ $me2$ >> -> @@ -868,9 +881,6 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct 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 ]; @@ -888,7 +898,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <:class_expr< virtual $lid:i$ [ $t$ ] >> -> pp f "@[<2>virtual@ @[<1>[%a]@]@ %a@]" o#class_params t o#var i | <:class_expr< fun $p$ -> $ce$ >> -> - pp f "@[<2>fun@ %a@ ->@ %a@]" o#patt p o#class_expr ce + pp f "@[<2>fun@ %a@ ->@ %a@]" o#simple_patt p o#class_expr ce | <:class_expr< let $rec:r$ $bi$ in $ce$ >> -> pp f "@[<2>let %a%a@]@ @[<2>in@ %a@]" o#rec_flag r o#binding bi o#class_expr ce @@ -903,7 +913,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | <: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 + 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 diff --git a/camlp4/Camlp4/Printers/OCaml.mli b/camlp4/Camlp4/Printers/OCaml.mli index e24eca78..6bc573b6 100644 --- a/camlp4/Camlp4/Printers/OCaml.mli +++ b/camlp4/Camlp4/Printers/OCaml.mli @@ -101,6 +101,7 @@ module Make (Syntax : Sig.Camlp4Syntax) : sig method match_case_aux : formatter -> Ast.match_case -> unit; method mk_expr_list : Ast.expr -> (list Ast.expr * option Ast.expr); method mk_patt_list : Ast.patt -> (list Ast.patt * option Ast.patt); + method simple_module_expr : formatter -> Ast.module_expr -> unit; method module_expr : formatter -> Ast.module_expr -> unit; method module_expr_get_functor_args : list (string * Ast.module_type) -> diff --git a/camlp4/Camlp4/Printers/OCamlr.ml b/camlp4/Camlp4/Printers/OCamlr.ml index b0887a01..ffe3b163 100644 --- a/camlp4/Camlp4/Printers/OCamlr.ml +++ b/camlp4/Camlp4/Printers/OCamlr.ml @@ -20,7 +20,7 @@ open Format; module Id = struct value name = "Camlp4.Printers.OCamlr"; - value version = "$Id: OCamlr.ml,v 1.17.4.6 2007/11/27 14:35:13 ertai Exp $"; + value version = "$Id: OCamlr.ml,v 1.23 2008/10/05 16:30:55 ertai Exp $"; end; module Make (Syntax : Sig.Camlp4Syntax) = struct @@ -147,7 +147,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | 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 = + method expr_list_cons _ f e = let (el, c) = o#mk_expr_list e in match c with [ None -> o#expr_list f el @@ -224,9 +224,16 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct 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 + pp f "@[<2>%a@ %a@]" o#module_expr me1 o#simple_module_expr me2 | me -> super#module_expr f me ]; + method simple_module_expr f me = + let () = o#node f me Ast.loc_of_module_expr in + match me with + [ <:module_expr< $_$ $_$ >> -> + pp f "(%a)" o#module_expr me + | _ -> super#simple_module_expr f me ]; + method implem f st = pp f "@[%a@]@." o#str_item st; method class_type f ct = diff --git a/camlp4/Camlp4/Sig.ml b/camlp4/Camlp4/Sig.ml index 3e8274fa..a03887c2 100644 --- a/camlp4/Camlp4/Sig.ml +++ b/camlp4/Camlp4/Sig.ml @@ -18,6 +18,8 @@ * - Nicolas Pouillard: refactoring *) +(* $Id: Sig.ml,v 1.7 2008/10/04 10:47:56 ertai Exp $ *) + (** Camlp4 signature repository *) (** {6 Basic signatures} *) @@ -42,7 +44,7 @@ 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.2.13 2007/06/23 16:00:09 ertai Exp $ with a versionning system. *) + (** The version of the extension, typically $ Id$ with a versionning system. *) value version : string; end; @@ -863,6 +865,9 @@ module type DynLoader = sig (** [find_in_path f] Returns the full path of the file [f] if [f] is in the current load path, raises [Not_found] otherwise. *) value find_in_path : t -> string -> string; + + (** [is_native] [True] if we are in native code, [False] for bytecode. *) + value is_native : bool; end; (** A signature for grammars. *) @@ -1261,6 +1266,7 @@ module type Camlp4Syntax = sig value expr_eoi : Gram.Entry.t Ast.expr; value expr_quot : Gram.Entry.t Ast.expr; value field_expr : Gram.Entry.t Ast.rec_binding; + value field_expr_list : Gram.Entry.t Ast.rec_binding; value fun_binding : Gram.Entry.t Ast.expr; value fun_def : Gram.Entry.t Ast.expr; value ident : Gram.Entry.t Ast.ident; @@ -1269,13 +1275,18 @@ module type Camlp4Syntax = sig value ipatt_tcon : Gram.Entry.t Ast.patt; value label : Gram.Entry.t string; value label_declaration : Gram.Entry.t Ast.ctyp; + value label_declaration_list : Gram.Entry.t Ast.ctyp; value label_expr : Gram.Entry.t Ast.rec_binding; + value label_expr_list : Gram.Entry.t Ast.rec_binding; value label_ipatt : Gram.Entry.t Ast.patt; + value label_ipatt_list : Gram.Entry.t Ast.patt; value label_longident : Gram.Entry.t Ast.ident; value label_patt : Gram.Entry.t Ast.patt; + value label_patt_list : Gram.Entry.t Ast.patt; value labeled_ipatt : Gram.Entry.t Ast.patt; value let_binding : Gram.Entry.t Ast.binding; - value meth_list : Gram.Entry.t Ast.ctyp; + value meth_list : Gram.Entry.t (Ast.ctyp * Ast.meta_bool); + value meth_decl : Gram.Entry.t Ast.ctyp; value module_binding : Gram.Entry.t Ast.module_binding; value module_binding0 : Gram.Entry.t Ast.module_expr; value module_binding_quot : Gram.Entry.t Ast.module_binding; diff --git a/camlp4/Camlp4/Struct/Camlp4Ast.mlast b/camlp4/Camlp4/Struct/Camlp4Ast.mlast index 0a34532a..6c4ea3bc 100644 --- a/camlp4/Camlp4/Struct/Camlp4Ast.mlast +++ b/camlp4/Camlp4/Struct/Camlp4Ast.mlast @@ -106,11 +106,14 @@ module Make (Loc : Sig.Loc) [ <:patt< $lid:_$ >> -> True | <:patt< () >> -> True | <:patt< _ >> -> True + | <:patt<>> -> True (* why not *) | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y | <:patt< { $p$ } >> -> is_irrefut_patt p | <:patt< $_$ = $p$ >> -> is_irrefut_patt p | <:patt< $p1$; $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 | <:patt< $p1$, $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 + | <:patt< $p1$ | $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 (* could be more fine grained *) + | <:patt< $p1$ $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p | <:patt< ($tup:pl$) >> -> is_irrefut_patt pl | <:patt< ? $_$ >> -> True @@ -118,7 +121,13 @@ module Make (Loc : Sig.Loc) | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p | <:patt< ~ $_$ >> -> True | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p - | _ -> False ]; + | <:patt< lazy $p$ >> -> is_irrefut_patt p + | <:patt< $id:_$ >> -> False (* here one need to know the arity of constructors *) + | <:patt< `$_$ >> | <:patt< $str:_$ >> | <:patt< $_$ .. $_$ >> | + <:patt< $flo:_$ >> | <:patt< $nativeint:_$ >> | <:patt< $int64:_$ >> | + <:patt< $int32:_$ >> | <:patt< $int:_$ >> | <:patt< $chr:_$ >> | + <:patt< #$_$ >> | <:patt< [| $_$ |] >> | <:patt< $anti:_$ >> -> False + ]; value rec is_constructor = fun diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml index 1b26866d..e41c8153 100644 --- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml +++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml @@ -18,7 +18,7 @@ * - Nicolas Pouillard: refactoring *) -(* $Id: Camlp4Ast2OCamlAst.ml,v 1.15.2.8 2007/09/19 13:20:33 ertai Exp $ *) +(* $Id: Camlp4Ast2OCamlAst.ml,v 1.22 2008/10/04 11:11:09 ertai Exp $ *) module Make (Ast : Sig.Camlp4Ast) = struct open Format; @@ -114,10 +114,10 @@ module Make (Ast : Sig.Camlp4Ast) = struct | Ast.BFalse -> Nonrecursive | Ast.BAnt _ -> assert False ]; - value mkli s = - loop (fun s -> lident s) where rec loop f = + value mkli s = loop lident + where rec loop f = fun - [ [i :: il] -> loop (fun s -> ldot (f i) s) il + [ [i :: il] -> loop (ldot (f i)) il | [] -> f s ] ; @@ -199,7 +199,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct 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] + | <:ctyp< '$s$ >> -> [s] | _ -> assert False ]; value rec ctyp = @@ -278,10 +278,11 @@ module Make (Ast : Sig.Camlp4Ast) = struct | _ -> assert False ] ; - value mktype loc tl cl tk tm = + value mktype loc tl cl tk tp 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} + ptype_private = tp; 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); @@ -306,10 +307,10 @@ module Make (Ast : Sig.Camlp4Ast) = struct type_decl tl cl loc m True t | <:ctyp< { $t$ } >> -> mktype loc tl cl - (Ptype_record (List.map mktrecord (list_of_ctyp t [])) (mkprivate' pflag)) m + (Ptype_record (List.map mktrecord (list_of_ctyp t []))) (mkprivate' pflag) m | <:ctyp< [ $t$ ] >> -> mktype loc tl cl - (Ptype_variant (List.map mkvariant (list_of_ctyp t [])) (mkprivate' pflag)) m + (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 @@ -318,8 +319,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct [ <:ctyp<>> -> None | _ -> Some (ctyp t) ] in - let k = if pflag then Ptype_private else Ptype_abstract in - mktype loc tl cl k m ] + mktype loc tl cl Ptype_abstract (mkprivate' pflag) m ] ; value type_decl tl cl t = type_decl tl cl (loc_of_ctyp t) None False t; @@ -343,8 +343,8 @@ module Make (Ast : Sig.Camlp4Ast) = struct value opt_private_ctyp = fun - [ <:ctyp< private $t$ >> -> (Ptype_private, ctyp t) - | t -> (Ptype_abstract, ctyp t) ]; + [ <:ctyp< private $t$ >> -> (Ptype_abstract, Private, ctyp t) + | t -> (Ptype_abstract, Public, ctyp t) ]; value rec type_parameters t acc = match t with @@ -376,11 +376,12 @@ module Make (Ast : Sig.Camlp4Ast) = struct | 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 + let (kind, priv, ct) = opt_private_ctyp ct in [(id, Pwith_type {ptype_params = params; ptype_cstrs = []; ptype_kind = kind; + ptype_private = priv; ptype_manifest = Some ct; ptype_loc = mkloc loc; ptype_variance = variance}) :: acc] | WcMod _ i1 i2 -> @@ -494,11 +495,12 @@ module Make (Ast : Sig.Camlp4Ast) = struct 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 [])))) + (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) + | PaLaz loc p -> mkpat loc (Ppat_lazy (patt p)) | PaEq _ _ _ | PaSem _ _ _ | PaCom _ _ _ | PaNil _ as p -> error (loc_of_patt p) "invalid pattern" ] and mklabpat = @@ -554,7 +556,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct 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) + (mkexp loc (Pexp_construct (mkli (conv_con s) ml) None ca), l) | [(loc, ml, <:expr< $lid:s$ >>) :: l] -> (mkexp loc (Pexp_ident (mkli s ml)), l) | [(_, [], e) :: l] -> (expr e, l) @@ -677,7 +679,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct | 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 -> + | ExObj loc po cfl -> let p = match po with [ <:patt<>> -> <:patt@loc< _ >> @@ -715,7 +717,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct 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 [])))) + 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< () >> -> @@ -919,7 +921,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct 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 -> diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli index e790f630..f3c15e29 100644 --- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli +++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.mli @@ -18,8 +18,7 @@ * - Nicolas Pouillard: refactoring *) - -(* $Id: Camlp4Ast2OCamlAst.mli,v 1.3.4.1 2007/05/22 09:09:45 pouillar Exp $ *) +(* $Id: Camlp4Ast2OCamlAst.mli,v 1.5 2008/01/11 16:13:16 doligez Exp $ *) module Make (Camlp4Ast : Sig.Camlp4Ast) : sig open Camlp4Ast; diff --git a/camlp4/Camlp4/Struct/DynLoader.ml b/camlp4/Camlp4/Struct/DynLoader.ml index 5975dede..f5e4986e 100644 --- a/camlp4/Camlp4/Struct/DynLoader.ml +++ b/camlp4/Camlp4/Struct/DynLoader.ml @@ -19,7 +19,7 @@ *) -(* $Id: DynLoader.ml,v 1.3 2007/02/07 10:09:21 ertai Exp $ *) +(* $Id: DynLoader.ml,v 1.4 2007/11/06 15:16:56 frisch Exp $ *) type t = Queue.t string; @@ -61,9 +61,7 @@ value find_in_path x name = 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 { + do { if not _initialized.val then try do { Dynlink.init (); @@ -80,5 +78,7 @@ value load = in try Dynlink.loadfile fname with [ Dynlink.Error e -> raise (Error fname (Dynlink.error_message e)) ] - } - END; + }; + + +value is_native = Dynlink.is_native; diff --git a/camlp4/Camlp4/Struct/FreeVars.ml b/camlp4/Camlp4/Struct/FreeVars.ml index 78c33ef4..66a9a8b0 100644 --- a/camlp4/Camlp4/Struct/FreeVars.ml +++ b/camlp4/Camlp4/Struct/FreeVars.ml @@ -21,13 +21,6 @@ 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$ >> -> - 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 inherit Ast.fold as super; @@ -42,6 +35,14 @@ module Make (Ast : Sig.Camlp4Ast) = struct value fold_pattern_vars f p init = ((new c_fold_pattern_vars f init)#patt p)#acc; + value rec fold_binding_vars f bi acc = + match bi with + [ <:binding< $bi1$ and $bi2$ >> -> + fold_binding_vars f bi1 (fold_binding_vars f bi2 acc) + | <:binding< $p$ = $_$ >> -> fold_pattern_vars f p acc + | <:binding<>> -> acc + | <:binding< $anti:_$ >> -> assert False ]; + class fold_free_vars ['accu] (f : string -> 'accu -> 'accu) ?(env_init = S.empty) free_init = object (o) inherit Ast.fold as super; diff --git a/camlp4/Camlp4/Struct/Grammar/Parser.ml b/camlp4/Camlp4/Struct/Grammar/Parser.ml index 1934dc69..715c48f7 100644 --- a/camlp4/Camlp4/Struct/Grammar/Parser.ml +++ b/camlp4/Camlp4/Struct/Grammar/Parser.ml @@ -80,16 +80,19 @@ module Make (Structure : Structure.S) = struct 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 + (* PR#4603, PR#4330, PR#4551: + Here Context.loc_bp replaced Context.loc_ep to fix all these bugs. + If you do change it again look at these bugs. *) + value skip_if_empty c bp _ = + if Context.loc_bp c = bp then Action.mk (fun _ -> raise Stream.Failure) + 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 = skip_if_empty c loc :] -> a | [: a = continue entry loc a s c son (parser_of_tree entry nlevn alevn son c) :] -> @@ -357,7 +360,7 @@ module Make (Structure : Structure.S) = struct fun c levn bp a strm -> if levn > clevn then p1 c levn bp a strm else - match strm with parser bp + match strm with parser [ [: act = p1 c levn bp a :] -> act | [: (act, loc) = add_loc c bp p2 :] -> let a = Action.getf2 act a loc in diff --git a/camlp4/Camlp4/Struct/Grammar/Parser.mli b/camlp4/Camlp4/Struct/Grammar/Parser.mli index df0340e8..0e6c44c0 100644 --- a/camlp4/Camlp4/Struct/Grammar/Parser.mli +++ b/camlp4/Camlp4/Struct/Grammar/Parser.mli @@ -13,7 +13,7 @@ (* *) (****************************************************************************) -(* $Id: Parser.mli,v 1.1.2.1 2007/03/22 21:46:09 pouillar Exp $ *) +(* $Id: Parser.mli,v 1.3 2008/10/03 15:18:37 ertai Exp $ *) (* Authors: * - Daniel de Rauglaudre: initial version @@ -37,8 +37,6 @@ module Make (Structure : Structure.S) : sig value continue : internal_entry -> Loc.t -> Action.t -> symbol -> Context.t -> tree -> (Stream.t (Token.t * Loc.t) -> Action.t) -> Stream.t (Token.t * Loc.t) -> Action.t; - value skip_if_empty : - Context.t -> Loc.t -> ('a -> 'b) -> 'a -> Action.t; value do_recover : (internal_entry -> 'a -> 'b -> tree -> Context.t -> Stream.t (Token.t * Loc.t) -> Action.t) -> internal_entry -> 'a -> 'b -> Loc.t -> Action.t -> symbol -> Context.t -> tree -> Stream.t (Token.t * Loc.t) -> Action.t; diff --git a/camlp4/Camlp4/Struct/Grammar/Static.ml b/camlp4/Camlp4/Struct/Grammar/Static.ml index b20eed77..7d7b51ef 100644 --- a/camlp4/Camlp4/Struct/Grammar/Static.ml +++ b/camlp4/Camlp4/Struct/Grammar/Static.ml @@ -16,6 +16,10 @@ * - Daniel de Rauglaudre: initial version * - Nicolas Pouillard: refactoring *) + +value uncurry f (x,y) = f x y; +value flip f x y = f y x; + module Make (Lexer : Sig.Lexer) : Sig.Grammar.Static with module Loc = Lexer.Loc and module Token = Lexer.Token @@ -68,12 +72,7 @@ module Make (Lexer : Sig.Lexer) 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; + Stree (List.fold_left (flip (uncurry (Insert.insert_tree e))) DeadEnd rl); value sfold0 = Fold.sfold0; value sfold1 = Fold.sfold1; value sfold0sep = Fold.sfold0sep; diff --git a/camlp4/Camlp4/Struct/Lexer.mll b/camlp4/Camlp4/Struct/Lexer.mll index dfc9a719..87193bca 100644 --- a/camlp4/Camlp4/Struct/Lexer.mll +++ b/camlp4/Camlp4/Struct/Lexer.mll @@ -17,8 +17,7 @@ * - Nicolas Pouillard: refactoring *) - -(* $Id: Lexer.mll,v 1.6.4.11 2007/11/27 14:38:03 ertai Exp $ *) +(* $Id: Lexer.mll,v 1.10 2008/01/11 16:13:16 doligez Exp $ *) (* The lexer definition *) diff --git a/camlp4/Camlp4/Struct/Quotation.ml b/camlp4/Camlp4/Struct/Quotation.ml index 349c6850..9401b259 100644 --- a/camlp4/Camlp4/Struct/Quotation.ml +++ b/camlp4/Camlp4/Struct/Quotation.ml @@ -18,7 +18,7 @@ * - Nicolas Pouillard: refactoring *) -(* $Id: Quotation.ml,v 1.4.4.3 2007/06/23 16:00:09 ertai Exp $ *) +(* $Id: Quotation.ml,v 1.6 2007/11/21 17:57:54 ertai Exp $ *) module Make (Ast : Sig.Camlp4Ast) : Sig.Quotation with module Ast = Ast diff --git a/camlp4/Camlp4Bin.ml b/camlp4/Camlp4Bin.ml index 4ce8720d..f49bd914 100644 --- a/camlp4/Camlp4Bin.ml +++ b/camlp4/Camlp4Bin.ml @@ -18,7 +18,7 @@ * - Nicolas Pouillard: refactoring *) -(* $Id: Camlp4Bin.ml,v 1.14.2.6 2007/06/23 16:00:09 ertai Exp $ *) +(* $Id: Camlp4Bin.ml,v 1.19 2008/10/03 15:41:24 ertai Exp $ *) open Camlp4; open PreCast.Syntax; @@ -48,6 +48,10 @@ value loaded_modules = ref SSet.empty; value add_to_loaded_modules name = loaded_modules.val := SSet.add name loaded_modules.val; +value (objext,libext) = + if DynLoader.is_native then (".cmxs",".cmxs") + else (".cmo",".cma"); + value rewrite_and_load n x = let dyn_loader = dyn_loader.val () in let find_in_path = DynLoader.find_in_path dyn_loader in @@ -59,7 +63,7 @@ value rewrite_and_load n x = if SSet.mem n loaded_modules.val || List.mem n Register.loaded_modules.val then () else begin add_to_loaded_modules n; - DynLoader.load dyn_loader (n ^ ".cmo"); + DynLoader.load dyn_loader (n ^ objext); end end in do { @@ -86,7 +90,6 @@ value rewrite_and_load n x = | ("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"|"", "pr_o.cmo" | "o" | "ocaml" | "camlp4ocamlprinter.cmo") -> @@ -98,7 +101,7 @@ value rewrite_and_load n x = | ("Printers"|"", "a" | "auto" | "camlp4autoprinter.cmo") -> load ["Camlp4AutoPrinter"] | _ -> - let y = "Camlp4"^n^"/"^x^".cmo" in + let y = "Camlp4"^n^"/"^x^objext in real_load (try find_in_path y with [ Not_found -> x ]) ]; rcall_callback.val (); }; @@ -172,7 +175,9 @@ 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@."; +.%s Load this module inside the Camlp4 core@." +(if DynLoader.is_native then "cmx " else "(cmo|cma)") +; Options.print_usage_list ini_sl; (* loop (ini_sl @ ext_sl) where rec loop = fun @@ -213,7 +218,7 @@ value (task, do_task) = value input_file x = let dyn_loader = dyn_loader.val () in do { - rcall_callback.val (); + 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 @@ -278,8 +283,8 @@ 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 if Filename.check_suffix name objext then ModuleImpl name + else if Filename.check_suffix name libext then ModuleImpl name else raise (Arg.Bad ("don't know what to do with " ^ name))); value main argv = diff --git a/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml b/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml index af2dc83e..b44f7f16 100644 --- a/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml +++ b/camlp4/Camlp4Filters/Camlp4FoldGenerator.ml @@ -22,7 +22,7 @@ open Camlp4; module Id = struct value name = "Camlp4FoldGenerator"; - value version = "$Id: Camlp4FoldGenerator.ml,v 1.1.4.10 2007/07/25 13:06:27 ertai Exp $"; + value version = "$Id: Camlp4FoldGenerator.ml,v 1.3 2007/11/21 17:51:39 ertai Exp $"; end; module Make (AstFilters : Camlp4.Sig.AstFilters) = struct diff --git a/camlp4/Camlp4Filters/Camlp4LocationStripper.ml b/camlp4/Camlp4Filters/Camlp4LocationStripper.ml index 820ff889..2c8f407e 100644 --- a/camlp4/Camlp4Filters/Camlp4LocationStripper.ml +++ b/camlp4/Camlp4Filters/Camlp4LocationStripper.ml @@ -22,7 +22,7 @@ open Camlp4; module Id = struct value name = "Camlp4LocationStripper"; - value version = "$Id: Camlp4LocationStripper.ml,v 1.1.4.1 2007/03/10 16:58:39 pouillar Exp $"; + value version = "$Id: Camlp4LocationStripper.ml,v 1.2 2007/10/08 14:19:34 doligez Exp $"; end; module Make (AstFilters : Camlp4.Sig.AstFilters) = struct diff --git a/camlp4/Camlp4Filters/Camlp4MapGenerator.ml b/camlp4/Camlp4Filters/Camlp4MapGenerator.ml index 7894c378..db5fb5c9 100644 --- a/camlp4/Camlp4Filters/Camlp4MapGenerator.ml +++ b/camlp4/Camlp4Filters/Camlp4MapGenerator.ml @@ -1,5 +1,5 @@ (* This module is useless now. Camlp4FoldGenerator handles map too. *) module Id = struct value name = "Camlp4MapGenerator"; - value version = "$Id: Camlp4MapGenerator.ml,v 1.1.4.5 2007/06/23 16:00:09 ertai Exp $"; + value version = "$Id: Camlp4MapGenerator.ml,v 1.4 2008/01/11 16:13:16 doligez Exp $"; end; diff --git a/camlp4/Camlp4Filters/Camlp4Tracer.ml b/camlp4/Camlp4Filters/Camlp4Tracer.ml deleted file mode 100644 index afb87b7c..00000000 --- a/camlp4/Camlp4Filters/Camlp4Tracer.ml +++ /dev/null @@ -1,58 +0,0 @@ -(* 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.4.1 2007/03/10 16:58:39 pouillar 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 (Ast.map_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 index e9cad22b..b0005cae 100644 --- a/camlp4/Camlp4Filters/Camlp4TrashRemover.ml +++ b/camlp4/Camlp4Filters/Camlp4TrashRemover.ml @@ -22,7 +22,7 @@ open Camlp4; module Id = struct value name = "Camlp4TrashRemover"; - value version = "$Id: Camlp4TrashRemover.ml,v 1.1.4.1 2007/03/10 16:58:39 pouillar Exp $"; + value version = "$Id: Camlp4TrashRemover.ml,v 1.2 2007/10/08 14:19:34 doligez Exp $"; end; module Make (AstFilters : Camlp4.Sig.AstFilters) = struct diff --git a/camlp4/Camlp4Parsers/Camlp4GrammarParser.ml b/camlp4/Camlp4Parsers/Camlp4GrammarParser.ml index 938ae59b..1b47156a 100644 --- a/camlp4/Camlp4Parsers/Camlp4GrammarParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4GrammarParser.ml @@ -21,7 +21,7 @@ open Camlp4; (* -*- camlp4r -*- *) module Id = struct value name = "Camlp4GrammarParser"; - value version = "$Id: Camlp4GrammarParser.ml,v 1.1.4.6 2007/12/18 08:59:35 ertai Exp $"; + value version = "$Id: Camlp4GrammarParser.ml,v 1.5 2008/01/11 16:13:16 doligez Exp $"; end; module Make (Syntax : Sig.Camlp4Syntax) = struct diff --git a/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml b/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml index 5ce53cc5..69d9fe2c 100644 --- a/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml +++ b/camlp4/Camlp4Parsers/Camlp4ListComprehension.ml @@ -21,7 +21,7 @@ open Camlp4; (* -*- camlp4r -*- *) module Id = struct value name = "Camlp4ListComprenhsion"; - value version = "$Id: Camlp4ListComprehension.ml,v 1.1.2.1 2007/05/27 16:23:35 pouillar Exp $"; + value version = "$Id: Camlp4ListComprehension.ml,v 1.2 2007/11/21 17:51:16 ertai Exp $"; end; module Make (Syntax : Sig.Camlp4Syntax) = struct diff --git a/camlp4/Camlp4Parsers/Camlp4MacroParser.ml b/camlp4/Camlp4Parsers/Camlp4MacroParser.ml index 96a76648..0995fac3 100644 --- a/camlp4/Camlp4Parsers/Camlp4MacroParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4MacroParser.ml @@ -18,11 +18,12 @@ open Camlp4; (* -*- camlp4r -*- *) * - Nicolas Pouillard: refactoring * - Aleksey Nogin: extra features and bug fixes. * - Christopher Conway: extra feature (-D=) + * - Jean-vincent Loddo: definitions inside IFs. *) module Id = struct value name = "Camlp4MacroParser"; - value version = "$Id: Camlp4MacroParser.ml,v 1.1.4.6 2007/06/23 16:00:09 ertai Exp $"; + value version = "$Id: Camlp4MacroParser.ml,v 1.5 2008/10/03 14:19:19 ertai Exp $"; end; (* @@ -96,7 +97,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct [ SdStr of 'a | SdDef of string and option (list string * Ast.expr) | SdUnd of string - | SdITE of string and list (item_or_def 'a) and list (item_or_def 'a) + | SdITE of bool and list (item_or_def 'a) and list (item_or_def 'a) | SdLazy of Lazy.t 'a ]; value rec list_remove x = @@ -269,7 +270,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct [ SdStr i -> i | SdDef x eo -> do { define eo x; nil } | SdUnd x -> do { undef x; nil } - | SdITE i l1 l2 -> execute_macro_list nil cons (if is_defined i then l1 else l2) + | SdITE b l1 l2 -> execute_macro_list nil cons (if b then l1 else l2) | SdLazy l -> Lazy.force l ] and execute_macro_list nil cons = fun @@ -280,6 +281,27 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct cons il1 il2 ] ; + (* Stack of conditionals. *) + value stack = Stack.create () ; + + (* Make an SdITE value by extracting the result of the test from the stack. *) + value make_SdITE_result st1 st2 = + let test = Stack.pop stack in + SdITE test st1 st2 ; + + type branch = [ Then | Else ]; + + (* Execute macro only if it belongs to the currently active branch. *) + value execute_macro_if_active_branch _loc nil cons branch macro_def = + let test = Stack.top stack in + let item = + if (test && branch=Then) || ((not test) && branch=Else) then + execute_macro nil cons macro_def + else (* ignore the macro *) + nil + in SdStr(item) + ; + EXTEND Gram GLOBAL: expr patt str_item sig_item; str_item: FIRST @@ -292,41 +314,61 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct ; macro_def: [ [ "DEFINE"; i = uident; def = opt_macro_value -> SdDef i def - | "UNDEF"; i = uident -> SdUnd i - | "IFDEF"; i = uident; "THEN"; st1 = smlist; st2 = else_macro_def -> - SdITE i st1 st2 - | "IFNDEF"; i = uident; "THEN"; st2 = smlist; st1 = else_macro_def -> - SdITE i st1 st2 + | "UNDEF"; i = uident -> SdUnd i + | "IFDEF"; uident_eval_ifdef; "THEN"; st1 = smlist_then; st2 = else_macro_def -> + make_SdITE_result st1 st2 + | "IFNDEF"; uident_eval_ifndef; "THEN"; st1 = smlist_then; st2 = else_macro_def -> + make_SdITE_result st1 st2 | "INCLUDE"; fname = STRING -> SdLazy (lazy (parse_include_file str_items fname)) ] ] ; macro_def_sig: [ [ "DEFINE"; i = uident -> SdDef i None - | "UNDEF"; i = uident -> SdUnd i - | "IFDEF"; i = uident; "THEN"; sg1 = sglist; sg2 = else_macro_def_sig -> - SdITE i sg1 sg2 - | "IFNDEF"; i = uident; "THEN"; sg2 = sglist; sg1 = else_macro_def_sig -> - SdITE i sg1 sg2 + | "UNDEF"; i = uident -> SdUnd i + | "IFDEF"; uident_eval_ifdef; "THEN"; sg1 = sglist_then; sg2 = else_macro_def_sig -> + make_SdITE_result sg1 sg2 + | "IFNDEF"; uident_eval_ifndef; "THEN"; sg1 = sglist_then; sg2 = else_macro_def_sig -> + make_SdITE_result sg1 sg2 | "INCLUDE"; fname = STRING -> SdLazy (lazy (parse_include_file sig_items fname)) ] ] ; + uident_eval_ifdef: + [ [ i = uident -> Stack.push (is_defined i) stack ]] + ; + uident_eval_ifndef: + [ [ i = uident -> Stack.push (not (is_defined i)) stack ]] + ; else_macro_def: - [ [ "ELSE"; st = smlist; endif -> st + [ [ "ELSE"; st = smlist_else; endif -> st | endif -> [] ] ] ; else_macro_def_sig: - [ [ "ELSE"; st = sglist; endif -> st + [ [ "ELSE"; st = sglist_else; endif -> st | endif -> [] ] ] ; else_expr: [ [ "ELSE"; e = expr; endif -> e | endif -> <:expr< () >> ] ] ; - smlist: - [ [ sml = LIST1 [ d = macro_def; semi -> d | si = str_item; semi -> SdStr si ] -> sml ] ] + smlist_then: + [ [ sml = LIST1 [ d = macro_def; semi -> + execute_macro_if_active_branch _loc <:str_item<>> (fun a b -> <:str_item< $a$; $b$ >>) Then d + | si = str_item; semi -> SdStr si ] -> sml ] ] + ; + smlist_else: + [ [ sml = LIST1 [ d = macro_def; semi -> + execute_macro_if_active_branch _loc <:str_item<>> (fun a b -> <:str_item< $a$; $b$ >>) Else d + | si = str_item; semi -> SdStr si ] -> sml ] ] + ; + sglist_then: + [ [ sgl = LIST1 [ d = macro_def_sig; semi -> + execute_macro_if_active_branch _loc <:sig_item<>> (fun a b -> <:sig_item< $a$; $b$ >>) Then d + | si = sig_item; semi -> SdStr si ] -> sgl ] ] ; - sglist: - [ [ sgl = LIST1 [ d = macro_def_sig; semi -> d | si = sig_item; semi -> SdStr si ] -> sgl ] ] + sglist_else: + [ [ sgl = LIST1 [ d = macro_def_sig; semi -> + execute_macro_if_active_branch _loc <:sig_item<>> (fun a b -> <:sig_item< $a$; $b$ >>) Else d + | si = sig_item; semi -> SdStr si ] -> sgl ] ] ; endif: [ [ "END" -> () diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml index 1538e4d8..7dee9d13 100644 --- a/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4OCamlParser.ml @@ -21,7 +21,7 @@ open Camlp4; (* -*- camlp4r -*- *) module Id : Sig.Id = struct value name = "Camlp4OCamlParser"; - value version = "$Id: Camlp4OCamlParser.ml,v 1.3.2.19 2007/12/18 08:53:26 ertai Exp $"; + value version = "$Id: Camlp4OCamlParser.ml,v 1.14 2008/10/05 15:26:54 ertai Exp $"; end; module Make (Syntax : Sig.Camlp4Syntax) = struct @@ -175,6 +175,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct DELETE_RULE Gram module_type: SELF; SELF; dummy END; DELETE_RULE Gram module_type: SELF; "."; SELF END; DELETE_RULE Gram label_expr: label_longident; fun_binding END; + DELETE_RULE Gram meth_list: meth_decl; opt_dot_dot END; DELETE_RULE Gram expr: "let"; opt_rec; binding; "in"; SELF END; DELETE_RULE Gram expr: "let"; "module"; a_UIDENT; module_binding0; "in"; SELF END; DELETE_RULE Gram expr: "fun"; "["; LIST0 match_case0 SEP "|"; "]" END; @@ -183,8 +184,8 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct DELETE_RULE Gram expr: SELF; SELF END; DELETE_RULE Gram expr: "new"; class_longident END; DELETE_RULE Gram expr: "["; sem_expr_for_list; "::"; expr; "]" END; - DELETE_RULE Gram expr: "{"; label_expr; "}" END; - DELETE_RULE Gram expr: "{"; "("; SELF; ")"; "with"; label_expr; "}" END; + DELETE_RULE Gram expr: "{"; label_expr_list; "}" END; + DELETE_RULE Gram expr: "{"; "("; SELF; ")"; "with"; label_expr_list; "}" END; DELETE_RULE Gram expr: "("; SELF; ","; comma_expr; ")" END; DELETE_RULE Gram expr: SELF; ":="; SELF; dummy END; DELETE_RULE Gram expr: "~"; a_LIDENT; ":"; SELF END; @@ -234,10 +235,11 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct 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_expr fun_binding + dummy eq_expr expr expr_eoi expr_quot 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 + label_declaration label_declaration_list label_expr label_expr_list + label_longident label_patt_list meth_list + labeled_ipatt let_binding 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 @@ -284,11 +286,13 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct <:str_item< let module $m$ = $mb$ in $e$ >> ] ] ; - expr: BEFORE "top" - [ ";" RIGHTA - [ e1 = SELF; ";"; e2 = SELF -> + seq_expr: + [ [ e1 = expr LEVEL "top"; ";"; e2 = SELF -> conc_seq e1 e2 - | e1 = SELF; ";" -> e1 ] ]; + | e1 = expr LEVEL "top"; ";" -> e1 + | e1 = expr LEVEL "top" -> e1 ] ]; + expr: BEFORE "top" + [ ";" [ e = seq_expr -> e ] ]; expr: LEVEL "top" [ [ "let"; r = opt_rec; bi = binding; "in"; x = expr LEVEL ";" -> @@ -306,8 +310,8 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct ] ]; expr: BEFORE "||" [ "," - [ e = SELF; ","; el = (*FIXME comma_expr*)LIST1 NEXT SEP "," -> - <:expr< ( $e$, $Ast.exCom_of_list el$ ) >> ] + [ e1 = SELF; ","; e2 = comma_expr -> + <:expr< ( $e1$, $e2$ ) >> ] | ":=" NONA [ e1 = SELF; ":="; e2 = expr LEVEL "top" -> <:expr< $e1$.val := $e2$ >> @@ -331,9 +335,9 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct expr: LEVEL "simple" (* LEFTA *) [ [ "false" -> <:expr< False >> | "true" -> <:expr< True >> - | "{"; test_label_eq; lel = label_expr; "}" -> + | "{"; test_label_eq; lel = label_expr_list; "}" -> <:expr< { $lel$ } >> - | "{"; e = expr LEVEL "."; "with"; lel = label_expr; "}" -> + | "{"; e = expr LEVEL "."; "with"; lel = label_expr_list; "}" -> <:expr< { ($e$) with $lel$ } >> | "new"; i = class_longident -> <:expr< new $i$ >> ] ] @@ -372,6 +376,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>) p1 (Ast.list_of_patt p []) | _ -> <:patt< $p1$ $p2$ >> ] + | "lazy"; p = SELF -> <:patt< lazy $p$ >> | `ANTIQUOT (""|"pat"|"anti" as n) s -> <:patt< $anti:mk_anti ~c:"patt" n s$ >> | p = patt_constr -> p ] @@ -404,7 +409,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct mk_list <:patt< [] >> | "[|"; "|]" -> <:patt< [||] >> | "[|"; pl = sem_patt; "|]" -> <:patt< [| $pl$ |] >> - | "{"; pl = label_patt; "}" -> <:patt< { $pl$ } >> + | "{"; pl = label_patt_list; "}" -> <:patt< { $pl$ } >> | "("; ")" -> <:patt< () >> | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> | "("; p = patt; ")" -> <:patt< $p$ >> @@ -412,10 +417,10 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | "`"; s = a_ident -> <:patt< ` $s$ >> | "#"; i = type_longident -> <:patt< # $i$ >> ] ] ; - (* comma_expr: - [ [ e1 = SELF; ","; e2 = SELF -> <:expr< $e1$, $e2$ >> - | e = expr LEVEL ":=" -> e ] ] - ; *) + comma_expr: + [ [ e1 = expr LEVEL ":="; ","; e2 = SELF -> <:expr< $e1$, $e2$ >> + | e1 = expr LEVEL ":=" -> e1 ] ] + ; (* comma_patt: [ [ p1 = SELF; ","; p2 = SELF -> <:patt< $p1$, $p2$ >> | p = patt LEVEL ".." -> p ] ] @@ -507,8 +512,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct mk <:ctyp< $i$ $t$ >> | "("; t = SELF; ")" -> <:ctyp< $t$ >> | "#"; i = class_longident -> <:ctyp< # $i$ >> - | "<"; ml = opt_meth_list; v = opt_dot_dot; ">" -> - <:ctyp< < $ml$ $..:v$ > >> + | "<"; t = opt_meth_list; ">" -> t | "["; OPT "|"; rfl = row_field; "]" -> <:ctyp< [ = $rfl$ ] >> | "["; ">"; "]" -> <:ctyp< [ > $<:ctyp<>>$ ] >> @@ -520,6 +524,8 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct <:ctyp< [ < $rfl$ > $ntl$ ] >> ] ] ; + meth_list: + [ [ m = meth_decl -> (m, Ast.BFalse) ] ]; comma_ctyp_app: [ [ t1 = ctyp; ","; t2 = SELF -> fun acc -> t2 <:ctyp< $acc$ $t1$ >> | t = ctyp -> fun acc -> <:ctyp< $acc$ $t$ >> @@ -569,11 +575,11 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct | t = ctyp -> <:ctyp< $t$ >> | t = ctyp; "="; "private"; tk = type_kind -> <:ctyp< $t$ == private $tk$ >> - | t1 = ctyp; "="; "{"; t2 = label_declaration; "}" -> + | t1 = ctyp; "="; "{"; t2 = label_declaration_list; "}" -> <:ctyp< $t1$ == { $t2$ } >> | t1 = ctyp; "="; OPT "|"; t2 = constructor_declarations -> <:ctyp< $t1$ == [ $t2$ ] >> - | "{"; t = label_declaration; "}" -> + | "{"; t = label_declaration_list; "}" -> <:ctyp< { $t$ } >> ] ] ; module_expr: LEVEL "apply" @@ -600,9 +606,7 @@ module Make (Syntax : Sig.Camlp4Syntax) = struct [ [ "val" -> () ] ] ; label_declaration: - [ LEFTA - [ t1 = SELF; ";"; t2 = SELF -> <:ctyp< $t1$; $t2$ >> - | `ANTIQUOT (""|"typ" as n) s -> + [ [ `ANTIQUOT (""|"typ" as n) s -> <:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >> | `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.ctyp_tag | s = a_LIDENT; ":"; t = poly_type -> <:ctyp< $lid:s$ : $t$ >> diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlReloadedParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlReloadedParser.ml index 3f2d7b79..c9e1e846 100644 --- a/camlp4/Camlp4Parsers/Camlp4OCamlReloadedParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4OCamlReloadedParser.ml @@ -19,7 +19,7 @@ open Camlp4; (* -*- camlp4r -*- *) module Id = struct value name = "Camlp4Reloaded"; - value version = "$Id: Camlp4OCamlReloadedParser.ml,v 1.1.2.3 2007/04/05 18:06:36 pouillar Exp $"; + value version = "$Id: Camlp4OCamlReloadedParser.ml,v 1.2 2007/10/08 14:19:34 doligez Exp $"; end; module Make (Syntax : Sig.Camlp4Syntax) = struct diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml index f2b7aedf..91dbd575 100644 --- a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParser.ml @@ -20,7 +20,7 @@ open Camlp4; (* -*- camlp4r -*- *) module Id = struct value name = "Camlp4OCamlRevisedParser"; - value version = "$Id: Camlp4OCamlRevisedParser.ml,v 1.2.2.31 2007/12/18 09:02:19 ertai Exp $"; + value version = "$Id: Camlp4OCamlRevisedParser.ml,v 1.15 2008/10/05 15:26:54 ertai Exp $"; end; module Make (Syntax : Sig.Camlp4Syntax) = struct @@ -115,6 +115,7 @@ Very old (no more supported) syntax: Gram.Entry.clear expr_eoi; Gram.Entry.clear expr_quot; Gram.Entry.clear field_expr; + Gram.Entry.clear field_expr_list; Gram.Entry.clear fun_binding; Gram.Entry.clear fun_def; Gram.Entry.clear ident; @@ -125,13 +126,18 @@ Very old (no more supported) syntax: Gram.Entry.clear ipatt_tcon; Gram.Entry.clear label; Gram.Entry.clear label_declaration; + Gram.Entry.clear label_declaration_list; + Gram.Entry.clear label_expr_list; Gram.Entry.clear label_expr; Gram.Entry.clear label_ipatt; + Gram.Entry.clear label_ipatt_list; Gram.Entry.clear label_longident; Gram.Entry.clear label_patt; + Gram.Entry.clear label_patt_list; Gram.Entry.clear labeled_ipatt; Gram.Entry.clear let_binding; Gram.Entry.clear meth_list; + Gram.Entry.clear meth_decl; Gram.Entry.clear module_binding; Gram.Entry.clear module_binding0; Gram.Entry.clear module_binding_quot; @@ -420,10 +426,11 @@ Very old (no more supported) syntax: 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_expr fun_binding + dummy eq_expr expr expr_eoi expr_quot field_expr field_expr_list 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 + label_declaration label_declaration_list label_expr label_expr_list + label_ipatt label_ipatt_list label_longident label_patt label_patt_list + labeled_ipatt let_binding meth_list meth_decl 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 @@ -692,15 +699,16 @@ Very old (no more supported) syntax: mk_list <:expr< [] >> | "[|"; "|]" -> <:expr< [| $<:expr<>>$ |] >> | "[|"; el = sem_expr; "|]" -> <:expr< [| $el$ |] >> - | "{"; el = label_expr; "}" -> <:expr< { $el$ } >> - | "{"; "("; e = SELF; ")"; "with"; el = label_expr; "}" -> + | "{"; el = label_expr_list; "}" -> <:expr< { $el$ } >> + | "{"; "("; e = SELF; ")"; "with"; el = label_expr_list; "}" -> <:expr< { ($e$) with $el$ } >> | "{<"; ">}" -> <:expr< {<>} >> - | "{<"; fel = field_expr; ">}" -> <:expr< {< $fel$ >} >> + | "{<"; fel = field_expr_list; ">}" -> <:expr< {< $fel$ >} >> | "("; ")" -> <:expr< () >> | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >> | "("; e = SELF; ","; el = comma_expr; ")" -> <:expr< ( $e$, $el$ ) >> | "("; e = SELF; ";"; seq = sequence; ")" -> mksequence _loc <:expr< $e$; $seq$ >> + | "("; e = SELF; ";"; ")" -> mksequence _loc e | "("; e = SELF; ":"; t = ctyp; ":>"; t2 = ctyp; ")" -> <:expr< ($e$ : $t$ :> $t2$ ) >> | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >> @@ -727,7 +735,7 @@ Very old (no more supported) syntax: comma_expr: [ [ e1 = SELF; ","; e2 = SELF -> <:expr< $e1$, $e2$ >> | `ANTIQUOT ("list" as n) s -> <:expr< $anti:mk_anti ~c:"expr," n s$ >> - | e = expr -> e ] ] + | e = expr LEVEL "top" -> e ] ] ; dummy: [ [ -> () ] ] @@ -797,9 +805,13 @@ Very old (no more supported) syntax: | p = patt -> p ] ] ; + label_expr_list: + [ [ b1 = label_expr; ";"; b2 = SELF -> <:rec_binding< $b1$ ; $b2$ >> + | b1 = label_expr; ";" -> b1 + | b1 = label_expr -> b1 + ] ]; label_expr: - [ [ b1 = SELF; ";"; b2 = SELF -> <:rec_binding< $b1$ ; $b2$ >> - | `ANTIQUOT ("rec_binding" as n) s -> + [ [ `ANTIQUOT ("rec_binding" as n) s -> <:rec_binding< $anti:mk_anti ~c:"rec_binding" n s$ >> | `ANTIQUOT (""|"anti" as n) s -> <:rec_binding< $anti:mk_anti ~c:"rec_binding" n s$ >> @@ -825,7 +837,8 @@ Very old (no more supported) syntax: | ".." NONA [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ] | "apply" LEFTA - [ p1 = SELF; p2 = SELF -> <:patt< $p1$ $p2$ >> ] + [ p1 = SELF; p2 = SELF -> <:patt< $p1$ $p2$ >> + | "lazy"; p = SELF -> <:patt< lazy $p$ >> ] | "simple" [ `ANTIQUOT (""|"pat"|"anti" as n) s -> <:patt< $anti:mk_anti ~c:"patt" n s$ >> @@ -851,7 +864,7 @@ Very old (no more supported) syntax: mk_list <:patt< [] >> | "[|"; "|]" -> <:patt< [| $<:patt<>>$ |] >> | "[|"; pl = sem_patt; "|]" -> <:patt< [| $pl$ |] >> - | "{"; pl = label_patt; "}" -> <:patt< { $pl$ } >> + | "{"; pl = label_patt_list; "}" -> <:patt< { $pl$ } >> | "("; ")" -> <:patt< () >> | "("; p = SELF; ")" -> p | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> @@ -894,10 +907,13 @@ Very old (no more supported) syntax: | p = patt -> fun acc -> <:patt< [ $p$ :: $acc$ ] >> ] ] ; + label_patt_list: + [ [ p1 = label_patt; ";"; p2 = SELF -> <:patt< $p1$ ; $p2$ >> + | p1 = label_patt; ";" -> p1 + | p1 = label_patt -> p1 + ] ]; label_patt: - [ LEFTA - [ p1 = SELF; ";"; p2 = SELF -> <:patt< $p1$; $p2$ >> - | `ANTIQUOT (""|"pat"|"anti" as n) s -> + [ [ `ANTIQUOT (""|"pat"|"anti" as n) s -> <:patt< $anti:mk_anti ~c:"patt" n s$ >> | `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.patt_tag | `ANTIQUOT ("list" as n) s -> @@ -906,7 +922,7 @@ Very old (no more supported) syntax: ] ] ; ipatt: - [ [ "{"; pl = label_ipatt; "}" -> <:patt< { $pl$ } >> + [ [ "{"; pl = label_ipatt_list; "}" -> <:patt< { $pl$ } >> | `ANTIQUOT (""|"pat"|"anti" as n) s -> <:patt< $anti:mk_anti ~c:"patt" n s$ >> | `ANTIQUOT ("tup" as n) s -> @@ -929,10 +945,13 @@ Very old (no more supported) syntax: | `ANTIQUOT ("list" as n) s -> <:patt< $anti:mk_anti ~c:"patt," n s$ >> | p = ipatt -> p ] ] ; + label_ipatt_list: + [ [ p1 = label_ipatt; ";"; p2 = SELF -> <:patt< $p1$ ; $p2$ >> + | p1 = label_ipatt; ";" -> p1 + | p1 = label_ipatt -> p1 + ] ]; label_ipatt: - [ LEFTA - [ p1 = SELF; ";"; p2 = SELF -> <:patt< $p1$; $p2$ >> - | `ANTIQUOT (""|"pat"|"anti" as n) s -> + [ [ `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$ >> | `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.patt_tag @@ -1035,10 +1054,9 @@ Very old (no more supported) syntax: <:ctyp< [ < $rfl$ ] >> | "[<"; rfl = row_field; ">"; ntl = name_tags; "]" -> <:ctyp< [ < $rfl$ > $ntl$ ] >> - | "{"; t = label_declaration; OPT ";"; "}" -> <:ctyp< { $t$ } >> + | "{"; t = label_declaration_list; "}" -> <:ctyp< { $t$ } >> | "#"; i = class_longident -> <:ctyp< # $i$ >> - | "<"; ml = opt_meth_list; v = opt_dot_dot; ">" -> - <:ctyp< < $ml$ $..:v$ > >> + | "<"; t = opt_meth_list; ">" -> t ] ] ; star_ctyp: @@ -1082,10 +1100,14 @@ Very old (no more supported) syntax: | t = ctyp -> t ] ] ; + label_declaration_list: + [ [ t1 = label_declaration; ";"; t2 = SELF -> <:ctyp< $t1$; $t2$ >> + | t1 = label_declaration; ";" -> t1 + | t1 = label_declaration -> t1 + ] ] + ; label_declaration: - [ LEFTA - [ t1 = SELF; ";"; t2 = SELF -> <:ctyp< $t1$; $t2$ >> - | `ANTIQUOT (""|"typ" as n) s -> + [ [ `ANTIQUOT (""|"typ" as n) s -> <:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >> | `ANTIQUOT ("list" as n) s -> <:ctyp< $anti:mk_anti ~c:"ctyp;" n s$ >> @@ -1355,26 +1377,33 @@ Very old (no more supported) syntax: | ci = class_info_for_class_type; "="; ct = class_type -> <:class_type< $ci$ = $ct$ >> ] ] ; + field_expr_list: + [ [ b1 = field_expr; ";"; b2 = SELF -> <:rec_binding< $b1$ ; $b2$ >> + | b1 = field_expr; ";" -> b1 + | b1 = field_expr -> b1 + ] ]; field_expr: - [ LEFTA - [ b1 = SELF; ";"; b2 = SELF -> <:rec_binding< $b1$ ; $b2$ >> - | `ANTIQUOT (""|"bi"|"anti" as n) s -> + [ [ `ANTIQUOT (""|"bi"|"anti" as n) s -> <:rec_binding< $anti:mk_anti ~c:"rec_binding" n s$ >> | `ANTIQUOT ("list" as n) s -> <:rec_binding< $anti:mk_anti ~c:"rec_binding" n s$ >> - | l = label; "="; e = expr LEVEL "top" -> <:rec_binding< $lid:l$ = $e$ >> ] ] + | l = label; "="; e = expr -> <:rec_binding< $lid:l$ = $e$ >> ] ] ; meth_list: - [ LEFTA - [ ml1 = SELF; ";"; ml2 = SELF -> <:ctyp< $ml1$; $ml2$ >> - | `ANTIQUOT (""|"typ" as n) s -> <:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >> + [ [ m = meth_decl; ";"; (ml, v) = SELF -> (<:ctyp< $m$; $ml$ >>, v) + | m = meth_decl; ";"; v = opt_dot_dot -> (m, v) + | m = meth_decl; v = opt_dot_dot -> (m, v) + ] ] + ; + meth_decl: + [ [ `ANTIQUOT (""|"typ" as n) s -> <:ctyp< $anti:mk_anti ~c:"ctyp" n s$ >> | `ANTIQUOT ("list" as n) s -> <:ctyp< $anti:mk_anti ~c:"ctyp;" n s$ >> | `QUOTATION x -> Quotation.expand _loc x Quotation.DynAst.ctyp_tag | lab = a_LIDENT; ":"; t = poly_type -> <:ctyp< $lid:lab$ : $t$ >> ] ] ; opt_meth_list: - [ [ ml = meth_list; OPT ";" -> ml - | -> <:ctyp<>> + [ [ (ml, v) = meth_list -> <:ctyp< < $ml$ $..:v$ > >> + | v = opt_dot_dot -> <:ctyp< < $..:v$ > >> ] ] ; poly_type: @@ -1613,7 +1642,7 @@ Very old (no more supported) syntax: ; ctyp_quot: [ [ x = more_ctyp; ","; y = comma_ctyp -> <:ctyp< $x$, $y$ >> - | x = more_ctyp; ";"; y = label_declaration -> <:ctyp< $x$; $y$ >> + | x = more_ctyp; ";"; y = label_declaration_list -> <:ctyp< $x$; $y$ >> | x = more_ctyp; "|"; y = constructor_declarations -> <:ctyp< $x$ | $y$ >> | x = more_ctyp; "of"; y = constructor_arg_list -> <:ctyp< $x$ of $y$ >> | x = more_ctyp; "of"; y = constructor_arg_list; "|"; z = constructor_declarations -> @@ -1622,7 +1651,7 @@ Very old (no more supported) syntax: | x = more_ctyp; "of"; "&"; y = amp_ctyp; "|"; z = row_field -> <:ctyp< $ <:ctyp< $x$ of & $y$ >> $ | $z$ >> | x = more_ctyp; ":"; y = more_ctyp -> <:ctyp< $x$ : $y$ >> - | x = more_ctyp; ":"; y = more_ctyp; ";"; z = label_declaration -> + | x = more_ctyp; ":"; y = more_ctyp; ";"; z = label_declaration_list -> <:ctyp< $ <:ctyp< $x$ : $y$ >> $ ; $z$ >> | x = more_ctyp; "*"; y = star_ctyp -> <:ctyp< $x$ * $y$ >> | x = more_ctyp; "&"; y = amp_ctyp -> <:ctyp< $x$ & $y$ >> @@ -1670,7 +1699,7 @@ Very old (no more supported) syntax: ] ] ; rec_binding_quot: - [ [ x = label_expr -> x + [ [ x = label_expr_list -> x | -> <:rec_binding<>> ] ] ; module_binding_quot: diff --git a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml index 8be11977..e33772c7 100644 --- a/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml +++ b/camlp4/Camlp4Parsers/Camlp4OCamlRevisedParserParser.ml @@ -21,7 +21,7 @@ open Camlp4; (* -*- camlp4r -*- *) module Id : Sig.Id = struct value name = "Camlp4OCamlRevisedParserParser"; - value version = "$Id: Camlp4OCamlRevisedParserParser.ml,v 1.1.4.3 2007/05/16 12:48:13 pouillar Exp $"; + value version = "$Id: Camlp4OCamlRevisedParserParser.ml,v 1.4 2008/01/11 16:13:16 doligez Exp $"; end; module Make (Syntax : Sig.Camlp4Syntax) = struct diff --git a/camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml b/camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml index 12c78c4a..bcc8cd77 100644 --- a/camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml +++ b/camlp4/Camlp4Parsers/Camlp4QuotationCommon.ml @@ -19,7 +19,7 @@ open Camlp4; (* -*- camlp4r -*- *) module Id = struct value name = "Camlp4QuotationCommon"; - value version = "$Id: Camlp4QuotationCommon.ml,v 1.1.4.7 2007/12/18 09:02:19 ertai Exp $"; + value version = "$Id: Camlp4QuotationCommon.ml,v 1.5 2008/01/11 16:13:16 doligez Exp $"; end; module Make (Syntax : Sig.Camlp4Syntax) diff --git a/camlp4/Camlp4Top/Rprint.ml b/camlp4/Camlp4Top/Rprint.ml index 88a96f2b..2e5a5ca9 100644 --- a/camlp4/Camlp4Top/Rprint.ml +++ b/camlp4/Camlp4Top/Rprint.ml @@ -18,8 +18,7 @@ * - Nicolas Pouillard: refactoring *) - -(* $Id: Rprint.ml,v 1.2.6.3 2007/05/22 10:54:59 pouillar Exp $ *) +(* $Id: Rprint.ml,v 1.5 2008/01/11 16:13:16 doligez Exp $ *) (* There is a few Obj.magic due to the fact that we no longer have compiler files like Parsetree, Location, Longident but Camlp4_import that wrap them to diff --git a/camlp4/Camlp4Top/Top.ml b/camlp4/Camlp4Top/Top.ml index 4fd4d0f6..f1cd069d 100644 --- a/camlp4/Camlp4Top/Top.ml +++ b/camlp4/Camlp4Top/Top.ml @@ -18,7 +18,7 @@ * - Nicolas Pouillard: refactoring *) -(* $Id: Top.ml,v 1.1.4.3 2007/05/22 09:09:45 pouillar Exp $ *) +(* $Id: Top.ml,v 1.4.4.1 2008/10/13 13:34:06 ertai Exp $ *) (* There is a few Obj.magic due to the fact that we no longer have compiler files like Parsetree, Location, Longident but Camlp4_import that wrap them to @@ -54,19 +54,29 @@ module Lexer = Camlp4.Struct.Lexer.Make Token; external not_filtered : 'a -> Gram.not_filtered 'a = "%identity"; +value initialization = lazy begin + if Sys.interactive.val + then Format.printf "\tCamlp4 Parsing version %s\n@." Camlp4_config.version + else () +end; + +value lookup x xs = try Some (List.assq x xs) with [ Not_found -> None ]; + value wrap parse_fun = - let token_stream_ref = ref None in + let token_streams = ref [] in + let cleanup lb = + try token_streams.val := List.remove_assq lb token_streams.val + with [ Not_found -> () ] + in fun lb -> + let () = Lazy.force initialization in let () = Register.iter_and_take_callbacks (fun (_, f) -> f ()) in let token_stream = - match token_stream_ref.val with + match lookup lb token_streams.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 } + do { token_streams.val := [ (lb,token_stream) :: token_streams.val ]; token_stream } | Some token_stream -> token_stream ] in try match token_stream with parser @@ -74,9 +84,8 @@ value wrap parse_fun = | [: :] -> parse_fun token_stream ] with [ End_of_file | Sys.Break | (Loc.Exc_located _ (End_of_file | Sys.Break)) - as x -> raise x + as x -> (cleanup lb; raise x) | x -> - let () = Stream.junk token_stream in let x = match x with [ Loc.Exc_located loc x -> do { @@ -86,6 +95,7 @@ value wrap parse_fun = | x -> x ] in do { + cleanup lb; Format.eprintf "@[<0>%a@]@." Camlp4.ErrorHandler.print x; raise Exit } ]; diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml index ad3b81c3..57104c22 100644 --- a/camlp4/boot/Camlp4.ml +++ b/camlp4/boot/Camlp4.ml @@ -372,6 +372,7 @@ module Sig = * - Daniel de Rauglaudre: initial version * - Nicolas Pouillard: refactoring *) + (* $Id$ *) (** Camlp4 signature repository *) (** {6 Basic signatures} *) (** Signature with just a type. *) @@ -398,7 +399,7 @@ module Sig = (** The name of the extension, typically the module name. *) val name : string - (** The version of the extension, typically $Id$ with a versionning system. *) + (** The version of the extension, typically $ Id$ with a versionning system. *) val version : string end @@ -808,433 +809,434 @@ module Sig = (** The inner module for locations *) module Loc : Loc - type (* i . i *) - (* i i *) - (* foo *) - (* Bar *) - (* $s$ *) - (* t as t *) + type loc = + Loc. + t + and meta_bool = + | BTrue | BFalse | BAnt of string + and 'a meta_option = + | ONone | OSome of 'a | OAnt of string + and 'a meta_list = + | LNil | LCons of 'a * 'a meta_list | LAnt of string + and ident = + | IdAcc of loc * ident * ident + | (* i . i *) + IdApp of loc * ident * ident + | (* i i *) + IdLid of loc * string + | (* foo *) + IdUid of loc * string + | (* Bar *) + IdAnt of loc * string + and (* $s$ *) + ctyp = + | TyNil of loc + | TyAli of loc * ctyp * ctyp + | (* t as t *) (* list 'a as 'a *) - (* _ *) - (* t t *) + TyAny of loc + | (* _ *) + TyApp of loc * ctyp * ctyp + | (* t t *) (* list 'a *) - (* t -> t *) + TyArr of loc * ctyp * ctyp + | (* t -> t *) (* int -> string *) - (* #i *) + TyCls of loc * ident + | (* #i *) (* #point *) - (* ~s:t *) - (* i *) + TyLab of loc * string * ctyp + | (* ~s:t *) + TyId of loc * ident + | (* i *) (* Lazy.t *) - (* t == t *) + TyMan of loc * ctyp * ctyp + | (* t == t *) (* type t = [ A | B ] == Foo.t *) (* type t 'a 'b 'c = t constraint t = t constraint t = t *) - (* < (t)? (..)? > *) + TyDcl of loc * string * ctyp list * ctyp * (ctyp * ctyp) list + | (* < (t)? (..)? > *) (* < move : int -> 'a .. > as 'a *) - (* ?s:t *) - (* ! t . t *) + TyObj of loc * ctyp * meta_bool + | TyOlb of loc * string * ctyp + | (* ?s:t *) + TyPol of loc * ctyp * ctyp + | (* ! t . t *) (* ! 'a . list 'a -> 'a *) - (* 's *) - (* +'s *) - (* -'s *) - (* `s *) - (* { t } *) + TyQuo of loc * string + | (* 's *) + TyQuP of loc * string + | (* +'s *) + TyQuM of loc * string + | (* -'s *) + TyVrn of loc * string + | (* `s *) + TyRec of loc * ctyp + | (* { t } *) (* { foo : int ; bar : mutable string } *) - (* t : t *) - (* t; t *) - (* t, t *) - (* [ t ] *) + TyCol of loc * ctyp * ctyp + | (* t : t *) + TySem of loc * ctyp * ctyp + | (* t; t *) + TyCom of loc * ctyp * ctyp + | (* t, t *) + TySum of loc * ctyp + | (* [ t ] *) (* [ A of int and string | B ] *) - (* t of t *) + TyOf of loc * ctyp * ctyp + | (* t of t *) (* A of int *) - (* t and t *) - (* t | t *) - (* private t *) - (* mutable t *) - (* ( t ) *) + TyAnd of loc * ctyp * ctyp + | (* t and t *) + TyOr of loc * ctyp * ctyp + | (* t | t *) + TyPrv of loc * ctyp + | (* private t *) + TyMut of loc * ctyp + | (* mutable t *) + TyTup of loc * ctyp + | (* ( t ) *) (* (int * string) *) - (* t * t *) - (* [ = t ] *) - (* [ > t ] *) - (* [ < t ] *) - (* [ < t > t ] *) - (* t & t *) - (* t of & t *) - (* $s$ *) - (* i *) - (* p as p *) + TySta of loc * ctyp * ctyp + | (* t * t *) + TyVrnEq of loc * ctyp + | (* [ = t ] *) + TyVrnSup of loc * ctyp + | (* [ > t ] *) + TyVrnInf of loc * ctyp + | (* [ < t ] *) + TyVrnInfSup of loc * ctyp * ctyp + | (* [ < t > t ] *) + TyAmp of loc * ctyp * ctyp + | (* t & t *) + TyOfAmp of loc * ctyp * ctyp + | (* t of & t *) + TyAnt of loc * string + and (* $s$ *) + patt = + | PaNil of loc + | PaId of loc * ident + | (* i *) + PaAli of loc * patt * patt + | (* p as p *) (* (Node x y as n) *) - (* $s$ *) - (* _ *) - (* p p *) + PaAnt of loc * string + | (* $s$ *) + PaAny of loc + | (* _ *) + PaApp of loc * patt * patt + | (* p p *) (* fun x y -> *) - (* [| p |] *) - (* p, p *) - (* p; p *) - (* c *) + PaArr of loc * patt + | (* [| p |] *) + PaCom of loc * patt * patt + | (* p, p *) + PaSem of loc * patt * patt + | (* p; p *) + PaChr of loc * string + | (* c *) (* 'x' *) - (* ~s or ~s:(p) *) - (* ?s or ?s:(p) *) - (* ?s:(p = e) or ?(p = e) *) - (* p | p *) - (* p .. p *) - (* { p } *) - (* i = 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 [ mc ] *) - (* 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 [ mc ] *) - (* new i *) - (* object ((p))? (cst)? end *) - (* ?s or ?s:e *) - (* {< rb >} *) - (* { rb } or { (e) with rb } *) - (* do { e } *) - (* e#s *) - (* e.[e] *) - (* s *) - (* "foo" *) - (* try e with [ mc ] *) - (* (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$ *) - (* bi and bi *) - (* let a = 42 and c = 43 *) - (* p = e *) - (* let patt = expr *) - (* $s$ *) - (* rb ; rb *) - (* i = e *) - (* $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 (rec)? bi *) - (* $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)? bi in ce *) - (* object ((p))? (cst)? end *) - (* ce : ct *) - (* ce and ce *) - (* ce = ce *) - (* $s$ *) - loc = - Loc. - t - and meta_bool = - | BTrue | BFalse | BAnt of string - and 'a meta_option = - | ONone | OSome of 'a | OAnt of string - and 'a meta_list = - | LNil | LCons of 'a * 'a meta_list | LAnt of string - and ident = - | IdAcc of loc * ident * ident - | IdApp of loc * ident * ident - | IdLid of loc * string - | IdUid of loc * string - | IdAnt of loc * string - and ctyp = - | TyNil of loc - | TyAli of loc * ctyp * ctyp - | TyAny of loc - | TyApp of loc * ctyp * ctyp - | TyArr of loc * ctyp * ctyp - | TyCls of loc * ident - | TyLab of loc * string * ctyp - | TyId of loc * ident - | TyMan of loc * ctyp * ctyp - | TyDcl of loc * string * ctyp list * ctyp * (ctyp * ctyp) list - | TyObj of loc * ctyp * meta_bool - | TyOlb of loc * string * ctyp - | TyPol of loc * ctyp * ctyp - | TyQuo of loc * string - | TyQuP of loc * string - | TyQuM of loc * string - | TyVrn of loc * string - | TyRec of loc * ctyp - | TyCol of loc * ctyp * ctyp - | TySem of loc * ctyp * ctyp - | TyCom of loc * ctyp * ctyp - | TySum of loc * ctyp - | TyOf of loc * ctyp * ctyp - | TyAnd of loc * ctyp * ctyp - | TyOr of loc * ctyp * ctyp - | TyPrv of loc * ctyp - | TyMut of loc * ctyp - | TyTup of loc * ctyp - | TySta of loc * ctyp * ctyp - | TyVrnEq of loc * ctyp - | TyVrnSup of loc * ctyp - | TyVrnInf of loc * ctyp - | TyVrnInfSup of loc * ctyp * ctyp - | TyAmp of loc * ctyp * ctyp - | TyOfAmp of loc * ctyp * ctyp - | TyAnt of loc * string - and patt = - | PaNil of loc - | PaId of loc * ident - | PaAli of loc * patt * patt - | PaAnt of loc * string - | PaAny of loc - | PaApp of loc * patt * patt - | PaArr of loc * patt - | PaCom of loc * patt * patt - | PaSem of loc * patt * patt - | PaChr of loc * string - | PaInt 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 - | PaOlb of loc * string * patt - | PaOlbi of loc * string * patt * expr + | (* ~s or ~s:(p) *) + (* ?s or ?s:(p) *) + PaOlb of loc * string * patt + | (* ?s:(p = e) or ?(p = e) *) + PaOlbi of loc * string * patt * expr | PaOrp of loc * patt * patt - | PaRng of loc * patt * patt - | PaRec of loc * patt - | PaEq of loc * ident * patt - | PaStr of loc * string - | PaTup of loc * patt - | PaTyc of loc * patt * ctyp - | PaTyp of loc * ident - | PaVrn of loc * string - and expr = + | (* p | p *) + PaRng of loc * patt * patt + | (* p .. p *) + PaRec of loc * patt + | (* { p } *) + PaEq of loc * ident * patt + | (* i = p *) + PaStr of loc * string + | (* s *) + PaTup of loc * patt + | (* ( p ) *) + PaTyc of loc * patt * ctyp + | (* (p : t) *) + PaTyp of loc * ident + | (* #i *) + PaVrn of loc * string + | (* `s *) + PaLaz of loc * patt + and (* lazy p *) + expr = | ExNil of loc | ExId of loc * ident - | ExAcc of loc * expr * expr - | ExAnt of loc * string - | ExApp of loc * expr * expr - | ExAre of loc * expr * expr - | ExArr of loc * expr - | ExSem of loc * expr * expr - | ExAsf of loc - | ExAsr of loc * expr - | ExAss of loc * expr * expr - | ExChr of loc * string - | ExCoe of loc * expr * ctyp * ctyp - | ExFlo of loc * string - | ExFor of loc * string * expr * expr * meta_bool * expr + | (* i *) + ExAcc of loc * expr * expr + | (* e.e *) + ExAnt of loc * string + | (* $s$ *) + ExApp of loc * expr * expr + | (* e e *) + ExAre of loc * expr * expr + | (* e.(e) *) + ExArr of loc * expr + | (* [| e |] *) + ExSem of loc * expr * expr + | (* e; e *) + ExAsf of loc + | (* assert False *) + ExAsr of loc * expr + | (* assert e *) + ExAss of loc * expr * expr + | (* e := e *) + ExChr of loc * string + | (* 'c' *) + ExCoe of loc * expr * ctyp * ctyp + | (* (e : t) or (e : t :> t) *) + ExFlo of loc * string + | (* 3.14 *) + (* for s = e to/downto e do { e } *) + ExFor of loc * string * expr * expr * meta_bool * expr | ExFun of loc * match_case - | ExIfe of loc * expr * expr * expr - | ExInt of loc * string - | ExInt32 of loc * string + | (* fun [ mc ] *) + ExIfe of loc * expr * expr * expr + | (* if e then e else e *) + ExInt of loc * string + | (* 42 *) + ExInt32 of loc * string | ExInt64 of loc * string | ExNativeInt of loc * string | ExLab of loc * string * expr - | ExLaz of loc * expr - | ExLet of loc * meta_bool * binding * expr - | ExLmd of loc * string * module_expr * expr - | ExMat of loc * expr * match_case - | ExNew of loc * ident - | ExObj of loc * patt * class_str_item - | ExOlb of loc * string * expr - | ExOvr of loc * rec_binding - | ExRec of loc * rec_binding * expr - | ExSeq of loc * expr - | ExSnd of loc * expr * string - | ExSte of loc * expr * expr - | ExStr of loc * string - | ExTry of loc * expr * match_case - | ExTup of loc * expr - | ExCom of loc * expr * expr - | ExTyc of loc * expr * ctyp - | ExVrn of loc * string - | ExWhi of loc * expr * expr + | (* ~s or ~s:e *) + ExLaz of loc * expr + | (* lazy e *) + (* let b in e or let rec b in e *) + ExLet of loc * meta_bool * binding * expr + | (* let module s = me in e *) + ExLmd of loc * string * module_expr * expr + | (* match e with [ mc ] *) + ExMat of loc * expr * match_case + | (* new i *) + ExNew of loc * ident + | (* object ((p))? (cst)? end *) + ExObj of loc * patt * class_str_item + | (* ?s or ?s:e *) + ExOlb of loc * string * expr + | (* {< rb >} *) + ExOvr of loc * rec_binding + | (* { rb } or { (e) with rb } *) + ExRec of loc * rec_binding * expr + | (* do { e } *) + ExSeq of loc * expr + | (* e#s *) + ExSnd of loc * expr * string + | (* e.[e] *) + ExSte of loc * expr * expr + | (* s *) + (* "foo" *) + ExStr of loc * string + | (* try e with [ mc ] *) + ExTry of loc * expr * match_case + | (* (e) *) + ExTup of loc * expr + | (* e, e *) + ExCom of loc * expr * expr + | (* (e : t) *) + ExTyc of loc * expr * ctyp + | (* `s *) + ExVrn of loc * string + | (* while e do { e } *) + ExWhi of loc * expr * expr and module_type = | MtNil of loc - | MtId of loc * ident - | MtFun of loc * string * module_type * module_type - | MtQuo of loc * string - | MtSig of loc * sig_item - | MtWit of loc * module_type * with_constr + | (* i *) + (* A.B.C *) + MtId of loc * ident + | (* functor (s : mt) -> mt *) + MtFun of loc * string * module_type * module_type + | (* 's *) + MtQuo of loc * string + | (* sig sg end *) + MtSig of loc * sig_item + | (* mt with wc *) + MtWit of loc * module_type * with_constr | MtAnt of loc * string - and sig_item = + and (* $s$ *) + sig_item = | SgNil of loc - | SgCls of loc * class_type - | SgClt of loc * class_type - | SgSem of loc * sig_item * sig_item - | SgDir of loc * string * expr - | SgExc of loc * ctyp - | SgExt of loc * string * ctyp * string meta_list - | SgInc of loc * module_type - | SgMod of loc * string * module_type - | SgRecMod of loc * module_binding - | SgMty of loc * string * module_type - | SgOpn of loc * ident - | SgTyp of loc * ctyp - | SgVal of loc * string * ctyp + | (* class cict *) + SgCls of loc * class_type + | (* class type cict *) + SgClt of loc * class_type + | (* sg ; sg *) + SgSem of loc * sig_item * sig_item + | (* # s or # s e *) + SgDir of loc * string * expr + | (* exception t *) + SgExc of loc * ctyp + | (* external s : t = s ... s *) + SgExt of loc * string * ctyp * string meta_list + | (* include mt *) + SgInc of loc * module_type + | (* module s : mt *) + SgMod of loc * string * module_type + | (* module rec mb *) + SgRecMod of loc * module_binding + | (* module type s = mt *) + SgMty of loc * string * module_type + | (* open i *) + SgOpn of loc * ident + | (* type t *) + SgTyp of loc * ctyp + | (* value s : t *) + SgVal of loc * string * ctyp | SgAnt of loc * string - and with_constr = + and (* $s$ *) + with_constr = | WcNil of loc - | WcTyp of loc * ctyp * ctyp - | WcMod of loc * ident * ident - | WcAnd of loc * with_constr * with_constr + | (* type t = t *) + WcTyp of loc * ctyp * ctyp + | (* module i = i *) + WcMod of loc * ident * ident + | (* wc and wc *) + WcAnd of loc * with_constr * with_constr | WcAnt of loc * string - and binding = + and (* $s$ *) + binding = | BiNil of loc - | BiAnd of loc * binding * binding - | BiEq of loc * patt * expr + | (* bi and bi *) + (* let a = 42 and c = 43 *) + BiAnd of loc * binding * binding + | (* p = e *) + (* let patt = expr *) + BiEq of loc * patt * expr | BiAnt of loc * string - and rec_binding = + and (* $s$ *) + rec_binding = | RbNil of loc - | RbSem of loc * rec_binding * rec_binding - | RbEq of loc * ident * expr + | (* rb ; rb *) + RbSem of loc * rec_binding * rec_binding + | (* i = e *) + RbEq of loc * ident * expr | RbAnt of loc * string - and module_binding = + and (* $s$ *) + module_binding = | MbNil of loc - | MbAnd of loc * module_binding * module_binding - | MbColEq of loc * string * module_type * module_expr - | MbCol of loc * string * module_type + | (* mb and mb *) + (* module rec (s : mt) = me and (s : mt) = me *) + MbAnd of loc * module_binding * module_binding + | (* s : mt = me *) + MbColEq of loc * string * module_type * module_expr + | (* s : mt *) + MbCol of loc * string * module_type | MbAnt of loc * string - and match_case = + and (* $s$ *) + match_case = | McNil of loc - | McOr of loc * match_case * match_case - | McArr of loc * patt * expr * expr + | (* a | a *) + McOr of loc * match_case * match_case + | (* p (when e)? -> e *) + McArr of loc * patt * expr * expr | McAnt of loc * string - and module_expr = + and (* $s$ *) + module_expr = | MeNil of loc - | MeId of loc * ident - | MeApp of loc * module_expr * module_expr - | MeFun of loc * string * module_type * module_expr - | MeStr of loc * str_item - | MeTyc of loc * module_expr * module_type + | (* i *) + MeId of loc * ident + | (* me me *) + MeApp of loc * module_expr * module_expr + | (* functor (s : mt) -> me *) + MeFun of loc * string * module_type * module_expr + | (* struct st end *) + MeStr of loc * str_item + | (* (me : mt) *) + MeTyc of loc * module_expr * module_type | MeAnt of loc * string - and str_item = + and (* $s$ *) + str_item = | StNil of loc - | StCls of loc * class_expr - | StClt of loc * class_type - | StSem of loc * str_item * str_item - | StDir of loc * string * expr - | StExc of loc * ctyp * ident meta_option - | StExp of loc * expr - | StExt of loc * string * ctyp * string meta_list - | StInc of loc * module_expr - | StMod of loc * string * module_expr - | StRecMod of loc * module_binding - | StMty of loc * string * module_type - | StOpn of loc * ident - | StTyp of loc * ctyp - | StVal of loc * meta_bool * binding + | (* class cice *) + StCls of loc * class_expr + | (* class type cict *) + StClt of loc * class_type + | (* st ; st *) + StSem of loc * str_item * str_item + | (* # s or # s e *) + StDir of loc * string * expr + | (* exception t or exception t = i *) + StExc of loc * ctyp * (*FIXME*) ident meta_option + | (* e *) + StExp of loc * expr + | (* external s : t = s ... s *) + StExt of loc * string * ctyp * string meta_list + | (* include me *) + StInc of loc * module_expr + | (* module s = me *) + StMod of loc * string * module_expr + | (* module rec mb *) + StRecMod of loc * module_binding + | (* module type s = mt *) + StMty of loc * string * module_type + | (* open i *) + StOpn of loc * ident + | (* type t *) + StTyp of loc * ctyp + | (* value (rec)? bi *) + StVal of loc * meta_bool * binding | StAnt of loc * string - and class_type = + and (* $s$ *) + class_type = | CtNil of loc - | CtCon of loc * meta_bool * ident * ctyp - | CtFun of loc * ctyp * class_type - | CtSig of loc * ctyp * class_sig_item - | CtAnd of loc * class_type * class_type - | CtCol of loc * class_type * class_type - | CtEq of loc * class_type * class_type - | CtAnt of loc * string + | (* (virtual)? i ([ t ])? *) + CtCon of loc * meta_bool * ident * ctyp + | (* [t] -> ct *) + CtFun of loc * ctyp * class_type + | (* object ((t))? (csg)? end *) + CtSig of loc * ctyp * class_sig_item + | (* ct and ct *) + CtAnd of loc * class_type * class_type + | (* ct : ct *) + CtCol of loc * class_type * class_type + | (* ct = ct *) + CtEq of loc * class_type * class_type + | (* $s$ *) + CtAnt of loc * string and class_sig_item = | CgNil of loc - | CgCtr of loc * ctyp * ctyp - | CgSem of loc * class_sig_item * class_sig_item - | CgInh of loc * class_type - | CgMth of loc * string * meta_bool * ctyp - | CgVal of loc * string * meta_bool * meta_bool * ctyp - | CgVir of loc * string * meta_bool * ctyp + | (* type t = t *) + CgCtr of loc * ctyp * ctyp + | (* csg ; csg *) + CgSem of loc * class_sig_item * class_sig_item + | (* inherit ct *) + CgInh of loc * class_type + | (* method s : t or method private s : t *) + CgMth of loc * string * meta_bool * ctyp + | (* value (virtual)? (mutable)? s : t *) + CgVal of loc * string * meta_bool * meta_bool * ctyp + | (* method virtual (mutable)? s : t *) + CgVir of loc * string * meta_bool * ctyp | CgAnt of loc * string - and class_expr = + and (* $s$ *) + class_expr = | CeNil of loc - | CeApp of loc * class_expr * expr - | CeCon of loc * meta_bool * ident * ctyp - | CeFun of loc * patt * class_expr - | CeLet of loc * meta_bool * binding * class_expr - | CeStr of loc * patt * class_str_item - | CeTyc of loc * class_expr * class_type - | CeAnd of loc * class_expr * class_expr - | CeEq of loc * class_expr * class_expr - | CeAnt of loc * string + | (* ce e *) + CeApp of loc * class_expr * expr + | (* (virtual)? i ([ t ])? *) + CeCon of loc * meta_bool * ident * ctyp + | (* fun p -> ce *) + CeFun of loc * patt * class_expr + | (* let (rec)? bi in ce *) + CeLet of loc * meta_bool * binding * class_expr + | (* object ((p))? (cst)? end *) + CeStr of loc * patt * class_str_item + | (* ce : ct *) + CeTyc of loc * class_expr * class_type + | (* ce and ce *) + CeAnd of loc * class_expr * class_expr + | (* ce = ce *) + CeEq of loc * class_expr * class_expr + | (* $s$ *) + CeAnt of loc * string and class_str_item = | CrNil of loc | (* cst ; cst *) @@ -1777,6 +1779,7 @@ module Sig = | PaTyc of loc * patt * ctyp | PaTyp of loc * ident | PaVrn of loc * string + | PaLaz of loc * patt and expr = | ExNil of loc | ExId of loc * ident @@ -2126,6 +2129,8 @@ module Sig = val find_in_path : t -> string -> string + val is_native : bool + end module Grammar = @@ -2578,6 +2583,8 @@ module Sig = val field_expr : Ast.rec_binding Gram.Entry.t + val field_expr_list : Ast.rec_binding Gram.Entry.t + val fun_binding : Ast.expr Gram.Entry.t val fun_def : Ast.expr Gram.Entry.t @@ -2594,19 +2601,29 @@ module Sig = val label_declaration : Ast.ctyp Gram.Entry.t + val label_declaration_list : Ast.ctyp Gram.Entry.t + val label_expr : Ast.rec_binding Gram.Entry.t + val label_expr_list : Ast.rec_binding Gram.Entry.t + val label_ipatt : Ast.patt Gram.Entry.t + val label_ipatt_list : Ast.patt Gram.Entry.t + val label_longident : Ast.ident Gram.Entry.t val label_patt : Ast.patt Gram.Entry.t + val label_patt_list : 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 meth_list : (Ast.ctyp * Ast.meta_bool) Gram.Entry.t + + val meth_decl : Ast.ctyp Gram.Entry.t val module_binding : Ast.module_binding Gram.Entry.t @@ -3706,15 +3723,19 @@ module Struct = \020\012\057\012\094\012\011\007\136\005\004\000\233\255\008\000\ \054\001\245\002\009\000\005\000\233\255\131\012\138\012\175\012\ \212\012\249\012\000\013\037\013\068\013\096\013\133\013\138\013\ - \205\013\242\013\023\014\085\014\006\000\148\002\251\255\047\015\ - \123\000\109\000\125\000\254\255\111\015\046\016\254\016\206\017\ - \174\018\129\000\017\001\130\000\141\000\249\255\248\255\237\006\ - \109\003\143\000\035\004\145\000\160\014\149\000\086\004\007\000\ - \201\018\250\255\121\016\154\004\091\001\057\001\171\004\073\017\ - \240\018\051\019\018\020\048\020\015\021\238\021\015\022\079\022\ - \031\023\254\255\164\001\010\000\128\000\079\001\095\023\030\024\ - \238\024\190\025\154\026\201\000\116\027\077\028\028\001\029\029\ - \206\001\080\001\013\000\093\029\028\030\236\030\188\031"; + \205\013\242\013\023\014\085\014\241\255\006\000\242\255\243\255\ + \148\002\251\255\047\015\123\000\109\000\125\000\255\255\254\255\ + \253\255\111\015\046\016\254\016\206\017\174\018\129\000\017\001\ + \130\000\141\000\249\255\248\255\247\255\237\006\109\003\143\000\ + \246\255\035\004\145\000\245\255\160\014\149\000\244\255\086\004\ + \247\255\248\255\007\000\249\255\201\018\255\255\250\255\121\016\ + \154\004\253\255\091\001\057\001\171\004\252\255\073\017\251\255\ + \240\018\051\019\018\020\048\020\255\255\015\021\238\021\015\022\ + \079\022\255\255\031\023\254\255\164\001\251\255\010\000\252\255\ + \253\255\128\000\079\001\255\255\095\023\030\024\238\024\190\025\ + \254\255\154\026\253\255\254\255\201\000\116\027\077\028\255\255\ + \028\001\029\029\206\001\251\255\080\001\013\000\253\255\254\255\ + \255\255\252\255\093\029\028\030\236\030\188\031"; Lexing.lex_backtrk = "\255\255\255\255\255\255\030\000\255\255\028\000\030\000\030\000\ \030\000\030\000\028\000\028\000\028\000\028\000\028\000\255\255\ @@ -3731,15 +3752,19 @@ module Struct = \255\255\019\000\030\000\255\255\255\255\022\000\255\255\255\255\ \255\255\255\255\255\255\022\000\255\255\255\255\255\255\255\255\ \028\000\255\255\028\000\255\255\028\000\028\000\028\000\028\000\ - \030\000\030\000\030\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"; + \030\000\030\000\030\000\255\255\255\255\013\000\255\255\255\255\ + \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\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\255\255\255\255\255\255\255\255\ + \255\255\255\255\006\000\255\255\008\000\255\255\255\255\005\000\ + \005\000\255\255\001\000\001\000\255\255\255\255\255\255\255\255\ + \000\000\001\000\001\000\255\255\255\255\002\000\002\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\003\000\255\255\ + \255\255\004\000\004\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\002\000\002\000\002\000\255\255\ + \255\255\255\255\255\255\255\255\004\000\002\000\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255"; Lexing.lex_default = "\001\000\000\000\000\000\255\255\000\000\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\000\000\ @@ -3756,19 +3781,23 @@ module Struct = \255\255\255\255\255\255\103\000\255\255\255\255\000\000\103\000\ \104\000\103\000\106\000\255\255\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\054\000\255\255\137\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\037\000\255\255\ - \153\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\126\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\032\000\255\255\255\255\255\255\255\255\255\255\ - \126\000\255\255\255\255\255\255\255\255\255\255\255\255"; + \255\255\255\255\255\255\124\000\000\000\255\255\000\000\000\000\ + \142\000\000\000\255\255\255\255\255\255\255\255\000\000\000\000\ + \000\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\000\000\000\000\000\000\255\255\255\255\255\255\ + \000\000\255\255\255\255\000\000\255\255\255\255\000\000\160\000\ + \000\000\000\000\255\255\000\000\166\000\000\000\000\000\255\255\ + \255\255\000\000\255\255\255\255\255\255\000\000\255\255\000\000\ + \255\255\255\255\255\255\255\255\000\000\255\255\255\255\255\255\ + \255\255\000\000\255\255\000\000\189\000\000\000\255\255\000\000\ + \000\000\255\255\255\255\000\000\255\255\255\255\255\255\255\255\ + \000\000\202\000\000\000\000\000\255\255\255\255\255\255\000\000\ + \255\255\255\255\211\000\000\000\255\255\255\255\000\000\000\000\ + \000\000\000\000\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\028\000\030\000\030\000\028\000\029\000\102\000\108\000\ - \053\000\141\000\102\000\108\000\034\000\101\000\107\000\032\000\ + \126\000\163\000\102\000\108\000\191\000\101\000\107\000\214\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \028\000\003\000\021\000\016\000\004\000\009\000\009\000\020\000\ \019\000\005\000\018\000\003\000\015\000\003\000\014\000\009\000\ @@ -3784,54 +3813,54 @@ module Struct = \025\000\025\000\025\000\010\000\008\000\005\000\027\000\015\000\ \117\000\117\000\053\000\100\000\052\000\028\000\045\000\045\000\ \028\000\115\000\117\000\044\000\044\000\044\000\044\000\044\000\ - \044\000\044\000\044\000\053\000\066\000\118\000\131\000\116\000\ + \044\000\044\000\044\000\053\000\066\000\118\000\135\000\116\000\ \115\000\115\000\100\000\117\000\028\000\046\000\046\000\046\000\ - \046\000\046\000\046\000\046\000\046\000\046\000\046\000\030\000\ - \037\000\142\000\099\000\099\000\099\000\099\000\099\000\099\000\ - \099\000\099\000\099\000\099\000\141\000\133\000\036\000\032\000\ - \035\000\117\000\051\000\132\000\021\000\050\000\131\000\000\000\ + \046\000\046\000\046\000\046\000\046\000\046\000\046\000\134\000\ + \148\000\147\000\099\000\099\000\099\000\099\000\099\000\099\000\ + \099\000\099\000\099\000\099\000\146\000\138\000\152\000\136\000\ + \155\000\117\000\051\000\137\000\158\000\050\000\200\000\000\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\118\000\ \024\000\024\000\024\000\024\000\024\000\024\000\024\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\182\000\ + \025\000\025\000\025\000\025\000\025\000\025\000\025\000\208\000\ \025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ - \002\000\003\000\000\000\131\000\003\000\003\000\003\000\051\000\ + \002\000\003\000\000\000\203\000\003\000\003\000\003\000\051\000\ \255\255\255\255\003\000\003\000\048\000\003\000\003\000\003\000\ \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ - \039\000\039\000\003\000\139\000\003\000\003\000\003\000\003\000\ + \039\000\039\000\003\000\144\000\003\000\003\000\003\000\003\000\ \003\000\000\000\096\000\096\000\052\000\038\000\084\000\000\000\ \047\000\000\000\047\000\084\000\096\000\046\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\084\000\ - \142\000\084\000\084\000\084\000\003\000\096\000\003\000\039\000\ - \102\000\000\000\157\000\101\000\003\000\038\000\000\000\003\000\ - \009\000\009\000\182\000\000\000\084\000\003\000\003\000\000\000\ - \003\000\006\000\009\000\000\000\068\000\000\000\131\000\068\000\ - \106\000\157\000\084\000\096\000\003\000\085\000\003\000\006\000\ - \006\000\006\000\003\000\009\000\157\000\157\000\000\000\000\000\ + \147\000\084\000\084\000\084\000\003\000\096\000\003\000\039\000\ + \102\000\000\000\171\000\101\000\003\000\038\000\000\000\003\000\ + \009\000\009\000\208\000\000\000\084\000\003\000\003\000\000\000\ + \003\000\006\000\009\000\000\000\068\000\000\000\203\000\068\000\ + \106\000\171\000\084\000\096\000\003\000\085\000\003\000\006\000\ + \006\000\006\000\003\000\009\000\171\000\171\000\000\000\000\000\ \000\000\003\000\000\000\068\000\003\000\121\000\121\000\000\000\ \000\000\084\000\003\000\003\000\074\000\003\000\007\000\121\000\ - \000\000\084\000\084\000\157\000\000\000\000\000\000\000\003\000\ + \000\000\084\000\084\000\171\000\000\000\000\000\000\000\003\000\ \084\000\009\000\120\000\000\000\007\000\007\000\007\000\003\000\ - \121\000\175\000\188\000\030\000\034\000\000\000\003\000\174\000\ - \187\000\003\000\009\000\009\000\000\000\000\000\005\000\003\000\ + \121\000\197\000\219\000\195\000\217\000\000\000\003\000\196\000\ + \218\000\003\000\009\000\009\000\000\000\000\000\005\000\003\000\ \003\000\000\000\003\000\006\000\009\000\000\000\000\000\085\000\ \084\000\003\000\000\000\000\000\003\000\005\000\121\000\085\000\ - \000\000\006\000\006\000\006\000\003\000\009\000\034\000\000\000\ - \255\255\171\000\000\000\003\000\000\000\000\000\003\000\009\000\ + \000\000\006\000\006\000\006\000\003\000\009\000\191\000\000\000\ + \255\255\190\000\000\000\003\000\000\000\000\000\003\000\009\000\ \009\000\000\000\000\000\094\000\003\000\003\000\000\000\003\000\ \009\000\009\000\000\000\000\000\120\000\005\000\003\000\000\000\ \000\000\003\000\005\000\009\000\098\000\000\000\009\000\009\000\ \009\000\003\000\009\000\000\000\000\000\000\000\000\000\000\000\ - \032\000\000\000\000\000\186\000\117\000\117\000\000\000\000\000\ - \173\000\000\000\172\000\111\000\111\000\115\000\117\000\005\000\ + \214\000\000\000\000\000\213\000\117\000\117\000\000\000\000\000\ + \194\000\000\000\193\000\111\000\111\000\115\000\117\000\005\000\ \000\000\085\000\005\000\003\000\109\000\111\000\003\000\094\000\ - \009\000\116\000\030\000\116\000\115\000\115\000\000\000\117\000\ + \009\000\116\000\216\000\116\000\115\000\115\000\000\000\117\000\ \114\000\000\000\109\000\112\000\112\000\000\000\111\000\111\000\ \111\000\000\000\080\000\084\000\000\000\080\000\000\000\000\000\ - \112\000\111\000\185\000\000\000\000\000\000\000\098\000\094\000\ + \112\000\111\000\212\000\000\000\000\000\000\000\098\000\094\000\ \003\000\000\000\000\000\000\000\110\000\117\000\109\000\109\000\ \109\000\080\000\111\000\005\000\111\000\045\000\045\000\000\000\ \000\000\000\000\081\000\003\000\000\000\000\000\003\000\009\000\ @@ -3849,18 +3878,18 @@ module Struct = \003\000\003\000\000\000\003\000\003\000\003\000\003\000\003\000\ \000\000\037\000\000\000\035\000\000\000\000\000\060\000\061\000\ \000\000\000\000\061\000\064\000\064\000\000\000\000\000\000\000\ - \065\000\061\000\000\000\061\000\062\000\064\000\139\000\000\000\ - \000\000\138\000\000\000\003\000\032\000\003\000\000\000\000\000\ + \065\000\061\000\000\000\061\000\062\000\064\000\144\000\000\000\ + \000\000\143\000\000\000\003\000\192\000\003\000\000\000\000\000\ \063\000\000\000\062\000\062\000\062\000\061\000\064\000\039\000\ \000\000\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ - \022\000\022\000\022\000\140\000\000\000\000\000\000\000\000\000\ + \022\000\022\000\022\000\145\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\003\000\000\000\003\000\038\000\000\000\ - \000\000\000\000\061\000\000\000\064\000\036\000\131\000\000\000\ + \000\000\000\000\061\000\000\000\064\000\036\000\215\000\000\000\ \039\000\000\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\000\000\000\000\040\000\000\000\038\000\038\000\ \000\000\000\000\063\000\000\000\061\000\037\000\036\000\035\000\ - \136\000\041\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \141\000\041\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\105\000\102\000\ \000\000\022\000\101\000\000\000\040\000\000\000\000\000\038\000\ \000\000\000\000\000\000\000\000\000\000\000\000\037\000\000\000\ @@ -3881,8 +3910,8 @@ module Struct = \058\000\058\000\058\000\058\000\058\000\058\000\058\000\049\000\ \049\000\049\000\049\000\049\000\049\000\049\000\049\000\049\000\ \049\000\000\000\000\000\000\000\255\255\000\000\000\000\043\000\ - \043\000\043\000\043\000\043\000\043\000\146\000\146\000\146\000\ - \146\000\146\000\146\000\146\000\146\000\146\000\146\000\000\000\ + \043\000\043\000\043\000\043\000\043\000\153\000\153\000\153\000\ + \153\000\153\000\153\000\153\000\153\000\153\000\153\000\000\000\ \000\000\000\000\000\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\ @@ -3904,25 +3933,25 @@ module Struct = \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\043\000\ \043\000\043\000\043\000\043\000\043\000\000\000\000\000\000\000\ - \000\000\000\000\036\000\147\000\147\000\147\000\147\000\147\000\ - \147\000\147\000\147\000\147\000\147\000\000\000\000\000\000\000\ - \141\000\000\000\000\000\151\000\000\000\043\000\000\000\043\000\ + \000\000\000\000\036\000\154\000\154\000\154\000\154\000\154\000\ + \154\000\154\000\154\000\154\000\154\000\000\000\000\000\000\000\ + \163\000\000\000\000\000\162\000\000\000\043\000\000\000\043\000\ \043\000\043\000\043\000\043\000\043\000\000\000\000\000\000\000\ \000\000\000\000\037\000\000\000\035\000\000\000\000\000\000\000\ - \030\000\000\000\000\000\025\000\025\000\025\000\025\000\025\000\ + \165\000\000\000\000\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\000\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\025\000\025\000\025\000\ - \025\000\025\000\152\000\025\000\025\000\025\000\025\000\025\000\ + \025\000\025\000\164\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\003\000\000\000\000\000\003\000\003\000\ \003\000\000\000\000\000\000\000\003\000\003\000\000\000\003\000\ - \003\000\003\000\158\000\158\000\158\000\158\000\158\000\158\000\ - \158\000\158\000\158\000\158\000\003\000\000\000\003\000\003\000\ - \003\000\003\000\003\000\034\000\034\000\034\000\034\000\034\000\ - \034\000\034\000\034\000\034\000\034\000\000\000\046\000\046\000\ + \003\000\003\000\172\000\172\000\172\000\172\000\172\000\172\000\ + \172\000\172\000\172\000\172\000\003\000\000\000\003\000\003\000\ + \003\000\003\000\003\000\173\000\173\000\173\000\173\000\173\000\ + \173\000\173\000\173\000\173\000\173\000\000\000\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \000\000\000\000\000\000\000\000\000\000\000\000\003\000\000\000\ \003\000\033\000\000\000\033\000\033\000\033\000\033\000\033\000\ @@ -3936,7 +3965,7 @@ module Struct = \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\003\000\000\000\003\000\031\000\142\000\031\000\ + \000\000\000\000\003\000\000\000\003\000\031\000\161\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\ @@ -3993,14 +4022,14 @@ module Struct = \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\000\000\000\000\000\000\105\000\102\000\000\000\000\000\ - \101\000\000\000\000\000\000\000\000\000\148\000\148\000\148\000\ - \148\000\148\000\148\000\148\000\148\000\148\000\148\000\000\000\ - \000\000\000\000\000\000\105\000\000\000\104\000\148\000\148\000\ - \148\000\148\000\148\000\148\000\000\000\000\000\000\000\000\000\ + \101\000\000\000\000\000\000\000\000\000\156\000\156\000\156\000\ + \156\000\156\000\156\000\156\000\156\000\156\000\156\000\000\000\ + \000\000\000\000\000\000\105\000\000\000\104\000\156\000\156\000\ + \156\000\156\000\156\000\156\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\099\000\099\000\099\000\099\000\099\000\ \099\000\099\000\099\000\099\000\099\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\148\000\148\000\ - \148\000\148\000\148\000\148\000\000\000\000\000\033\000\033\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\156\000\156\000\ + \156\000\156\000\156\000\156\000\000\000\000\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\000\000\033\000\033\000\ @@ -4225,133 +4254,133 @@ module Struct = \094\000\003\000\003\000\000\000\003\000\121\000\121\000\000\000\ \000\000\120\000\005\000\003\000\000\000\000\000\003\000\094\000\ \121\000\122\000\000\000\121\000\121\000\121\000\003\000\121\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\053\000\ - \000\000\000\000\124\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\126\000\ + \000\000\000\000\125\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\122\000\094\000\ - \003\000\000\000\000\000\003\000\094\000\121\000\000\000\126\000\ - \000\000\000\000\000\000\000\000\125\000\130\000\000\000\129\000\ + \003\000\000\000\000\000\003\000\094\000\121\000\000\000\129\000\ + \000\000\000\000\000\000\000\000\128\000\133\000\000\000\132\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\128\000\000\000\122\000\094\000\003\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \000\000\000\000\000\000\000\000\127\000\000\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \149\000\149\000\149\000\149\000\149\000\149\000\149\000\149\000\ - \149\000\149\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\149\000\149\000\149\000\149\000\149\000\149\000\000\000\ + \000\000\131\000\000\000\122\000\094\000\003\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\ + \157\000\157\000\157\000\157\000\157\000\157\000\157\000\157\000\ + \157\000\157\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\157\000\157\000\157\000\157\000\157\000\157\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\149\000\149\000\149\000\149\000\149\000\149\000\000\000\ + \000\000\157\000\157\000\157\000\157\000\157\000\157\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\000\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\000\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\052\000\127\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\000\000\000\000\000\000\000\000\127\000\000\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\000\000\000\000\000\000\000\000\000\000\000\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\000\000\000\000\000\000\000\000\135\000\000\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\000\000\000\000\000\000\000\000\000\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\000\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\000\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\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\000\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\135\000\000\000\135\000\ - \135\000\135\000\135\000\135\000\135\000\135\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\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\159\000\159\000\159\000\159\000\159\000\159\000\159\000\ - \159\000\159\000\159\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\159\000\159\000\159\000\159\000\159\000\159\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\000\000\130\000\130\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\127\000\130\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\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\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\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\000\000\000\000\000\000\000\000\140\000\000\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\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\000\000\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\000\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\000\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\000\000\000\000\000\000\000\000\139\000\000\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\174\000\174\000\174\000\174\000\174\000\174\000\174\000\ + \174\000\174\000\174\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\174\000\174\000\174\000\174\000\174\000\174\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\159\000\159\000\159\000\159\000\159\000\159\000\ + \000\000\000\000\174\000\174\000\174\000\174\000\174\000\174\000\ \000\000\000\000\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\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\032\000\000\000\000\000\000\000\132\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\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\126\000\126\000\126\000\126\000\126\000\126\000\126\000\ - \126\000\126\000\126\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\126\000\126\000\126\000\126\000\126\000\126\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\000\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \000\000\000\000\136\000\000\000\000\000\000\000\137\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\000\000\000\000\000\000\000\000\139\000\000\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\175\000\175\000\175\000\175\000\175\000\175\000\175\000\ + \175\000\175\000\175\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\175\000\175\000\175\000\175\000\175\000\175\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\126\000\126\000\126\000\126\000\126\000\126\000\ + \000\000\000\000\175\000\175\000\175\000\175\000\175\000\175\000\ \000\000\000\000\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\135\000\134\000\134\000\ - \134\000\134\000\134\000\134\000\134\000\134\000\135\000\135\000\ - \135\000\135\000\135\000\135\000\135\000\135\000\135\000\135\000\ - \000\000\000\000\032\000\000\000\000\000\000\000\000\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\000\000\000\000\000\000\000\000\135\000\000\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\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\000\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\140\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \000\000\000\000\136\000\000\000\000\000\000\000\000\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\000\000\000\000\000\000\000\000\140\000\000\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ @@ -4359,44 +4388,44 @@ module Struct = \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\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\000\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\135\000\000\000\135\000\135\000\ - \135\000\135\000\135\000\135\000\135\000\135\000\145\000\000\000\ - \145\000\000\000\000\000\157\000\000\000\145\000\156\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\ - \000\000\032\000\000\000\032\000\000\000\000\000\000\000\000\000\ - \032\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\155\000\155\000\155\000\155\000\155\000\155\000\155\000\ - \155\000\155\000\155\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\145\000\000\000\000\000\000\000\000\000\000\000\ - \145\000\160\000\000\000\000\000\160\000\160\000\160\000\000\000\ - \000\000\000\000\160\000\160\000\145\000\160\000\160\000\160\000\ - \145\000\000\000\145\000\000\000\000\000\032\000\143\000\000\000\ - \000\000\000\000\160\000\032\000\160\000\160\000\160\000\160\000\ - \160\000\000\000\000\000\000\000\000\000\000\000\000\000\032\000\ - \000\000\000\000\000\000\032\000\000\000\032\000\000\000\000\000\ - \000\000\154\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\160\000\000\000\160\000\000\000\ - \000\000\000\000\000\000\000\000\162\000\000\000\000\000\162\000\ - \162\000\162\000\000\000\000\000\000\000\162\000\162\000\000\000\ - \162\000\162\000\162\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\160\000\162\000\160\000\162\000\ - \162\000\162\000\162\000\162\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\000\000\162\000\ - \000\000\162\000\163\000\000\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\000\000\162\000\ - \000\000\162\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\000\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\000\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\151\000\000\000\ + \151\000\000\000\000\000\171\000\000\000\151\000\170\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\150\000\150\000\ + \150\000\150\000\150\000\150\000\150\000\150\000\150\000\150\000\ + \000\000\169\000\000\000\169\000\000\000\000\000\000\000\000\000\ + \169\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ + \168\000\168\000\168\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\151\000\000\000\000\000\000\000\000\000\000\000\ + \151\000\176\000\000\000\000\000\176\000\176\000\176\000\000\000\ + \000\000\000\000\176\000\176\000\151\000\176\000\176\000\176\000\ + \151\000\000\000\151\000\000\000\000\000\169\000\149\000\000\000\ + \000\000\000\000\176\000\169\000\176\000\176\000\176\000\176\000\ + \176\000\000\000\000\000\000\000\000\000\000\000\000\000\169\000\ + \000\000\000\000\000\000\169\000\000\000\169\000\000\000\000\000\ + \000\000\167\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\176\000\000\000\176\000\000\000\ + \000\000\000\000\000\000\000\000\178\000\000\000\000\000\178\000\ + \178\000\178\000\000\000\000\000\000\000\178\000\178\000\000\000\ + \178\000\178\000\178\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\176\000\178\000\176\000\178\000\ + \178\000\178\000\178\000\178\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\000\000\178\000\ + \000\000\178\000\179\000\000\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\000\000\178\000\ + \000\000\178\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\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\ @@ -4404,30 +4433,30 @@ module Struct = \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\000\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\000\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\162\000\000\000\000\000\162\000\162\000\ - \162\000\000\000\000\000\000\000\162\000\162\000\000\000\162\000\ - \162\000\162\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\162\000\000\000\162\000\162\000\ - \162\000\162\000\162\000\000\000\000\000\000\000\000\000\163\000\ + \000\000\000\000\000\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\000\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\000\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\178\000\000\000\000\000\178\000\178\000\ + \178\000\000\000\000\000\000\000\178\000\178\000\000\000\178\000\ + \178\000\178\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\178\000\000\000\178\000\178\000\ + \178\000\178\000\178\000\000\000\000\000\000\000\000\000\179\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\000\000\000\000\030\000\000\000\162\000\000\000\ - \162\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\000\000\000\000\000\000\162\000\163\000\ - \162\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\000\000\000\000\000\000\000\000\000\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\000\000\000\000\180\000\000\000\178\000\000\000\ + \178\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\000\000\000\000\000\000\178\000\179\000\ + \178\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ @@ -4436,26 +4465,26 @@ module Struct = \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\000\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\000\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \165\000\000\000\000\000\165\000\165\000\165\000\000\000\000\000\ - \000\000\165\000\165\000\000\000\165\000\165\000\165\000\000\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\000\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\000\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \182\000\000\000\000\000\182\000\182\000\182\000\000\000\000\000\ + \000\000\182\000\182\000\000\000\182\000\182\000\182\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\165\000\000\000\165\000\165\000\165\000\165\000\165\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\000\000\165\000\000\000\165\000\166\000\000\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\000\000\165\000\000\000\165\000\000\000\000\000\ + \000\000\182\000\000\000\182\000\182\000\182\000\182\000\182\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\000\000\182\000\000\000\182\000\183\000\000\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\000\000\182\000\000\000\182\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ @@ -4463,97 +4492,97 @@ module Struct = \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\000\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\000\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\165\000\ - \000\000\000\000\165\000\165\000\165\000\000\000\000\000\000\000\ - \165\000\165\000\000\000\165\000\165\000\165\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\000\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\000\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\182\000\ + \000\000\000\000\182\000\182\000\182\000\000\000\000\000\000\000\ + \182\000\182\000\000\000\182\000\182\000\182\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \165\000\000\000\165\000\165\000\165\000\165\000\165\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\166\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\000\000\165\000\030\000\165\000\000\000\000\000\167\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\165\000\000\000\165\000\000\000\166\000\000\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\000\000\000\000\000\000\000\000\168\000\000\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\000\000\000\000\000\000\000\000\000\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\000\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\000\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\000\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\000\000\000\000\169\000\000\000\000\000\000\000\000\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\000\000\000\000\000\000\000\000\168\000\000\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\000\000\000\000\000\000\000\000\177\000\000\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\000\000\000\000\000\000\000\000\000\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\000\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\000\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\000\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\000\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\000\000\000\000\000\000\000\000\176\000\000\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \182\000\000\000\182\000\182\000\182\000\182\000\182\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\183\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\000\000\182\000\185\000\182\000\000\000\000\000\184\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\182\000\000\000\182\000\000\000\183\000\000\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\000\000\000\000\000\000\000\000\186\000\000\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\000\000\000\000\000\000\000\000\000\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\000\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\000\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\000\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\000\000\000\000\187\000\000\000\000\000\000\000\000\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\000\000\000\000\000\000\000\000\186\000\000\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\000\000\000\000\000\000\000\000\199\000\000\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\000\000\000\000\000\000\000\000\000\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\000\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\000\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\000\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\000\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\000\000\000\000\000\000\000\000\198\000\000\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ @@ -4561,25 +4590,25 @@ module Struct = \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\000\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \000\000\000\000\030\000\000\000\000\000\000\000\174\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\000\000\000\000\000\000\000\000\176\000\000\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\000\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \000\000\000\000\195\000\000\000\000\000\000\000\196\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\000\000\000\000\000\000\000\000\198\000\000\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ @@ -4587,25 +4616,25 @@ module Struct = \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\000\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\177\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \000\000\000\000\030\000\000\000\000\000\000\000\000\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\000\000\000\000\000\000\000\000\177\000\000\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\000\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\199\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \000\000\000\000\195\000\000\000\000\000\000\000\000\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\000\000\000\000\000\000\000\000\199\000\000\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ @@ -4613,26 +4642,26 @@ module Struct = \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\000\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\000\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\030\000\000\000\ - \000\000\180\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \179\000\000\000\180\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\131\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\180\000\000\000\000\000\000\000\ - \000\000\180\000\181\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\180\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\000\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\000\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\207\000\000\000\ + \000\000\205\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \204\000\000\000\205\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\203\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\205\000\000\000\000\000\000\000\ + \000\000\205\000\206\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\205\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ @@ -4641,25 +4670,25 @@ module Struct = \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\180\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\000\000\180\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\000\000\180\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\180\000\255\255\183\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\131\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\000\000\ - \000\000\000\000\000\000\183\000\000\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\000\000\ + \000\000\000\000\205\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\000\000\205\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\000\000\205\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\205\000\255\255\209\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\203\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\000\000\ + \000\000\000\000\000\000\209\000\000\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ @@ -4668,25 +4697,25 @@ module Struct = \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\000\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\000\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\182\000\000\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\131\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \000\000\000\000\000\000\000\000\183\000\000\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \000\000\000\000\000\000\000\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\000\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\000\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\208\000\000\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\203\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \000\000\000\000\000\000\000\000\209\000\000\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ @@ -4695,56 +4724,56 @@ module Struct = \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\000\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\131\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \000\000\000\000\000\000\000\000\183\000\000\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \000\000\000\000\000\000\000\000\190\000\000\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \000\000\000\000\000\000\000\000\000\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\000\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\000\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\000\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\000\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\000\000\ - \000\000\000\000\000\000\189\000\000\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\000\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\203\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \000\000\000\000\000\000\000\000\209\000\000\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \000\000\000\000\000\000\000\000\221\000\000\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \000\000\000\000\000\000\000\000\000\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\000\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\000\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\000\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\000\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\000\000\ + \000\000\000\000\000\000\220\000\000\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ @@ -4753,24 +4782,24 @@ module Struct = \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\000\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\000\000\000\000\ - \034\000\000\000\000\000\000\000\187\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\000\000\ - \000\000\000\000\000\000\189\000\000\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\000\000\ + \000\000\000\000\000\000\000\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\000\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\000\000\000\000\ + \217\000\000\000\000\000\000\000\218\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\000\000\ + \000\000\000\000\000\000\220\000\000\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ @@ -4779,24 +4808,24 @@ module Struct = \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\000\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\190\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\000\000\000\000\ - \034\000\000\000\000\000\000\000\000\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\000\000\ - \000\000\000\000\000\000\190\000\000\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\000\000\ + \000\000\000\000\000\000\000\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\000\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\221\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\000\000\000\000\ + \217\000\000\000\000\000\000\000\000\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\000\000\ + \000\000\000\000\000\000\221\000\000\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ @@ -4805,19 +4834,19 @@ module Struct = \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\000\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\000\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\000\000"; + \000\000\000\000\000\000\000\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\000\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\000\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\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\029\000\000\000\000\000\101\000\107\000\ - \124\000\151\000\103\000\106\000\171\000\103\000\106\000\186\000\ + \125\000\162\000\103\000\106\000\190\000\103\000\106\000\213\000\ \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\ @@ -4833,54 +4862,54 @@ module Struct = \000\000\000\000\000\000\000\000\000\000\000\000\000\000\012\000\ \010\000\010\000\049\000\016\000\051\000\028\000\040\000\040\000\ \028\000\010\000\010\000\041\000\041\000\041\000\041\000\041\000\ - \041\000\041\000\041\000\057\000\065\000\010\000\129\000\010\000\ + \041\000\041\000\041\000\057\000\065\000\010\000\132\000\010\000\ \010\000\010\000\016\000\010\000\028\000\047\000\047\000\047\000\ - \047\000\047\000\047\000\047\000\047\000\047\000\047\000\130\000\ - \137\000\139\000\016\000\016\000\016\000\016\000\016\000\016\000\ - \016\000\016\000\016\000\016\000\140\000\128\000\145\000\128\000\ - \147\000\010\000\020\000\128\000\149\000\020\000\172\000\255\255\ + \047\000\047\000\047\000\047\000\047\000\047\000\047\000\133\000\ + \142\000\144\000\016\000\016\000\016\000\016\000\016\000\016\000\ + \016\000\016\000\016\000\016\000\145\000\131\000\151\000\131\000\ + \154\000\010\000\020\000\131\000\157\000\020\000\193\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\ \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\179\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\204\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\003\000\255\255\179\000\003\000\003\000\003\000\050\000\ + \000\000\003\000\255\255\204\000\003\000\003\000\003\000\050\000\ \103\000\106\000\003\000\003\000\020\000\003\000\003\000\003\000\ \039\000\039\000\039\000\039\000\039\000\039\000\039\000\039\000\ - \039\000\039\000\003\000\138\000\003\000\003\000\003\000\003\000\ + \039\000\039\000\003\000\143\000\003\000\003\000\003\000\003\000\ \003\000\255\255\005\000\005\000\050\000\039\000\005\000\255\255\ \038\000\255\255\038\000\005\000\005\000\038\000\038\000\038\000\ \038\000\038\000\038\000\038\000\038\000\038\000\038\000\005\000\ - \138\000\005\000\005\000\005\000\003\000\005\000\003\000\039\000\ - \104\000\255\255\157\000\104\000\006\000\039\000\255\255\006\000\ - \006\000\006\000\182\000\255\255\006\000\006\000\006\000\255\255\ - \006\000\006\000\006\000\255\255\068\000\255\255\182\000\068\000\ - \104\000\157\000\005\000\005\000\003\000\006\000\003\000\006\000\ - \006\000\006\000\006\000\006\000\156\000\156\000\255\255\255\255\ + \143\000\005\000\005\000\005\000\003\000\005\000\003\000\039\000\ + \104\000\255\255\171\000\104\000\006\000\039\000\255\255\006\000\ + \006\000\006\000\208\000\255\255\006\000\006\000\006\000\255\255\ + \006\000\006\000\006\000\255\255\068\000\255\255\208\000\068\000\ + \104\000\171\000\005\000\005\000\003\000\006\000\003\000\006\000\ + \006\000\006\000\006\000\006\000\170\000\170\000\255\255\255\255\ \255\255\007\000\255\255\068\000\007\000\007\000\007\000\255\255\ \255\255\007\000\007\000\007\000\068\000\007\000\007\000\007\000\ - \255\255\005\000\005\000\156\000\255\255\255\255\255\255\006\000\ + \255\255\005\000\005\000\170\000\255\255\255\255\255\255\006\000\ \006\000\006\000\007\000\255\255\007\000\007\000\007\000\007\000\ - \007\000\173\000\185\000\173\000\185\000\255\255\008\000\173\000\ - \185\000\008\000\008\000\008\000\255\255\255\255\008\000\008\000\ + \007\000\194\000\212\000\194\000\212\000\255\255\008\000\194\000\ + \212\000\008\000\008\000\008\000\255\255\255\255\008\000\008\000\ \008\000\255\255\008\000\008\000\008\000\255\255\255\255\006\000\ \006\000\006\000\255\255\255\255\007\000\007\000\007\000\008\000\ - \255\255\008\000\008\000\008\000\008\000\008\000\170\000\255\255\ - \020\000\170\000\255\255\009\000\255\255\255\255\009\000\009\000\ + \255\255\008\000\008\000\008\000\008\000\008\000\188\000\255\255\ + \020\000\188\000\255\255\009\000\255\255\255\255\009\000\009\000\ \009\000\255\255\255\255\009\000\009\000\009\000\255\255\009\000\ \009\000\009\000\255\255\255\255\007\000\007\000\007\000\255\255\ \255\255\008\000\008\000\008\000\009\000\255\255\009\000\009\000\ \009\000\009\000\009\000\255\255\255\255\255\255\255\255\255\255\ - \184\000\255\255\255\255\184\000\011\000\011\000\255\255\255\255\ - \170\000\255\255\170\000\013\000\013\000\011\000\011\000\013\000\ + \210\000\255\255\255\255\210\000\011\000\011\000\255\255\255\255\ + \188\000\255\255\188\000\013\000\013\000\011\000\011\000\013\000\ \255\255\008\000\008\000\008\000\013\000\013\000\009\000\009\000\ - \009\000\011\000\184\000\011\000\011\000\011\000\255\255\011\000\ + \009\000\011\000\210\000\011\000\011\000\011\000\255\255\011\000\ \013\000\255\255\013\000\013\000\013\000\255\255\013\000\014\000\ \014\000\255\255\080\000\014\000\255\255\080\000\255\255\255\255\ - \014\000\014\000\184\000\255\255\255\255\255\255\009\000\009\000\ + \014\000\014\000\210\000\255\255\255\255\255\255\009\000\009\000\ \009\000\255\255\255\255\255\255\014\000\011\000\014\000\014\000\ \014\000\080\000\014\000\013\000\013\000\045\000\045\000\255\255\ \255\255\255\255\080\000\017\000\255\255\255\255\017\000\017\000\ @@ -4898,18 +4927,18 @@ module Struct = \017\000\018\000\255\255\018\000\018\000\018\000\018\000\018\000\ \255\255\044\000\255\255\044\000\255\255\255\255\019\000\019\000\ \255\255\255\255\019\000\019\000\019\000\255\255\255\255\255\255\ - \019\000\019\000\255\255\019\000\019\000\019\000\125\000\255\255\ - \255\255\125\000\255\255\018\000\170\000\018\000\255\255\255\255\ + \019\000\019\000\255\255\019\000\019\000\019\000\128\000\255\255\ + \255\255\128\000\255\255\018\000\188\000\018\000\255\255\255\255\ \019\000\255\255\019\000\019\000\019\000\019\000\019\000\022\000\ \255\255\022\000\022\000\022\000\022\000\022\000\022\000\022\000\ - \022\000\022\000\022\000\125\000\255\255\255\255\255\255\255\255\ + \022\000\022\000\022\000\128\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\018\000\255\255\018\000\022\000\255\255\ - \255\255\255\255\019\000\255\255\019\000\022\000\184\000\255\255\ + \255\255\255\255\019\000\255\255\019\000\022\000\210\000\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\255\255\255\255\255\255\255\255\ \022\000\255\255\255\255\255\255\023\000\255\255\022\000\023\000\ \255\255\255\255\019\000\255\255\019\000\022\000\023\000\022\000\ - \125\000\023\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \128\000\023\000\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\023\000\255\255\255\255\255\255\105\000\105\000\ \255\255\023\000\105\000\255\255\023\000\255\255\255\255\023\000\ \255\255\255\255\255\255\255\255\255\255\255\255\023\000\255\255\ @@ -4929,9 +4958,9 @@ module Struct = \042\000\042\000\042\000\042\000\042\000\056\000\056\000\056\000\ \056\000\056\000\056\000\056\000\056\000\056\000\056\000\058\000\ \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ - \058\000\255\255\255\255\255\255\125\000\255\255\255\255\042\000\ - \042\000\042\000\042\000\042\000\042\000\144\000\144\000\144\000\ - \144\000\144\000\144\000\144\000\144\000\144\000\144\000\255\255\ + \058\000\255\255\255\255\255\255\128\000\255\255\255\255\042\000\ + \042\000\042\000\042\000\042\000\042\000\150\000\150\000\150\000\ + \150\000\150\000\150\000\150\000\150\000\150\000\150\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\ @@ -4953,25 +4982,25 @@ module Struct = \043\000\043\000\043\000\043\000\043\000\043\000\043\000\043\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\043\000\ \043\000\043\000\043\000\043\000\043\000\255\255\255\255\255\255\ - \255\255\255\255\043\000\146\000\146\000\146\000\146\000\146\000\ - \146\000\146\000\146\000\146\000\146\000\255\255\255\255\255\255\ - \150\000\255\255\255\255\150\000\255\255\043\000\255\255\043\000\ + \255\255\255\255\043\000\153\000\153\000\153\000\153\000\153\000\ + \153\000\153\000\153\000\153\000\153\000\255\255\255\255\255\255\ + \159\000\255\255\255\255\159\000\255\255\043\000\255\255\043\000\ \043\000\043\000\043\000\043\000\043\000\255\255\255\255\255\255\ \255\255\255\255\043\000\255\255\043\000\255\255\255\255\255\255\ - \150\000\255\255\255\255\025\000\025\000\025\000\025\000\025\000\ + \159\000\255\255\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\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\025\000\025\000\025\000\025\000\025\000\ - \025\000\025\000\150\000\025\000\025\000\025\000\025\000\025\000\ + \025\000\025\000\159\000\025\000\025\000\025\000\025\000\025\000\ \025\000\025\000\025\000\026\000\255\255\255\255\026\000\026\000\ \026\000\255\255\255\255\255\255\026\000\026\000\255\255\026\000\ - \026\000\026\000\155\000\155\000\155\000\155\000\155\000\155\000\ - \155\000\155\000\155\000\155\000\026\000\255\255\026\000\026\000\ - \026\000\026\000\026\000\158\000\158\000\158\000\158\000\158\000\ - \158\000\158\000\158\000\158\000\158\000\255\255\046\000\046\000\ + \026\000\026\000\168\000\168\000\168\000\168\000\168\000\168\000\ + \168\000\168\000\168\000\168\000\026\000\255\255\026\000\026\000\ + \026\000\026\000\026\000\172\000\172\000\172\000\172\000\172\000\ + \172\000\172\000\172\000\172\000\172\000\255\255\046\000\046\000\ \046\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ \255\255\255\255\255\255\255\255\255\255\255\255\026\000\255\255\ \026\000\026\000\255\255\026\000\026\000\026\000\026\000\026\000\ @@ -4985,7 +5014,7 @@ module Struct = \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\027\000\255\255\027\000\027\000\150\000\027\000\ + \255\255\255\255\027\000\255\255\027\000\027\000\159\000\027\000\ \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ \027\000\027\000\027\000\027\000\027\000\027\000\027\000\027\000\ @@ -5042,14 +5071,14 @@ module Struct = \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\255\255\255\255\255\255\099\000\099\000\255\255\255\255\ - \099\000\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\255\255\ - \255\255\255\255\255\255\099\000\255\255\099\000\143\000\143\000\ - \143\000\143\000\143\000\143\000\255\255\255\255\255\255\255\255\ + \099\000\255\255\255\255\255\255\255\255\149\000\149\000\149\000\ + \149\000\149\000\149\000\149\000\149\000\149\000\149\000\255\255\ + \255\255\255\255\255\255\099\000\255\255\099\000\149\000\149\000\ + \149\000\149\000\149\000\149\000\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\099\000\099\000\099\000\099\000\099\000\ \099\000\099\000\099\000\099\000\099\000\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\255\255\255\255\033\000\033\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\149\000\149\000\ + \149\000\149\000\149\000\149\000\255\255\255\255\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\033\000\033\000\033\000\ \033\000\033\000\033\000\033\000\033\000\255\255\033\000\033\000\ @@ -5289,13 +5318,13 @@ module Struct = \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ - \148\000\148\000\148\000\148\000\148\000\148\000\148\000\148\000\ - \148\000\148\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\148\000\148\000\148\000\148\000\148\000\148\000\255\255\ + \156\000\156\000\156\000\156\000\156\000\156\000\156\000\156\000\ + \156\000\156\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\156\000\156\000\156\000\156\000\156\000\156\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\148\000\148\000\148\000\148\000\148\000\148\000\255\255\ + \255\255\156\000\156\000\156\000\156\000\156\000\156\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\123\000\123\000\123\000\ \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ @@ -5305,102 +5334,102 @@ module Struct = \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ \123\000\123\000\123\000\123\000\123\000\123\000\123\000\123\000\ \123\000\123\000\123\000\123\000\255\255\123\000\123\000\123\000\ - \123\000\123\000\123\000\123\000\123\000\123\000\127\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\255\255\255\255\255\255\255\255\127\000\255\255\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\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\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\255\255\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\255\255\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\000\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\255\255\127\000\ - \127\000\127\000\127\000\127\000\127\000\127\000\127\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\ - \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\133\000\ - \133\000\133\000\133\000\133\000\133\000\133\000\133\000\133\000\ - \133\000\133\000\133\000\133\000\133\000\133\000\133\000\133\000\ - \133\000\133\000\133\000\133\000\133\000\133\000\133\000\133\000\ - \133\000\255\255\255\255\255\255\255\255\133\000\255\255\133\000\ - \133\000\133\000\133\000\133\000\133\000\133\000\133\000\133\000\ - \133\000\133\000\133\000\133\000\133\000\133\000\133\000\133\000\ - \133\000\133\000\133\000\133\000\133\000\133\000\133\000\133\000\ - \133\000\154\000\154\000\154\000\154\000\154\000\154\000\154\000\ - \154\000\154\000\154\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\154\000\154\000\154\000\154\000\154\000\154\000\ + \123\000\123\000\123\000\123\000\123\000\123\000\130\000\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\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\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\ + \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\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\255\255\130\000\ + \130\000\130\000\130\000\130\000\130\000\130\000\130\000\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\138\000\ + \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ + \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ + \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ + \138\000\255\255\255\255\255\255\255\255\138\000\255\255\138\000\ + \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ + \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ + \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ + \138\000\167\000\167\000\167\000\167\000\167\000\167\000\167\000\ + \167\000\167\000\167\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\167\000\167\000\167\000\167\000\167\000\167\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\154\000\154\000\154\000\154\000\154\000\154\000\ + \255\255\255\255\167\000\167\000\167\000\167\000\167\000\167\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\133\000\133\000\ - \133\000\133\000\133\000\133\000\133\000\133\000\133\000\133\000\ - \133\000\133\000\133\000\133\000\133\000\133\000\133\000\133\000\ - \133\000\133\000\133\000\133\000\133\000\255\255\133\000\133\000\ - \133\000\133\000\133\000\133\000\133\000\133\000\133\000\133\000\ - \133\000\133\000\133\000\133\000\133\000\133\000\133\000\133\000\ - \133\000\133\000\133\000\133\000\133\000\133\000\133\000\133\000\ - \133\000\133\000\133\000\133\000\133\000\134\000\133\000\133\000\ - \133\000\133\000\133\000\133\000\133\000\133\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\134\000\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\ - \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\159\000\159\000\159\000\159\000\159\000\159\000\159\000\ - \159\000\159\000\159\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\159\000\159\000\159\000\159\000\159\000\159\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\138\000\138\000\ + \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ + \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ + \138\000\138\000\138\000\138\000\138\000\255\255\138\000\138\000\ + \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ + \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ + \138\000\138\000\138\000\138\000\138\000\138\000\138\000\138\000\ + \138\000\138\000\138\000\138\000\138\000\139\000\138\000\138\000\ + \138\000\138\000\138\000\138\000\138\000\138\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \255\255\255\255\139\000\255\255\255\255\255\255\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\255\255\255\255\255\255\255\255\139\000\255\255\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\174\000\174\000\174\000\174\000\174\000\174\000\174\000\ + \174\000\174\000\174\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\174\000\174\000\174\000\174\000\174\000\174\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\159\000\159\000\159\000\159\000\159\000\159\000\ + \255\255\255\255\174\000\174\000\174\000\174\000\174\000\174\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\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\135\000\134\000\134\000\ - \134\000\134\000\134\000\134\000\134\000\134\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\135\000\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\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\255\255\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\140\000\139\000\139\000\ + \139\000\139\000\139\000\139\000\139\000\139\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \255\255\255\255\140\000\255\255\255\255\255\255\255\255\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\255\255\255\255\255\255\255\255\140\000\255\255\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\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\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ @@ -5408,75 +5437,75 @@ module Struct = \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\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\255\255\135\000\135\000\ - \135\000\135\000\135\000\135\000\135\000\135\000\136\000\255\255\ - \136\000\255\255\255\255\152\000\255\255\136\000\152\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\136\000\136\000\ - \136\000\136\000\136\000\136\000\136\000\136\000\136\000\136\000\ - \255\255\152\000\255\255\152\000\255\255\255\255\255\255\255\255\ - \152\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\152\000\152\000\152\000\152\000\152\000\152\000\152\000\ - \152\000\152\000\152\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\136\000\255\255\255\255\255\255\255\255\255\255\ - \136\000\160\000\255\255\255\255\160\000\160\000\160\000\255\255\ - \255\255\255\255\160\000\160\000\136\000\160\000\160\000\160\000\ - \136\000\255\255\136\000\255\255\255\255\152\000\136\000\255\255\ - \255\255\255\255\160\000\152\000\160\000\160\000\160\000\160\000\ - \160\000\255\255\255\255\255\255\255\255\255\255\255\255\152\000\ - \255\255\255\255\255\255\152\000\255\255\152\000\255\255\255\255\ - \255\255\152\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\160\000\255\255\160\000\255\255\ - \255\255\255\255\255\255\255\255\161\000\255\255\255\255\161\000\ - \161\000\161\000\255\255\255\255\255\255\161\000\161\000\255\255\ - \161\000\161\000\161\000\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\160\000\161\000\160\000\161\000\ - \161\000\161\000\161\000\161\000\161\000\161\000\161\000\161\000\ - \161\000\161\000\161\000\161\000\161\000\161\000\161\000\161\000\ - \161\000\161\000\161\000\161\000\161\000\161\000\161\000\161\000\ - \161\000\161\000\161\000\161\000\161\000\161\000\255\255\161\000\ - \255\255\161\000\161\000\255\255\161\000\161\000\161\000\161\000\ - \161\000\161\000\161\000\161\000\161\000\161\000\161\000\161\000\ - \161\000\161\000\161\000\161\000\161\000\161\000\161\000\161\000\ - \161\000\161\000\161\000\161\000\161\000\161\000\255\255\161\000\ - \255\255\161\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\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\255\255\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\255\255\140\000\140\000\ + \140\000\140\000\140\000\140\000\140\000\140\000\141\000\255\255\ + \141\000\255\255\255\255\164\000\255\255\141\000\164\000\255\255\ + \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\ + \255\255\164\000\255\255\164\000\255\255\255\255\255\255\255\255\ + \164\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ + \164\000\164\000\164\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\141\000\255\255\255\255\255\255\255\255\255\255\ + \141\000\176\000\255\255\255\255\176\000\176\000\176\000\255\255\ + \255\255\255\255\176\000\176\000\141\000\176\000\176\000\176\000\ + \141\000\255\255\141\000\255\255\255\255\164\000\141\000\255\255\ + \255\255\255\255\176\000\164\000\176\000\176\000\176\000\176\000\ + \176\000\255\255\255\255\255\255\255\255\255\255\255\255\164\000\ + \255\255\255\255\255\255\164\000\255\255\164\000\255\255\255\255\ + \255\255\164\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\176\000\255\255\176\000\255\255\ + \255\255\255\255\255\255\255\255\177\000\255\255\255\255\177\000\ + \177\000\177\000\255\255\255\255\255\255\177\000\177\000\255\255\ + \177\000\177\000\177\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\176\000\177\000\176\000\177\000\ + \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ + \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ + \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ + \177\000\177\000\177\000\177\000\177\000\177\000\255\255\177\000\ + \255\255\177\000\177\000\255\255\177\000\177\000\177\000\177\000\ + \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ + \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ + \177\000\177\000\177\000\177\000\177\000\177\000\255\255\177\000\ + \255\255\177\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\152\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\164\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\161\000\161\000\161\000\161\000\161\000\ - \161\000\161\000\161\000\161\000\161\000\161\000\161\000\161\000\ - \161\000\161\000\161\000\161\000\161\000\161\000\161\000\161\000\ - \161\000\161\000\255\255\161\000\161\000\161\000\161\000\161\000\ - \161\000\161\000\161\000\161\000\161\000\161\000\161\000\161\000\ - \161\000\161\000\161\000\161\000\161\000\161\000\161\000\161\000\ - \161\000\161\000\161\000\161\000\161\000\161\000\161\000\161\000\ - \161\000\161\000\255\255\161\000\161\000\161\000\161\000\161\000\ - \161\000\161\000\161\000\162\000\255\255\255\255\162\000\162\000\ - \162\000\255\255\255\255\255\255\162\000\162\000\255\255\162\000\ - \162\000\162\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\162\000\255\255\162\000\162\000\ - \162\000\162\000\162\000\255\255\255\255\255\255\255\255\163\000\ + \255\255\255\255\255\255\177\000\177\000\177\000\177\000\177\000\ + \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ + \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ + \177\000\177\000\255\255\177\000\177\000\177\000\177\000\177\000\ + \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ + \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ + \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ + \177\000\177\000\255\255\177\000\177\000\177\000\177\000\177\000\ + \177\000\177\000\177\000\178\000\255\255\255\255\178\000\178\000\ + \178\000\255\255\255\255\255\255\178\000\178\000\255\255\178\000\ + \178\000\178\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\178\000\255\255\178\000\178\000\ + \178\000\178\000\178\000\255\255\255\255\255\255\255\255\179\000\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\255\255\255\255\163\000\255\255\162\000\255\255\ - \162\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\255\255\255\255\255\255\162\000\163\000\ - \162\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\255\255\255\255\255\255\255\255\255\255\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\255\255\255\255\179\000\255\255\178\000\255\255\ + \178\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\255\255\255\255\255\255\178\000\179\000\ + \178\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\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\ @@ -5485,26 +5514,26 @@ module Struct = \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\255\255\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\255\255\ - \163\000\163\000\163\000\163\000\163\000\163\000\163\000\163\000\ - \164\000\255\255\255\255\164\000\164\000\164\000\255\255\255\255\ - \255\255\164\000\164\000\255\255\164\000\164\000\164\000\255\255\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\255\255\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\255\255\ + \179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ + \181\000\255\255\255\255\181\000\181\000\181\000\255\255\255\255\ + \255\255\181\000\181\000\255\255\181\000\181\000\181\000\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\164\000\255\255\164\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\255\255\164\000\255\255\164\000\164\000\255\255\ - \164\000\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\255\255\164\000\255\255\164\000\255\255\255\255\ + \255\255\181\000\255\255\181\000\181\000\181\000\181\000\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ + \181\000\181\000\255\255\181\000\255\255\181\000\181\000\255\255\ + \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ + \181\000\181\000\255\255\181\000\255\255\181\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\ @@ -5512,97 +5541,97 @@ module Struct = \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\255\255\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\255\255\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\164\000\165\000\ - \255\255\255\255\165\000\165\000\165\000\255\255\255\255\255\255\ - \165\000\165\000\255\255\165\000\165\000\165\000\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\255\255\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\255\255\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\181\000\182\000\ + \255\255\255\255\182\000\182\000\182\000\255\255\255\255\255\255\ + \182\000\182\000\255\255\182\000\182\000\182\000\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \165\000\255\255\165\000\165\000\165\000\165\000\165\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\166\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\255\255\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\255\255\165\000\166\000\165\000\255\255\255\255\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\165\000\255\255\165\000\255\255\166\000\255\255\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \167\000\167\000\167\000\167\000\167\000\167\000\167\000\167\000\ - \167\000\167\000\167\000\167\000\167\000\167\000\167\000\167\000\ - \167\000\167\000\167\000\167\000\167\000\167\000\167\000\167\000\ - \167\000\167\000\255\255\255\255\255\255\255\255\167\000\255\255\ - \167\000\167\000\167\000\167\000\167\000\167\000\167\000\167\000\ - \167\000\167\000\167\000\167\000\167\000\167\000\167\000\167\000\ - \167\000\167\000\167\000\167\000\167\000\167\000\167\000\167\000\ - \167\000\167\000\255\255\255\255\255\255\255\255\255\255\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\255\255\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\255\255\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\167\000\ - \167\000\167\000\167\000\167\000\167\000\167\000\167\000\167\000\ - \167\000\167\000\167\000\167\000\167\000\167\000\167\000\167\000\ - \167\000\167\000\167\000\167\000\167\000\167\000\255\255\167\000\ - \167\000\167\000\167\000\167\000\167\000\167\000\167\000\167\000\ - \167\000\167\000\167\000\167\000\167\000\167\000\167\000\167\000\ - \167\000\167\000\167\000\167\000\167\000\167\000\167\000\167\000\ - \167\000\167\000\167\000\167\000\167\000\167\000\168\000\167\000\ - \167\000\167\000\167\000\167\000\167\000\167\000\167\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\255\255\255\255\168\000\255\255\255\255\255\255\255\255\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\255\255\255\255\255\255\255\255\168\000\255\255\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \174\000\174\000\174\000\174\000\174\000\174\000\174\000\174\000\ - \174\000\174\000\174\000\174\000\174\000\174\000\174\000\174\000\ - \174\000\174\000\174\000\174\000\174\000\174\000\174\000\174\000\ - \174\000\174\000\255\255\255\255\255\255\255\255\174\000\255\255\ - \174\000\174\000\174\000\174\000\174\000\174\000\174\000\174\000\ - \174\000\174\000\174\000\174\000\174\000\174\000\174\000\174\000\ - \174\000\174\000\174\000\174\000\174\000\174\000\174\000\174\000\ - \174\000\174\000\255\255\255\255\255\255\255\255\255\255\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\255\255\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\255\255\168\000\ - \168\000\168\000\168\000\168\000\168\000\168\000\168\000\174\000\ - \174\000\174\000\174\000\174\000\174\000\174\000\174\000\174\000\ - \174\000\174\000\174\000\174\000\174\000\174\000\174\000\174\000\ - \174\000\174\000\174\000\174\000\174\000\174\000\255\255\174\000\ - \174\000\174\000\174\000\174\000\174\000\174\000\174\000\174\000\ - \174\000\174\000\174\000\174\000\174\000\174\000\174\000\174\000\ - \174\000\174\000\174\000\174\000\174\000\174\000\174\000\174\000\ - \174\000\174\000\174\000\174\000\174\000\174\000\255\255\174\000\ - \174\000\174\000\174\000\174\000\174\000\174\000\174\000\175\000\ - \175\000\175\000\175\000\175\000\175\000\175\000\175\000\175\000\ - \175\000\175\000\175\000\175\000\175\000\175\000\175\000\175\000\ - \175\000\175\000\175\000\175\000\175\000\175\000\175\000\175\000\ - \175\000\255\255\255\255\255\255\255\255\175\000\255\255\175\000\ - \175\000\175\000\175\000\175\000\175\000\175\000\175\000\175\000\ - \175\000\175\000\175\000\175\000\175\000\175\000\175\000\175\000\ - \175\000\175\000\175\000\175\000\175\000\175\000\175\000\175\000\ - \175\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \182\000\255\255\182\000\182\000\182\000\182\000\182\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\183\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\255\255\182\000\183\000\182\000\255\255\255\255\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\182\000\255\255\182\000\255\255\183\000\255\255\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ + \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ + \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ + \184\000\184\000\255\255\255\255\255\255\255\255\184\000\255\255\ + \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ + \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ + \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ + \184\000\184\000\255\255\255\255\255\255\255\255\255\255\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\255\255\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\255\255\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\184\000\ + \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ + \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ + \184\000\184\000\184\000\184\000\184\000\184\000\255\255\184\000\ + \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ + \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ + \184\000\184\000\184\000\184\000\184\000\184\000\184\000\184\000\ + \184\000\184\000\184\000\184\000\184\000\184\000\186\000\184\000\ + \184\000\184\000\184\000\184\000\184\000\184\000\184\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\255\255\255\255\186\000\255\255\255\255\255\255\255\255\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\255\255\255\255\255\255\255\255\186\000\255\255\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ + \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ + \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ + \196\000\196\000\255\255\255\255\255\255\255\255\196\000\255\255\ + \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ + \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ + \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ + \196\000\196\000\255\255\255\255\255\255\255\255\255\255\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\255\255\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\255\255\186\000\ + \186\000\186\000\186\000\186\000\186\000\186\000\186\000\196\000\ + \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ + \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ + \196\000\196\000\196\000\196\000\196\000\196\000\255\255\196\000\ + \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ + \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ + \196\000\196\000\196\000\196\000\196\000\196\000\196\000\196\000\ + \196\000\196\000\196\000\196\000\196\000\196\000\255\255\196\000\ + \196\000\196\000\196\000\196\000\196\000\196\000\196\000\197\000\ + \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ + \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ + \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ + \197\000\255\255\255\255\255\255\255\255\197\000\255\255\197\000\ + \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ + \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ + \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ + \197\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\ @@ -5610,25 +5639,25 @@ module Struct = \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\175\000\175\000\ - \175\000\175\000\175\000\175\000\175\000\175\000\175\000\175\000\ - \175\000\175\000\175\000\175\000\175\000\175\000\175\000\175\000\ - \175\000\175\000\175\000\175\000\175\000\255\255\175\000\175\000\ - \175\000\175\000\175\000\175\000\175\000\175\000\175\000\175\000\ - \175\000\175\000\175\000\175\000\175\000\175\000\175\000\175\000\ - \175\000\175\000\175\000\175\000\175\000\175\000\175\000\175\000\ - \175\000\175\000\175\000\175\000\175\000\176\000\175\000\175\000\ - \175\000\175\000\175\000\175\000\175\000\175\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \255\255\255\255\176\000\255\255\255\255\255\255\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\255\255\255\255\255\255\255\255\176\000\255\255\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\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\197\000\197\000\ + \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ + \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ + \197\000\197\000\197\000\197\000\197\000\255\255\197\000\197\000\ + \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ + \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ + \197\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ + \197\000\197\000\197\000\197\000\197\000\198\000\197\000\197\000\ + \197\000\197\000\197\000\197\000\197\000\197\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \255\255\255\255\198\000\255\255\255\255\255\255\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\255\255\255\255\255\255\255\255\198\000\255\255\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\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\ @@ -5636,25 +5665,25 @@ module Struct = \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\255\255\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\177\000\176\000\176\000\ - \176\000\176\000\176\000\176\000\176\000\176\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \255\255\255\255\177\000\255\255\255\255\255\255\255\255\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\255\255\255\255\255\255\255\255\177\000\255\255\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\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\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\255\255\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\199\000\198\000\198\000\ + \198\000\198\000\198\000\198\000\198\000\198\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \255\255\255\255\199\000\255\255\255\255\255\255\255\255\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\255\255\255\255\255\255\255\255\199\000\255\255\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\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\ @@ -5662,26 +5691,26 @@ module Struct = \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\255\255\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\255\255\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\255\255\177\000\177\000\ - \177\000\177\000\177\000\177\000\177\000\177\000\178\000\255\255\ - \255\255\178\000\255\255\255\255\255\255\255\255\255\255\255\255\ - \178\000\255\255\178\000\178\000\178\000\178\000\178\000\178\000\ - \178\000\178\000\178\000\178\000\178\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\178\000\178\000\178\000\178\000\178\000\ - \178\000\178\000\178\000\178\000\178\000\178\000\178\000\178\000\ - \178\000\178\000\178\000\178\000\178\000\178\000\178\000\178\000\ - \178\000\178\000\178\000\178\000\178\000\255\255\255\255\255\255\ - \255\255\178\000\178\000\178\000\178\000\178\000\178\000\178\000\ - \178\000\178\000\178\000\178\000\178\000\178\000\178\000\178\000\ - \178\000\178\000\178\000\178\000\178\000\178\000\178\000\178\000\ - \178\000\178\000\178\000\178\000\178\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\255\255\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\255\255\199\000\199\000\ + \199\000\199\000\199\000\199\000\199\000\199\000\201\000\255\255\ + \255\255\201\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \201\000\255\255\201\000\201\000\201\000\201\000\201\000\201\000\ + \201\000\201\000\201\000\201\000\201\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\201\000\201\000\201\000\201\000\201\000\ + \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ + \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ + \201\000\201\000\201\000\201\000\201\000\255\255\255\255\255\255\ + \255\255\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ + \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ + \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ + \201\000\201\000\201\000\201\000\201\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\ @@ -5690,25 +5719,25 @@ module Struct = \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\178\000\178\000\178\000\178\000\178\000\178\000\ - \178\000\178\000\178\000\178\000\178\000\178\000\178\000\178\000\ - \178\000\178\000\178\000\178\000\178\000\178\000\178\000\178\000\ - \178\000\255\255\178\000\178\000\178\000\178\000\178\000\178\000\ - \178\000\178\000\178\000\178\000\178\000\178\000\178\000\178\000\ - \178\000\178\000\178\000\178\000\178\000\178\000\178\000\178\000\ - \178\000\178\000\178\000\178\000\178\000\178\000\178\000\178\000\ - \178\000\255\255\178\000\178\000\178\000\178\000\178\000\178\000\ - \178\000\178\000\178\000\180\000\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\180\000\180\000\180\000\255\255\ - \255\255\255\255\255\255\255\255\255\255\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\180\000\180\000\180\000\255\255\ - \255\255\255\255\255\255\180\000\255\255\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\180\000\180\000\180\000\255\255\ + \255\255\255\255\201\000\201\000\201\000\201\000\201\000\201\000\ + \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ + \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ + \201\000\255\255\201\000\201\000\201\000\201\000\201\000\201\000\ + \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ + \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ + \201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ + \201\000\255\255\201\000\201\000\201\000\201\000\201\000\201\000\ + \201\000\201\000\201\000\205\000\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\205\000\205\000\205\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\205\000\205\000\205\000\255\255\ + \255\255\255\255\255\255\205\000\255\255\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\205\000\205\000\205\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\ @@ -5717,25 +5746,25 @@ module Struct = \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\255\255\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\255\255\180\000\180\000\180\000\180\000\ - \180\000\180\000\180\000\180\000\181\000\255\255\255\255\255\255\ - \255\255\255\255\255\255\181\000\255\255\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \255\255\255\255\255\255\255\255\181\000\255\255\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ + \255\255\255\255\255\255\255\255\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\255\255\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\255\255\205\000\205\000\205\000\205\000\ + \205\000\205\000\205\000\205\000\206\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\206\000\255\255\206\000\206\000\206\000\ + \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\206\000\206\000\ + \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ + \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ + \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ + \255\255\255\255\255\255\255\255\206\000\255\255\206\000\206\000\ + \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ + \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ + \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\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\ @@ -5744,56 +5773,56 @@ module Struct = \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\255\255\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\183\000\181\000\181\000\181\000\ - \181\000\181\000\181\000\181\000\181\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \255\255\255\255\255\255\255\255\183\000\255\255\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \255\255\255\255\255\255\255\255\255\255\255\255\187\000\187\000\ - \187\000\187\000\187\000\187\000\187\000\187\000\187\000\187\000\ - \187\000\187\000\187\000\187\000\187\000\187\000\187\000\187\000\ - \187\000\187\000\187\000\187\000\187\000\187\000\187\000\187\000\ - \255\255\255\255\255\255\255\255\187\000\255\255\187\000\187\000\ - \187\000\187\000\187\000\187\000\187\000\187\000\187\000\187\000\ - \187\000\187\000\187\000\187\000\187\000\187\000\187\000\187\000\ - \187\000\187\000\187\000\187\000\187\000\187\000\187\000\187\000\ - \255\255\255\255\255\255\255\255\255\255\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\255\255\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\255\255\183\000\183\000\183\000\ - \183\000\183\000\183\000\183\000\183\000\187\000\187\000\187\000\ - \187\000\187\000\187\000\187\000\187\000\187\000\187\000\187\000\ - \187\000\187\000\187\000\187\000\187\000\187\000\187\000\187\000\ - \187\000\187\000\187\000\187\000\255\255\187\000\187\000\187\000\ - \187\000\187\000\187\000\187\000\187\000\187\000\187\000\187\000\ - \187\000\187\000\187\000\187\000\187\000\187\000\187\000\187\000\ - \187\000\187\000\187\000\187\000\187\000\187\000\187\000\187\000\ - \187\000\187\000\187\000\187\000\255\255\187\000\187\000\187\000\ - \187\000\187\000\187\000\187\000\187\000\188\000\188\000\188\000\ - \188\000\188\000\188\000\188\000\188\000\188\000\188\000\188\000\ - \188\000\188\000\188\000\188\000\188\000\188\000\188\000\188\000\ - \188\000\188\000\188\000\188\000\188\000\188\000\188\000\255\255\ - \255\255\255\255\255\255\188\000\255\255\188\000\188\000\188\000\ - \188\000\188\000\188\000\188\000\188\000\188\000\188\000\188\000\ - \188\000\188\000\188\000\188\000\188\000\188\000\188\000\188\000\ - \188\000\188\000\188\000\188\000\188\000\188\000\188\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\206\000\206\000\206\000\ + \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ + \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ + \206\000\206\000\206\000\206\000\255\255\206\000\206\000\206\000\ + \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ + \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ + \206\000\206\000\206\000\206\000\206\000\206\000\206\000\206\000\ + \206\000\206\000\206\000\206\000\209\000\206\000\206\000\206\000\ + \206\000\206\000\206\000\206\000\206\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \255\255\255\255\255\255\255\255\209\000\255\255\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\218\000\218\000\ + \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ + \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ + \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ + \255\255\255\255\255\255\255\255\218\000\255\255\218\000\218\000\ + \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ + \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ + \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ + \255\255\255\255\255\255\255\255\255\255\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\255\255\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\255\255\209\000\209\000\209\000\ + \209\000\209\000\209\000\209\000\209\000\218\000\218\000\218\000\ + \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ + \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ + \218\000\218\000\218\000\218\000\255\255\218\000\218\000\218\000\ + \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ + \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ + \218\000\218\000\218\000\218\000\218\000\218\000\218\000\218\000\ + \218\000\218\000\218\000\218\000\255\255\218\000\218\000\218\000\ + \218\000\218\000\218\000\218\000\218\000\219\000\219\000\219\000\ + \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ + \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ + \219\000\219\000\219\000\219\000\219\000\219\000\219\000\255\255\ + \255\255\255\255\255\255\219\000\255\255\219\000\219\000\219\000\ + \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ + \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ + \219\000\219\000\219\000\219\000\219\000\219\000\219\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\ @@ -5802,24 +5831,24 @@ module Struct = \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\188\000\188\000\188\000\188\000\ - \188\000\188\000\188\000\188\000\188\000\188\000\188\000\188\000\ - \188\000\188\000\188\000\188\000\188\000\188\000\188\000\188\000\ - \188\000\188\000\188\000\255\255\188\000\188\000\188\000\188\000\ - \188\000\188\000\188\000\188\000\188\000\188\000\188\000\188\000\ - \188\000\188\000\188\000\188\000\188\000\188\000\188\000\188\000\ - \188\000\188\000\188\000\188\000\188\000\188\000\188\000\188\000\ - \188\000\188\000\188\000\189\000\188\000\188\000\188\000\188\000\ - \188\000\188\000\188\000\188\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\255\255\255\255\ - \189\000\255\255\255\255\255\255\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\255\255\ - \255\255\255\255\255\255\189\000\255\255\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\255\255\ + \255\255\255\255\255\255\255\255\219\000\219\000\219\000\219\000\ + \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ + \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ + \219\000\219\000\219\000\255\255\219\000\219\000\219\000\219\000\ + \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ + \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ + \219\000\219\000\219\000\219\000\219\000\219\000\219\000\219\000\ + \219\000\219\000\219\000\220\000\219\000\219\000\219\000\219\000\ + \219\000\219\000\219\000\219\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\255\255\255\255\ + \220\000\255\255\255\255\255\255\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\255\255\ + \255\255\255\255\255\255\220\000\255\255\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\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\ @@ -5828,24 +5857,24 @@ module Struct = \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\255\255\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\190\000\189\000\189\000\189\000\189\000\ - \189\000\189\000\189\000\189\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\255\255\255\255\ - \190\000\255\255\255\255\255\255\255\255\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\255\255\ - \255\255\255\255\255\255\190\000\255\255\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\255\255\ + \255\255\255\255\255\255\255\255\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\255\255\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\221\000\220\000\220\000\220\000\220\000\ + \220\000\220\000\220\000\220\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\255\255\255\255\ + \221\000\255\255\255\255\255\255\255\255\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\255\255\ + \255\255\255\255\255\255\221\000\255\255\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\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\ @@ -5854,15 +5883,15 @@ module Struct = \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\255\255\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\255\255\190\000\190\000\190\000\190\000\ - \190\000\190\000\190\000\190\000\255\255"; + \255\255\255\255\255\255\255\255\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\255\255\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\000\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\255\255\221\000\221\000\221\000\221\000\ + \221\000\221\000\221\000\221\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\ @@ -5883,11 +5912,15 @@ module Struct = \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\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\036\002\000\000\244\002\000\000\ - \000\000\061\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\ + \000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\036\002\000\000\244\002\ + \000\000\000\000\000\000\061\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\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\ @@ -5908,11 +5941,15 @@ module Struct = \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\061\000\061\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\061\000\061\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\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\ @@ -5937,7 +5974,11 @@ module Struct = \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ - \000\000\000\000\000\000\000\000\000\000\000\000\000\000"; + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\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\058\000\058\000\000\000\058\000\000\000\ @@ -6068,7 +6109,7 @@ module Struct = \058\000\058\000\058\000\058\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\016\000\104\000\152\000\156\000\104\000\152\000\255\255\ + \255\255\016\000\104\000\164\000\170\000\104\000\164\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\ \016\000\255\255\104\000\000\000\019\000\105\000\255\255\019\000\ @@ -6143,14 +6184,14 @@ module Struct = \100\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\ \100\000\100\000\100\000\100\000\100\000\100\000\100\000\100\000\ - \100\000\100\000\079\000\255\255\079\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\164\000\255\255\ - \255\255\255\255\255\255\164\000\255\255\164\000\164\000\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\164\000\255\255\ + \100\000\100\000\079\000\255\255\079\000\181\000\181\000\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\181\000\255\255\ + \255\255\255\255\255\255\181\000\255\255\181\000\181\000\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\181\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\ @@ -6159,24 +6200,24 @@ module Struct = \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\255\255\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\164\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\166\000\164\000\164\000\164\000\164\000\ - \164\000\164\000\164\000\164\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\255\255\255\255\ - \255\255\255\255\255\255\255\255\255\255\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\255\255\ - \255\255\255\255\255\255\166\000\255\255\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\255\255\ + \255\255\255\255\255\255\255\255\181\000\181\000\181\000\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ + \181\000\181\000\181\000\255\255\181\000\181\000\181\000\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ + \181\000\181\000\181\000\181\000\181\000\181\000\181\000\181\000\ + \181\000\181\000\181\000\183\000\181\000\181\000\181\000\181\000\ + \181\000\181\000\181\000\181\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\255\255\ + \255\255\255\255\255\255\183\000\255\255\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\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\ @@ -6185,15 +6226,15 @@ module Struct = \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ - \255\255\255\255\255\255\255\255\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\255\255\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\255\255\166\000\166\000\166\000\166\000\ - \166\000\166\000\166\000\166\000\255\255"; + \255\255\255\255\255\255\255\255\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\255\255\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\255\255\183\000\183\000\183\000\183\000\ + \183\000\183\000\183\000\183\000\255\255"; Lexing.lex_code = "\255\004\255\255\009\255\255\006\255\005\255\255\007\255\255\008\ \255\255\000\007\255\000\006\001\008\255\000\005\255\011\255\010\ @@ -6453,7 +6494,7 @@ module Struct = __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 150) + __ocaml_lex_string_rec c lexbuf 159) and __ocaml_lex_string_rec c lexbuf __ocaml_lex_state = match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state lexbuf @@ -6487,7 +6528,7 @@ module Struct = (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 160 + __ocaml_lex_symbolchar_star_rec beginning c lexbuf 176 and __ocaml_lex_symbolchar_star_rec beginning c lexbuf __ocaml_lex_state = @@ -6505,7 +6546,7 @@ module Struct = __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 161 + __ocaml_lex_maybe_quotation_at_rec c lexbuf 177 and __ocaml_lex_maybe_quotation_at_rec c lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf @@ -6527,7 +6568,7 @@ module Struct = __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 164) + __ocaml_lex_maybe_quotation_colon_rec c lexbuf 181) and __ocaml_lex_maybe_quotation_colon_rec c lexbuf __ocaml_lex_state = @@ -6560,7 +6601,7 @@ module Struct = (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 170 + and quotation c lexbuf = __ocaml_lex_quotation_rec c lexbuf 188 and __ocaml_lex_quotation_rec c lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with @@ -6572,7 +6613,7 @@ module Struct = | __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 178 + and dollar c lexbuf = __ocaml_lex_dollar_rec c lexbuf 201 and __ocaml_lex_dollar_rec c lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with @@ -6589,7 +6630,7 @@ module Struct = (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 184 + __ocaml_lex_antiquot_rec name c lexbuf 210 and __ocaml_lex_antiquot_rec name c lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with @@ -6775,6 +6816,7 @@ module Struct = | Ast.PaId (_, (Ast.IdLid (_, _))) -> true | Ast.PaId (_, (Ast.IdUid (_, "()"))) -> true | Ast.PaAny _ -> true + | Ast.PaNil _ -> true | Ast.PaAli (_, x, y) -> (is_irrefut_patt x) && (is_irrefut_patt y) | Ast.PaRec (_, p) -> is_irrefut_patt p @@ -6783,6 +6825,10 @@ module Struct = (is_irrefut_patt p1) && (is_irrefut_patt p2) | Ast.PaCom (_, p1, p2) -> (is_irrefut_patt p1) && (is_irrefut_patt p2) + | Ast.PaOrp (_, p1, p2) -> + (is_irrefut_patt p1) && (is_irrefut_patt p2) + | Ast.PaApp (_, 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 @@ -6790,7 +6836,13 @@ module Struct = | Ast.PaOlbi (_, _, p, _) -> is_irrefut_patt p | Ast.PaLab (_, _, (Ast.PaNil _)) -> true | Ast.PaLab (_, _, p) -> is_irrefut_patt p - | _ -> false + | Ast.PaLaz (_, p) -> is_irrefut_patt p + | Ast.PaId (_, _) -> false + | Ast.PaVrn (_, _) | Ast.PaStr (_, _) | Ast.PaRng (_, _, _) | + Ast.PaFlo (_, _) | Ast.PaNativeInt (_, _) | + Ast.PaInt64 (_, _) | Ast.PaInt32 (_, _) | Ast.PaInt (_, _) + | Ast.PaChr (_, _) | Ast.PaTyp (_, _) | Ast.PaArr (_, _) | + Ast.PaAnt (_, _) -> false let rec is_constructor = function @@ -8678,6 +8730,14 @@ module Struct = meta_loc _loc x0) and meta_patt _loc = function + | Ast.PaLaz (x0, x1) -> + Ast.ExApp (_loc, + Ast.ExApp (_loc, + Ast.ExId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaLaz"))), + meta_loc _loc x0), + meta_patt _loc x1) | Ast.PaVrn (x0, x1) -> Ast.ExApp (_loc, Ast.ExApp (_loc, @@ -10709,6 +10769,14 @@ module Struct = meta_loc _loc x0) and meta_patt _loc = function + | Ast.PaLaz (x0, x1) -> + Ast.PaApp (_loc, + Ast.PaApp (_loc, + Ast.PaId (_loc, + Ast.IdAcc (_loc, Ast.IdUid (_loc, "Ast"), + Ast.IdUid (_loc, "PaLaz"))), + meta_loc _loc x0), + meta_patt _loc x1) | Ast.PaVrn (x0, x1) -> Ast.PaApp (_loc, Ast.PaApp (_loc, @@ -11569,6 +11637,9 @@ module Struct = | PaVrn (_x, _x_i1) -> let _x = o#loc _x in let _x_i1 = o#string _x_i1 in PaVrn (_x, _x_i1) + | PaLaz (_x, _x_i1) -> + let _x = o#loc _x in + let _x_i1 = o#patt _x_i1 in PaLaz (_x, _x_i1) method module_type : module_type -> module_type = function @@ -12402,6 +12473,8 @@ module Struct = let o = o#loc _x in let o = o#ident _x_i1 in o | PaVrn (_x, _x_i1) -> let o = o#loc _x in let o = o#string _x_i1 in o + | PaLaz (_x, _x_i1) -> + let o = o#loc _x in let o = o#patt _x_i1 in o method module_type : module_type -> 'self_type = function @@ -13359,10 +13432,8 @@ module Struct = 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) + function | i :: il -> loop (ldot (f i)) il | [] -> f s + in loop lident let rec ctyp_fa al = function @@ -13542,13 +13613,14 @@ module Struct = (mkfield loc (Pfield (lab, mkpolytype (ctyp t)))) :: acc | _ -> assert false - let mktype loc tl cl tk tm = + let mktype loc tl cl tk tp tm = let (params, variance) = List.split tl in { ptype_params = params; ptype_cstrs = cl; ptype_kind = tk; + ptype_private = tp; ptype_manifest = tm; ptype_loc = mkloc loc; ptype_variance = variance; @@ -13583,14 +13655,12 @@ module Struct = | Ast.TyPrv (_, t) -> type_decl tl cl loc m true t | Ast.TyRec (_, t) -> mktype loc tl cl - (Ptype_record (List.map mktrecord (list_of_ctyp t []), - mkprivate' pflag)) - m + (Ptype_record (List.map mktrecord (list_of_ctyp t []))) + (mkprivate' pflag) m | Ast.TySum (_, t) -> mktype loc tl cl - (Ptype_variant (List.map mkvariant (list_of_ctyp t []), - mkprivate' pflag)) - m + (Ptype_variant (List.map mkvariant (list_of_ctyp t []))) + (mkprivate' pflag) m | t -> if m <> None then @@ -13599,9 +13669,8 @@ module Struct = (let m = match t with | Ast.TyNil _ -> None - | _ -> Some (ctyp t) in - let k = if pflag then Ptype_private else Ptype_abstract - in mktype loc tl cl k m) + | _ -> Some (ctyp t) + in mktype loc tl cl Ptype_abstract (mkprivate' pflag) m) let type_decl tl cl t = type_decl tl cl (loc_of_ctyp t) None false t @@ -13627,8 +13696,8 @@ module Struct = let opt_private_ctyp = function - | Ast.TyPrv (_, t) -> (Ptype_private, (ctyp t)) - | t -> (Ptype_abstract, (ctyp t)) + | Ast.TyPrv (_, t) -> (Ptype_abstract, Private, (ctyp t)) + | t -> (Ptype_abstract, Public, (ctyp t)) let rec type_parameters t acc = match t with @@ -13661,7 +13730,7 @@ module Struct = | 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 + let (kind, priv, ct) = opt_private_ctyp ct in (id, (Pwith_type @@ -13669,6 +13738,7 @@ module Struct = ptype_params = params; ptype_cstrs = []; ptype_kind = kind; + ptype_private = priv; ptype_manifest = Some ct; ptype_loc = mkloc loc; ptype_variance = variance; @@ -13824,6 +13894,7 @@ module Struct = 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)) + | PaLaz (loc, p) -> mkpat loc (Ppat_lazy (patt p)) | (PaEq (_, _, _) | PaSem (_, _, _) | PaCom (_, _, _) | PaNil _ as p) -> error (loc_of_patt p) "invalid pattern" and mklabpat = @@ -13879,7 +13950,9 @@ module Struct = | (loc, ml, Ast.ExId (_, (Ast.IdUid (_, s)))) :: l -> let ca = constructors_arity () in - ((mkexp loc (Pexp_construct (mkli s ml, None, ca))), + ((mkexp loc + (Pexp_construct (mkli (conv_con s) ml, None, + ca))), l) | (loc, ml, Ast.ExId (_, (Ast.IdLid (_, s)))) :: l -> ((mkexp loc (Pexp_ident (mkli s ml))), l) @@ -14765,8 +14838,30 @@ module Struct = let _initialized = ref false in fun _path file -> - raise - (Error (file, "native-code program cannot do a dynamic load")) + (if not !_initialized + then + (try + (Dynlink.init (); + Dynlink.allow_unsafe_modules true; + _initialized := 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))) + + let is_native = Dynlink.is_native end @@ -14853,14 +14948,6 @@ module Struct = struct module S = Set.Make(String) - let rec fold_binding_vars f bi acc = - match bi with - | Ast.BiAnd (_, 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 inherit Ast.fold as super @@ -14880,6 +14967,14 @@ module Struct = let fold_pattern_vars f p init = ((new c_fold_pattern_vars f init)#patt p)#acc + let rec fold_binding_vars f bi acc = + match bi with + | Ast.BiAnd (_, bi1, bi2) -> + fold_binding_vars f bi1 (fold_binding_vars f bi2 acc) + | Ast.BiEq (_, p, _) -> fold_pattern_vars f p acc + | Ast.BiNil _ -> acc + | Ast.BiAnt (_, _) -> assert false + class ['accu] fold_free_vars (f : string -> 'accu -> 'accu) ?(env_init = S.empty) free_init = object (o) @@ -15991,9 +16086,9 @@ module Struct = (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) + let skip_if_empty c bp _ = + if (Context.loc_bp c) = bp + then Action.mk (fun _ -> raise Stream.Failure) else raise Stream.Failure let do_recover parser_of_tree entry nlevn alevn loc a s c son @@ -16003,10 +16098,7 @@ module Struct = __strm with | Stream.Failure -> - (try - skip_if_empty c loc - (fun (__strm : _ Stream.t) -> raise Stream.Failure) - __strm + (try skip_if_empty c loc __strm with | Stream.Failure -> continue entry loc a s c son @@ -16408,8 +16500,7 @@ module Struct = if levn > clevn then p1 c levn bp a strm else - (let (__strm : _ Stream.t) = strm in - let bp = Stream.count __strm + (let (__strm : _ Stream.t) = strm in try p1 c levn bp a __strm with @@ -17189,6 +17280,10 @@ module Struct = module Static = struct + let uncurry f (x, y) = f x y + + let flip f x y = f y x + module Make (Lexer : Sig.Lexer) : Sig.Grammar.Static with module Loc = Lexer.Loc and module Token = Lexer.Token = @@ -17261,12 +17356,9 @@ module Struct = 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 + Stree + (List.fold_left (flip (uncurry (Insert.insert_tree e))) + DeadEnd rl) let sfold0 = Fold.sfold0 @@ -17606,6 +17698,9 @@ module Printers = method mk_patt_list : Ast.patt -> ((Ast.patt list) * (Ast.patt option)) + method simple_module_expr : + formatter -> Ast.module_expr -> unit + method module_expr : formatter -> Ast.module_expr -> unit @@ -18112,13 +18207,14 @@ module Printers = fun f (p, e) -> let (pl, e) = expr_fun_args e in - pp f "%a@ ->@ %a" (list o#patt "@ ") (p :: pl) o#expr e + pp f "%a@ ->@ %a" (list o#simple_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) + pp f "%a =@]@ %a" (list o#simple_patt "@ ") (p :: pl) o#class_expr ce method constrain = @@ -18304,6 +18400,17 @@ module Printers = | Ast.ExLmd (_, s, me, e) -> pp f "@[<2>let module %a =@ %a@]@ @[<2>in@ %a@]" o#var s o#module_expr me o#reset_semi#expr e + | 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 | e -> o#apply_expr f e method apply_expr = @@ -18385,17 +18492,6 @@ module Printers = | 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.ExCom (_, e1, e2) -> pp f "%a,@ %a" o#simple_expr e1 o#simple_expr e2 | Ast.ExSem (_, e1, e2) -> @@ -18407,7 +18503,8 @@ module Printers = Ast.ExTry (_, _, _) | Ast.ExIfe (_, _, _, _) | Ast.ExLet (_, _, _, _) | Ast.ExLmd (_, _, _, _) | Ast.ExAsr (_, _) | Ast.ExAsf _ | Ast.ExLaz (_, _) | - Ast.ExNew (_, _) -> pp f "(%a)" o#reset#expr e + Ast.ExNew (_, _) | Ast.ExObj (_, _, _) -> + pp f "(%a)" o#reset#expr e method direction_flag = fun f b -> @@ -18473,6 +18570,8 @@ module Printers = (Ast.PaId (_, (Ast.IdUid (_, "::")))), _)), _) as p) -> o#simple_patt f p + | Ast.PaLaz (_, p) -> + pp f "@[<2>lazy %a@]" o#simple_patt p | Ast.PaApp (_, x, y) -> let (a, al) = get_patt_args x [ y ] in @@ -18537,7 +18636,7 @@ module Printers = | (Ast.PaApp (_, _, _) | Ast.PaAli (_, _, _) | Ast.PaOrp (_, _, _) | Ast.PaRng (_, _, _) | Ast.PaCom (_, _, _) | Ast.PaSem (_, _, _) | - Ast.PaEq (_, _, _) + Ast.PaEq (_, _, _) | Ast.PaLaz (_, _) as p) -> pp f "@[<1>(%a)@]" o#patt p method patt_tycon = @@ -18775,8 +18874,8 @@ module Printers = | Ast.StExp (_, e) -> pp f "@[<2>let _ =@ %a%(%)@]" o#expr e semisep | Ast.StInc (_, me) -> - pp f "@[<2>include@ %a%(%)@]" o#module_expr me - semisep + pp f "@[<2>include@ %a%(%)@]" o#simple_module_expr + me semisep | Ast.StClt (_, ct) -> pp f "@[<2>class type %a%(%)@]" o#class_type ct semisep @@ -18826,6 +18925,19 @@ module Printers = | 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.MeNil _ -> assert false + | 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 + | _ -> o#simple_module_expr f me + + method simple_module_expr = fun f me -> let () = o#node f me Ast.loc_of_module_expr in @@ -18842,11 +18954,6 @@ module Printers = | 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 @@ -18869,8 +18976,8 @@ module Printers = pp f "@[<2>virtual@ @[<1>[%a]@]@ %a@]" o#class_params t o#var i | Ast.CeFun (_, p, ce) -> - pp f "@[<2>fun@ %a@ ->@ %a@]" o#patt p o#class_expr - ce + pp f "@[<2>fun@ %a@ ->@ %a@]" o#simple_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 @@ -19437,10 +19544,18 @@ module Printers = in match me with | Ast.MeApp (_, me1, me2) -> - pp f "@[<2>%a@,(%a)@]" o#module_expr me1 - o#module_expr me2 + pp f "@[<2>%a@ %a@]" o#module_expr me1 + o#simple_module_expr me2 | me -> super#module_expr f me + method simple_module_expr = + fun f me -> + let () = o#node f me Ast.loc_of_module_expr + in + match me with + | Ast.MeApp (_, _, _) -> pp f "(%a)" o#module_expr me + | _ -> super#simple_module_expr f me + method implem = fun f st -> pp f "@[%a@]@." o#str_item st method class_type = @@ -19684,6 +19799,8 @@ module OCamlInitSyntax = let field_expr = Gram.Entry.mk "field_expr" + let field_expr_list = Gram.Entry.mk "field_expr_list" + let fun_binding = Gram.Entry.mk "fun_binding" let fun_def = Gram.Entry.mk "fun_def" @@ -19702,20 +19819,30 @@ module OCamlInitSyntax = let label_declaration = Gram.Entry.mk "label_declaration" + let label_declaration_list = Gram.Entry.mk "label_declaration_list" + let label_expr = Gram.Entry.mk "label_expr" + let label_expr_list = Gram.Entry.mk "label_expr_list" + let label_ipatt = Gram.Entry.mk "label_ipatt" + let label_ipatt_list = Gram.Entry.mk "label_ipatt_list" + let label_longident = Gram.Entry.mk "label_longident" let label_patt = Gram.Entry.mk "label_patt" + let label_patt_list = Gram.Entry.mk "label_patt_list" + 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 meth_decl = Gram.Entry.mk "meth_decl" + let module_binding = Gram.Entry.mk "module_binding" let module_binding0 = Gram.Entry.mk "module_binding0" diff --git a/camlp4/boot/Camlp4Ast.ml b/camlp4/boot/Camlp4Ast.ml index a55c0cab..68ce6da4 100644 --- a/camlp4/boot/Camlp4Ast.ml +++ b/camlp4/boot/Camlp4Ast.ml @@ -20,7 +20,7 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = module Loc = Loc; module Ast = struct - include Sig.MakeCamlp4Ast(Loc); + include (Sig.MakeCamlp4Ast Loc); value safe_string_escaped s = if ((String.length s) > 2) && ((s.[0] = '\\') && (s.[1] = '$')) then s @@ -89,11 +89,16 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = [ 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.PaNil _ -> True + | (* why not *) Ast.PaAli _ x y -> + (is_irrefut_patt x) && (is_irrefut_patt y) | Ast.PaRec _ p -> is_irrefut_patt p | Ast.PaEq _ _ 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.PaOrp _ p1 p2 -> (is_irrefut_patt p1) && (is_irrefut_patt p2) + | (* could be more fine grained *) Ast.PaApp _ 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 @@ -101,7 +106,14 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = | Ast.PaOlbi _ _ p _ -> is_irrefut_patt p | Ast.PaLab _ _ (Ast.PaNil _) -> True | Ast.PaLab _ _ p -> is_irrefut_patt p - | _ -> False ]; + | Ast.PaLaz _ p -> is_irrefut_patt p + | Ast.PaId _ _ -> False + | (* here one need to know the arity of constructors *) + Ast.PaVrn _ _ | Ast.PaStr _ _ | Ast.PaRng _ _ _ | Ast.PaFlo _ _ | + Ast.PaNativeInt _ _ | Ast.PaInt64 _ _ | Ast.PaInt32 _ _ | + Ast.PaInt _ _ | Ast.PaChr _ _ | Ast.PaTyp _ _ | Ast.PaArr _ _ | + Ast.PaAnt _ _ + -> False ]; value rec is_constructor = fun [ Ast.IdAcc _ _ i -> is_constructor i @@ -1806,7 +1818,15 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = (meta_loc _loc x0) ] and meta_patt _loc = fun - [ Ast.PaVrn x0 x1 -> + [ Ast.PaLaz x0 x1 -> + Ast.ExApp _loc + (Ast.ExApp _loc + (Ast.ExId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaLaz"))) + (meta_loc _loc x0)) + (meta_patt _loc x1) + | Ast.PaVrn x0 x1 -> Ast.ExApp _loc (Ast.ExApp _loc (Ast.ExId _loc @@ -3718,7 +3738,15 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = (meta_loc _loc x0) ] and meta_patt _loc = fun - [ Ast.PaVrn x0 x1 -> + [ Ast.PaLaz x0 x1 -> + Ast.PaApp _loc + (Ast.PaApp _loc + (Ast.PaId _loc + (Ast.IdAcc _loc (Ast.IdUid _loc "Ast") + (Ast.IdUid _loc "PaLaz"))) + (meta_loc _loc x0)) + (meta_patt _loc x1) + | Ast.PaVrn x0 x1 -> Ast.PaApp _loc (Ast.PaApp _loc (Ast.PaId _loc @@ -4518,7 +4546,9 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = let _x_i1 = o#ident _x_i1 in PaTyp _x _x_i1 | PaVrn _x _x_i1 -> let _x = o#loc _x in - let _x_i1 = o#string _x_i1 in PaVrn _x _x_i1 ]; + let _x_i1 = o#string _x_i1 in PaVrn _x _x_i1 + | PaLaz _x _x_i1 -> + let _x = o#loc _x in let _x_i1 = o#patt _x_i1 in PaLaz _x _x_i1 ]; method module_type : module_type -> module_type = fun [ MtNil _x -> let _x = o#loc _x in MtNil _x @@ -5237,7 +5267,8 @@ module Make (Loc : Sig.Loc) : Sig.Camlp4Ast with module Loc = Loc = let o = o#loc _x in let o = o#patt _x_i1 in let o = o#ctyp _x_i2 in o | PaTyp _x _x_i1 -> let o = o#loc _x in let o = o#ident _x_i1 in o - | PaVrn _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o ]; + | PaVrn _x _x_i1 -> let o = o#loc _x in let o = o#string _x_i1 in o + | PaLaz _x _x_i1 -> let o = o#loc _x in let o = o#patt _x_i1 in o ]; method module_type : module_type -> 'self_type = fun [ MtNil _x -> let o = o#loc _x in o diff --git a/camlp4/boot/camlp4boot.ml b/camlp4/boot/camlp4boot.ml index c66680c8..f58725c7 100644 --- a/camlp4/boot/camlp4boot.ml +++ b/camlp4/boot/camlp4boot.ml @@ -181,6 +181,8 @@ Very old (no more supported) syntax: let _ = Gram.Entry.clear field_expr + let _ = Gram.Entry.clear field_expr_list + let _ = Gram.Entry.clear fun_binding let _ = Gram.Entry.clear fun_def @@ -201,20 +203,30 @@ Very old (no more supported) syntax: let _ = Gram.Entry.clear label_declaration + let _ = Gram.Entry.clear label_declaration_list + + let _ = Gram.Entry.clear label_expr_list + let _ = Gram.Entry.clear label_expr let _ = Gram.Entry.clear label_ipatt + let _ = Gram.Entry.clear label_ipatt_list + let _ = Gram.Entry.clear label_longident let _ = Gram.Entry.clear label_patt + let _ = Gram.Entry.clear label_patt_list + let _ = Gram.Entry.clear labeled_ipatt let _ = Gram.Entry.clear let_binding let _ = Gram.Entry.clear meth_list + let _ = Gram.Entry.clear meth_decl + let _ = Gram.Entry.clear module_binding let _ = Gram.Entry.clear module_binding0 @@ -814,13 +826,19 @@ Very old (no more supported) syntax: 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_decl : 'meth_decl 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_list : 'label_patt_list Gram.Entry.t) and _ = (label_patt : 'label_patt Gram.Entry.t) and _ = (label_longident : 'label_longident Gram.Entry.t) + and _ = (label_ipatt_list : 'label_ipatt_list Gram.Entry.t) and _ = (label_ipatt : 'label_ipatt Gram.Entry.t) + and _ = (label_expr_list : 'label_expr_list Gram.Entry.t) and _ = (label_expr : 'label_expr Gram.Entry.t) + and _ = + (label_declaration_list : 'label_declaration_list 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) @@ -831,6 +849,7 @@ Very old (no more supported) syntax: 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_list : 'field_expr_list Gram.Entry.t) and _ = (field_expr : 'field_expr Gram.Entry.t) and _ = (expr_quot : 'expr_quot Gram.Entry.t) and _ = (expr_eoi : 'expr_eoi Gram.Entry.t) @@ -2229,6 +2248,11 @@ Very old (no more supported) syntax: (fun _ (t2 : 'ctyp) _ (t : 'ctyp) _ (e : 'expr) _ (_loc : Gram.Loc.t) -> (Ast.ExCoe (_loc, e, t, t2) : 'expr)))); + ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ";"; + Gram.Skeyword ")" ], + (Gram.Action.mk + (fun _ _ (e : 'expr) _ (_loc : Gram.Loc.t) -> + (mksequence _loc e : 'expr)))); ([ Gram.Skeyword "("; Gram.Sself; Gram.Skeyword ";"; Gram.Snterm (Gram.Entry.obj @@ -2265,11 +2289,13 @@ Very old (no more supported) syntax: ([ Gram.Skeyword "{<"; Gram.Snterm (Gram.Entry.obj - (field_expr : 'field_expr Gram.Entry.t)); + (field_expr_list : + 'field_expr_list Gram.Entry.t)); Gram.Skeyword ">}" ], (Gram.Action.mk - (fun _ (fel : 'field_expr) _ (_loc : Gram.Loc.t) - -> (Ast.ExOvr (_loc, fel) : 'expr)))); + (fun _ (fel : 'field_expr_list) _ + (_loc : Gram.Loc.t) -> + (Ast.ExOvr (_loc, fel) : 'expr)))); ([ Gram.Skeyword "{<"; Gram.Skeyword ">}" ], (Gram.Action.mk (fun _ _ (_loc : Gram.Loc.t) -> @@ -2278,20 +2304,22 @@ Very old (no more supported) syntax: Gram.Skeyword ")"; Gram.Skeyword "with"; Gram.Snterm (Gram.Entry.obj - (label_expr : 'label_expr Gram.Entry.t)); + (label_expr_list : + 'label_expr_list Gram.Entry.t)); Gram.Skeyword "}" ], (Gram.Action.mk - (fun _ (el : 'label_expr) _ _ (e : 'expr) _ _ - (_loc : Gram.Loc.t) -> + (fun _ (el : 'label_expr_list) _ _ (e : 'expr) _ + _ (_loc : Gram.Loc.t) -> (Ast.ExRec (_loc, el, e) : 'expr)))); ([ Gram.Skeyword "{"; Gram.Snterm (Gram.Entry.obj - (label_expr : 'label_expr Gram.Entry.t)); + (label_expr_list : + 'label_expr_list Gram.Entry.t)); Gram.Skeyword "}" ], (Gram.Action.mk - (fun _ (el : 'label_expr) _ (_loc : Gram.Loc.t) - -> + (fun _ (el : 'label_expr_list) _ + (_loc : Gram.Loc.t) -> (Ast.ExRec (_loc, el, Ast.ExNil _loc) : 'expr)))); ([ Gram.Skeyword "[|"; @@ -2559,8 +2587,9 @@ Very old (no more supported) syntax: ((fun () -> (None, [ (None, None, - [ ([ Gram.Snterm - (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], + [ ([ Gram.Snterml + (Gram.Entry.obj (expr : 'expr Gram.Entry.t), + "top") ], (Gram.Action.mk (fun (e : 'expr) (_loc : Gram.Loc.t) -> (e : 'comma_expr)))); @@ -2978,6 +3007,32 @@ Very old (no more supported) syntax: (Ast.PaAli (_loc, p1, p2) : 'patt_as_patt_opt)))) ]) ])) ()); + Gram.extend (label_expr_list : 'label_expr_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (label_expr : 'label_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (b1 : 'label_expr) (_loc : Gram.Loc.t) -> + (b1 : 'label_expr_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_expr : 'label_expr Gram.Entry.t)); + Gram.Skeyword ";" ], + (Gram.Action.mk + (fun _ (b1 : 'label_expr) (_loc : Gram.Loc.t) -> + (b1 : 'label_expr_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_expr : 'label_expr Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (b2 : 'label_expr_list) _ + (b1 : 'label_expr) (_loc : Gram.Loc.t) -> + (Ast.RbSem (_loc, b1, b2) : 'label_expr_list)))) ]) ])) + ()); Gram.extend (label_expr : 'label_expr Gram.Entry.t) ((fun () -> (None, @@ -3053,12 +3108,7 @@ Very old (no more supported) syntax: (Ast.RbAnt (_loc, mk_anti ~c: "rec_binding" n s) : 'label_expr) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (b2 : 'label_expr) _ (b1 : 'label_expr) - (_loc : Gram.Loc.t) -> - (Ast.RbSem (_loc, b1, b2) : 'label_expr)))) ]) ])) + | _ -> assert false))) ]) ])) ()); Gram.extend (fun_def : 'fun_def Gram.Entry.t) ((fun () -> @@ -3126,7 +3176,11 @@ Very old (no more supported) syntax: (_loc : Gram.Loc.t) -> (Ast.PaRng (_loc, p1, p2) : 'patt)))) ]); ((Some "apply"), (Some Camlp4.Sig.Grammar.LeftA), - [ ([ Gram.Sself; Gram.Sself ], + [ ([ Gram.Skeyword "lazy"; Gram.Sself ], + (Gram.Action.mk + (fun (p : 'patt) _ (_loc : Gram.Loc.t) -> + (Ast.PaLaz (_loc, p) : 'patt)))); + ([ Gram.Sself; Gram.Sself ], (Gram.Action.mk (fun (p2 : 'patt) (p1 : 'patt) (_loc : Gram.Loc.t) -> @@ -3338,11 +3392,13 @@ Very old (no more supported) syntax: ([ Gram.Skeyword "{"; Gram.Snterm (Gram.Entry.obj - (label_patt : 'label_patt Gram.Entry.t)); + (label_patt_list : + 'label_patt_list Gram.Entry.t)); Gram.Skeyword "}" ], (Gram.Action.mk - (fun _ (pl : 'label_patt) _ (_loc : Gram.Loc.t) - -> (Ast.PaRec (_loc, pl) : 'patt)))); + (fun _ (pl : 'label_patt_list) _ + (_loc : Gram.Loc.t) -> + (Ast.PaRec (_loc, pl) : 'patt)))); ([ Gram.Skeyword "[|"; Gram.Snterm (Gram.Entry.obj @@ -3597,10 +3653,36 @@ Very old (no more supported) syntax: pl acc) : 'sem_patt_for_list)))) ]) ])) ()); + Gram.extend (label_patt_list : 'label_patt_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (label_patt : 'label_patt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p1 : 'label_patt) (_loc : Gram.Loc.t) -> + (p1 : 'label_patt_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_patt : 'label_patt Gram.Entry.t)); + Gram.Skeyword ";" ], + (Gram.Action.mk + (fun _ (p1 : 'label_patt) (_loc : Gram.Loc.t) -> + (p1 : 'label_patt_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_patt : 'label_patt Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (p2 : 'label_patt_list) _ + (p1 : 'label_patt) (_loc : Gram.Loc.t) -> + (Ast.PaSem (_loc, p1, p2) : 'label_patt_list)))) ]) ])) + ()); Gram.extend (label_patt : 'label_patt Gram.Entry.t) ((fun () -> (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (label_longident : @@ -3652,12 +3734,7 @@ Very old (no more supported) syntax: -> (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 : Gram.Loc.t) -> - (Ast.PaSem (_loc, p1, p2) : 'label_patt)))) ]) ])) + | _ -> assert false))) ]) ])) ()); Gram.extend (ipatt : 'ipatt Gram.Entry.t) ((fun () -> @@ -3752,11 +3829,13 @@ Very old (no more supported) syntax: ([ Gram.Skeyword "{"; Gram.Snterm (Gram.Entry.obj - (label_ipatt : 'label_ipatt Gram.Entry.t)); + (label_ipatt_list : + 'label_ipatt_list Gram.Entry.t)); Gram.Skeyword "}" ], (Gram.Action.mk - (fun _ (pl : 'label_ipatt) _ (_loc : Gram.Loc.t) - -> (Ast.PaRec (_loc, pl) : 'ipatt)))) ]) ])) + (fun _ (pl : 'label_ipatt_list) _ + (_loc : Gram.Loc.t) -> + (Ast.PaRec (_loc, pl) : 'ipatt)))) ]) ])) ()); Gram.extend (labeled_ipatt : 'labeled_ipatt Gram.Entry.t) ((fun () -> @@ -3797,10 +3876,37 @@ Very old (no more supported) syntax: (_loc : Gram.Loc.t) -> (Ast.PaCom (_loc, p1, p2) : 'comma_ipatt)))) ]) ])) ()); + Gram.extend (label_ipatt_list : 'label_ipatt_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (label_ipatt : 'label_ipatt Gram.Entry.t)) ], + (Gram.Action.mk + (fun (p1 : 'label_ipatt) (_loc : Gram.Loc.t) -> + (p1 : 'label_ipatt_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_ipatt : 'label_ipatt Gram.Entry.t)); + Gram.Skeyword ";" ], + (Gram.Action.mk + (fun _ (p1 : 'label_ipatt) (_loc : Gram.Loc.t) + -> (p1 : 'label_ipatt_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_ipatt : 'label_ipatt Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (p2 : 'label_ipatt_list) _ + (p1 : 'label_ipatt) (_loc : Gram.Loc.t) -> + (Ast.PaSem (_loc, p1, p2) : + 'label_ipatt_list)))) ]) ])) + ()); Gram.extend (label_ipatt : 'label_ipatt Gram.Entry.t) ((fun () -> (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (label_longident : @@ -3852,12 +3958,7 @@ Very old (no more supported) syntax: -> (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 : Gram.Loc.t) -> - (Ast.PaSem (_loc, p1, p2) : 'label_ipatt)))) ]) ])) + | _ -> assert false))) ]) ])) ()); Gram.extend (type_declaration : 'type_declaration Gram.Entry.t) ((fun () -> @@ -4193,14 +4294,10 @@ Very old (no more supported) syntax: (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 : Gram.Loc.t) -> - (Ast.TyObj (_loc, ml, v) : 'ctyp)))); + (fun _ (t : 'opt_meth_list) _ + (_loc : Gram.Loc.t) -> (t : 'ctyp)))); ([ Gram.Skeyword "#"; Gram.Snterm (Gram.Entry.obj @@ -4213,11 +4310,11 @@ Very old (no more supported) syntax: ([ Gram.Skeyword "{"; Gram.Snterm (Gram.Entry.obj - (label_declaration : - 'label_declaration Gram.Entry.t)); - Gram.Sopt (Gram.Skeyword ";"); Gram.Skeyword "}" ], + (label_declaration_list : + 'label_declaration_list Gram.Entry.t)); + Gram.Skeyword "}" ], (Gram.Action.mk - (fun _ _ (t : 'label_declaration) _ + (fun _ (t : 'label_declaration_list) _ (_loc : Gram.Loc.t) -> (Ast.TyRec (_loc, t) : 'ctyp)))); ([ Gram.Skeyword "[<"; @@ -4594,11 +4691,46 @@ Very old (no more supported) syntax: 'constructor_arg_list) | _ -> assert false))) ]) ])) ()); + Gram.extend + (label_declaration_list : + 'label_declaration_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (label_declaration : + 'label_declaration Gram.Entry.t)) ], + (Gram.Action.mk + (fun (t1 : 'label_declaration) + (_loc : Gram.Loc.t) -> + (t1 : 'label_declaration_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_declaration : + 'label_declaration Gram.Entry.t)); + Gram.Skeyword ";" ], + (Gram.Action.mk + (fun _ (t1 : 'label_declaration) + (_loc : Gram.Loc.t) -> + (t1 : 'label_declaration_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (label_declaration : + 'label_declaration Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (t2 : 'label_declaration_list) _ + (t1 : 'label_declaration) (_loc : Gram.Loc.t) + -> + (Ast.TySem (_loc, t1, t2) : + 'label_declaration_list)))) ]) ])) + ()); Gram.extend (label_declaration : 'label_declaration Gram.Entry.t) ((fun () -> (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); @@ -4664,14 +4796,7 @@ Very old (no more supported) syntax: | 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 : Gram.Loc.t) - -> - (Ast.TySem (_loc, t1, t2) : - 'label_declaration)))) ]) ])) + | _ -> assert false))) ]) ])) ()); Gram.extend (a_ident : 'a_ident Gram.Entry.t) ((fun () -> @@ -6141,16 +6266,41 @@ Very old (no more supported) syntax: (Ast.CtAnd (_loc, cd1, cd2) : 'class_type_declaration)))) ]) ])) ()); + Gram.extend (field_expr_list : 'field_expr_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (field_expr : 'field_expr Gram.Entry.t)) ], + (Gram.Action.mk + (fun (b1 : 'field_expr) (_loc : Gram.Loc.t) -> + (b1 : 'field_expr_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (field_expr : 'field_expr Gram.Entry.t)); + Gram.Skeyword ";" ], + (Gram.Action.mk + (fun _ (b1 : 'field_expr) (_loc : Gram.Loc.t) -> + (b1 : 'field_expr_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (field_expr : 'field_expr Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Sself ], + (Gram.Action.mk + (fun (b2 : 'field_expr_list) _ + (b1 : 'field_expr) (_loc : Gram.Loc.t) -> + (Ast.RbSem (_loc, b1, b2) : 'field_expr_list)))) ]) ])) + ()); Gram.extend (field_expr : 'field_expr Gram.Entry.t) ((fun () -> (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (label : 'label Gram.Entry.t)); Gram.Skeyword "="; - Gram.Snterml - (Gram.Entry.obj (expr : 'expr Gram.Entry.t), - "top") ], + Gram.Snterm + (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk (fun (e : 'expr) _ (l : 'label) (_loc : Gram.Loc.t) -> @@ -6184,17 +6334,44 @@ Very old (no more supported) syntax: (Ast.RbAnt (_loc, mk_anti ~c: "rec_binding" n s) : 'field_expr) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword ";"; Gram.Sself ], + | _ -> assert false))) ]) ])) + ()); + Gram.extend (meth_list : 'meth_list Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj + (meth_decl : 'meth_decl Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ], + (Gram.Action.mk + (fun (v : 'opt_dot_dot) (m : 'meth_decl) + (_loc : Gram.Loc.t) -> ((m, v) : 'meth_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (meth_decl : 'meth_decl Gram.Entry.t)); + Gram.Skeyword ";"; + Gram.Snterm + (Gram.Entry.obj + (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ], + (Gram.Action.mk + (fun (v : 'opt_dot_dot) _ (m : 'meth_decl) + (_loc : Gram.Loc.t) -> ((m, v) : 'meth_list)))); + ([ Gram.Snterm + (Gram.Entry.obj + (meth_decl : 'meth_decl Gram.Entry.t)); + Gram.Skeyword ";"; Gram.Sself ], (Gram.Action.mk - (fun (b2 : 'field_expr) _ (b1 : 'field_expr) + (fun ((ml, v) : 'meth_list) _ (m : 'meth_decl) (_loc : Gram.Loc.t) -> - (Ast.RbSem (_loc, b1, b2) : 'field_expr)))) ]) ])) + (((Ast.TySem (_loc, m, ml)), v) : 'meth_list)))) ]) ])) ()); - Gram.extend (meth_list : 'meth_list Gram.Entry.t) + Gram.extend (meth_decl : 'meth_decl Gram.Entry.t) ((fun () -> (None, - [ (None, (Some Camlp4.Sig.Grammar.LeftA), + [ (None, None, [ ([ Gram.Snterm (Gram.Entry.obj (a_LIDENT : 'a_LIDENT Gram.Entry.t)); @@ -6207,7 +6384,7 @@ Very old (no more supported) syntax: (_loc : Gram.Loc.t) -> (Ast.TyCol (_loc, Ast.TyId (_loc, Ast.IdLid (_loc, lab)), t) : - 'meth_list)))); + 'meth_decl)))); ([ Gram.Stoken (((function | QUOTATION _ -> true | _ -> false), "QUOTATION _")) ], @@ -6218,7 +6395,7 @@ Very old (no more supported) syntax: | QUOTATION x -> (Quotation.expand _loc x Quotation. DynAst.ctyp_tag : - 'meth_list) + 'meth_decl) | _ -> assert false))); ([ Gram.Stoken (((function @@ -6232,7 +6409,7 @@ Very old (no more supported) syntax: | ANTIQUOT ((("list" as n)), s) -> (Ast.TyAnt (_loc, mk_anti ~c: "ctyp;" n s) : - 'meth_list) + 'meth_decl) | _ -> assert false))); ([ Gram.Stoken (((function @@ -6245,29 +6422,26 @@ Very old (no more supported) syntax: match __camlp4_0 with | ANTIQUOT ((("" | "typ" as n)), s) -> (Ast.TyAnt (_loc, mk_anti ~c: "ctyp" n s) : - 'meth_list) - | _ -> assert false))); - ([ Gram.Sself; Gram.Skeyword ";"; Gram.Sself ], - (Gram.Action.mk - (fun (ml2 : 'meth_list) _ (ml1 : 'meth_list) - (_loc : Gram.Loc.t) -> - (Ast.TySem (_loc, ml1, ml2) : 'meth_list)))) ]) ])) + 'meth_decl) + | _ -> assert false))) ]) ])) ()); Gram.extend (opt_meth_list : 'opt_meth_list Gram.Entry.t) ((fun () -> (None, [ (None, None, - [ ([], + [ ([ Gram.Snterm + (Gram.Entry.obj + (opt_dot_dot : 'opt_dot_dot Gram.Entry.t)) ], (Gram.Action.mk - (fun (_loc : Gram.Loc.t) -> - (Ast.TyNil _loc : 'opt_meth_list)))); + (fun (v : 'opt_dot_dot) (_loc : Gram.Loc.t) -> + (Ast.TyObj (_loc, Ast.TyNil _loc, v) : + 'opt_meth_list)))); ([ Gram.Snterm (Gram.Entry.obj - (meth_list : 'meth_list Gram.Entry.t)); - Gram.Sopt (Gram.Skeyword ";") ], + (meth_list : 'meth_list Gram.Entry.t)) ], (Gram.Action.mk - (fun _ (ml : 'meth_list) (_loc : Gram.Loc.t) -> - (ml : 'opt_meth_list)))) ]) ])) + (fun ((ml, v) : 'meth_list) (_loc : Gram.Loc.t) + -> (Ast.TyObj (_loc, ml, v) : 'opt_meth_list)))) ]) ])) ()); Gram.extend (poly_type : 'poly_type Gram.Entry.t) ((fun () -> @@ -7605,11 +7779,12 @@ Very old (no more supported) syntax: Gram.Skeyword ";"; Gram.Snterm (Gram.Entry.obj - (label_declaration : - 'label_declaration Gram.Entry.t)) ], + (label_declaration_list : + 'label_declaration_list Gram.Entry.t)) ], (Gram.Action.mk - (fun (z : 'label_declaration) _ (y : 'more_ctyp) - _ (x : 'more_ctyp) (_loc : Gram.Loc.t) -> + (fun (z : 'label_declaration_list) _ + (y : 'more_ctyp) _ (x : 'more_ctyp) + (_loc : Gram.Loc.t) -> (Ast.TySem (_loc, Ast.TyCol (_loc, x, y), z) : 'ctyp_quot)))); ([ Gram.Snterm @@ -7699,11 +7874,11 @@ Very old (no more supported) syntax: Gram.Skeyword ";"; Gram.Snterm (Gram.Entry.obj - (label_declaration : - 'label_declaration Gram.Entry.t)) ], + (label_declaration_list : + 'label_declaration_list Gram.Entry.t)) ], (Gram.Action.mk - (fun (y : 'label_declaration) _ (x : 'more_ctyp) - (_loc : Gram.Loc.t) -> + (fun (y : 'label_declaration_list) _ + (x : 'more_ctyp) (_loc : Gram.Loc.t) -> (Ast.TySem (_loc, x, y) : 'ctyp_quot)))); ([ Gram.Snterm (Gram.Entry.obj @@ -7890,10 +8065,11 @@ Very old (no more supported) syntax: (Ast.RbNil _loc : 'rec_binding_quot)))); ([ Gram.Snterm (Gram.Entry.obj - (label_expr : 'label_expr Gram.Entry.t)) ], + (label_expr_list : + 'label_expr_list Gram.Entry.t)) ], (Gram.Action.mk - (fun (x : 'label_expr) (_loc : Gram.Loc.t) -> - (x : 'rec_binding_quot)))) ]) ])) + (fun (x : 'label_expr_list) (_loc : Gram.Loc.t) + -> (x : 'rec_binding_quot)))) ]) ])) ()); Gram.extend (module_binding_quot : 'module_binding_quot Gram.Entry.t) @@ -10056,12 +10232,7 @@ module G = | STstring_tok 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 = + type ('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 @@ -10071,7 +10242,12 @@ module G = | TXself of loc | TXkwd of loc * string | TXtok of loc * 'e * string - and ('e, 'p) entry = + and (** 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) entry = { name : 'e name; pos : 'e option; levels : (('e, 'p) level) list } and ('e, 'p) level = @@ -10166,14 +10342,13 @@ module G = let retype_rule_list_without_patterns _loc rl = try - (* ...; [ "foo" ]; ... ==> ...; (x = [ "foo" ] -> Gram.Token.extract_string x); ... *) - (* ...; [ symb ]; ... ==> ...; (x = [ symb ] -> x); ... *) - (* ...; ([] -> a); ... *) List.map (function - | { - prod = [ ({ pattern = None; styp = STtok _ } as s) ]; - action = None } -> + | (* ...; [ "foo" ]; ... ==> ...; (x = [ "foo" ] -> Gram.Token.extract_string x); ... *) + { + prod = [ ({ pattern = None; styp = STtok _ } as s) ]; + action = None + } -> { prod = [ { @@ -10191,7 +10366,8 @@ module G = Ast.IdLid (_loc, "extract_string")))), Ast.ExId (_loc, Ast.IdLid (_loc, "x")))); } - | { prod = [ ({ pattern = None } as s) ]; action = None } -> + | (* ...; [ symb ]; ... ==> ...; (x = [ symb ] -> x); ... *) + { prod = [ ({ pattern = None } as s) ]; action = None } -> { prod = [ { @@ -10202,7 +10378,8 @@ module G = } ]; action = Some (Ast.ExId (_loc, Ast.IdLid (_loc, "x"))); } - | ({ prod = []; action = Some _ } as r) -> r + | (* ...; ([] -> a); ... *) + ({ prod = []; action = Some _ } as r) -> r | _ -> raise Exit) rl with | Exit -> rl @@ -10286,7 +10463,7 @@ module G = | None -> Ast.ExId (_loc, Ast.IdUid (_loc, "()")) in let (tok_match_pl, act, _) = List.fold_left - (fun ((tok_match_pl, act, i) as accu) -> + (fun (((tok_match_pl, act, i) as accu)) -> function | { pattern = None } -> accu | { pattern = Some p } when Ast.is_irrefut_patt p -> accu @@ -12412,6 +12589,7 @@ module M = * - Nicolas Pouillard: refactoring * - Aleksey Nogin: extra features and bug fixes. * - Christopher Conway: extra feature (-D=) + * - Jean-vincent Loddo: definitions inside IFs. *) module Id = struct let name = "Camlp4MacroParser" @@ -12490,7 +12668,7 @@ Added statements: | SdStr of 'a | SdDef of string * ((string list) * Ast.expr) option | SdUnd of string - | SdITE of string * ('a item_or_def) list * ('a item_or_def) list + | SdITE of bool * ('a item_or_def) list * ('a item_or_def) list | SdLazy of 'a Lazy.t let rec list_remove x = @@ -12756,8 +12934,8 @@ Added statements: | SdStr i -> i | SdDef (x, eo) -> (define eo x; nil) | SdUnd x -> (undef x; nil) - | SdITE (i, l1, l2) -> - execute_macro_list nil cons (if is_defined i then l1 else l2) + | SdITE (b, l1, l2) -> + execute_macro_list nil cons (if b then l1 else l2) | SdLazy l -> Lazy.force l and execute_macro_list nil cons = function @@ -12766,6 +12944,24 @@ Added statements: let il1 = execute_macro nil cons hd in let il2 = execute_macro_list nil cons tl in cons il1 il2 + (* Stack of conditionals. *) + let stack = Stack.create () + + (* Make an SdITE value by extracting the result of the test from the stack. *) + let make_SdITE_result st1 st2 = + let test = Stack.pop stack in SdITE (test, st1, st2) + + type branch = | Then | Else + + (* Execute macro only if it belongs to the currently active branch. *) + let execute_macro_if_active_branch _loc nil cons branch macro_def = + let test = Stack.top stack in + let item = + if (test && (branch = Then)) || ((not test) && (branch = Else)) + then execute_macro nil cons macro_def + else (* ignore the macro *) nil + in SdStr item + let _ = let _ = (expr : 'expr Gram.Entry.t) and _ = (sig_item : 'sig_item Gram.Entry.t) @@ -12778,14 +12974,24 @@ Added statements: and opt_macro_value : 'opt_macro_value Gram.Entry.t = grammar_entry_create "opt_macro_value" and endif : 'endif Gram.Entry.t = grammar_entry_create "endif" - and sglist : 'sglist Gram.Entry.t = grammar_entry_create "sglist" - and smlist : 'smlist Gram.Entry.t = grammar_entry_create "smlist" + and sglist_else : 'sglist_else Gram.Entry.t = + grammar_entry_create "sglist_else" + and sglist_then : 'sglist_then Gram.Entry.t = + grammar_entry_create "sglist_then" + and smlist_else : 'smlist_else Gram.Entry.t = + grammar_entry_create "smlist_else" + and smlist_then : 'smlist_then Gram.Entry.t = + grammar_entry_create "smlist_then" and else_expr : 'else_expr Gram.Entry.t = grammar_entry_create "else_expr" and else_macro_def_sig : 'else_macro_def_sig Gram.Entry.t = grammar_entry_create "else_macro_def_sig" and else_macro_def : 'else_macro_def Gram.Entry.t = grammar_entry_create "else_macro_def" + and uident_eval_ifndef : 'uident_eval_ifndef Gram.Entry.t = + grammar_entry_create "uident_eval_ifndef" + and uident_eval_ifdef : 'uident_eval_ifdef Gram.Entry.t = + grammar_entry_create "uident_eval_ifdef" and macro_def_sig : 'macro_def_sig Gram.Entry.t = grammar_entry_create "macro_def_sig" in @@ -12835,32 +13041,40 @@ Added statements: 'macro_def)))); ([ Gram.Skeyword "IFNDEF"; Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); + (Gram.Entry.obj + (uident_eval_ifndef : + 'uident_eval_ifndef Gram.Entry.t)); Gram.Skeyword "THEN"; Gram.Snterm - (Gram.Entry.obj (smlist : 'smlist Gram.Entry.t)); + (Gram.Entry.obj + (smlist_then : 'smlist_then Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (else_macro_def : 'else_macro_def Gram.Entry.t)) ], (Gram.Action.mk - (fun (st1 : 'else_macro_def) (st2 : 'smlist) _ - (i : 'uident) _ (_loc : Gram.Loc.t) -> - (SdITE (i, st1, st2) : 'macro_def)))); + (fun (st2 : 'else_macro_def) + (st1 : 'smlist_then) _ _ _ + (_loc : Gram.Loc.t) -> + (make_SdITE_result st1 st2 : 'macro_def)))); ([ Gram.Skeyword "IFDEF"; Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); + (Gram.Entry.obj + (uident_eval_ifdef : + 'uident_eval_ifdef Gram.Entry.t)); Gram.Skeyword "THEN"; Gram.Snterm - (Gram.Entry.obj (smlist : 'smlist Gram.Entry.t)); + (Gram.Entry.obj + (smlist_then : 'smlist_then Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (else_macro_def : 'else_macro_def Gram.Entry.t)) ], (Gram.Action.mk - (fun (st2 : 'else_macro_def) (st1 : 'smlist) _ - (i : 'uident) _ (_loc : Gram.Loc.t) -> - (SdITE (i, st1, st2) : 'macro_def)))); + (fun (st2 : 'else_macro_def) + (st1 : 'smlist_then) _ _ _ + (_loc : Gram.Loc.t) -> + (make_SdITE_result st1 st2 : 'macro_def)))); ([ Gram.Skeyword "UNDEF"; Gram.Snterm (Gram.Entry.obj (uident : 'uident Gram.Entry.t)) ], @@ -12898,32 +13112,40 @@ Added statements: 'macro_def_sig)))); ([ Gram.Skeyword "IFNDEF"; Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); + (Gram.Entry.obj + (uident_eval_ifndef : + 'uident_eval_ifndef Gram.Entry.t)); Gram.Skeyword "THEN"; Gram.Snterm - (Gram.Entry.obj (sglist : 'sglist Gram.Entry.t)); + (Gram.Entry.obj + (sglist_then : 'sglist_then Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (else_macro_def_sig : 'else_macro_def_sig Gram.Entry.t)) ], (Gram.Action.mk - (fun (sg1 : 'else_macro_def_sig) (sg2 : 'sglist) - _ (i : 'uident) _ (_loc : Gram.Loc.t) -> - (SdITE (i, sg1, sg2) : 'macro_def_sig)))); + (fun (sg2 : 'else_macro_def_sig) + (sg1 : 'sglist_then) _ _ _ + (_loc : Gram.Loc.t) -> + (make_SdITE_result sg1 sg2 : 'macro_def_sig)))); ([ Gram.Skeyword "IFDEF"; Gram.Snterm - (Gram.Entry.obj (uident : 'uident Gram.Entry.t)); + (Gram.Entry.obj + (uident_eval_ifdef : + 'uident_eval_ifdef Gram.Entry.t)); Gram.Skeyword "THEN"; Gram.Snterm - (Gram.Entry.obj (sglist : 'sglist Gram.Entry.t)); + (Gram.Entry.obj + (sglist_then : 'sglist_then Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (else_macro_def_sig : 'else_macro_def_sig Gram.Entry.t)) ], (Gram.Action.mk - (fun (sg2 : 'else_macro_def_sig) (sg1 : 'sglist) - _ (i : 'uident) _ (_loc : Gram.Loc.t) -> - (SdITE (i, sg1, sg2) : 'macro_def_sig)))); + (fun (sg2 : 'else_macro_def_sig) + (sg1 : 'sglist_then) _ _ _ + (_loc : Gram.Loc.t) -> + (make_SdITE_result sg1 sg2 : 'macro_def_sig)))); ([ Gram.Skeyword "UNDEF"; Gram.Snterm (Gram.Entry.obj (uident : 'uident Gram.Entry.t)) ], @@ -12937,6 +13159,30 @@ Added statements: (fun (i : 'uident) _ (_loc : Gram.Loc.t) -> (SdDef (i, None) : 'macro_def_sig)))) ]) ])) ()); + Gram.extend + (uident_eval_ifdef : 'uident_eval_ifdef Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (uident : 'uident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'uident) (_loc : Gram.Loc.t) -> + (Stack.push (is_defined i) stack : + 'uident_eval_ifdef)))) ]) ])) + ()); + Gram.extend + (uident_eval_ifndef : 'uident_eval_ifndef Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Snterm + (Gram.Entry.obj (uident : 'uident Gram.Entry.t)) ], + (Gram.Action.mk + (fun (i : 'uident) (_loc : Gram.Loc.t) -> + (Stack.push (not (is_defined i)) stack : + 'uident_eval_ifndef)))) ]) ])) + ()); Gram.extend (else_macro_def : 'else_macro_def Gram.Entry.t) ((fun () -> (None, @@ -12948,12 +13194,13 @@ Added statements: ([] : 'else_macro_def)))); ([ Gram.Skeyword "ELSE"; Gram.Snterm - (Gram.Entry.obj (smlist : 'smlist Gram.Entry.t)); + (Gram.Entry.obj + (smlist_else : 'smlist_else Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], (Gram.Action.mk - (fun _ (st : 'smlist) _ (_loc : Gram.Loc.t) -> - (st : 'else_macro_def)))) ]) ])) + (fun _ (st : 'smlist_else) _ (_loc : Gram.Loc.t) + -> (st : 'else_macro_def)))) ]) ])) ()); Gram.extend (else_macro_def_sig : 'else_macro_def_sig Gram.Entry.t) @@ -12967,12 +13214,13 @@ Added statements: ([] : 'else_macro_def_sig)))); ([ Gram.Skeyword "ELSE"; Gram.Snterm - (Gram.Entry.obj (sglist : 'sglist Gram.Entry.t)); + (Gram.Entry.obj + (sglist_else : 'sglist_else Gram.Entry.t)); Gram.Snterm (Gram.Entry.obj (endif : 'endif Gram.Entry.t)) ], (Gram.Action.mk - (fun _ (st : 'sglist) _ (_loc : Gram.Loc.t) -> - (st : 'else_macro_def_sig)))) ]) ])) + (fun _ (st : 'sglist_else) _ (_loc : Gram.Loc.t) + -> (st : 'else_macro_def_sig)))) ]) ])) ()); Gram.extend (else_expr : 'else_expr Gram.Entry.t) ((fun () -> @@ -12993,12 +13241,12 @@ Added statements: (fun _ (e : 'expr) _ (_loc : Gram.Loc.t) -> (e : 'else_expr)))) ]) ])) ()); - Gram.extend (smlist : 'smlist Gram.Entry.t) + Gram.extend (smlist_then : 'smlist_then Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Slist1 - (Gram.srules smlist + (Gram.srules smlist_then [ ([ Gram.Snterm (Gram.Entry.obj (str_item : @@ -13019,17 +13267,60 @@ Added statements: (semi : 'semi Gram.Entry.t)) ], (Gram.Action.mk (fun _ (d : 'macro_def) - (_loc : Gram.Loc.t) -> (d : 'e__18)))) ]) ], + (_loc : Gram.Loc.t) -> + (execute_macro_if_active_branch + _loc (Ast.StNil _loc) + (fun a b -> + Ast.StSem (_loc, a, b)) + Then d : + 'e__18)))) ]) ], (Gram.Action.mk (fun (sml : 'e__18 list) (_loc : Gram.Loc.t) -> - (sml : 'smlist)))) ]) ])) + (sml : 'smlist_then)))) ]) ])) ()); - Gram.extend (sglist : 'sglist Gram.Entry.t) + Gram.extend (smlist_else : 'smlist_else Gram.Entry.t) ((fun () -> (None, [ (None, None, [ ([ Gram.Slist1 - (Gram.srules sglist + (Gram.srules smlist_else + [ ([ 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 _ (si : 'str_item) + (_loc : Gram.Loc.t) -> + (SdStr si : 'e__19)))); + ([ Gram.Snterm + (Gram.Entry.obj + (macro_def : + 'macro_def Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (semi : 'semi Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (d : 'macro_def) + (_loc : Gram.Loc.t) -> + (execute_macro_if_active_branch + _loc (Ast.StNil _loc) + (fun a b -> + Ast.StSem (_loc, a, b)) + Else d : + 'e__19)))) ]) ], + (Gram.Action.mk + (fun (sml : 'e__19 list) (_loc : Gram.Loc.t) -> + (sml : 'smlist_else)))) ]) ])) + ()); + Gram.extend (sglist_then : 'sglist_then Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Slist1 + (Gram.srules sglist_then [ ([ Gram.Snterm (Gram.Entry.obj (sig_item : @@ -13040,7 +13331,7 @@ Added statements: (Gram.Action.mk (fun _ (si : 'sig_item) (_loc : Gram.Loc.t) -> - (SdStr si : 'e__19)))); + (SdStr si : 'e__20)))); ([ Gram.Snterm (Gram.Entry.obj (macro_def_sig : @@ -13050,10 +13341,53 @@ Added statements: (semi : 'semi Gram.Entry.t)) ], (Gram.Action.mk (fun _ (d : 'macro_def_sig) - (_loc : Gram.Loc.t) -> (d : 'e__19)))) ]) ], + (_loc : Gram.Loc.t) -> + (execute_macro_if_active_branch + _loc (Ast.SgNil _loc) + (fun a b -> + Ast.SgSem (_loc, a, b)) + Then d : + 'e__20)))) ]) ], (Gram.Action.mk - (fun (sgl : 'e__19 list) (_loc : Gram.Loc.t) -> - (sgl : 'sglist)))) ]) ])) + (fun (sgl : 'e__20 list) (_loc : Gram.Loc.t) -> + (sgl : 'sglist_then)))) ]) ])) + ()); + Gram.extend (sglist_else : 'sglist_else Gram.Entry.t) + ((fun () -> + (None, + [ (None, None, + [ ([ Gram.Slist1 + (Gram.srules sglist_else + [ ([ 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 _ (si : 'sig_item) + (_loc : Gram.Loc.t) -> + (SdStr si : 'e__21)))); + ([ Gram.Snterm + (Gram.Entry.obj + (macro_def_sig : + 'macro_def_sig Gram.Entry.t)); + Gram.Snterm + (Gram.Entry.obj + (semi : 'semi Gram.Entry.t)) ], + (Gram.Action.mk + (fun _ (d : 'macro_def_sig) + (_loc : Gram.Loc.t) -> + (execute_macro_if_active_branch + _loc (Ast.SgNil _loc) + (fun a b -> + Ast.SgSem (_loc, a, b)) + Else d : + 'e__21)))) ]) ], + (Gram.Action.mk + (fun (sgl : 'e__21 list) (_loc : Gram.Loc.t) -> + (sgl : 'sglist_else)))) ]) ])) ()); Gram.extend (endif : 'endif Gram.Entry.t) ((fun () -> @@ -13093,13 +13427,13 @@ Added statements: (_loc : Gram.Loc.t) -> (let x = Gram.Token.extract_string x - in x : 'e__20)))) ], + in x : 'e__22)))) ], Gram.Skeyword ","); Gram.Skeyword ")"; Gram.Skeyword "="; Gram.Snterm (Gram.Entry.obj (expr : 'expr Gram.Entry.t)) ], (Gram.Action.mk - (fun (e : 'expr) _ _ (pl : 'e__20 list) _ + (fun (e : 'expr) _ _ (pl : 'e__22 list) _ (_loc : Gram.Loc.t) -> (Some ((pl, e)) : 'opt_macro_value)))) ]) ])) ()); @@ -13931,6 +14265,9 @@ module B = let add_to_loaded_modules name = loaded_modules := SSet.add name !loaded_modules + let (objext, libext) = + if DynLoader.is_native then (".cmxs", ".cmxs") else (".cmo", ".cma") + let rewrite_and_load n x = let dyn_loader = !dyn_loader () in let find_in_path = DynLoader.find_in_path dyn_loader in @@ -13945,7 +14282,7 @@ module B = then () else (add_to_loaded_modules n; - DynLoader.load dyn_loader (n ^ ".cmo"))) + DynLoader.load dyn_loader (n ^ objext))) in ((match (n, (String.lowercase x)) with | (("Parsers" | ""), @@ -14006,8 +14343,6 @@ module B = 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 () @@ -14022,7 +14357,7 @@ module B = | (("Printers" | ""), ("a" | "auto" | "camlp4autoprinter.cmo")) -> load [ "Camlp4AutoPrinter" ] | _ -> - let y = "Camlp4" ^ (n ^ ("/" ^ (x ^ ".cmo"))) + let y = "Camlp4" ^ (n ^ ("/" ^ (x ^ objext))) in real_load (try find_in_path y with | Not_found -> x)); !rcall_callback ()) @@ -14098,7 +14433,8 @@ 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@."; +.%s Load this module inside the Camlp4 core@." + (if DynLoader.is_native then "cmx " else "(cmo|cma)"); Options.print_usage_list ini_sl; (* loop (ini_sl @ ext_sl) where rec loop = fun @@ -14209,10 +14545,10 @@ You should give the -noassert option to the ocaml compiler instead.@." if Filename.check_suffix name ".ml" then Impl name else - if Filename.check_suffix name ".cmo" + if Filename.check_suffix name objext then ModuleImpl name else - if Filename.check_suffix name ".cma" + if Filename.check_suffix name libext then ModuleImpl name else raise (Arg.Bad ("don't know what to do with " ^ name))) diff --git a/camlp4/camlp4fulllib.mllib b/camlp4/camlp4fulllib.mllib index 52c7099e..c7073c28 100644 --- a/camlp4/camlp4fulllib.mllib +++ b/camlp4/camlp4fulllib.mllib @@ -30,7 +30,6 @@ Camlp4Filters/Camlp4LocationStripper Camlp4Filters/Camlp4MapGenerator Camlp4Filters/Camlp4MetaGenerator Camlp4Filters/Camlp4Profiler -Camlp4Filters/Camlp4Tracer Camlp4Filters/Camlp4TrashRemover Camlp4Top diff --git a/camlp4/examples/_tags b/camlp4/examples/_tags index c35bcfbf..19b2d701 100644 --- a/camlp4/examples/_tags +++ b/camlp4/examples/_tags @@ -1,9 +1,11 @@ +true: warn_A, warn_e <{apply_operator,type_quotation,global_handler,expression_closure{,_filter}}.ml> or : camlp4rf, use_camlp4 "lambda_quot.ml": camlp4rf, use_camlp4_full -"lambda_quot_o.ml": camlp4of, use_camlp4_full +<{fancy_,}lambda_{quot,quot_{expr,patt},parser}.ml>: camlp4of, use_camlp4_full "macros.ml" or or "gen_match_case.ml": camlp4of, use_camlp4 "test_macros.ml": pp(camlp4of ./macros.cmo) "lambda_test.ml": pp(camlp4of ./lambda_quot_o.cmo) +"fancy_lambda_quot_test.ml": use_camlp4, pp(camlp4of ./fancy_lambda_quot.cmo) : camlp4of, use_camlp4_full, use_dynlink "test_type_quotation.ml": pp(camlp4of ./type_quotation.cmo) "apply_operator_test.ml": pp(camlp4o ./apply_operator.cmo) @@ -13,3 +15,5 @@ "syb_map.ml": pp(camlp4o -filter map), use_camlp4 "ex_str.ml": camlp4of, use_camlp4, use_camlp4_full "ex_str_test.ml": pp(camlp4o ./ex_str.cmo) +"poly_by_default.ml": camlp4of, use_camlp4 +"poly_by_default_test.ml": pp(camlp4of ./poly_by_default.cmo) diff --git a/camlp4/examples/fancy_lambda_quot.ml b/camlp4/examples/fancy_lambda_quot.ml new file mode 100644 index 00000000..be21fa2f --- /dev/null +++ b/camlp4/examples/fancy_lambda_quot.ml @@ -0,0 +1,159 @@ +(* module LambdaSyntax = struct + module Loc = Camlp4.PreCast.Loc + type 'a antiquotable = + | Val of Loc.t * 'a + | Ant of Loc.t * string + type term' = + | Lam of var * term + | App of term * term + | Var of var + | Int of int antiquotable + |+ Why you don't want an antiquotation case here: + * Basically it seems natural that since an antiquotation of expression + * can be at any expression place. One can be a + * .... in fact not I not against that... + | Anti of Loc.t * string + +| + and term = term' antiquotable + and var = string antiquotable +end *) +module Antiquotable = struct + module Loc = Camlp4.PreCast.Loc + type 'a t = + | Val of Loc.t * 'a + | Ant of Loc.t * string +end +module Identity_type_functor = struct + type 'a t = 'a +end +module MakeLambdaSyntax(Node : sig type 'a t end) = struct + type term' = + | Lam of var * term + | App of term * term + | Var of var + | Int of num + and term = term' Node.t + and num = int Node.t + and var = string Node.t +end +module AntiquotableLambdaSyntax = MakeLambdaSyntax(Antiquotable);; +module LambdaSyntax = MakeLambdaSyntax(Identity_type_functor);; +module LambdaParser = struct + open Antiquotable;; + open AntiquotableLambdaSyntax;; + open Camlp4.PreCast;; + + module LambdaGram = MakeGram(Lexer);; + + let term = LambdaGram.Entry.mk "term";; + let term_eoi = LambdaGram.Entry.mk "lambda term quotation";; + + Camlp4_config.antiquotations := true;; + + let mkLam _loc v t = Val(_loc, Lam(v, t));; + let mkApp _loc f x = Val(_loc, App(f, x));; + let mkVar _loc x = Val(_loc, Var(x));; + let mkInt _loc v = Val(_loc, Int(v));; + + EXTEND LambdaGram + GLOBAL: term term_eoi; + term: + [ "top" + [ "fun"; v = var; "->"; t = term -> mkLam _loc v t ] + | "app" + [ t1 = SELF; t2 = SELF -> mkApp _loc t1 t2 ] + | "simple" + [ `ANTIQUOT((""|"term"), a) -> Ant(_loc, a) + | i = int -> mkInt _loc i + | v = var -> mkVar _loc v + | "("; t = term; ")" -> t ] + ]; + var: + [[ v = LIDENT -> Val(_loc, v) + | `ANTIQUOT((""|"var"), a) -> Ant(_loc, a) + ]]; + int: + [[ `INT(i, _) -> Val(_loc, i) + | `ANTIQUOT((""|"int"), a) -> Ant(_loc, a) + ]]; + term_eoi: + [[ t = term; `EOI -> t ]]; + END;; + + let parse_string = LambdaGram.parse_string term_eoi +end +module LambdaLifter = struct + open Antiquotable;; + open AntiquotableLambdaSyntax;; + module CamlSyntax = + Camlp4OCamlParser.Make( + Camlp4OCamlRevisedParser.Make( + Camlp4.PreCast.Syntax + ) + );; + module Ast = Camlp4.PreCast.Ast + let expr_of_string = CamlSyntax.Gram.parse_string CamlSyntax.expr_eoi;; + let patt_of_string = CamlSyntax.Gram.parse_string CamlSyntax.patt_eoi;; + + (* + << fun x -> $3$ >> -> Lam(VAtom"x", 3) + + (* compilo.ml -pp lam.cmo *) + match t with + | << (fun $x$ -> $e1$) $e2$ >> -> << $subst ...$ >> + *) + + (* This part can be generated use SwitchValRepr *) + let rec term_to_expr = function + | Val(_loc, Lam(v, t)) -> <:expr< Lam($var_to_expr v$, $term_to_expr t$) >> + | Val(_loc, App(t1, t2)) -> <:expr< App($term_to_expr t1$, $term_to_expr t2$) >> + | Val(_loc, Var(v)) -> <:expr< Var($var_to_expr v$) >> + | Val(_loc, Int(i)) -> <:expr< Int($int_to_expr i$) >> + | Ant(_loc, a) -> expr_of_string _loc a + and var_to_expr = function + | Val(_loc, v) -> <:expr< $str:v$ >> + | Ant(_loc, s) -> expr_of_string _loc s + and int_to_expr = function + | Val(_loc, v) -> <:expr< $`int:v$ >> + | Ant(_loc, s) -> expr_of_string _loc s + ;; + + let rec term_to_patt = function + | Val(_loc, Lam(v, t)) -> <:patt< Lam($var_to_patt v$, $term_to_patt t$) >> + | Val(_loc, App(t1, t2)) -> <:patt< App($term_to_patt t1$, $term_to_patt t2$) >> + | Val(_loc, Var(v)) -> <:patt< Var($var_to_patt v$) >> + | Val(_loc, Int(i)) -> <:patt< Int($int_to_patt i$) >> + | Ant(_loc, a) -> patt_of_string _loc a + and var_to_patt = function + | Val(_loc, v) -> <:patt< $str:v$ >> + | Ant(_loc, s) -> patt_of_string _loc s + and int_to_patt = function + | Val(_loc, v) -> <:patt< $`int:v$ >> + | Ant(_loc, s) -> patt_of_string _loc s + ;; + + (* +Arrow(Var"a", Var"b") +<:typ< 'a -> 'b >> + + let a = ... + let b = ... + let ( ^-> ) t1 t2 = Arrow(t1, t2) + a ^-> b + *) +end +module LambadExpander = struct + module Q = Camlp4.PreCast.Syntax.Quotation;; + let expand_lambda_quot_expr loc _loc_name_opt quotation_contents = + LambdaLifter.term_to_expr + (LambdaParser.parse_string loc quotation_contents) + ;; + Q.add "lam" Q.DynAst.expr_tag expand_lambda_quot_expr;; + let expand_lambda_quot_patt loc _loc_name_opt quotation_contents = + LambdaLifter.term_to_patt + (LambdaParser.parse_string loc quotation_contents) + ;; + Q.add "lam" Q.DynAst.patt_tag expand_lambda_quot_patt;; + + Q.default := "lam";; +end diff --git a/camlp4/examples/fancy_lambda_quot_test.ml b/camlp4/examples/fancy_lambda_quot_test.ml new file mode 100644 index 00000000..32009828 --- /dev/null +++ b/camlp4/examples/fancy_lambda_quot_test.ml @@ -0,0 +1,22 @@ +open Fancy_lambda_quot.LambdaSyntax;; +let _loc = Camlp4.PreCast.Loc.ghost;; +let rec propagate = function + | << $f$ $x$ $y$ >> -> + begin match propagate f, propagate x, propagate y with + | f, << $int:i$ >>, << $int:j$ >> -> + begin match f with + | << plus >> -> << $int:i + j$ >> + | << minus >> -> << $int:i - j$ >> + | << times >> -> << $int:i * j$ >> + | << div >> -> << $int:i / j$ >> + | _ -> << $f$ $int:i$ $int:j$ >> + end + | f, x, y -> << $f$ $x$ $y$ >> + end + | << $f$ $x$ >> -> << $propagate f$ $propagate x$ >> + | << fun $x$ -> $e$ >> -> << fun $x$ -> $propagate e$ >> (* here x should not be a primitive like plus *) + | << $var:_$ >> | << $int:_$ >> as e -> e +;; + +let ex1 = propagate << f (fun x -> g (plus 3 (times 4 42)) (minus 1 (x 3))) >> +;; diff --git a/camlp4/examples/free_vars_test.ml b/camlp4/examples/free_vars_test.ml index 793d99fd..be01edc1 100644 --- a/camlp4/examples/free_vars_test.ml +++ b/camlp4/examples/free_vars_test.ml @@ -66,5 +66,7 @@ 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 >>; +fv << let f x = x and g x = x in x >> << x >>; +fv << let (x, y) = (42, 44) in x y z >> << z >>; printf "@]@."; diff --git a/camlp4/examples/gettext_test.ml b/camlp4/examples/gettext_test.ml new file mode 100644 index 00000000..27f6ceed --- /dev/null +++ b/camlp4/examples/gettext_test.ml @@ -0,0 +1 @@ +f "test", f "foo", "bar" diff --git a/camlp4/examples/lambda_parser.ml b/camlp4/examples/lambda_parser.ml new file mode 100644 index 00000000..9c709767 --- /dev/null +++ b/camlp4/examples/lambda_parser.ml @@ -0,0 +1,34 @@ +(* Please keep me in sync with brion.inria.fr/gallium/index.php/Lambda_calculus_quotations *) + +type term = + | Lam of var * term + | App of term * term + | Int of int + | Var of var +and var = string + +module LambdaGram = Camlp4.PreCast.MakeGram(Camlp4.PreCast.Lexer);; +module Loc = Camlp4.PreCast.Loc;; (* should not be necessary when camlp4 will be fixed *) +open Camlp4.Sig;; (* from tokens *) +let term = LambdaGram.Entry.mk "term";; +let term_eoi = LambdaGram.Entry.mk "lambda term quotation";; + +EXTEND LambdaGram + GLOBAL: term term_eoi; + term: + [ "top" + [ "fun"; v = var; "->"; t = term -> Lam(v, t) ] + | "app" + [ t1 = SELF; t2 = SELF -> App(t1, t2) ] + | "simple" + [ v = var -> Var(v) + | `INT(i, _) -> Int(i) + | "("; t = term; ")" -> t ] + ]; + var: + [[ `LIDENT v -> v ]]; + term_eoi: + [[ t = term; `EOI -> t ]]; +END;; + +let lambda_parser = LambdaGram.parse_string term_eoi;; diff --git a/camlp4/examples/lambda_quot_expr.ml b/camlp4/examples/lambda_quot_expr.ml index 3b51f47f..98922123 100644 --- a/camlp4/examples/lambda_quot_expr.ml +++ b/camlp4/examples/lambda_quot_expr.ml @@ -35,6 +35,7 @@ END;; let expand_lambda_quot_expr loc _loc_name_opt quotation_contents = LambdaGram.parse_string term_eoi loc quotation_contents;; +(* to have this syntax <:lam< fun k -> k >> *) Syntax.Quotation.add "lam" Syntax.Quotation.DynAst.expr_tag expand_lambda_quot_expr;; Syntax.Quotation.default := "lam";; diff --git a/camlp4/examples/lambda_quot_patt.ml b/camlp4/examples/lambda_quot_patt.ml new file mode 100644 index 00000000..e6732dd3 --- /dev/null +++ b/camlp4/examples/lambda_quot_patt.ml @@ -0,0 +1,41 @@ +(* Please keep me in sync with brion.inria.fr/gallium/index.php/Lambda_calculus_quotations *) + +open Camlp4.PreCast;; +module CamlSyntax = Camlp4OCamlParser.Make(Camlp4OCamlRevisedParser.Make(Syntax));; + +let patt_of_string = CamlSyntax.Gram.parse_string CamlSyntax.patt_eoi;; + +module LambdaGram = MakeGram(Lexer);; + +let term = LambdaGram.Entry.mk "term";; +let term_eoi = LambdaGram.Entry.mk "lambda term quotation";; + +Camlp4_config.antiquotations := true;; + +EXTEND LambdaGram + GLOBAL: term term_eoi; + term: + [ "top" + [ "fun"; v = var; "->"; t = term -> <:patt< `Lam($v$, $t$) >> ] + | "app" + [ t1 = SELF; t2 = SELF -> <:patt< `App($t1$, $t2$) >> ] + | "simple" + [ `ANTIQUOT((""|"term"), a) -> patt_of_string _loc a + | v = var -> <:patt< `Var($v$) >> + | "("; t = term; ")" -> t ] + ]; + var: + [[ v = LIDENT -> <:patt< $str:v$ >> + | `ANTIQUOT((""|"var"), a) -> patt_of_string _loc a + ]]; + term_eoi: + [[ t = term; `EOI -> t ]]; +END;; + +let expand_lambda_quot_patt loc _loc_name_opt quotation_contents = + LambdaGram.parse_string term_eoi loc quotation_contents;; + +(* function <:lam< fun x -> $(t|u)$ >> -> ... *) +Syntax.Quotation.add "lam" Syntax.Quotation.DynAst.patt_tag expand_lambda_quot_patt;; + +Syntax.Quotation.default := "lam";; diff --git a/camlp4/mkcamlp4.ml b/camlp4/mkcamlp4.ml index e231954c..c741f6aa 100644 --- a/camlp4/mkcamlp4.ml +++ b/camlp4/mkcamlp4.ml @@ -17,7 +17,7 @@ * - Nicolas Pouillard: rewriting in OCaml *) -(* $Id: mkcamlp4.ml,v 1.3 2007/02/07 10:09:21 ertai Exp $ *) +(* $Id: mkcamlp4.ml,v 1.4 2008/10/03 15:50:09 ertai Exp $ *) open Camlp4; open Camlp4_config; @@ -61,7 +61,7 @@ try do { close_out cout }; - run (["ocamlc"; "-I"; camlp4_standard_library; "Camlp4.cma"; crc_ml] + run (["ocamlc"; "-I"; camlp4_standard_library; "camlp4lib.cma"; crc_ml] @ includes @ options @ ["Camlp4Bin.cmo"; "-linkall"]); clean(); } diff --git a/config/Makefile-templ b/config/Makefile-templ index 515c2ec5..f672be16 100644 --- a/config/Makefile-templ +++ b/config/Makefile-templ @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile-templ,v 1.30 2006/08/18 14:52:19 xleroy Exp $ +# $Id: Makefile-templ,v 1.31 2007/10/30 12:37:16 xleroy Exp $ ### Compile-time configuration @@ -180,26 +180,19 @@ SHARPBANGSCRIPTS=true # at run-time for shared libraries #NATIVECCRPATH=-Wl,-rpath -### Flags for the assembler +### Command and flags to use for assembling ocamlopt-generated code # For the Alpha or the Mips: -#ASFLAGS=-O2 +#AS=as -O2 # For the PowerPC: -#ASFLAGS=-u -m ppc -w -# For the RS6000: -#ASFLAGS=-u -m pwr -w +#AS=as -u -m ppc -w # Otherwise: -#ASFLAGS= +#AS=as ### Command and flags to use for assembling .S files (often with preprocessing) # If gcc is available: -#ASPP=gcc -#ASPPFLAGS=-c -DSYS_$(SYSTEM) +#ASPP=gcc -c # On SunOS and Solaris: -#ASPP=$(AS) -#ASPPFLAGS=-P -DSYS_$(SYSTEM) -# Otherwise: -#ASPP=$(AS) -#ASPPFLAGS= +#ASPP=as -P ### Extra flags to use for assembling .S files in profiling mode # On Digital Unix: diff --git a/config/Makefile.mingw b/config/Makefile.mingw index 34db3c0f..a2e33ff1 100644 --- a/config/Makefile.mingw +++ b/config/Makefile.mingw @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile.mingw,v 1.19 2007/03/01 14:48:53 xleroy Exp $ +# $Id: Makefile.mingw,v 1.27 2008/07/29 08:31:41 xleroy Exp $ # Configuration for Windows, Mingw compiler @@ -61,16 +61,16 @@ SHAREDCCCOMPOPTS= MKSHAREDLIBRPATH= NATIVECCPROFOPTS= NATIVECCRPATH= -ASFLAGS= -ASPP= -ASPPFLAGS= +ASM=as +ASPP=gcc ASPPPROFFLAGS= PROFILING=noprof DYNLINKOPTS= -DEBUGGER= +DEBUGGER=ocamldebugger CC_PROFILE= SYSTHREAD_SUPPORT=true EXTRALIBS= +CMXS=cmxs ########## Configuration for the bytecode compiler @@ -87,19 +87,19 @@ BYTECCLINKOPTS= DLLCCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused -DCAML_DLL ### Libraries needed -BYTECCLIBS= -NATIVECCLIBS= +BYTECCLIBS=-lws2_32 +NATIVECCLIBS=-lws2_32 ### 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;; +### Flexlink +FLEXLINK=flexlink -chain mingw +FLEXDIR=$(shell $(FLEXLINK) -where) +IFLEXDIR=-I"$(FLEXDIR)" +MKDLL=$(FLEXLINK) +MKEXE=$(FLEXLINK) -exe +MKMAINDLL=$(FLEXLINK) -maindll ### How to build a static library MKLIB=rm -f $(1); ar rcs $(1) $(2) @@ -134,12 +134,11 @@ NATIVECCCOMPOPTS=-O -mms-bitfields -Wall -Wno-unused NATIVECCLINKOPTS= ### Build partially-linked object file -PARTIALLD=ld -r $(NATIVECCLINKOPTS) -PACKLD=$(PARTIALLD) -o #there must be a space after this '-o' +PACKLD=ld -r $(NATIVECCLINKOPTS) -o #there must be a space after this '-o' ############# Configuration for the contributed libraries -OTHERLIBRARIES=win32unix systhreads str num win32graph dynlink bigarray labltk +OTHERLIBRARIES=win32unix str num win32graph dynlink bigarray systhreads labltk ### Name of the target architecture for the "num" library BNG_ARCH=ia32 @@ -150,7 +149,8 @@ BNG_ASM_LEVEL=1 # 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/tk84.lib $(TK_ROOT)/lib/tcl84.lib +TK_LINK=$(TK_ROOT)/bin/tk83.dll $(TK_ROOT)/bin/tcl83.dll -lws2_32 +#TK_LINK=$(TK_ROOT)/lib/tk84.lib $(TK_ROOT)/lib/tcl84.lib -lws2_32 ############# Aliases for common commands diff --git a/config/Makefile.msvc b/config/Makefile.msvc index a9ad26e6..bfea63cb 100644 --- a/config/Makefile.msvc +++ b/config/Makefile.msvc @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile.msvc,v 1.21.2.3 2007/10/25 09:31:54 xleroy Exp $ +# $Id: Makefile.msvc,v 1.30 2008/07/29 08:31:41 xleroy Exp $ # Configuration for Windows, Visual C++ compiler @@ -60,16 +60,16 @@ SUPPORTS_SHARED_LIBRARIES=true SHAREDCCCOMPOPTS= NATIVECCPROFOPTS= NATIVECCRPATH= -ASFLAGS= +ASM=ml /nologo /coff /Cp /c /Fo ASPP= -ASPPFLAGS= ASPPPROFFLAGS= PROFILING=noprof DYNLINKOPTS= -DEBUGGER= +DEBUGGER=ocamldebugger CC_PROFILE= SYSTHREAD_SUPPORT=true EXTRALIBS= +CMXS=cmxs ########## Configuration for the bytecode compiler @@ -77,36 +77,28 @@ EXTRALIBS= BYTECC=cl /nologo -D_CRT_SECURE_NO_DEPRECATE ### Additional compile-time options for $(BYTECC). (For static linking.) -BYTECCCOMPOPTS=/Ox /MT +BYTECCCOMPOPTS=/Ox /MD ### Additional link-time options for $(BYTECC). (For static linking.) -BYTECCLINKOPTS=/MT /F16777216 +BYTECCLINKOPTS=/MD /F16777216 ### Additional compile-time options for $(BYTECC). (For building a DLL.) -DLLCCCOMPOPTS=/Ox /MD -DCAML_DLL +DLLCCCOMPOPTS=/Ox /MD ### Libraries needed -BYTECCLIBS=advapi32.lib -NATIVECCLIBS=advapi32.lib +BYTECCLIBS=advapi32.lib ws2_32.lib +NATIVECCLIBS=advapi32.lib ws2_32.lib ### How to invoke the C preprocessor CPP=cl /nologo /EP -### How to merge a .manifest (if any) in a .exe -MERGEMANIFESTEXE=test ! -f $(1).manifest || mt -nologo -outputresource:$(1) -manifest $(1).manifest && rm -f $(1).manifest -#ml let mergemanifestexe 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) && ($(MERGEMANIFESTEXE)) -#ml let mkexe out files opts = Printf.sprintf "%s /Fe%s %s %s && (%s)" bytecc out opts files (mergemanifestexe out);; - -### How to merge a .manifest (if any) in a .dll -MERGEMANIFESTDLL=test ! -f $(1).manifest || mt -nologo -outputresource:"$(1);\#2" -manifest $(1).manifest && rm -f $(1).manifest -#ml let mergemanifestdll out = Printf.sprintf "test ! -f %s.manifest || mt -nologo -outputresource:\"%s;\\#2\" -manifest %s.manifest && rm -f %s.manifest" out out out out;; - -### How to build a DLL -MKDLL=link /nologo /dll /out:$(1) /implib:$(2) $(3) && ($(MERGEMANIFESTDLL)) -#ml let mkdll out implib files opts = Printf.sprintf "link /nologo /dll /out:%s /implib:%s %s %s && (%s)" out implib opts files (mergemanifestdll out);; +### Flexlink +FLEXLINK=flexlink -merge-manifest +FLEXDIR=$(shell $(FLEXLINK) -where) +IFLEXDIR=-I"$(FLEXDIR)" +MKDLL=$(FLEXLINK) +MKEXE=$(FLEXLINK) -exe +MKMAINDLL=$(FLEXLINK) -maindll ### How to build a static library MKLIB=link /lib /nologo /out:$(1) $(2) @@ -118,7 +110,7 @@ SYSLIB=$(1).lib #ml let syslib x = x ^ ".lib";; ### The ranlib command -RANLIB= +RANLIB=echo RANLIBCMD= ############# Configuration for the native-code compiler @@ -136,13 +128,12 @@ SYSTEM=win32 NATIVECC=cl /nologo -D_CRT_SECURE_NO_DEPRECATE ### Additional compile-time options for $(NATIVECC). -NATIVECCCOMPOPTS=/Ox /MT +NATIVECCCOMPOPTS=/Ox /MD ### Additional link-time options for $(NATIVECC) -NATIVECCLINKOPTS=/MT /F16777216 +NATIVECCLINKOPTS=/MD /F16777216 ### Build partially-linked object file -PARTIALLD=link /lib /nologo PACKLD=link /lib /nologo /out:# there must be no space after this '/out:' ############# Configuration for the contributed libraries @@ -161,10 +152,11 @@ 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=tk84.lib tcl84.lib +#TK_LINK=tk84.lib tcl84.lib ws2_32.lib +TK_LINK=tk83.lib tcl83.lib ws2_32.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 +# TK_LINK=$(TK_ROOT)/tk83.lib $(TK_ROOT)/tcl83.lib ws2_32.lib ############# Aliases for common commands diff --git a/config/Makefile.msvc64 b/config/Makefile.msvc64 index 4d26ec50..d409347c 100644 --- a/config/Makefile.msvc64 +++ b/config/Makefile.msvc64 @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile.msvc64,v 1.6.2.1 2007/10/25 09:31:54 xleroy Exp $ +# $Id: Makefile.msvc64,v 1.13 2008/07/29 08:31:41 xleroy Exp $ # Configuration for Windows, Visual C++ compiler @@ -61,15 +61,15 @@ SUPPORTS_SHARED_LIBRARIES=true SHAREDCCCOMPOPTS= NATIVECCPROFOPTS= NATIVECCRPATH= -ASFLAGS= +ASM=ml64 /nologo /Cp /c /Fo ASPP= -ASPPFLAGS= ASPPPROFFLAGS= PROFILING=noprof DYNLINKOPTS= -DEBUGGER= +DEBUGGER=ocamldebugger CC_PROFILE= SYSTHREAD_SUPPORT=true +CMXS=cmxs ########## Configuration for the bytecode compiler @@ -77,36 +77,32 @@ SYSTHREAD_SUPPORT=true BYTECC=cl /nologo -D_CRT_SECURE_NO_DEPRECATE ### Additional compile-time options for $(BYTECC). (For static linking.) -BYTECCCOMPOPTS=/Ox /MT +BYTECCCOMPOPTS=/Ox /MD ### 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 /F33554432 +BYTECCLINKOPTS=/MD /F33554432 ### Additional compile-time options for $(BYTECC). (For building a DLL.) -DLLCCCOMPOPTS=/Ox /MD -DCAML_DLL +DLLCCCOMPOPTS=/Ox /MD ### Libraries needed EXTRALIBS=bufferoverflowu.lib -BYTECCLIBS=advapi32.lib $(EXTRALIBS) -NATIVECCLIBS=advapi32.lib $(EXTRALIBS) +BYTECCLIBS=advapi32.lib ws2_32.lib $(EXTRALIBS) +NATIVECCLIBS=advapi32.lib ws2_32.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);; +### Flexlink +FLEXLINK=flexlink -x64 -merge-manifest +FLEXDIR=$(shell $(FLEXLINK) -where) +IFLEXDIR=-I"$(FLEXDIR)" +MKDLL=$(FLEXLINK) +MKEXE=$(FLEXLINK) -exe +MKMAINDLL=$(FLEXLINK) -maindll ### How to build a static library MKLIB=link /lib /nologo /machine:AMD64 /out:$(1) $(2) @@ -118,7 +114,7 @@ SYSLIB=$(1).lib #ml let syslib x = x ^ ".lib";; ### The ranlib command -RANLIB= +RANLIB=echo RANLIBCMD= ############# Configuration for the native-code compiler @@ -136,13 +132,12 @@ SYSTEM=win64 NATIVECC=cl /nologo ### Additional compile-time options for $(NATIVECC). -NATIVECCCOMPOPTS=/Ox /MT +NATIVECCCOMPOPTS=/Ox /MD ### Additional link-time options for $(NATIVECC) -NATIVECCLINKOPTS=/MT /F33554432 +NATIVECCLINKOPTS=/MD /F33554432 ### 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 diff --git a/config/auto-aux/stackov.c b/config/auto-aux/stackov.c index b5e52142..2ef87130 100644 --- a/config/auto-aux/stackov.c +++ b/config/auto-aux/stackov.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: stackov.c,v 1.4.18.1 2007/11/06 12:26:15 xleroy Exp $ */ +/* $Id: stackov.c,v 1.5 2008/01/11 16:13:16 doligez Exp $ */ #include #include diff --git a/configure b/configure index 110b321c..748f1cef 100755 --- a/configure +++ b/configure @@ -13,7 +13,7 @@ # # ######################################################################### -# $Id: configure,v 1.244.4.7 2008/01/04 13:26:38 doligez Exp $ +# $Id: configure,v 1.266 2008/10/06 13:31:47 doligez Exp $ configure_options="$*" prefix=/usr/local @@ -23,6 +23,8 @@ mandir='' manext=1 host_type=unknown ccoption='' +asoption='' +asppoption='' cclibs='' curseslibs='' mathlib='-lm' @@ -73,6 +75,10 @@ while : ; do host_type=$2; shift;; -cc*) ccoption="$2"; shift;; + -as) + asoption="$2"; shift;; + -aspp) + asppoption="$2"; shift;; -lib*) cclibs="$2 $cclibs"; shift;; -no-curses) @@ -233,10 +239,13 @@ esac # Configure the bytecode compiler bytecc="$cc" +mkexe="\$(BYTECC)" bytecccompopts="" bytecclinkopts="" +dllccompopts="" ostype="Unix" exe="" +iflexdir="" case "$bytecc,$host" in cc,*-*-nextstep*) @@ -291,6 +300,11 @@ case "$bytecc,$host" in bytecccompopts="-D_XOPEN_SOURCE=500";; gcc*,*-*-cygwin*) bytecccompopts="-fno-defer-pop $gcc_warnings -U_WIN32" + dllccompopts="-D_WIN32 -DCAML_DLL" + flexlink="flexlink -chain cygwin -merge-manifest" + flexdir=`$flexlink -where | dos2unix` + iflexdir="-I\"$flexdir\"" + mkexe="$flexlink -exe" exe=".exe" ostype="Cygwin";; gcc*,x86_64-*-linux*) @@ -485,27 +499,36 @@ sharedcccompopts='' mksharedlib='' byteccrpath='' mksharedlibrpath='' +natdynlinkopts="" +cmxs="cmxa" if test $withsharedlibs = "yes"; then case "$host" in - *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*|*-*-netbsd*|*-*-gnu*) + *-*-cygwin*) + cmxs="cmxs" + mksharedlib="$flexlink" + mkmaindll="$flexlink -maindll" + shared_libraries_supported=true;; + *-*-linux-gnu|*-*-linux|*-*-freebsd[3-9]*|*-*-openbsd*|*-*-netbsd*|*-*-gnu*) + cmxs="cmxs" sharedcccompopts="-fPIC" - mksharedlib="$bytecc -shared -o" + mksharedlib="$bytecc -shared" bytecclinkopts="$bytecclinkopts -Wl,-E" byteccrpath="-Wl,-rpath," mksharedlibrpath="-Wl,-rpath," + natdynlinkopts="-Wl,-E" shared_libraries_supported=true;; alpha*-*-osf*) case "$bytecc" in gcc*) sharedcccompopts="-fPIC" - mksharedlib="$bytecc -shared -o" + mksharedlib="$bytecc -shared" byteccrpath="-Wl,-rpath," mksharedlibrpath="-Wl,-rpath," shared_libraries_supported=true;; cc*) sharedcccompopts="" - mksharedlib="ld -shared -expect_unresolved '*' -o" + mksharedlib="ld -shared -expect_unresolved '*'" byteccrpath="-Wl,-rpath," mksharedlibrpath="-rpath " shared_libraries_supported=true;; @@ -515,12 +538,13 @@ if test $withsharedlibs = "yes"; then gcc*) sharedcccompopts="-fPIC" if sh ./solaris-ld; then - mksharedlib="$bytecc -shared -o" + mksharedlib="$bytecc -shared" byteccrpath="-R" mksharedlibrpath="-R" else - mksharedlib="$bytecc -shared -o" + mksharedlib="$bytecc -shared" bytecclinkopts="$bytecclinkopts -Wl,-E" + natdynlinkopts="-Wl,-E" byteccrpath="-Wl,-rpath," mksharedlibrpath="-Wl,-rpath," fi @@ -529,7 +553,7 @@ if test $withsharedlibs = "yes"; then sharedcccompopts="-KPIC" byteccrpath="-R" mksharedlibrpath="-R" - mksharedlib="/usr/ccs/bin/ld -G -o" + mksharedlib="/usr/ccs/bin/ld -G" shared_libraries_supported=true;; esac;; mips*-*-irix[56]*) @@ -537,26 +561,45 @@ if test $withsharedlibs = "yes"; then cc*) sharedcccompopts="";; gcc*) sharedcccompopts="-fPIC";; esac - mksharedlib="ld -shared -rdata_shared -o" + mksharedlib="ld -shared -rdata_shared" byteccrpath="-Wl,-rpath," mksharedlibrpath="-rpath " shared_libraries_supported=true;; + i[3456]86-*-darwin*) + dyld=ld + if test -f /usr/bin/ld_classic; then + # The new linker in Mac OS X 10.5 does not support read_only_relocs + # dyld=/usr/bin/ld_classic XXX FIXME incompatible with X11 libs + : + fi + mksharedlib="$dyld -bundle -flat_namespace -undefined suppress -read_only_relocs suppress" + bytecccompopts="$dl_defs $bytecccompopts" + dl_needs_underscore=false + shared_libraries_supported=true;; *-apple-darwin*) - mksharedlib="$bytecc -bundle -flat_namespace -undefined suppress -o" + mksharedlib="$bytecc -bundle -flat_namespace -undefined suppress" bytecccompopts="$dl_defs $bytecccompopts" #sharedcccompopts="-fnocommon" - dl_needs_underscore=true + dl_needs_underscore=false + shared_libraries_supported=true;; + m88k-*-openbsd*) + shared_libraries_supported=false;; + vax-*-openbsd*) + shared_libraries_supported=false;; + *-*-openbsd*) + sharedcccompopts="-fPIC" + mksharedlib="$bytecc -shared" + bytecclinkopts="$bytecclinkopts -Wl,-E" + natdynlinkopts="-Wl,-E" + byteccrpath="-Wl,-rpath," + mksharedlibrpath="-Wl,-rpath," shared_libraries_supported=true;; esac fi -# Further machine-specific hacks - -case "$host" in - ia64-*-linux*|alpha*-*-linux*|x86_64-*-linux*|sparc64-*-linux*) - echo "Will use mmap() instead of malloc() for allocation of major heap chunks." - echo "#define USE_MMAP_INSTEAD_OF_MALLOC" >> s.h;; -esac +if test -z "$mkmaindll"; then + mkmaindll=$mksharedlib +fi # Configure the native-code compiler @@ -645,40 +688,46 @@ case "$arch,$nativecc,$system,$host_type" in *,gcc*,*,*) nativecccompopts="$gcc_warnings";; esac -asflags='' -aspp='' -asppflags='' asppprofflags='-DPROFILING' case "$arch,$model,$system" in - alpha,*,digital) aspp='as'; asflags='-O2'; asppflags='-O2 -DSYS_$(SYSTEM)'; + alpha,*,digital) as='as -O2 -nocpp' + aspp='as -O2' asppprofflags='-pg -DPROFILING';; - alpha,*,linux) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; - alpha,*,gnu) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; - alpha,*,freebsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; - alpha,*,netbsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; - alpha,*,openbsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; - mips,*,irix) aspp='as'; asflags='-n32 -O2'; asppflags="$asflags";; - sparc,*,bsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; - sparc,*,linux) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; - sparc,*,gnu) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; - sparc,*,*) case "$cc" in - gcc*) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; - *) aspp='as'; asppflags='-P -DSYS_$(SYSTEM)';; + alpha,*,*) as='as' + aspp='gcc -c';; + amd64,*,*) as='as' + aspp='gcc -c';; + arm,*,*) as='as'; + aspp='gcc -c';; + hppa,*,*) as='as'; + aspp='gcc -traditional -c';; + i386,*,solaris) as='as' + aspp='/usr/ccs/bin/as -P';; + i386,*,*) as='as' + aspp='gcc -c';; + ia64,*,*) as='as -xexplicit' + aspp='gcc -c -Wa,-xexplicit';; + mips,*,irix) as='as -n32 -O2 -nocpp -g0' + aspp='as -n32 -O2';; + power,*,elf) as='as -u -m ppc' + aspp='gcc -c';; + power,*,bsd) as='as' + aspp='gcc -c';; + power,*,rhapsody) as="as -arch $model" + aspp="$bytecc -c";; + sparc,*,solaris) as='as' + case "$cc" in + gcc*) aspp='gcc -c';; + *) aspp='as -P';; esac;; - i386,*,solaris) aspp='/usr/ccs/bin/as'; asppflags='-P -DSYS_$(SYSTEM)';; - i386,*,*) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; - hppa,*,*) aspp="$cc"; asppflags='-traditional -c -DSYS_$(SYSTEM)';; - power,*,elf) aspp='gcc'; asppflags='-c';; - power,*,bsd) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; - 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 - aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM) -Wa,-xexplicit';; - amd64,*,*) aspp='gcc'; asppflags='-c -DSYS_$(SYSTEM)';; + sparc,*,*) as='as' + aspp='gcc -c';; esac +if test -n "$asoption"; then as="$asoption"; fi +if test -n "$asppoption"; then aspp="$asppoption"; fi + cc_profile='-pg' case "$arch,$model,$system" in alpha,*,digital) profiling='prof';; @@ -988,10 +1037,8 @@ if sh ./hasgot -i locale.h && sh ./hasgot setlocale; then echo "#define HAS_LOCALE" >> s.h fi -if sh ./hasgot -i mach-o/dyld.h && sh ./hasgot NSLinkModule; then - echo "NSLinkModule() found. Using darwin dynamic loading." - echo "#define HAS_NSLINKMODULE" >> s.h -elif sh ./hasgot $dllib dlopen; then + +if sh ./hasgot $dllib dlopen; then echo "dlopen() found." elif sh ./hasgot $dllib -ldl dlopen; then echo "dlopen() found in -ldl." @@ -1238,8 +1285,11 @@ do if test $dir = /usr/lib; then x11_link="-lX11" else - x11_link="-L$dir -lX11" x11_libs="-L$dir" + case "$host" in + *-*-*bsd*) x11_link="-R$dir -L$dir -lX11";; + *) x11_link="-L$dir -lX11";; + esac fi break fi @@ -1333,6 +1383,9 @@ if test $has_tk = true; then tcl_version=`sh ./runtest $tk_defs $tk_x11_include tclversion.c` for tk_incs in \ "-I/usr/local/include" \ + "-I/usr/include" \ + "-I/usr/local/include/tcl8.5 -I/usr/local/include/tk8.5" \ + "-I/usr/include/tcl8.5 -I/usr/include/tk8.5" \ "-I/usr/local/include/tcl8.4 -I/usr/local/include/tk8.4" \ "-I/usr/include/tcl8.4 -I/usr/include/tk8.4" \ "-I/usr/local/include/tcl8.3 -I/usr/local/include/tk8.3" \ @@ -1355,6 +1408,7 @@ if test $has_tk = true; then 8.2) tclmaj=8 tclmin=2 tkmaj=8 tkmin=2 ;; 8.3) tclmaj=8 tclmin=3 tkmaj=8 tkmin=3 ;; 8.4) tclmaj=8 tclmin=4 tkmaj=8 tkmin=4 ;; + 8.5) tclmaj=8 tclmin=5 tkmaj=8 tkmin=5 ;; *) echo "This version is not known."; has_tk=false ;; esac else @@ -1390,7 +1444,10 @@ if test $has_tk = true; then -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" + case "$host" in + *-*-*bsd*) tk_libs="-R/usr/pkg/lib -L/usr/pkg/lib $tk_libs $tk_x11_libs -ltk$tkmaj$tkmin -ltcl$tclmaj$tclmin -lpthread $tkauxlibs";; + *) tk_libs="-L/usr/pkg/lib $tk_libs $tk_x11_libs -ltk$tkmaj$tkmin -ltcl$tclmaj$tclmin -lpthread $tkauxlibs";; + esac else echo "Tcl library not found." has_tk=false @@ -1401,11 +1458,17 @@ 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" + case "$host" in + *-*-*bsd*) tk_libs="-R/sw/lib -L/sw/lib $tk_libs";; + *) tk_libs="-L/sw/lib $tk_libs";; + esac 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" + case "$host" in + *-*-*bsd*) tk_libs="-R/usr/pkg/lib -L/usr/pkg/lib $tk_libs";; + *) tk_libs="-L/usr/pkg/lib $tk_libs";; + esac echo "Tcl/Tk libraries found." else echo "Tcl library found." @@ -1451,17 +1514,11 @@ echo "EXE=$exe" >> Makefile echo "SUPPORTS_SHARED_LIBRARIES=$shared_libraries_supported" >> Makefile echo "SHAREDCCCOMPOPTS=$sharedcccompopts" >> Makefile echo "MKSHAREDLIBRPATH=$mksharedlibrpath" >> Makefile +echo "NATDYNLINKOPTS=$natdynlinkopts" >> Makefile cat >> Makefile <> Makefile echo "NATIVECCLINKOPTS=$nativecclinkopts" >> Makefile echo "NATIVECCRPATH=$nativeccrpath" >> Makefile echo "NATIVECCLIBS=$cclibs $dllib" >> Makefile -echo "ASFLAGS=$asflags" >> Makefile +echo "ASM=$as" >> Makefile echo "ASPP=$aspp" >> Makefile -echo "ASPPFLAGS=$asppflags" >> Makefile echo "ASPPPROFFLAGS=$asppprofflags" >> Makefile echo "PROFILING=$profiling" >> Makefile echo "DYNLINKOPTS=$dllib" >> Makefile @@ -1486,9 +1542,12 @@ echo "DEBUGGER=$debugger" >> Makefile echo "CC_PROFILE=$cc_profile" >> Makefile echo "SYSTHREAD_SUPPORT=$systhread_support" >> Makefile echo "PARTIALLD=$partialld" >> Makefile -echo "DLLCCCOMPOPTS=" >> Makefile +echo "PACKLD=\$(PARTIALLD) \$(NATIVECCLINKOPTS) -o " >> Makefile +echo "DLLCCCOMPOPTS=$dllccompopts" >> Makefile +echo "IFLEXDIR=$iflexdir" >> Makefile echo "O=o" >> Makefile echo "A=a" >> Makefile +echo "SO=so" >> Makefile echo "EXT_OBJ=.o" >> Makefile echo "EXT_ASM=.s" >> Makefile echo "EXT_LIB=.a" >> Makefile @@ -1496,6 +1555,10 @@ echo "EXT_DLL=.so" >> Makefile echo "EXTRALIBS=" >> Makefile echo "CCOMPTYPE=cc" >> Makefile echo "TOOLCHAIN=cc" >> Makefile +echo "CMXS=$cmxs" >> Makefile +echo "MKEXE=$mkexe" >> Makefile +echo "MKDLL=$mksharedlib" >> Makefile +echo "MKMAINDLL=$mkmaindll" >> Makefile rm -f tst hasgot.c rm -f ../m.h ../s.h ../Makefile @@ -1518,7 +1581,7 @@ echo " options for linking....... $bytecclinkopts $cclibs $dllib $cursesl if $shared_libraries_supported; then echo " shared libraries are supported" echo " options for compiling..... $sharedcccompopts $bytecccompopts" -echo " command for building...... $mksharedlib lib.so $mksharedlibrpath/a/path objs" +echo " command for building...... $mksharedlib -o lib.so $mksharedlibrpath/a/path objs" else echo " shared libraries not supported" fi @@ -1538,8 +1601,8 @@ else echo " C compiler used........... $nativecc" echo " options for compiling..... $nativecccompopts" echo " options for linking....... $nativecclinkopts $cclibs" - echo " assembler ................ \$(AS) $asflags" - echo " preprocessed assembler ... $aspp $asppflags" + echo " assembler ................ $as" + echo " preprocessed assembler ... $aspp" if test "$profiling" = "prof"; then echo " profiling with gprof ..... supported" else diff --git a/debugger/.depend b/debugger/.depend index f56903a3..afac5c0d 100644 --- a/debugger/.depend +++ b/debugger/.depend @@ -1,15 +1,22 @@ breakpoints.cmi: primitives.cmi ../bytecomp/instruct.cmi checkpoints.cmi: primitives.cmi debugcom.cmi +command_line.cmi: debugcom.cmi: primitives.cmi +debugger_config.cmi: +dynlink.cmi: envaux.cmi: ../typing/path.cmi ../bytecomp/instruct.cmi ../typing/env.cmi eval.cmi: ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \ ../parsing/longident.cmi ../bytecomp/instruct.cmi ../typing/ident.cmi \ ../typing/env.cmi debugcom.cmi events.cmi: ../bytecomp/instruct.cmi +exec.cmi: frames.cmi: primitives.cmi ../bytecomp/instruct.cmi +history.cmi: input_handling.cmi: primitives.cmi +int64ops.cmi: lexer.cmi: parser.cmi loadprinter.cmi: ../parsing/longident.cmi dynlink.cmi +parameters.cmi: parser.cmi: parser_aux.cmi ../parsing/longident.cmi parser_aux.cmi: primitives.cmi ../parsing/longident.cmi pattern_matching.cmi: ../typing/typedtree.cmi parser_aux.cmi debugcom.cmi @@ -18,10 +25,14 @@ primitives.cmi: ../otherlibs/unix/unix.cmi printval.cmi: ../typing/types.cmi ../typing/path.cmi parser_aux.cmi \ ../typing/env.cmi debugcom.cmi program_loading.cmi: primitives.cmi +program_management.cmi: +question.cmi: show_information.cmi: ../bytecomp/instruct.cmi show_source.cmi: ../bytecomp/instruct.cmi +source.cmi: symbols.cmi: ../bytecomp/instruct.cmi time_travel.cmi: primitives.cmi +trap_barrier.cmi: unix_tools.cmi: ../otherlibs/unix/unix.cmi breakpoints.cmo: symbols.cmi source.cmi primitives.cmi pos.cmi \ ../bytecomp/instruct.cmi exec.cmi debugcom.cmi checkpoints.cmi \ diff --git a/debugger/Makefile b/debugger/Makefile index 35181ddf..bc57cde2 100644 --- a/debugger/Makefile +++ b/debugger/Makefile @@ -10,107 +10,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.32 2006/12/09 13:49:10 ertai Exp $ +# $Id: Makefile,v 1.33 2008/07/29 08:31:41 xleroy Exp $ -include ../config/Makefile - -CAMLC=../ocamlcomp.sh -COMPFLAGS=-warn-error A $(INCLUDES) -LINKFLAGS=-linkall -I ../otherlibs/unix -CAMLYACC=../boot/ocamlyacc -YACCFLAGS= -CAMLLEX=../boot/ocamlrun ../boot/ocamllex -CAMLDEP=../boot/ocamlrun ../tools/ocamldep -DEPFLAGS=$(INCLUDES) - -INCLUDES=\ - -I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../toplevel \ - -I ../otherlibs/unix - -OTHEROBJS=\ - ../otherlibs/unix/unix.cma \ - ../utils/misc.cmo ../utils/config.cmo \ - ../utils/tbl.cmo ../utils/clflags.cmo ../utils/consistbl.cmo \ - ../parsing/longident.cmo \ - ../typing/ident.cmo ../typing/path.cmo ../typing/types.cmo \ - ../typing/btype.cmo ../typing/primitive.cmo ../typing/typedtree.cmo \ - ../typing/subst.cmo ../typing/predef.cmo \ - ../typing/datarepr.cmo ../typing/env.cmo ../typing/oprint.cmo \ - ../typing/ctype.cmo ../typing/printtyp.cmo ../typing/mtype.cmo \ - ../bytecomp/runtimedef.cmo ../bytecomp/bytesections.cmo \ - ../bytecomp/dll.cmo ../bytecomp/meta.cmo ../bytecomp/symtable.cmo \ - ../bytecomp/opcodes.cmo \ - ../toplevel/genprintval.cmo - - -OBJS=\ - dynlink.cmo \ - int64ops.cmo \ - primitives.cmo \ - unix_tools.cmo \ - debugger_config.cmo \ - envaux.cmo \ - parameters.cmo \ - lexer.cmo \ - input_handling.cmo \ - question.cmo \ - debugcom.cmo \ - exec.cmo \ - source.cmo \ - pos.cmo \ - checkpoints.cmo \ - events.cmo \ - symbols.cmo \ - breakpoints.cmo \ - trap_barrier.cmo \ - history.cmo \ - program_loading.cmo \ - printval.cmo \ - show_source.cmo \ - time_travel.cmo \ - program_management.cmo \ - frames.cmo \ - eval.cmo \ - show_information.cmo \ - loadprinter.cmo \ - parser.cmo \ - command_line.cmo \ - main.cmo - -all: ocamldebug$(EXE) - -ocamldebug$(EXE): $(OBJS) $(OTHEROBJS) - $(CAMLC) $(LINKFLAGS) -o ocamldebug$(EXE) -linkall $(OTHEROBJS) $(OBJS) - -install: - cp ocamldebug$(EXE) $(BINDIR)/ocamldebug$(EXE) - -clean:: - rm -f ocamldebug$(EXE) - rm -f *.cmo *.cmi - -.SUFFIXES: -.SUFFIXES: .ml .cmo .mli .cmi - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -depend: beforedepend - $(CAMLDEP) $(DEPFLAGS) *.mli *.ml > .depend - -lexer.ml: lexer.mll - $(CAMLLEX) lexer.mll -clean:: - rm -f lexer.ml -beforedepend:: lexer.ml - -parser.ml parser.mli: parser.mly - $(CAMLYACC) parser.mly -clean:: - rm -f parser.ml parser.mli -beforedepend:: parser.ml parser.mli - -include .depend +UNIXDIR=../otherlibs/unix +include Makefile.shared diff --git a/debugger/Makefile.nt b/debugger/Makefile.nt new file mode 100644 index 00000000..523eb657 --- /dev/null +++ b/debugger/Makefile.nt @@ -0,0 +1,17 @@ +######################################################################### +# # +# 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 Q Public License version 1.0. # +# # +######################################################################### + +# $Id: Makefile.nt,v 1.1 2008/07/29 08:31:41 xleroy Exp $ + +UNIXDIR=../otherlibs/win32unix +include Makefile.shared + diff --git a/debugger/Makefile.shared b/debugger/Makefile.shared new file mode 100644 index 00000000..1e97af45 --- /dev/null +++ b/debugger/Makefile.shared @@ -0,0 +1,116 @@ +######################################################################### +# # +# 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 Q Public License version 1.0. # +# # +######################################################################### + +# $Id: Makefile.shared,v 1.1 2008/07/29 08:31:41 xleroy Exp $ + +include ../config/Makefile + +CAMLC=../ocamlcomp.sh +COMPFLAGS=-warn-error A $(INCLUDES) +LINKFLAGS=-linkall -I $(UNIXDIR) +CAMLYACC=../boot/ocamlyacc +YACCFLAGS= +CAMLLEX=../boot/ocamlrun ../boot/ocamllex +CAMLDEP=../boot/ocamlrun ../tools/ocamldep +DEPFLAGS=$(INCLUDES) + +INCLUDES=\ + -I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../toplevel \ + -I $(UNIXDIR) + +OTHEROBJS=\ + $(UNIXDIR)/unix.cma \ + ../utils/misc.cmo ../utils/config.cmo \ + ../utils/tbl.cmo ../utils/clflags.cmo ../utils/consistbl.cmo \ + ../parsing/longident.cmo \ + ../typing/ident.cmo ../typing/path.cmo ../typing/types.cmo \ + ../typing/btype.cmo ../typing/primitive.cmo ../typing/typedtree.cmo \ + ../typing/subst.cmo ../typing/predef.cmo \ + ../typing/datarepr.cmo ../typing/env.cmo ../typing/oprint.cmo \ + ../typing/ctype.cmo ../typing/printtyp.cmo ../typing/mtype.cmo \ + ../bytecomp/runtimedef.cmo ../bytecomp/bytesections.cmo \ + ../bytecomp/dll.cmo ../bytecomp/meta.cmo ../bytecomp/symtable.cmo \ + ../bytecomp/opcodes.cmo \ + ../toplevel/genprintval.cmo + + +OBJS=\ + dynlink.cmo \ + int64ops.cmo \ + primitives.cmo \ + unix_tools.cmo \ + debugger_config.cmo \ + envaux.cmo \ + parameters.cmo \ + lexer.cmo \ + input_handling.cmo \ + question.cmo \ + debugcom.cmo \ + exec.cmo \ + source.cmo \ + pos.cmo \ + checkpoints.cmo \ + events.cmo \ + symbols.cmo \ + breakpoints.cmo \ + trap_barrier.cmo \ + history.cmo \ + program_loading.cmo \ + printval.cmo \ + show_source.cmo \ + time_travel.cmo \ + program_management.cmo \ + frames.cmo \ + eval.cmo \ + show_information.cmo \ + loadprinter.cmo \ + parser.cmo \ + command_line.cmo \ + main.cmo + +all: ocamldebug$(EXE) + +ocamldebug$(EXE): $(OBJS) $(OTHEROBJS) + $(CAMLC) $(LINKFLAGS) -o ocamldebug$(EXE) -linkall $(OTHEROBJS) $(OBJS) + +install: + cp ocamldebug$(EXE) $(BINDIR)/ocamldebug$(EXE) + +clean:: + rm -f ocamldebug$(EXE) + rm -f *.cmo *.cmi + +.SUFFIXES: +.SUFFIXES: .ml .cmo .mli .cmi + +.ml.cmo: + $(CAMLC) -c $(COMPFLAGS) $< + +.mli.cmi: + $(CAMLC) -c $(COMPFLAGS) $< + +depend: beforedepend + $(CAMLDEP) $(DEPFLAGS) *.mli *.ml > .depend + +lexer.ml: lexer.mll + $(CAMLLEX) lexer.mll +clean:: + rm -f lexer.ml +beforedepend:: lexer.ml + +parser.ml parser.mli: parser.mly + $(CAMLYACC) parser.mly +clean:: + rm -f parser.ml parser.mli +beforedepend:: parser.ml parser.mli + +include .depend diff --git a/debugger/command_line.ml b/debugger/command_line.ml index c77d1ce3..475d8646 100644 --- a/debugger/command_line.ml +++ b/debugger/command_line.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: command_line.ml,v 1.24 2006/12/09 13:49:10 ertai Exp $ *) +(* $Id: command_line.ml,v 1.25 2008/07/29 08:31:41 xleroy Exp $ *) (************************ Reading and executing commands ***************) @@ -76,6 +76,13 @@ let error text = eprintf "%s@." text; raise Toplevel +let check_not_windows feature = + match Sys.os_type with + | "Win32" -> + error ("'"^feature^"' feature not supported on Windows") + | _ -> + () + let eol = end_of_line Lexer.lexeme @@ -220,7 +227,7 @@ let instr_shell ppf lexbuf = let instr_pwd ppf lexbuf = eol lexbuf; - ignore(system "/bin/pwd") + fprintf ppf "%s@." (Sys.getcwd ()) let instr_dir ppf lexbuf = let new_directory = argument_list_eol argument lexbuf in @@ -254,6 +261,7 @@ let instr_run ppf lexbuf = let instr_reverse ppf lexbuf = eol lexbuf; + check_not_windows "reverse"; ensure_loaded (); reset_named_values(); back_run (); @@ -276,6 +284,7 @@ let instr_back ppf lexbuf = | None -> _1 | Some x -> x in + check_not_windows "backstep"; ensure_loaded (); reset_named_values(); step (_0 -- step_count); @@ -301,6 +310,7 @@ let instr_next ppf lexbuf = let instr_start ppf lexbuf = eol lexbuf; + check_not_windows "start"; ensure_loaded (); reset_named_values(); start (); @@ -312,6 +322,7 @@ let instr_previous ppf lexbuf = | None -> 1 | Some x -> x in + check_not_windows "previous"; ensure_loaded (); reset_named_values(); previous step_count; @@ -672,6 +683,7 @@ let instr_last ppf lexbuf = | None -> _1 | Some x -> x in + check_not_windows "last"; reset_named_values(); go_to (History.previous_time count); show_current_event ppf diff --git a/debugger/debugcom.ml b/debugger/debugcom.ml index 777304f7..b4bf427e 100644 --- a/debugger/debugcom.ml +++ b/debugger/debugcom.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: debugcom.ml,v 1.12 2002/10/29 17:53:23 doligez Exp $ *) +(* $Id: debugcom.ml,v 1.13 2008/07/29 08:31:41 xleroy Exp $ *) (* Low-level communication with the debuggee *) @@ -99,10 +99,13 @@ let rec do_go n = (* Perform a checkpoint *) let do_checkpoint () = - output_char !conn.io_out 'c'; - flush !conn.io_out; - let pid = input_binary_int !conn.io_in in - if pid = -1 then Checkpoint_failed else Checkpoint_done pid + match Sys.os_type with + "Win32" -> failwith "do_checkpoint" + | _ -> + output_char !conn.io_out 'c'; + flush !conn.io_out; + let pid = input_binary_int !conn.io_in in + if pid = -1 then Checkpoint_failed else Checkpoint_done pid (* Kill the given process. *) let stop chan = diff --git a/debugger/debugger_config.ml b/debugger/debugger_config.ml index f25f7f8b..9af436d5 100644 --- a/debugger/debugger_config.ml +++ b/debugger/debugger_config.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: debugger_config.ml,v 1.10 2002/11/17 16:42:10 xleroy Exp $ *) +(* $Id: debugger_config.ml,v 1.11 2008/07/29 08:31:41 xleroy Exp $ *) (**************************** Configuration file ***********************) @@ -51,7 +51,10 @@ let event_mark_before = "<|b|>" let event_mark_after = "<|a|>" (* Name of shell used to launch the debuggee *) -let shell = "/bin/sh" +let shell = + match Sys.os_type with + "Win32" -> "cmd" + | _ -> "/bin/sh" (* Name of the Objective Caml runtime. *) let runtime_program = "ocamlrun" @@ -71,5 +74,7 @@ let checkpoint_small_step = ref (~~ "1000") let checkpoint_max_count = ref 15 (* Whether to keep checkpoints or not. *) -let make_checkpoints = ref true - +let make_checkpoints = ref + (match Sys.os_type with + "Win32" -> false + | _ -> true) diff --git a/debugger/eval.ml b/debugger/eval.ml index 0299454b..4a2e5ae8 100644 --- a/debugger/eval.ml +++ b/debugger/eval.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: eval.ml,v 1.28 2003/07/02 09:14:30 xleroy Exp $ *) +(* $Id: eval.ml,v 1.30 2007/11/28 22:32:14 weis Exp $ *) open Debugger_config open Misc @@ -101,7 +101,7 @@ let rec expression event env = function end | E_item(arg, n) -> let (v, ty) = expression event env arg in - begin match (Ctype.repr(Ctype.expand_head env ty)).desc with + begin match (Ctype.repr(Ctype.expand_head_opt env ty)).desc with Ttuple ty_list -> if n < 1 || n > List.length ty_list then raise(Error(Tuple_index(ty, List.length ty_list, n))) @@ -131,11 +131,11 @@ let rec expression event env = function end | E_field(arg, lbl) -> let (v, ty) = expression event env arg in - begin match (Ctype.repr(Ctype.expand_head env ty)).desc with + begin match (Ctype.repr(Ctype.expand_head_opt env ty)).desc with Tconstr(path, args, _) -> let tydesc = Env.find_type path env in begin match tydesc.type_kind with - Type_record(lbl_list, repr, priv) -> + Type_record(lbl_list, repr) -> let (pos, ty_res) = find_label lbl env ty path tydesc 0 lbl_list in (Debugcom.Remote_value.field v pos, ty_res) diff --git a/debugger/exec.ml b/debugger/exec.ml index 5eeeee97..2cf667e9 100644 --- a/debugger/exec.ml +++ b/debugger/exec.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: exec.ml,v 1.4 1999/11/17 18:57:24 xleroy Exp $ *) +(* $Id: exec.ml,v 1.5 2008/07/29 08:31:41 xleroy Exp $ *) (* Handling of keyboard interrupts *) @@ -25,8 +25,11 @@ let break signum = else raise Sys.Break let _ = - Sys.set_signal Sys.sigint (Sys.Signal_handle break); - Sys.set_signal Sys.sigpipe (Sys.Signal_handle (fun _ -> raise End_of_file)) + match Sys.os_type with + "Win32" -> () + | _ -> + Sys.set_signal Sys.sigint (Sys.Signal_handle break); + Sys.set_signal Sys.sigpipe (Sys.Signal_handle (fun _ -> raise End_of_file)) let protect f = if !is_protected then diff --git a/debugger/main.ml b/debugger/main.ml index 6c82e387..1d8d4965 100644 --- a/debugger/main.ml +++ b/debugger/main.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: main.ml,v 1.19.6.1 2007/09/24 07:45:31 garrigue Exp $ *) +(* $Id: main.ml,v 1.21 2008/07/29 08:31:41 xleroy Exp $ *) open Primitives open Misc @@ -148,8 +148,15 @@ let speclist = [ let main () = try - socket_name := Filename.concat Filename.temp_dir_name - ("camldebug" ^ (string_of_int (Unix.getpid ()))); + socket_name := + (match Sys.os_type with + "Win32" -> + (Unix.string_of_inet_addr Unix.inet_addr_loopback)^ + ":"^ + (string_of_int (10000 + ((Unix.getpid ()) mod 10000))) + | _ -> Filename.concat Filename.temp_dir_name + ("camldebug" ^ (string_of_int (Unix.getpid ()))) + ); begin try Arg.parse speclist anonymous ""; Arg.usage speclist diff --git a/debugger/program_loading.ml b/debugger/program_loading.ml index fe11f79e..a820a09c 100644 --- a/debugger/program_loading.ml +++ b/debugger/program_loading.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: program_loading.ml,v 1.7 2005/08/13 20:59:37 doligez Exp $ *) +(* $Id: program_loading.ml,v 1.8 2008/07/29 08:31:41 xleroy Exp $ *) (* Program loading *) @@ -37,7 +37,7 @@ let load_program () = (*** Launching functions. ***) (* A generic function for launching the program *) -let generic_exec cmdline = function () -> +let generic_exec_unix cmdline = function () -> if !debug_loading then prerr_endline "Launching program..."; let child = @@ -64,11 +64,36 @@ let generic_exec cmdline = function () -> (_, WEXITED 0) -> () | _ -> raise Toplevel +let generic_exec_win cmdline = function () -> + if !debug_loading then + prerr_endline "Launching program..."; + try ignore(create_process "cmd.exe" [| "/C"; cmdline() |] stdin stdout stderr) + with x -> + Unix_tools.report_error x; + raise Toplevel + +let generic_exec = + match Sys.os_type with + "Win32" -> generic_exec_win + | _ -> generic_exec_unix + (* Execute the program by calling the runtime explicitely *) let exec_with_runtime = generic_exec (function () -> - Printf.sprintf "CAML_DEBUG_SOCKET=%s %s %s %s" + match Sys.os_type with + "Win32" -> + (* This fould fail on a file name with spaces + but quoting is even worse because Unix.create_process + thinks each command line parameter is a file. + So no good solution so far *) + Printf.sprintf "set CAML_DEBUG_SOCKET=%s && %s %s %s" + !socket_name + runtime_program + !program_name + !arguments + | _ -> + Printf.sprintf "CAML_DEBUG_SOCKET=%s %s %s %s" !socket_name (Filename.quote runtime_program) (Filename.quote !program_name) @@ -78,7 +103,15 @@ let exec_with_runtime = let exec_direct = generic_exec (function () -> - Printf.sprintf "CAML_DEBUG_SOCKET=%s %s %s" + match Sys.os_type with + "Win32" -> + (* See the comment above *) + Printf.sprintf "set CAML_DEBUG_SOCKET=%s && %s %s" + !socket_name + !program_name + !arguments + | _ -> + Printf.sprintf "CAML_DEBUG_SOCKET=%s %s %s" !socket_name (Filename.quote !program_name) !arguments) diff --git a/debugger/program_management.ml b/debugger/program_management.ml index 263a9935..1a83e60a 100644 --- a/debugger/program_management.ml +++ b/debugger/program_management.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: program_management.ml,v 1.12 2006/12/09 13:49:10 ertai Exp $ *) +(* $Id: program_management.ml,v 1.13 2008/07/29 08:31:41 xleroy Exp $ *) (* Manage the loading of the program *) @@ -74,6 +74,7 @@ let open_connection address continue = let sock = socket sock_domain SOCK_STREAM 0 in (try bind sock sock_address; + setsockopt sock SO_REUSEADDR true; listen sock 3; connection := io_channel_of_descr sock; Input_handling.add_file !connection (accept_connection continue); diff --git a/debugger/unix_tools.ml b/debugger/unix_tools.ml index 747e53ae..1e153622 100644 --- a/debugger/unix_tools.ml +++ b/debugger/unix_tools.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: unix_tools.ml,v 1.8 2002/11/02 22:36:45 doligez Exp $ *) +(* $Id: unix_tools.ml,v 1.9 2008/07/29 08:31:41 xleroy Exp $ *) (****************** Tools for Unix *************************************) @@ -36,7 +36,9 @@ let convert_address address = prerr_endline "The port number should be an integer"; failwith "Can't convert address"))) with Not_found -> - (PF_UNIX, ADDR_UNIX address) + match Sys.os_type with + "Win32" -> failwith "Unix sockets not supported" + | _ -> (PF_UNIX, ADDR_UNIX address) (*** Report a unix error. ***) let report_error = function diff --git a/driver/compile.ml b/driver/compile.ml index e1230e77..c2e7074b 100644 --- a/driver/compile.ml +++ b/driver/compile.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: compile.ml,v 1.58 2005/08/08 09:41:51 xleroy Exp $ *) +(* $Id: compile.ml,v 1.61 2008/10/06 13:53:54 doligez Exp $ *) (* The batch compiler *) @@ -48,12 +48,35 @@ let initial_env () = with Not_found -> fatal_error "cannot open pervasives.cmi" +(* Note: this function is duplicated in optcompile.ml *) +let check_unit_name ppf filename name = + try + begin match name.[0] with + | 'A'..'Z' -> () + | _ -> + Location.print_warning (Location.in_file filename) ppf + (Warnings.Bad_module_name name); + raise Exit; + end; + for i = 1 to String.length name - 1 do + match name.[i] with + | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '\'' -> () + | _ -> + Location.print_warning (Location.in_file filename) ppf + (Warnings.Bad_module_name name); + raise Exit; + done; + with Exit -> () +;; + (* Compile a .mli file *) let interface ppf sourcefile outputprefix = + Location.input_name := sourcefile; init_path (); let modulename = String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in + check_unit_name ppf sourcefile modulename; Env.set_unit_name modulename; let inputfile = Pparse.preprocess sourcefile in try @@ -81,9 +104,11 @@ let print_if ppf flag printer arg = let (++) x f = f x let implementation ppf sourcefile outputprefix = + Location.input_name := sourcefile; init_path (); let modulename = String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in + check_unit_name ppf sourcefile modulename; Env.set_unit_name modulename; let inputfile = Pparse.preprocess sourcefile in let env = initial_env() in @@ -95,7 +120,7 @@ let implementation ppf sourcefile outputprefix = with x -> Pparse.remove_preprocessed_if_ast inputfile; raise x - end else begin + end else begin let objfile = outputprefix ^ ".cmo" in let oc = open_out_bin objfile in try @@ -111,14 +136,17 @@ let implementation ppf sourcefile outputprefix = ++ print_if ppf Clflags.dump_instr Printinstr.instrlist ++ Emitcode.to_file oc modulename; Warnings.check_fatal (); - Pparse.remove_preprocessed inputfile; close_out oc; + Pparse.remove_preprocessed inputfile; + Stypes.dump (outputprefix ^ ".annot"); with x -> close_out oc; remove_file objfile; Pparse.remove_preprocessed_if_ast inputfile; + Stypes.dump (outputprefix ^ ".annot"); raise x end let c_file name = + Location.input_name := name; if Ccomp.compile_file name <> 0 then exit 2 diff --git a/driver/errors.ml b/driver/errors.ml index c7d747fe..0481b9cb 100644 --- a/driver/errors.ml +++ b/driver/errors.ml @@ -10,10 +10,11 @@ (* *) (***********************************************************************) -(* $Id: errors.ml,v 1.26 2006/01/04 16:55:49 doligez Exp $ *) +(* $Id: errors.ml,v 1.27 2007/12/04 13:38:58 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. + opterrors.ml and ocamldoc/odoc_analyse.ml + to see if you need to make the same changes there. *) open Format @@ -23,47 +24,58 @@ open Format let report_error ppf exn = let report ppf = function | Lexer.Error(err, loc) -> - Location.print ppf loc; + Location.print_error ppf loc; Lexer.report_error ppf err | Syntaxerr.Error err -> Syntaxerr.report_error ppf err | Pparse.Error -> + Location.print_error_cur_file ppf; fprintf ppf "Preprocessor error" | Env.Error err -> + Location.print_error_cur_file ppf; Env.report_error ppf err - | Ctype.Tags(l, l') -> fprintf ppf + | Ctype.Tags(l, l') -> + Location.print_error_cur_file ppf; + fprintf ppf "In this program,@ variant constructors@ `%s and `%s@ \ have the same hash value.@ Change one of them." l l' | Typecore.Error(loc, err) -> - Location.print ppf loc; Typecore.report_error ppf err + Location.print_error ppf loc; Typecore.report_error ppf err | Typetexp.Error(loc, err) -> - Location.print ppf loc; Typetexp.report_error ppf err + Location.print_error ppf loc; Typetexp.report_error ppf err | Typedecl.Error(loc, err) -> - Location.print ppf loc; Typedecl.report_error ppf err + Location.print_error ppf loc; Typedecl.report_error ppf err | Typeclass.Error(loc, err) -> - Location.print ppf loc; Typeclass.report_error ppf err + Location.print_error ppf loc; Typeclass.report_error ppf err | Includemod.Error err -> + Location.print_error_cur_file ppf; Includemod.report_error ppf err | Typemod.Error(loc, err) -> - Location.print ppf loc; Typemod.report_error ppf err + Location.print_error ppf loc; Typemod.report_error ppf err | Translcore.Error(loc, err) -> - Location.print ppf loc; Translcore.report_error ppf err + Location.print_error ppf loc; Translcore.report_error ppf err | Translclass.Error(loc, err) -> - Location.print ppf loc; Translclass.report_error ppf err + Location.print_error ppf loc; Translclass.report_error ppf err | Translmod.Error(loc, err) -> - Location.print ppf loc; Translmod.report_error ppf err + Location.print_error ppf loc; Translmod.report_error ppf err | Symtable.Error code -> + Location.print_error_cur_file ppf; Symtable.report_error ppf code | Bytelink.Error code -> + Location.print_error_cur_file ppf; Bytelink.report_error ppf code | Bytelibrarian.Error code -> + Location.print_error_cur_file ppf; Bytelibrarian.report_error ppf code | Bytepackager.Error code -> + Location.print_error_cur_file ppf; Bytepackager.report_error ppf code | Sys_error msg -> + Location.print_error_cur_file ppf; fprintf ppf "I/O error: %s" msg | Warnings.Errors (n) -> - fprintf ppf "@.Error: error-enabled warnings (%d occurrences)" n + Location.print_error_cur_file ppf; + fprintf ppf "Error-enabled warnings (%d occurrences)" n | x -> fprintf ppf "@]"; raise x in fprintf ppf "@[%a@]@." report exn diff --git a/driver/main.ml b/driver/main.ml index bdb11184..7459f66b 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: main.ml,v 1.68 2005/05/09 13:39:17 doligez Exp $ *) +(* $Id: main.ml,v 1.71.2.1 2008/10/15 08:48:51 xleroy Exp $ *) open Config open Clflags @@ -89,15 +89,15 @@ module Options = Main_args.Make_options (struct let set r () = r := true let unset r () = r := false let _a = set make_archive + let _annot = set annotations let _c = set compile_only - let _cc s = c_compiler := s; c_linker := s + let _cc s = c_compiler := Some s let _cclib s = ccobjs := Misc.rev_split_words s @ !ccobjs let _ccopt s = ccopts := s :: !ccopts let _config = show_config let _custom = set custom_runtime let _dllib s = dllibs := Misc.rev_split_words s @ !dllibs let _dllpath s = dllpaths := !dllpaths @ [s] - let _dtypes = set save_types let _g = set debug let _i () = print_types := true; compile_only := true let _I s = include_dirs := s :: !include_dirs @@ -137,12 +137,13 @@ module Options = Main_args.Make_options (struct let anonymous = anonymous end) +let fatal err = + prerr_endline err; + exit 2 + let extract_output = function | Some s -> s - | None -> - prerr_endline - "Please specify the name of the output file, using option -o"; - exit 2 + | None -> fatal "Please specify the name of the output file, using option -o" let default_output = function | Some s -> s @@ -151,6 +152,12 @@ let default_output = function let main () = try Arg.parse Options.list anonymous usage; + if + List.length (List.filter (fun x -> !x) + [make_archive;make_package;compile_only;output_c_object]) > 1 + then + fatal "Please specify at most one of -pack, -a, -c, -output-obj"; + if !make_archive then begin Compile.init_path(); Bytelibrarian.create_archive (List.rev !objfiles) @@ -162,8 +169,24 @@ let main () = (extract_output !output_name) end else if not !compile_only && !objfiles <> [] then begin + let target = + if !output_c_object then + let s = extract_output !output_name in + if (Filename.check_suffix s Config.ext_obj + || Filename.check_suffix s Config.ext_dll + || Filename.check_suffix s ".c") + then s + else + fatal + (Printf.sprintf + "The extension of the output file must be .c, %s or %s" + Config.ext_obj Config.ext_dll + ) + else + default_output !output_name + in Compile.init_path(); - Bytelink.link (List.rev !objfiles) (default_output !output_name) + Bytelink.link (List.rev !objfiles) target end; exit 0 with x -> diff --git a/driver/main_args.ml b/driver/main_args.ml index 72b6172c..7e1c23eb 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -10,11 +10,12 @@ (* *) (***********************************************************************) -(* $Id: main_args.ml,v 1.49 2006/04/05 02:28:13 garrigue Exp $ *) +(* $Id: main_args.ml,v 1.50 2007/05/16 08:21:40 doligez Exp $ *) module Make_options (F : sig val _a : unit -> unit + val _annot : unit -> unit val _c : unit -> unit val _cc : string -> unit val _cclib : string -> unit @@ -23,7 +24,6 @@ module Make_options (F : val _custom : unit -> unit val _dllib : string -> unit val _dllpath : string -> unit - val _dtypes : unit -> unit val _g : unit -> unit val _i : unit -> unit val _I : string -> unit @@ -65,6 +65,7 @@ module Make_options (F : struct let list = [ "-a", Arg.Unit F._a, " Build a library"; + "-annot", Arg.Unit F._annot, " Save information in .annot"; "-c", Arg.Unit F._c, " Compile only (do not link)"; "-cc", Arg.String F._cc, " Use as the C compiler and linker"; @@ -78,7 +79,7 @@ struct " Use the dynamically-loaded library "; "-dllpath", Arg.String F._dllpath, " Add to the run-time search path for shared libraries"; - "-dtypes", Arg.Unit F._dtypes, " Save type information in .annot"; + "-dtypes", Arg.Unit F._annot, " (deprecated) same as -annot"; "-for-pack", Arg.String (fun s -> ()), " Ignored (for compatibility with ocamlopt)"; "-g", Arg.Unit F._g, " Save debugging information"; diff --git a/driver/main_args.mli b/driver/main_args.mli index 53733302..f9a08c37 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -10,11 +10,12 @@ (* *) (***********************************************************************) -(* $Id: main_args.mli,v 1.26 2005/05/09 13:39:17 doligez Exp $ *) +(* $Id: main_args.mli,v 1.27 2007/05/16 08:21:40 doligez Exp $ *) module Make_options (F : sig val _a : unit -> unit + val _annot : unit -> unit val _c : unit -> unit val _cc : string -> unit val _cclib : string -> unit @@ -23,7 +24,6 @@ module Make_options (F : val _custom : unit -> unit val _dllib : string -> unit val _dllpath : string -> unit - val _dtypes : unit -> unit val _g : unit -> unit val _i : unit -> unit val _I : string -> unit diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 1b6fa987..096350b9 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: optcompile.ml,v 1.53 2005/08/08 09:41:51 xleroy Exp $ *) +(* $Id: optcompile.ml,v 1.56.2.1 2008/10/08 13:07:13 doligez Exp $ *) (* The batch compiler *) @@ -43,14 +43,37 @@ let initial_env () = then Env.initial else Env.open_pers_signature "Pervasives" Env.initial with Not_found -> - fatal_error "cannot open Pervasives.cmi" + fatal_error "cannot open pervasives.cmi" + +(* Note: this function is duplicated in compile.ml *) +let check_unit_name ppf filename name = + try + begin match name.[0] with + | 'A'..'Z' -> () + | _ -> + Location.print_warning (Location.in_file filename) ppf + (Warnings.Bad_module_name name); + raise Exit; + end; + for i = 1 to String.length name - 1 do + match name.[i] with + | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '\'' -> () + | _ -> + Location.print_warning (Location.in_file filename) ppf + (Warnings.Bad_module_name name); + raise Exit; + done; + with Exit -> () +;; (* Compile a .mli file *) let interface ppf sourcefile outputprefix = + Location.input_name := sourcefile; init_path (); let modulename = String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in + check_unit_name ppf sourcefile modulename; Env.set_unit_name modulename; let inputfile = Pparse.preprocess sourcefile in try @@ -64,9 +87,11 @@ let interface ppf sourcefile outputprefix = Warnings.check_fatal (); if not !Clflags.print_types then Env.save_signature sg modulename (outputprefix ^ ".cmi"); - Pparse.remove_preprocessed inputfile + Pparse.remove_preprocessed inputfile; + Stypes.dump (outputprefix ^ ".annot"); with e -> Pparse.remove_preprocessed_if_ast inputfile; + Stypes.dump (outputprefix ^ ".annot"); raise e (* Compile a .ml file *) @@ -79,13 +104,17 @@ let (++) x f = f x let (+++) (x, y) f = (x, f y) let implementation ppf sourcefile outputprefix = + Location.input_name := sourcefile; init_path (); let modulename = String.capitalize(Filename.basename(chop_extension_if_any sourcefile)) in + check_unit_name ppf sourcefile modulename; Env.set_unit_name modulename; let inputfile = Pparse.preprocess sourcefile in let env = initial_env() in Compilenv.reset ?packname:!Clflags.for_package modulename; + let cmxfile = outputprefix ^ ".cmx" in + let objfile = outputprefix ^ ext_obj in try if !Clflags.print_types then ignore( Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number @@ -102,11 +131,13 @@ let implementation ppf sourcefile outputprefix = +++ Simplif.simplify_lambda +++ print_if ppf Clflags.dump_lambda Printlambda.lambda ++ Asmgen.compile_implementation outputprefix ppf; - Compilenv.save_unit_info (outputprefix ^ ".cmx"); + Compilenv.save_unit_info cmxfile; end; Warnings.check_fatal (); Pparse.remove_preprocessed inputfile with x -> + remove_file objfile; + remove_file cmxfile; Pparse.remove_preprocessed_if_ast inputfile; raise x diff --git a/driver/opterrors.ml b/driver/opterrors.ml index 8c9e44b0..cea33b0a 100644 --- a/driver/opterrors.ml +++ b/driver/opterrors.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: opterrors.ml,v 1.19 2006/04/16 23:28:21 doligez Exp $ *) +(* $Id: opterrors.ml,v 1.20 2007/12/04 13:38:58 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. @@ -23,49 +23,61 @@ open Format let report_error ppf exn = let report ppf = function | Lexer.Error(err, l) -> - Location.print ppf l; + Location.print_error ppf l; Lexer.report_error ppf err | Syntaxerr.Error err -> Syntaxerr.report_error ppf err | Pparse.Error -> + Location.print_error_cur_file ppf; fprintf ppf "Preprocessor error" | Env.Error err -> + Location.print_error_cur_file ppf; Env.report_error ppf err - | Ctype.Tags(l, l') -> fprintf ppf + | Ctype.Tags(l, l') -> + Location.print_error_cur_file ppf; + fprintf ppf "In this program,@ variant constructors@ `%s and `%s@ \ have the same hash value.@ Change one of them." l l' | Typecore.Error(loc, err) -> - Location.print ppf loc; Typecore.report_error ppf err + Location.print_error ppf loc; Typecore.report_error ppf err | Typetexp.Error(loc, err) -> - Location.print ppf loc; Typetexp.report_error ppf err + Location.print_error ppf loc; Typetexp.report_error ppf err | Typedecl.Error(loc, err) -> - Location.print ppf loc; Typedecl.report_error ppf err + Location.print_error ppf loc; Typedecl.report_error ppf err | Typeclass.Error(loc, err) -> - Location.print ppf loc; Typeclass.report_error ppf err + Location.print_error ppf loc; Typeclass.report_error ppf err | Includemod.Error err -> + Location.print_error_cur_file ppf; Includemod.report_error ppf err | Typemod.Error(loc, err) -> - Location.print ppf loc; Typemod.report_error ppf err + Location.print_error ppf loc; Typemod.report_error ppf err | Translcore.Error(loc, err) -> - Location.print ppf loc; Translcore.report_error ppf err + Location.print_error ppf loc; Translcore.report_error ppf err | Translclass.Error(loc, err) -> - Location.print ppf loc; Translclass.report_error ppf err + Location.print_error ppf loc; Translclass.report_error ppf err | Translmod.Error(loc, err) -> - Location.print ppf loc; Translmod.report_error ppf err + Location.print_error ppf loc; Translmod.report_error ppf err | Compilenv.Error code -> + Location.print_error_cur_file ppf; Compilenv.report_error ppf code | Asmgen.Error code -> + Location.print_error_cur_file ppf; Asmgen.report_error ppf code | Asmlink.Error code -> + Location.print_error_cur_file ppf; Asmlink.report_error ppf code | Asmlibrarian.Error code -> + Location.print_error_cur_file ppf; Asmlibrarian.report_error ppf code | Asmpackager.Error code -> + Location.print_error_cur_file ppf; Asmpackager.report_error ppf code | Sys_error msg -> + Location.print_error_cur_file ppf; fprintf ppf "I/O error: %s" msg | Warnings.Errors (n) -> - fprintf ppf "@.Error: error-enabled warnings (%d occurrences)" n + Location.print_error_cur_file ppf; + fprintf ppf "Error-enabled warnings (%d occurrences)" n | x -> fprintf ppf "@]"; raise x in fprintf ppf "@[%a@]@." report exn diff --git a/driver/optmain.ml b/driver/optmain.ml index dc08cede..04fd6a4a 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: optmain.ml,v 1.89 2007/01/29 12:11:15 xleroy Exp $ *) +(* $Id: optmain.ml,v 1.98.2.1 2008/10/15 08:48:51 xleroy Exp $ *) open Config open Clflags @@ -32,11 +32,8 @@ let process_implementation_file ppf name = let process_file ppf name = if Filename.check_suffix name ".ml" - || Filename.check_suffix name ".mlt" then begin - let opref = output_prefix name in - Optcompile.implementation ppf name opref; - objfiles := (opref ^ ".cmx") :: !objfiles - end + || Filename.check_suffix name ".mlt" then + process_implementation_file ppf name else if Filename.check_suffix name !Config.interface_suffix then begin let opref = output_prefix name in Optcompile.interface ppf name opref; @@ -71,12 +68,14 @@ let print_version_string () = let print_standard_library () = print_string Config.standard_library; print_newline(); exit 0 +let fatal err = + prerr_endline err; + exit 2 + let extract_output = function | Some s -> s | None -> - prerr_endline - "Please specify the name of the output file, using option -o"; - exit 2 + fatal "Please specify the name of the output file, using option -o" let default_output = function | Some s -> s @@ -91,14 +90,14 @@ let show_config () = let main () = native_code := true; - c_compiler := Config.native_c_compiler; - c_linker := Config.native_c_linker; let ppf = Format.err_formatter in try Arg.parse (Arch.command_line_options @ [ "-a", Arg.Set make_archive, " Build a library"; + "-annot", Arg.Set annotations, + " Save information in .annot"; "-c", Arg.Set compile_only, " Compile only (do not link)"; - "-cc", Arg.String(fun s -> c_compiler := s; c_linker := s), + "-cc", Arg.String(fun s -> c_compiler := Some s), " Use as the C compiler and linker"; "-cclib", Arg.String(fun s -> ccobjs := Misc.rev_split_words s @ !ccobjs), @@ -109,12 +108,13 @@ let main () = " Optimize code size rather than speed"; "-config", Arg.Unit show_config, " print configuration values and exit"; - "-dtypes", Arg.Set save_types, - " Save type information in .annot"; + "-dtypes", Arg.Set annotations, + " (deprecated) same as -annot"; "-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"; + "-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), @@ -134,7 +134,9 @@ let main () = " Link all modules, even unused ones"; "-noassert", Arg.Set noassert, " Don't compile assertion checks"; "-noautolink", Arg.Set no_auto_link, - " Don't automatically link C libraries specified in .cma files"; + " Don't automatically link C libraries specified in .cmxa files"; + "-nodynlink", Arg.Clear dlcode, + " Enable optimizations for code that will not be dynlinked"; "-nolabels", Arg.Set classic, " Ignore non-optional labels in types"; "-nostdlib", Arg.Set no_std_include, " do not add standard directory to the list of include directories"; @@ -153,6 +155,8 @@ let main () = " Check principality of type inference"; "-rectypes", Arg.Set recursive_types, " Allow arbitrary recursive types"; + "-shared", Arg.Unit (fun () -> shared := true; dlcode := true), + " Produce a dynlinkable plugin"; "-S", Arg.Set keep_asm_file, " Keep intermediate assembly file"; "-thread", Arg.Set use_threads, " Generate code that supports the system threads library"; @@ -209,19 +213,44 @@ let main () = "-", Arg.String (process_file ppf), " Treat as a file name (even if it starts with `-')" ]) (process_file ppf) usage; + if + List.length (List.filter (fun x -> !x) + [make_archive;make_package;shared;compile_only;output_c_object]) > 1 + then + fatal "Please specify at most one of -pack, -a, -shared, -c, -output-obj"; if !make_archive then begin Optcompile.init_path(); - Asmlibrarian.create_archive (List.rev !objfiles) - (extract_output !output_name) + let target = extract_output !output_name in + Asmlibrarian.create_archive (List.rev !objfiles) target; end else if !make_package then begin Optcompile.init_path(); - Asmpackager.package_files ppf (List.rev !objfiles) - (extract_output !output_name) + let target = extract_output !output_name in + Asmpackager.package_files ppf (List.rev !objfiles) target; + end + else if !shared then begin + Optcompile.init_path(); + let target = extract_output !output_name in + Asmlink.link_shared ppf (List.rev !objfiles) target; end else if not !compile_only && !objfiles <> [] then begin + let target = + if !output_c_object then + let s = extract_output !output_name in + if (Filename.check_suffix s Config.ext_obj + || Filename.check_suffix s Config.ext_dll) + then s + else + fatal + (Printf.sprintf + "The extension of the output file must be %s or %s" + Config.ext_obj Config.ext_dll + ) + else + default_output !output_name + in Optcompile.init_path(); - Asmlink.link ppf (List.rev !objfiles) (default_output !output_name) + Asmlink.link ppf (List.rev !objfiles) target end; exit 0 with x -> diff --git a/emacs/README b/emacs/README index 67248a71..42a66d15 100644 --- a/emacs/README +++ b/emacs/README @@ -1,4 +1,4 @@ - O'Caml emacs mode, snapshot of $Date: 2007/10/29 07:16:43 $ + O'Caml emacs mode, snapshot of $Date: 2008/01/11 16:13:16 $ The files in this archive define a caml-mode for emacs, for editing Objective Caml and Objective Label programs, as well as an diff --git a/emacs/caml-font-old.el b/emacs/caml-font-old.el index d5c29baf..f226e1c9 100644 --- a/emacs/caml-font-old.el +++ b/emacs/caml-font-old.el @@ -10,7 +10,7 @@ ;(* *) ;(***********************************************************************) -;(* $Id: caml-font-old.el,v 1.1.2.1 2007/10/29 07:16:43 garrigue Exp $ *) +;(* $Id: caml-font-old.el,v 1.2 2008/01/11 16:13:16 doligez Exp $ *) ;; useful colors diff --git a/emacs/caml-types.el b/emacs/caml-types.el index 5e60c9d1..67237a31 100644 --- a/emacs/caml-types.el +++ b/emacs/caml-types.el @@ -10,14 +10,14 @@ ;(* *) ;(***********************************************************************) -;(* $Id: caml-types.el,v 1.33.4.1 2007/06/25 14:40:23 doligez Exp $ *) +;(* $Id: caml-types.el,v 1.38 2008/07/29 15:49:31 doligez Exp $ *) -; An emacs-lisp complement to the "-dtypes" option of ocamlc and ocamlopt. +; An emacs-lisp complement to the "-annot" option of ocamlc and ocamlopt. ;; XEmacs compatibility (eval-and-compile - (if (and (boundp 'running-xemacs) running-xemacs) + (if (and (boundp 'running-xemacs) running-xemacs) (require 'caml-xemacs) (require 'caml-emacs))) @@ -25,15 +25,15 @@ (defvar caml-types-location-re nil "Regexp to parse *.annot files. -Annotation files *.annot may be generated with the \"-dtypes\" option -of ocamlc and ocamlopt. +Annotation files *.annot may be generated with the \"-annot\" option +of ocamlc and ocamlopt. Their format is: file ::= block * block ::= position position annotation * position ::= filename num num num - annotation ::= keyword open-paren data close-paren + annotation ::= keyword open-paren data close-paren is a space character (ASCII 0x20) is a line-feed character (ASCII 0x0A) @@ -52,38 +52,60 @@ Their format is: - the char number within the line is the difference between the third and second nums. -For the moment, the only possible keyword is \"type\"." +The current list of keywords is: +type call ident" ) (let* ((caml-types-filename-re "\"\\(\\([^\\\"]\\|\\\\.\\)*\\)\"") - (caml-types-number-re "\\([0-9]*\\)") - (caml-types-position-re + (caml-types-number-re "\\([0-9]*\\)")) + (setq caml-types-position-re (concat caml-types-filename-re " " caml-types-number-re " " caml-types-number-re " " - caml-types-number-re))) + caml-types-number-re)) (setq caml-types-location-re (concat "^" caml-types-position-re " " caml-types-position-re))) (defvar caml-types-expr-ovl (make-overlay 1 1)) - -(make-face 'caml-types-face) -(set-face-doc-string 'caml-types-face +(make-face 'caml-types-expr-face) +(set-face-doc-string 'caml-types-expr-face "face for hilighting expressions and types") -(if (not (face-differs-from-default-p 'caml-types-face)) - (set-face-background 'caml-types-face "#88FF44")) +(if (not (face-differs-from-default-p 'caml-types-expr-face)) + (set-face-background 'caml-types-expr-face "#88FF44")) +(overlay-put caml-types-expr-ovl 'face 'caml-types-expr-face) (defvar caml-types-typed-ovl (make-overlay 1 1)) - (make-face 'caml-types-typed-face) (set-face-doc-string 'caml-types-typed-face "face for hilighting typed expressions") (if (not (face-differs-from-default-p 'caml-types-typed-face)) (set-face-background 'caml-types-typed-face "#FF8844")) - -(overlay-put caml-types-expr-ovl 'face 'caml-types-face) (overlay-put caml-types-typed-ovl 'face 'caml-types-typed-face) +(defvar caml-types-scope-ovl (make-overlay 1 1)) +(make-face 'caml-types-scope-face) +(set-face-doc-string 'caml-types-scope-face + "face for hilighting variable scopes") +(if (not (face-differs-from-default-p 'caml-types-scope-face)) + (set-face-background 'caml-types-scope-face "#BBFFFF")) +(overlay-put caml-types-scope-ovl 'face 'caml-types-scope-face) + +(defvar caml-types-def-ovl (make-overlay 1 1)) +(make-face 'caml-types-def-face) +(set-face-doc-string 'caml-types-def-face + "face for hilighting binding occurrences") +(if (not (face-differs-from-default-p 'caml-types-def-face)) + (set-face-background 'caml-types-def-face "#FF4444")) +(overlay-put caml-types-def-ovl 'face 'caml-types-def-face) + +(defvar caml-types-occ-ovl (make-overlay 1 1)) +(make-face 'caml-types-occ-face) +(set-face-doc-string 'caml-types-occ-face + "face for hilighting variable occurrences") +(if (not (face-differs-from-default-p 'caml-types-occ-face)) + (set-face-background 'caml-types-occ-face "#44FF44")) +(overlay-put caml-types-occ-ovl 'face 'caml-types-occ-face) + (defvar caml-types-annotation-tree nil) (defvar caml-types-annotation-date nil) @@ -113,7 +135,7 @@ For the moment, the only possible keyword is \"type\"." in the file, up to where the type checker failed. Types are also displayed in the buffer *caml-types*, which is -displayed when the command is called with Prefix argument 4. +displayed when the command is called with Prefix argument 4. See also `caml-types-explore' for exploration by mouse dragging. See `caml-types-location-re' for annotation file format. @@ -128,7 +150,7 @@ See `caml-types-location-re' for annotation file format. (caml-types-preprocess (buffer-file-name)) (setq caml-types-buffer (get-buffer-create caml-types-buffer-name)) (let* ((targ-loc (vector target-file target-line target-bol target-cnum)) - (node (caml-types-find-location targ-loc () + (node (caml-types-find-location targ-loc "type" () caml-types-annotation-tree))) (cond ((null node) @@ -137,7 +159,7 @@ See `caml-types-location-re' for annotation file format. (t (let ((left (caml-types-get-pos target-buf (elt node 0))) (right (caml-types-get-pos target-buf (elt node 1))) - (type (elt node 2))) + (type (cdr (assoc "type" (elt node 2))))) (move-overlay caml-types-expr-ovl left right target-buf) (with-current-buffer caml-types-buffer (erase-buffer) @@ -152,6 +174,154 @@ See `caml-types-location-re' for annotation file format. (delete-overlay caml-types-expr-ovl) ))) +(defun caml-types-show-call (arg) + "Show the kind of call at point. + The smallest function call that contains point is + temporarily highlighted. Its kind is highlighted in the .annot + file and the mark is set to the beginning of the kind. + The kind is also displayed in the mini-buffer. + +The kind is also displayed in the buffer *caml-types*, which is +displayed when the command is called with Prefix argument 4. + +See `caml-types-location-re' for annotation file format. +" + (interactive "p") + (let* ((target-buf (current-buffer)) + (target-file (file-name-nondirectory (buffer-file-name))) + (target-line (1+ (count-lines (point-min) + (caml-line-beginning-position)))) + (target-bol (caml-line-beginning-position)) + (target-cnum (point))) + (caml-types-preprocess (buffer-file-name)) + (setq caml-types-buffer (get-buffer-create caml-types-buffer-name)) + (let* ((targ-loc (vector target-file target-line target-bol target-cnum)) + (node (caml-types-find-location targ-loc "call" () + caml-types-annotation-tree))) + (cond + ((null node) + (delete-overlay caml-types-expr-ovl) + (message "Point is not within a function call.")) + (t + (let ((left (caml-types-get-pos target-buf (elt node 0))) + (right (caml-types-get-pos target-buf (elt node 1))) + (kind (cdr (assoc "call" (elt node 2))))) + (move-overlay caml-types-expr-ovl left right target-buf) + (with-current-buffer caml-types-buffer + (erase-buffer) + (insert kind) + (message (format "%s call" kind))) + )))) + (if (and (= arg 4) + (not (window-live-p (get-buffer-window caml-types-buffer)))) + (display-buffer caml-types-buffer)) + (unwind-protect + (caml-sit-for 60) + (delete-overlay caml-types-expr-ovl) + ))) + +(defun caml-types-show-ident (arg) + "Show the binding of identifier at point. + The identifier that contains point is + temporarily highlighted. Its binding is highlighted in the .annot + file and the mark is set to the beginning of the binding. + The binding is also displayed in the mini-buffer. + +The binding is also displayed in the buffer *caml-types*, which is +displayed when the command is called with Prefix argument 4. + +See `caml-types-location-re' for annotation file format. +" + (interactive "p") + (let* ((target-buf (current-buffer)) + (target-file (file-name-nondirectory (buffer-file-name))) + (target-line (1+ (count-lines (point-min) + (caml-line-beginning-position)))) + (target-bol (caml-line-beginning-position)) + (target-cnum (point))) + (caml-types-preprocess (buffer-file-name)) + (setq caml-types-buffer (get-buffer-create caml-types-buffer-name)) + (let* ((targ-loc (vector target-file target-line target-bol target-cnum)) + (node (caml-types-find-location targ-loc "ident" () + caml-types-annotation-tree))) + (cond + ((null node) + (delete-overlay caml-types-expr-ovl) + (message "Point is not within an identifier.")) + (t + (let ((left (caml-types-get-pos target-buf (elt node 0))) + (right (caml-types-get-pos target-buf (elt node 1))) + (kind (cdr (assoc "ident" (elt node 2))))) + (move-overlay caml-types-expr-ovl left right target-buf) + (let* ((loc-re (concat caml-types-position-re " " + caml-types-position-re)) + (end-re (concat caml-types-position-re " --")) + (def-re (concat "def \\([^ ]\\)* " loc-re)) + (def-end-re (concat "def \\([^ ]\\)* " end-re)) + (internal-re (concat "int_ref \\([^ ]\\)* " loc-re)) + (external-re "ext_ref \\(.*\\)")) + (cond + ((string-match def-re kind) + (let ((var-name (match-string 1 kind)) + (l-file (file-name-nondirectory (match-string 2 kind))) + (l-line (string-to-int (match-string 4 kind))) + (l-bol (string-to-int (match-string 5 kind))) + (l-cnum (string-to-int (match-string 6 kind))) + (r-file (file-name-nondirectory (match-string 7 kind))) + (r-line (string-to-int (match-string 9 kind))) + (r-bol (string-to-int (match-string 10 kind))) + (r-cnum (string-to-int (match-string 11 kind)))) + (let* ((lpos (vector l-file l-line l-bol l-cnum)) + (rpos (vector r-file r-line r-bol r-cnum)) + (left (caml-types-get-pos target-buf lpos)) + (right (caml-types-get-pos target-buf rpos))) + (message (format "local variable %s is bound here" var-name)) + (move-overlay caml-types-scope-ovl left right target-buf)))) + ((string-match def-end-re kind) + (let ((var-name (match-string 1 kind)) + (l-file (file-name-nondirectory (match-string 2 kind))) + (l-line (string-to-int (match-string 4 kind))) + (l-bol (string-to-int (match-string 5 kind))) + (l-cnum (string-to-int (match-string 6 kind)))) + (let* ((lpos (vector l-file l-line l-bol l-cnum)) + (left (caml-types-get-pos target-buf lpos)) + (right (buffer-size target-buf))) + (message (format "global variable %s is bound here" var-name)) + (move-overlay caml-types-scope-ovl left right target-buf)))) + ((string-match internal-re kind) + (let ((var-name (match-string 1 kind)) + (l-file (file-name-nondirectory (match-string 2 kind))) + (l-line (string-to-int (match-string 4 kind))) + (l-bol (string-to-int (match-string 5 kind))) + (l-cnum (string-to-int (match-string 6 kind))) + (r-file (file-name-nondirectory (match-string 7 kind))) + (r-line (string-to-int (match-string 9 kind))) + (r-bol (string-to-int (match-string 10 kind))) + (r-cnum (string-to-int (match-string 11 kind)))) + (let* ((lpos (vector l-file l-line l-bol l-cnum)) + (rpos (vector r-file r-line r-bol r-cnum)) + (left (caml-types-get-pos target-buf lpos)) + (right (caml-types-get-pos target-buf rpos))) + (move-overlay caml-types-def-ovl left right target-buf) + (message (format "%s is bound at line %d char %d" + var-name l-line (- l-cnum l-bol)))))) + ((string-match external-re kind) + (let ((fullname (match-string 1 kind))) + (with-current-buffer caml-types-buffer + (erase-buffer) + (insert fullname) + (message (format "external ident: %s" fullname))))))) + )))) + (if (and (= arg 4) + (not (window-live-p (get-buffer-window caml-types-buffer)))) + (display-buffer caml-types-buffer)) + (unwind-protect + (caml-sit-for 60) + (delete-overlay caml-types-expr-ovl) + (delete-overlay caml-types-def-ovl) + (delete-overlay caml-types-scope-ovl) + ))) + (defun caml-types-preprocess (target-path) (let* ((type-path (caml-types-locate-type-file target-path)) (type-date (nth 5 (file-attributes (file-chase-links type-path)))) @@ -167,12 +337,12 @@ See `caml-types-location-re' for annotation file format. (tree (with-current-buffer type-buf (widen) (goto-char (point-min)) - (caml-types-build-tree + (caml-types-build-tree (file-name-nondirectory target-path))))) (setq caml-types-annotation-tree tree caml-types-annotation-date type-date) (kill-buffer type-buf) - (message "")) + (message "done")) ))) (defun caml-types-locate-type-file (target-path) @@ -182,8 +352,8 @@ See `caml-types-location-re' for annotation file format. (defun parent-dir (d) (file-name-directory (directory-file-name d))) (let ((project-dir (file-name-directory sibling)) type-path) - (while (not (file-exists-p - (setq type-path + (while (not (file-exists-p + (setq type-path (expand-file-name (file-relative-name sibling project-dir) (expand-file-name "_build" project-dir))))) @@ -192,7 +362,7 @@ See `caml-types-location-re' for annotation file format. "You should compile with option \"-dtypes\"."))) (setq project-dir (parent-dir project-dir))) type-path)))) - + (defun caml-types-date< (date1 date2) (or (< (car date1) (car date2)) (and (= (car date1) (car date2)) @@ -208,18 +378,26 @@ See `caml-types-location-re' for annotation file format. (symbol-name (intern elem table))) +(defun next-annotation () + (forward-char 1) + (if (re-search-forward "^[a-z\"]" () t) + (forward-char -1) + (goto-char (point-max))) + (looking-at "[a-z]") +) + ; tree of intervals ; each node is a vector -; [ pos-left pos-right type-info child child child... ] -; type-info = -; () if this node does not correspond to an annotated interval -; (type-start . type-end) address of the annotation in the .annot file +; [ pos-left pos-right annotation child child child... ] +; annotation is a list of: +; (kind . info) where kind = "type" "call" etc. +; and info = the contents of the annotation (defun caml-types-build-tree (target-file) (let ((stack ()) (accu ()) (table (caml-types-make-hash-table)) - (type-info ())) + (annotation ())) (while (re-search-forward caml-types-location-re () t) (let ((l-file (file-name-nondirectory (match-string 1))) (l-line (string-to-int (match-string 3))) @@ -230,14 +408,13 @@ See `caml-types-location-re' for annotation file format. (r-bol (string-to-int (match-string 9))) (r-cnum (string-to-int (match-string 10)))) (unless (caml-types-not-in-file l-file r-file target-file) - (while (and (re-search-forward "^" () t) - (not (looking-at "type")) - (not (looking-at "\\\""))) - (forward-char 1)) - (setq type-info - (if (looking-at - "^type(\n\\( \\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)") - (caml-types-hcons (match-string 1) table))) + (setq annotation ()) + (while (next-annotation) + (cond ((looking-at + "^\\([a-z]+\\)(\n \\(\\([^\n)]\\|.)\\|\n[^)]\\)*\\)\n)") + (let ((kind (caml-types-hcons (match-string 1) table)) + (info (caml-types-hcons (match-string 2) table))) + (setq annotation (cons (cons kind info) annotation)))))) (setq accu ()) (while (and stack (caml-types-pos-contains l-cnum r-cnum (car stack))) @@ -245,7 +422,7 @@ See `caml-types-location-re' for annotation file format. (setq stack (cdr stack))) (let* ((left-pos (vector l-file l-line l-bol l-cnum)) (right-pos (vector r-file r-line r-bol r-cnum)) - (node (caml-types-make-node left-pos right-pos type-info + (node (caml-types-make-node left-pos right-pos annotation accu))) (setq stack (cons node stack)))))) (if (null stack) @@ -262,12 +439,12 @@ See `caml-types-location-re' for annotation file format. (and (not (string= r-file target-file)) (not (string= r-file ""))))) -(defun caml-types-make-node (left-pos right-pos type-info children) +(defun caml-types-make-node (left-pos right-pos annotation children) (let ((result (make-vector (+ 3 (length children)) ())) (i 3)) (aset result 0 left-pos) (aset result 1 right-pos) - (aset result 2 type-info) + (aset result 2 annotation) (while children (aset result i (car children)) (setq children (cdr children)) @@ -278,15 +455,15 @@ See `caml-types-location-re' for annotation file format. (and (<= l-cnum (elt (elt node 0) 3)) (>= r-cnum (elt (elt node 1) 3)))) -(defun caml-types-find-location (targ-pos curr node) +(defun caml-types-find-location (targ-pos kind curr node) (if (not (caml-types-pos-inside targ-pos node)) curr - (if (elt node 2) + (if (and (elt node 2) (assoc kind (elt node 2))) (setq curr node)) (let ((i (caml-types-search node targ-pos))) (if (and (> i 3) (caml-types-pos-inside targ-pos (elt node (1- i)))) - (caml-types-find-location targ-pos curr (elt node (1- i))) + (caml-types-find-location targ-pos kind curr (elt node (1- i))) curr)))) ; trouve le premier fils qui commence apres la position @@ -410,12 +587,12 @@ See `caml-types-location-re' for annotation file format. (defun caml-types-explore (event) "Explore type annotations by mouse dragging. -The expression under the mouse is highlighted and its type is displayed +The expression under the mouse is highlighted and its type is displayed in the minibuffer, until the move is released, much as `caml-types-show-type'. -The function uses two overlays. +The function uses two overlays. - . One overlay delimits the largest region whose all subnodes - are well-typed. + . One overlay delimits the largest region whose all subnodes + are well-typed. . Another overlay delimits the current node under the mouse (whose type annotation is beeing displayed). " @@ -444,7 +621,7 @@ The function uses two overlays. (caml-track-mouse (while event (cond - ;; we ignore non mouse events + ;; we ignore non mouse events ((caml-ignore-event-p event)) ;; we stop when the original button is released ((caml-release-event-p original-event event) @@ -462,7 +639,7 @@ The function uses two overlays. ) (while (and (caml-sit-for 0 (/ 500 speed)) - (setq time (caml-types-time)) + (setq time (caml-types-time)) (> (- time last-time) (/ 500 speed)) (setq mouse (caml-mouse-vertical-position)) (or (< mouse top) (>= mouse bottom)) @@ -479,7 +656,7 @@ The function uses two overlays. (condition-case nil (scroll-up 1) (error (message "End of buffer!")))) - ) + ) (setq speed (* speed speed)) ))) ;; main action, when the motion is inside the window @@ -491,7 +668,7 @@ The function uses two overlays. (<= (car region) cnum) (< cnum (cdr region))) ;; mouse remains in outer region nil - ;; otherwise, reset the outer region + ;; otherwise, reset the outer region (setq region (caml-types-typed-make-overlay target-buf (caml-event-point-start event)))) @@ -509,7 +686,7 @@ The function uses two overlays. target-pos (vector target-file target-line target-bol cnum)) (save-excursion - (setq node (caml-types-find-location + (setq node (caml-types-find-location "type" target-pos () target-tree)) (set-buffer caml-types-buffer) (erase-buffer) @@ -554,7 +731,7 @@ The function uses two overlays. ;; However, it could also be a key stroke before mouse release. ;; Emacs does not allow to test whether mouse is up or down. ;; Not sure it is robust to loop for mouse release after an error - ;; occured, as is done for exploration. + ;; occured, as is done for exploration. ;; So far, we just ignore next event. (Next line also be uncommenting.) (if event (caml-read-event)) ))) @@ -582,7 +759,7 @@ The function uses two overlays. (defun caml-types-version () "internal version number of caml-types.el" (interactive) - (message "2") + (message "4") ) (provide 'caml-types) diff --git a/emacs/caml.el b/emacs/caml.el index a4b17db5..18ec3c33 100644 --- a/emacs/caml.el +++ b/emacs/caml.el @@ -10,7 +10,7 @@ ;(* *) ;(***********************************************************************) -;(* $Id: caml.el,v 1.39 2005/02/04 17:19:21 remy Exp $ *) +;(* $Id: caml.el,v 1.44 2008/08/19 12:54:51 doligez Exp $ *) ;;; caml.el --- O'Caml code editing commands for Emacs @@ -296,7 +296,9 @@ have caml-electric-indent on, which see.") (define-key caml-mode-map "\177" 'backward-delete-char-untabify)) ;; caml-types - (define-key caml-mode-map [?\C-c?\C-t] 'caml-types-show-type) + (define-key caml-mode-map [?\C-c?\C-t] 'caml-types-show-type) ; "type" + (define-key caml-mode-map [?\C-c?\C-f] 'caml-types-show-call) ; "function" + (define-key caml-mode-map [?\C-c?\C-l] 'caml-types-show-ident) ; "let" ;; must be a mouse-down event. Can be any button and any prefix (define-key caml-mode-map [?\C-c down-mouse-1] 'caml-types-explore) ;; caml-help @@ -542,12 +544,14 @@ have caml-electric-indent on, which see.") (run-hooks 'caml-mode-hook)) (defun caml-set-compile-command () - "Hook to set compile-command locally, unless there is a Makefile in the - current directory." + "Hook to set compile-command locally, unless there is a Makefile or + a _build directory or a _tags file in the current directory." (interactive) (unless (or (null buffer-file-name) (file-exists-p "makefile") - (file-exists-p "Makefile")) + (file-exists-p "Makefile") + (file-exists-p "_build") + (file-exists-p "_tags")) (let* ((filename (file-name-nondirectory buffer-file-name)) (basename (file-name-sans-extension filename)) (command nil)) @@ -563,7 +567,7 @@ have caml-electric-indent on, which see.") (setq command "ocamlyacc")) ) (if command - (progn + (progn (make-local-variable 'compile-command) (setq compile-command (concat command " " filename)))) ))) @@ -590,7 +594,7 @@ have caml-electric-indent on, which see.") (inferior-caml-eval-region start end)) ;; old version ---to be deleted later -; +; ; (defun caml-eval-phrase () ; "Send the current Caml phrase to the inferior Caml process." ; (interactive) @@ -600,15 +604,15 @@ have caml-electric-indent on, which see.") (defun caml-eval-phrase (arg &optional min max) "Send the phrase containing the point to the CAML process. -With prefix-arg send as many phrases as its numeric value, +With prefix-arg send as many phrases as its numeric value, If an error occurs during evalutaion, stop at this phrase and -repport the error. +repport the error. Return nil if noerror and position of error if any. If arg's numeric value is zero or negative, evaluate the current phrase -or as many as prefix arg, ignoring evaluation errors. -This allows to jump other erroneous phrases. +or as many as prefix arg, ignoring evaluation errors. +This allows to jump other erroneous phrases. Optional arguments min max defines a region within which the phrase should lies." @@ -807,6 +811,10 @@ from an error message produced by camlc.") ;; Wrapper around next-error. (defvar caml-error-overlay nil) +(defvar caml-next-error-skip-warnings-flag nil) + +(defun caml-string-to-int (x) + (if (fboundp 'string-to-number) (string-to-number x) (string-to-int x))) ;;itz 04-21-96 somebody didn't get the documetation for next-error ;;right. When the optional argument is a number n, it should move @@ -823,7 +831,7 @@ fragment. The erroneous fragment is also temporarily highlighted if possible." (if (eq major-mode 'caml-mode) - (let (bol beg end) + (let (skip bol beg end) (save-excursion (set-buffer (if (boundp 'compilation-last-buffer) @@ -833,12 +841,19 @@ possible." (goto-char (window-point (get-buffer-window (current-buffer)))) (if (looking-at caml-error-chars-regexp) (setq beg - (string-to-int + (caml-string-to-int (buffer-substring (match-beginning 1) (match-end 1))) end - (string-to-int - (buffer-substring (match-beginning 2) (match-end 2))))))) - (cond (beg + (caml-string-to-int + (buffer-substring (match-beginning 2) (match-end 2))))) + (next-line) + (beginning-of-line) + (if (and (looking-at "Warning") + caml-next-error-skip-warnings-flag) + (setq skip 't)))) + (cond + (skip (next-error)) + (beg (setq end (- end beg)) (beginning-of-line) (forward-byte beg) @@ -858,6 +873,14 @@ possible." (sit-for 60)) (delete-overlay caml-error-overlay))))))))) +(defun caml-next-error-skip-warnings (&rest args) + (let ((old-flag caml-next-error-skip-warnings-flag)) + (unwind-protect + (progn (setq caml-next-error-skip-warnings-flag 't) + (apply 'next-error args)) + (setq caml-next-error-skip-warnings-flag old-flag)))) + + ;; Usual match-string doesn't work properly with font-lock-mode ;; on some emacs. @@ -967,7 +990,7 @@ to the end. (push-mark) (goto-char beg) (cons beg end))) - + ;;itz Fri Sep 25 12:58:13 PDT 1998 support for adding change-log entries (defun caml-current-defun () (save-excursion @@ -1731,7 +1754,7 @@ by |, insert one." ;; to mark phrases, so that repeated calls will take several of them ;; knows little about Ocaml appart literals and comments, so it should work -;; with other dialects as long as ;; marks the end of phrase. +;; with other dialects as long as ;; marks the end of phrase. (defun caml-indent-phrase (arg) "Indent current phrase diff --git a/lex/.depend b/lex/.depend index df396491..df03846a 100644 --- a/lex/.depend +++ b/lex/.depend @@ -1,11 +1,13 @@ common.cmi: syntax.cmi lexgen.cmi compact.cmi: lexgen.cmi +cset.cmi: lexer.cmi: parser.cmi lexgen.cmi: syntax.cmi output.cmi: syntax.cmi lexgen.cmi compact.cmi common.cmi outputbis.cmi: syntax.cmi lexgen.cmi common.cmi parser.cmi: syntax.cmi syntax.cmi: cset.cmi +table.cmi: common.cmo: syntax.cmi lexgen.cmi common.cmi common.cmx: syntax.cmx lexgen.cmx common.cmi compact.cmo: table.cmi lexgen.cmi compact.cmi diff --git a/lex/lexgen.ml b/lex/lexgen.ml index efa7f749..93f3a113 100644 --- a/lex/lexgen.ml +++ b/lex/lexgen.ml @@ -12,7 +12,7 @@ (* *) (***********************************************************************) -(* $Id: lexgen.ml,v 1.20 2007/01/30 09:18:25 maranget Exp $ *) +(* $Id: lexgen.ml,v 1.21 2008/03/07 15:24:48 maranget Exp $ *) (* Compiling a lexer definition *) @@ -626,7 +626,7 @@ type 'a dfa_state = {final : int * ('a * int TagMap.t) ; others : ('a * int TagMap.t) MemMap.t} -(* + let dtag oc t = fprintf oc "%s<%s>" t.id (if t.start then "s" else "e") @@ -653,7 +653,7 @@ let dstate {final=(act,(_,m)) ; others=o} = dtag_map (fun x -> eprintf "%d" x) (fun () -> prerr_string " ,") m) (fun () -> prerr_endline "") o -*) + let dfa_state_empty = {final=(no_action, (max_int,TagMap.empty)) ; @@ -752,18 +752,25 @@ let tag_cells = Hashtbl.create 17 let state_table = Table.create dfa_state_empty -let reset_state_mem () = - state_map := StateMap.empty; +(* Initial reset of state *) +let reset_state () = Stack.clear todo; next_state_num := 0 ; let _ = Table.trim state_table in () -(* Allocation of memory cells *) -let reset_cell_mem ntags = +(* Reset state before processing a given automata. + We clear both the memory mapping and + the state mapping, as state sharing beetween different + automata may lead to incorret estimation of the cell memory size + BUG ID 0004517 *) + + +let reset_state_partial ntags = next_mem_cell := ntags ; Hashtbl.clear tag_cells ; - temp_pending := false + temp_pending := false ; + state_map := StateMap.empty let do_alloc_temp () = temp_pending := true ; @@ -1095,7 +1102,6 @@ let translate_state shortest_match tags chars follow st = reachs chars follow st.others) end -(* let dtags chan tags = Tags.iter (fun t -> fprintf chan " %a" dtag t) @@ -1117,7 +1123,7 @@ let dfollow t = dtransset t.(i) done ; prerr_endline "]" -*) + let make_tag_entry id start act a r = match a with | Sum (Mem m,0) -> @@ -1146,13 +1152,13 @@ let make_dfa lexdef = (* dfollow follow ; *) - reset_state_mem () ; + reset_state () ; let r_states = ref [] in let initial_states = List.map (fun (le,args,shortest) -> let tags = extract_tags le.lex_actions in - reset_cell_mem le.lex_mem_tags ; + reset_state_partial le.lex_mem_tags ; let pos_set = firstpos le.lex_regexp in (* prerr_string "trans={" ; dtransset pos_set ; prerr_endline "}" ; @@ -1181,6 +1187,7 @@ let make_dfa lexdef = *) let actions = Array.create !next_state_num (Perform (0,[])) in List.iter (fun (act, i) -> actions.(i) <- act) states; - reset_state_mem () ; - reset_cell_mem 0 ; +(* Useless state reset, so as to restrict GC roots *) + reset_state () ; + reset_state_partial 0 ; (initial_states, actions) diff --git a/man/ocaml.m b/man/ocaml.m index 47c263a7..5f97b9c1 100644 --- a/man/ocaml.m +++ b/man/ocaml.m @@ -1,16 +1,14 @@ +\" $Id: ocaml.m,v 1.10 2008/09/15 14:05:30 doligez Exp $ + .TH OCAML 1 .SH NAME ocaml \- The Objective Caml interactive toplevel - .SH SYNOPSIS .B ocaml [ -.B \-unsafe -] -[ -.BI \-I \ lib-dir +.I options ] [ .I object-files @@ -32,7 +30,7 @@ system prints a # (sharp) prompt before reading each phrase. A toplevel phrase can span several lines. It is terminated by ;; (a double-semicolon). The syntax of toplevel phrases is as follows. -The toplevel system is started by the command +The toplevel system is started by the command .BR ocaml (1). Phrases are read on standard input, results are printed on standard output, errors on standard error. End-of-file on standard input @@ -41,11 +39,8 @@ terminates If one or more .I object-files -(ending in -.B .cmo -or -.B .cma - ) are given, they are loaded silently before starting the toplevel. +(ending in .cmo or .cma) are given, they are loaded silently before +starting the toplevel. If a .I script-file @@ -58,34 +53,111 @@ exits after the execution of the last phrase. The following command-line options are recognized by .BR ocaml (1). - .TP -.BI \-I \ directory +.BI -I \ directory Add the given directory to the list of directories searched for source and compiled files. By default, the current directory is searched first, then the standard library directory. Directories added -with +with .B \-I are searched after the current directory, in the order in which they were given on the command line, but before the standard library directory. - +.IP +If the given directory starts with +.BR + , +it is taken relative to the +standard library directory. For instance, +.B \-I\ +labltk +adds the subdirectory +.B labltk +of the standard library to the search path. +.IP +Directories can also be added to the search path once the toplevel +is running with the +.B #directory +directive. +.TP +.BI \-init \ file +Load the given file instead of the default initialization file. +The default file is +.B .ocamlinit +in the current directory if it exists, otherwise +.B .ocamlinit +in the user's home directory. +.TP +.B \-labels +Labels are not ignored in types, labels may be used in applications, +and labelled parameters can be given in any order. This is the default. +.TP +.B \-noassert +Do not compile assertion checks. Note that the special form +.B assert\ false +is always compiled because it is typed specially. +.TP +.B \-nolabels +Ignore non-optional labels in types. Labels cannot be used in +applications, and parameter order becomes strict. +.TP +.B \-noprompt +Do not display any prompt when waiting for input. +.TP +.B \-nostdlib +Do not include the standard library directory in the list of +directories searched for source and compiled files. +.TP +.B \-principal +Check information path during type-checking, to make sure that all +types are derived in a principal way. When using labelled arguments +and/or polymorphic methods, this flag is required to ensure future +versions of the compiler will be able to infer types correctly, even +if internal algorithms change. +All programs accepted in +.B \-principal +mode are also accepted in the +default mode with equivalent types, but different binary signatures, +and this may slow down type checking; yet it is a good idea to +use it once before publishing source code. +.TP +.B \-rectypes +Allow arbitrary recursive types during type-checking. By default, +only recursive types where the recursion goes through an object type +are supported. .TP .B \-unsafe -Turn bound checking off on array and string accesses (the v.(i) -and s.[i] constructs). Programs compiled with +Turn bound checking off on array and string accesses (the +.BR v.(i) and s.[i] +constructs). Programs compiled with .B \-unsafe are therefore slightly faster, but unsafe: anything can happen if the program accesses an array or string outside of its bounds. +.TP +.B \-version +Print version string and exit. +.TP +.BI \-w \ warning-list +Enable or disable warnings according to the argument +.IR warning-list . +See +.BR ocamlc (1) +for the syntax of the argument. +.TP +.BI \-warn-error \ warning-list +Treat as errors the warnings enabled by the argument +.IR warning-list . +See +.BR ocamlc (1) +for the syntax of the argument. +.TP +.BR \-help \ or \ \-\-help +Display a short usage summary and exit. .SH ENVIRONMENT VARIABLES - .TP .B LC_CTYPE If set to iso_8859_1, accented characters (from the ISO Latin-1 character set) in string and character literals are printed as is; otherwise, they are printed as decimal escape sequences. - .TP .B TERM When printing error messages, the toplevel system @@ -94,8 +166,7 @@ consults the TERM variable to determines the type of output terminal and look up its capabilities in the terminal database. .SH SEE ALSO -.BR ocamlc (1). +.BR ocamlc (1), \ ocamlopt (1), \ ocamlrun (1). .br -.I The Objective Caml user's manual, +.IR The\ Objective\ Caml\ user's\ manual , chapter "The toplevel system". - diff --git a/man/ocamlc.m b/man/ocamlc.m index eec9cff9..0ce1e8d8 100644 --- a/man/ocamlc.m +++ b/man/ocamlc.m @@ -1,47 +1,33 @@ +\" $Id: ocamlc.m,v 1.12 2008/09/15 14:12:56 doligez Exp $ + .TH OCAMLC 1 .SH NAME ocamlc \- The Objective Caml bytecode compiler - .SH SYNOPSIS .B ocamlc [ -.B \-aciv -] -[ -.BI \-cclib \ libname -] -[ -.BI \-ccopt \ option -] -[ -.B \-custom -] -[ -.B \-unsafe -] -[ -.BI \-o \ exec-file -] -[ -.BI \-I \ lib-dir +.I options ] .I filename ... .B ocamlc.opt -.I (same options) +[ +.I options +] +.I filename ... .SH DESCRIPTION The Objective Caml bytecode compiler .BR ocamlc (1) -compiles Caml source files to bytecode object files and link +compiles Caml source files to bytecode object files and links these object files to produce standalone bytecode executable files. These executable files are then run by the bytecode interpreter .BR ocamlrun (1). -The +The .BR ocamlc (1) command has a command-line interface similar to the one of most C compilers. It accepts several types of arguments and processes them @@ -51,25 +37,25 @@ Arguments ending in .mli are taken to be source files for compilation unit interfaces. Interfaces specify the names exported by compilation units: they declare value names with their types, define public data types, declare abstract data types, and so on. From the -file +file .IR x \&.mli, -the +the .BR ocamlc (1) compiler produces a compiled interface -in the file +in the file .IR x \&.cmi. Arguments ending in .ml are taken to be source files for compilation unit implementations. Implementations provide definitions for the names exported by the unit, and also contain expressions to be -evaluated for their side-effects. From the file +evaluated for their side-effects. From the file .IR x \&.ml, -the +the .BR ocamlc (1) -compiler produces compiled object bytecode in the file +compiler produces compiled object bytecode in the file .IR x \&.cmo. - -If the interface file + +If the interface file .IR x \&.mli exists, the implementation .IR x \&.ml @@ -77,17 +63,17 @@ is checked against the corresponding compiled interface .IR x \&.cmi, which is assumed to exist. If no interface .IR x \&.mli -is provided, the compilation of +is provided, the compilation of .IR x \&.ml -produces a compiled interface file +produces a compiled interface file .IR x \&.cmi -in addition to the compiled object code file +in addition to the compiled object code file .IR x \&.cmo. -The file +The file .IR x \&.cmi produced corresponds to an interface that exports everything that is defined in -the implementation +the implementation .IR x \&.ml. Arguments ending in .cmo are taken to be compiled object bytecode. These @@ -97,35 +83,72 @@ library, to produce a standalone executable program. The order in which .cmo and.ml arguments are presented on the command line is relevant: compilation units are initialized in that order at run-time, and it is a link-time error to use a component of a unit -before having initialized it. Hence, a given +before having initialized it. Hence, a given .IR x \&.cmo -file must come before all .cmo files that refer to the unit +file must come before all .cmo files that refer to the unit .IR x . Arguments ending in .cma are taken to be libraries of object bytecode. A library of object bytecode packs in a single file a set of object -bytecode files (.cmo files). Libraries are built with -.B ocamlc \-a -(see the description of the +bytecode files (.cmo files). Libraries are built with +.B ocamlc\ \-a +(see the description of the .B \-a option below). The object files -contained in the library are linked as regular .cmo files (see above), in the order specified when the .cma file was built. The only difference is that if an object file +contained in the library are linked as regular .cmo files (see above), +in the order specified when the .cma file was built. The only +difference is that if an object file contained in a library is not referenced anywhere in the program, then it is not linked in. -Arguments ending in .c are passed to the C compiler, which generates a .o object file. This object file is linked with the program if the +Arguments ending in .c are passed to the C compiler, which generates +a .o object file. This object file is linked with the program if the .B \-custom -flag is set (see the description of +flag is set (see the description of .B \-custom below). Arguments ending in .o or .a are assumed to be C object files and -libraries. They are passed to the C linker when linking in +libraries. They are passed to the C linker when linking in .B \-custom -mode (see the description of +mode (see the description of .B \-custom below). +Arguments ending in .so +are assumed to be C shared libraries (DLLs). During linking, they are +searched for external C functions referenced from the Caml code, +and their names are written in the generated bytecode executable. +The run-time system +.BR ocamlrun (1) +then loads them dynamically at program start-up time. + +The output of the linking phase is a file containing compiled bytecode +that can be executed by the Objective Caml bytecode interpreter: +the command +.BR ocamlrun (1). +If +.B caml.out +is the name of the file produced by the linking phase, the command +.B ocamlrun caml.out +.IR arg1 \ \ arg2 \ ... \ argn +executes the compiled code contained in +.BR caml.out , +passing it as arguments the character strings +.I arg1 +to +.IR argn . +(See +.BR ocamlrun (1) +for more details.) + +On most systems, the file produced by the linking +phase can be run directly, as in: +.B ./caml.out +.IR arg1 \ \ arg2 \ ... \ argn . +The produced file has the executable bit set, and it manages to launch +the bytecode interpreter by itself. + .B ocamlc.opt is the same compiler as .BR ocamlc , @@ -135,114 +158,428 @@ Thus, it behaves exactly like .BR ocamlc , but compiles faster. .B ocamlc.opt -is not available in all installations of Objective Caml. +may not be available in all installations of Objective Caml. .SH OPTIONS -The following command-line options are recognized by +The following command-line options are recognized by .BR ocamlc (1). - .TP .B \-a -Build a library (.cma file) with the object files (.cmo files) given on the command line, instead of linking them into an executable -file. The name of the library can be set with the +Build a library (.cma file) with the object files (.cmo files) given +on the command line, instead of linking them into an executable +file. The name of the library must be set with the .B \-o -option. The default name is -.BR library.cma . - +option. +.IP +If +.BR \-custom , \ \-cclib \ or \ \-ccopt +options are passed on the command +line, these options are stored in the resulting .cma library. Then, +linking with this library automatically adds back the +.BR \-custom , \ \-cclib \ and \ \-ccopt +options as if they had been provided on the +command line, unless the +.B -noautolink +option is given. +.TP +.B \-annot +Dump detailed information about the compilation (types, bindings, +tail-calls, etc). The information for file +.IR src .ml +is put into file +.IR src .annot. +In case of a type error, dump all the information inferred by the +type-checker before the error. The +.IR src .annot +file can be used with the emacs commands given in +.B emacs/caml\-types.el +to display types and other annotations interactively. .TP .B \-c Compile only. Suppress the linking phase of the compilation. Source code files are turned into compiled files, but no executable file is produced. This option is useful to compile modules separately. - +.TP +.BI \-cc \ ccomp +Use +.I ccomp +as the C linker when linking in "custom runtime" mode (see the +.B \-custom +option) and as the C compiler for compiling .c source files. .TP .BI \-cclib\ -l libname -Pass the +Pass the .BI \-l libname -option to the C linker when linking in -``custom runtime'' mode (see the +option to the C linker when linking in "custom runtime" mode (see the .B \-custom -option). This causes the -given C library to be linked with the program. - +option). This causes the given C library to be linked with the program. .TP .B \-ccopt Pass the given option to the C compiler and linker, when linking in -``custom runtime'' mode (see the +"custom runtime" mode (see the .B \-custom option). For instance, -.B -ccopt -L -.I dir +.BI \-ccopt\ \-L dir causes the C linker to search for C libraries in -directory +directory .IR dir . - +.TP +.B \-config +Print the version number of +.BR ocamlc (1) +and a detailed summary of its configuration, then exit. .TP .B \-custom -Link in ``custom runtime'' mode. In the default linking mode, the +Link in "custom runtime" mode. In the default linking mode, the linker produces bytecode that is intended to be executed with the -shared runtime system, +shared runtime system, .BR ocamlrun (1). In the custom runtime mode, the linker produces an output file that contains both the runtime system and the bytecode for the program. The resulting file is larger, but it -can be executed directly, even if the +can be executed directly, even if the .BR ocamlrun (1) command is not -installed. Moreover, the ``custom runtime'' mode enables linking Caml +installed. Moreover, the "custom runtime" mode enables linking Caml code with user-defined C functions. +Never use the +.BR strip (1) +command on executables produced by +.BR ocamlc\ \-custom , +this would remove the bytecode part of the executable. +.TP +.BI \-dllib\ \-l libname +Arrange for the C shared library +.BI dll libname .so +to be loaded dynamically by the run-time system +.BR ocamlrun (1) +at program start-up time. +.TP +.BI \-dllpath \ dir +Adds the directory +.I dir +to the run-time search path for shared +C libraries. At link-time, shared libraries are searched in the +standard search path (the one corresponding to the +.B \-I +option). +The +.B \-dllpath +option simply stores +.I dir +in the produced +executable file, where +.BR ocamlrun (1) +can find it and use it. +.TP +.B \-g +Add debugging information while compiling and linking. This option is +required in order to be able to debug the program with +.BR ocamldebug (1) +and to produce stack backtraces when +the program terminates on an uncaught exception. .TP .B \-i Cause the compiler to print all defined names (with their inferred types or their definitions) when compiling an implementation (.ml -file). This can be useful to check the types inferred by the +file). No compiled files (.cmo and .cmi files) are produced. +This can be useful to check the types inferred by the compiler. Also, since the output follows the syntax of interfaces, it can help in writing an explicit interface (.mli file) for a file: just 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 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 +compiled interface files (.cmi), compiled object code files +(.cmo), libraries (.cma), and C libraries specified with +.B \-cclib\ \-l +.IR xxx . +By default, the current directory is searched first, then the standard library directory. Directories added with .B -I are searched after the current directory, in the order in which they were given on the command line, but before the standard library directory. +If the given directory starts with +.BR + , +it is taken relative to the +standard library directory. For instance, +.B \-I\ +labltk +adds the subdirectory +.B labltk +of the standard library to the search path. +.TP +.BI \-impl \ filename +Compile the file +.I filename +as an implementation file, even if its extension is not .ml. .TP -.BI \-o \ exec-file +.BI \-intf \ filename +Compile the file +.I filename +as an interface file, even if its extension is not .mli. +.TP +.BI \-intf\-suffix \ string +Recognize file names ending with +.I string +as interface files (instead of the default .mli). +.TP +.B \-labels +Labels are not ignored in types, labels may be used in applications, +and labelled parameters can be given in any order. This is the default. +.TP +.B \-linkall +Force all modules contained in libraries to be linked in. If this +flag is not given, unreferenced modules are not linked in. When +building a library (option +.BR \-a ), +setting the +.B \-linkall +option forces all subsequent links of programs involving that library +to link all the modules contained in the library. +.TP +.B \-make\-runtime +Build a custom runtime system (in the file specified by option +.BR \-o ) +incorporating the C object files and libraries given on the command +line. This custom runtime system can be used later to execute +bytecode executables produced with the option +.B ocamlc\ \-use\-runtime +.IR runtime-name . +.TP +.B \-noassert +Do not compile assertion checks. Note that the special form +.B assert\ false +is always compiled because it is typed specially. +This flag has no effect when linking already-compiled files. +.TP +.B \-noautolink +When linking .cma libraries, ignore +.BR \-custom , \ \-cclib \ and \ \-ccopt +options potentially contained in the libraries (if these options were +given when building the libraries). This can be useful if a library +contains incorrect specifications of C libraries or C options; in this +case, during linking, set +.B \-noautolink +and pass the correct C libraries and options on the command line. +.TP +.B \-nolabels +Ignore non-optional labels in types. Labels cannot be used in +applications, and parameter order becomes strict. +.TP +.BI \-o \ exec\-file Specify the name of the output file produced by the linker. The -default output name is +default output name is .BR a.out , -in keeping with the Unix tradition. If the +in keeping with the Unix tradition. If the .B \-a -option is given, specify the name of the library produced. - +option is given, specify the name of the library +produced. If the +.B \-pack +option is given, specify the name of the +packed object file produced. If the +.B \-output\-obj +option is given, +specify the name of the output file produced. .TP -.B \-v -Print the version number of the compiler. - +.B \-output\-obj +Cause the linker to produce a C object file instead of a bytecode +executable file. This is useful to wrap Caml code as a C library, +callable from any C program. The name of the output object file is +.B camlprog.o +by default; it can be set with the +.B \-o +option. This +option can also be used to produce a C source file (.c extension) or +a compiled shared/dynamic library (.so extension). +.TP +.B \-pack +Build a bytecode object file (.cmo file) and its associated compiled +interface (.cmi) that combines the object +files given on the command line, making them appear as sub-modules of +the output .cmo file. The name of the output .cmo file must be +given with the +.B \-o +option. For instance, +.B ocamlc\ \-pack\ \-o\ p.cmo\ a.cmo\ b.cmo\ c.cmo +generates compiled files p.cmo and p.cmi describing a compilation +unit having three sub-modules A, B and C, corresponding to the +contents of the object files a.cmo, b.cmo and c.cmo. These +contents can be referenced as P.A, P.B and P.C in the remainder +of the program. +.TP +.BI \-pp \ command +Cause the compiler to call the given +.I command +as a preprocessor for each source file. The output of +.I command +is redirected to +an intermediate file, which is compiled. If there are no compilation +errors, the intermediate file is deleted afterwards. The name of this +file is built from the basename of the source file with the extension +.ppi for an interface (.mli) file and .ppo for an implementation +(.ml) file. +.TP +.B \-principal +Check information path during type-checking, to make sure that all +types are derived in a principal way. When using labelled arguments +and/or polymorphic methods, this flag is required to ensure future +versions of the compiler will be able to infer types correctly, even +if internal algorithms change. +All programs accepted in +.B \-principal +mode are also accepted in the +default mode with equivalent types, but different binary signatures, +and this may slow down type checking; yet it is a good idea to +use it once before publishing source code. +.TP +.B \-rectypes +Allow arbitrary recursive types during type-checking. By default, +only recursive types where the recursion goes through an object type +are supported. Note that once you have created an interface using this +flag, you must use it again for all dependencies. +.TP +.B \-thread +Compile or link multithreaded programs, in combination with the +system "threads" library described in +.IR The\ Objective\ Caml\ user's\ manual . .TP .B \-unsafe -Turn bound checking off on array and string accesses (the -.B v.(i) -and -.B s.[i] -constructs). Programs compiled with +Turn bound checking off for array and string accesses (the +.BR v.(i) and s.[i] +constructs). Programs compiled with .B \-unsafe are therefore slightly faster, but unsafe: anything can happen if the program accesses an array or string outside of its bounds. +.TP +.BI \-use\-runtime \ runtime\-name +Generate a bytecode executable file that can be executed on the custom +runtime system +.IR runtime\-name , +built earlier with +.B ocamlc\ \-make\-runtime +.IR runtime\-name . +.TP +.B \-v +Print the version number of the compiler and the location of the +standard library directory, then exit. +.TP +.B \-verbose +Print all external commands before they are executed, in particular +invocations of the C compiler and linker in +.B \-custom +mode. Useful to debug C library problems. +.TP +.B \-version +Print the version number of the compiler in short form (e.g. "3.11.0"), +then exit. +.TP +.B \-vmthread +Compile or link multithreaded programs, in combination with the +VM-level threads library described in +.IR The\ Objective\ Caml\ user's\ manual . +.TP +.BI \-w \ warning\-list +Enable or disable warnings according to the argument +.IR warning\-list . +The argument is a set of letters. If a letter is +uppercase, it enables the corresponding warnings; lowercase disables +the warnings. The correspondence is the following: + +.B A +\ \ all warnings + +.B C +\ \ start of comments that look like mistakes + +.B D +\ \ use of deprecated features + +.B E +\ \ fragile pattern matchings (matchings that will remain +complete even if additional constructors are added to one of the +variant types matched) + +.B F +\ \ partially applied functions (expressions whose result has +function type and is ignored) + +.B L +\ \ omission of labels in applications + +.B M +\ \ overriding of methods + +.B P +\ \ missing cases in pattern matchings (i.e. partial matchings) + +.B S +\ \ expressions in the left-hand side of a sequence that don't +have type +.B unit +(and that are not functions, see +.B F +above) + +.B U +\ \ redundant cases in pattern matching (unused cases) + +.B V +\ \ overriding of instance variables + +.B Y +\ \ unused variables that are bound with +.BR let \ or \ as , +and don't start with an underscore (_) character + +.B Z +\ \ all other cases of unused variables that don't start with an +underscore (_) character + +.B X +\ \ warnings that don't fit in the above categories (except +.BR A ) +.IP +The default setting is +.BR \-w\ Aelz , +enabling all warnings except fragile +pattern matchings, omitted labels, and innocuous unused variables. +Note that warnings +.BR F \ and \ S +are not always triggered, depending on the internals of the type checker. +.TP +.BI \-warn\-error \ warning\-list +Turn the warnings indicated in the argument +.I warning\-list +into errors. The compiler will stop with an error when one of these +warnings is emitted. The +.I warning\-list +has the same meaning as for +the "-w" option: an uppercase character turns the corresponding +warning into an error, a lowercase character leaves it as a warning. +The default setting is +.B \-warn\-error\ a +(none of the warnings is treated as an error). +.TP +.B \-where +Print the location of the standard library, then exit. +.TP +.BI \- \ file +Process +.I file +as a file name, even if it starts with a dash (-) character. +.TP +.BR \-help \ or \ \-\-help +Display a short usage summary and exit. .SH SEE ALSO -.BR ocaml (1), -.BR ocamlrun (1). +.BR ocamlopt (1), \ ocamlrun (1), \ ocaml (1). .br -.I The Objective Caml user's manual, +.IR "The Objective Caml user's manual" , chapter "Batch compilation". diff --git a/man/ocamlcp.m b/man/ocamlcp.m index 8b188ce4..1b3cc52a 100644 --- a/man/ocamlcp.m +++ b/man/ocamlcp.m @@ -1,3 +1,5 @@ +\" $Id: ocamlcp.m,v 1.4 2008/09/15 14:05:30 doligez Exp $ + .TH OCAMLCP 1 .SH NAME @@ -16,7 +18,7 @@ ocamlcp \- The Objective Caml profiling compiler .SH DESCRIPTION The .B ocamlcp -script is a front-end to +command is a front-end to .BR ocamlc (1) that instruments the source code, adding code to record how many times functions are called, branches of conditionals are taken, ... @@ -36,53 +38,62 @@ options, .B ocamlcp accepts the following option controlling the amount of profiling information: - .TP -.BR \-p \ letters -The letters following -.B -p +.BI \-p \ letters +The +.I letters indicate which parts of the program should be profiled: - .TP .B a all options .TP .B f -function calls : a count point is set at the beginning of function bodies +function calls : a count point is set at the beginning of each function body .TP .B i -if... then... else: count points are set in -both "then" branch and "else" branch +.BR if \ ... \ then \ ... \ else : +count points are set in both +.BR then \ and \ else +branches .TP .B l -while, for loops: a count point is set at the beginning of -the loop body +\BR while , \ for +loops: a count point is set at the beginning of the loop body .TP .B m -"match" branches: a count point is set at the beginning of the -body of each branch +.B match +branches: a count point is set at the beginning of the +body of each branch of a pattern-matching .TP .B t -try...with branches: a count point is set at the -beginning of the body of each branch +.BR try \ ... \ with +branches: a count point is set at the beginning of the body of each +branch of an exception catcher -For instance, compiling with -.B ocamlcp \-pfilm -profiles function calls, if... then... else..., loops, and pattern -matching. +.PP +For instance, compiling with +.B ocamlcp\ \-pfilm +profiles function calls, +.BR if \ ... \ then \ ... \ else \ ..., +loops, and pattern matching. -Calling +Calling .BR ocamlcp (1) without the .B \-p option defaults to -.B \-p fm -meaning -that only function calls and pattern matching are profiled. +.B \-p\ fm +meaning that only function calls and pattern matching are profiled. + +Note: due to the implementation of streams and stream patterns as +syntactic sugar, it is hard to predict what parts of stream expressions +and patterns will be profiled by a given flag. To profile a program with +streams, we recommend using +.BR ocamlcp\ \-p\ a . .SH SEE ALSO .BR ocamlc (1), .BR ocamlprof (1). .br -.I The Objective Caml user's manual, +.IR "The Objective Caml user's manual" , chapter "Profiling". diff --git a/man/ocamldebug.m b/man/ocamldebug.m index 4e157ebf..1e81e896 100644 --- a/man/ocamldebug.m +++ b/man/ocamldebug.m @@ -1,3 +1,5 @@ +\" $Id: ocamldebug.m,v 1.2 2008/09/15 14:05:30 doligez Exp $ + .TH OCAMLDEBUG 1 .SH NAME @@ -8,30 +10,74 @@ ocamldebug \- the Objective Caml source-level replay debugger. .SH DESCRIPTION .B ocamldebug is the Objective Caml source-level replay debugger. + +Before the debugger can be used, the program must be compiled and +linked with the +.B \-g +option: all .cmo and .cma files that are part +of the program should have been created with +.BR ocamlc\ \-g , +and they must be linked together with +.BR ocamlc\ \-g . + +Compiling with +.B \-g +entails no penalty on the running time of +programs: object files and bytecode executable files are bigger and +take longer to produce, but the executable files run at +exactly the same speed as if they had been compiled without +.BR \-g . + .SH OPTIONS A summary of options are included below. For a complete description, see the html documentation in the ocaml-doc package. .TP -.B \-I directory -Add directory to the list of directories searched for source files and -compiled files. +.BI \-c \ count +Set the maximum number of simultaneously live checkpoints to +.IR count . .TP -.B \-s socket -Use socket for communicating with the debugged program. -.TP -.B \-c count -Set the maximum number of simultaneously live checkpoints to count. -.TP -.B \-cd directory -Run the debugger program from the given directory, -instead of the current working directory. +.BI \-cd \ dir +Run the debugger program from the working directory +.IR dir , +instead of the current working directory. (See also the +.B cd +command.) .TP .B \-emacs -Tell the debugger it is executed under Emacs. +Tell the debugger it is executed under Emacs. (See +.I "The Objective Caml user's manual" +for information on how to run the debugger under Emacs.) +.TP +.BI \-I \ directory +Add +.I directory +to the list of directories searched for source files and +compiled files. (See also the +.B directory +command.) +.TP +.BI \-s \ socket +Use +.I socket +for communicating with the debugged program. See the description +of the command +.B set\ socket +in +.I "The Objective Caml user's manual" +for the format of +.IR socket . +.TP +.B \-version +Print version and exit. +.TP +.BR \-help \ or \ \-\-help +Display a short usage summary and exit. .SH SEE ALSO -ocamldebug is documented fully in the Ocaml HTML documentation. +.BR ocamlc (1) +.br +.IR "The Objective Caml user's manual" , +chapter "The debugger". .SH AUTHOR This manual page was written by Sven LUTHER , for the Debian GNU/Linux system (but may be used by others). - diff --git a/man/ocamldep.m b/man/ocamldep.m index 7b24082a..884ceb15 100644 --- a/man/ocamldep.m +++ b/man/ocamldep.m @@ -1,18 +1,20 @@ +\" $Id: ocamldep.m,v 1.6 2008/09/15 14:12:56 doligez Exp $ + .TH OCAMLDEP 1 .SH NAME ocamldep \- Dependency generator for Objective Caml .SH SYNOPSIS -.B ocamldep +.B ocamldep [ -.BI \-I \ lib-dir +.I options ] .I filename ... .SH DESCRIPTION -The +The .BR ocamldep (1) command scans a set of Objective Caml source files (.ml and .mli files) for references to external compilation units, @@ -24,7 +26,7 @@ file is modified. The typical usage is: .P -ocamldep +ocamldep .I options *.mli *.ml > .depend .P @@ -32,30 +34,45 @@ where .depend is the file that should contain the dependencies. Dependencies are generated both for compiling with the bytecode -compiler +compiler .BR ocamlc (1) -and with the native-code compiler +and with the native-code compiler .BR ocamlopt (1). .SH OPTIONS -The following command-line option is recognized by +The following command-line options are recognized by .BR ocamldep (1). - .TP .BI \-I \ directory Add the given directory to the list of directories searched for source files. If a source file foo.ml mentions an external compilation unit Bar, a dependency on that unit's interface bar.cmi is generated only if the source for bar is found in the -current directory or in one of the directories specified with -.BR -I . +current directory or in one of the directories specified with +.BR \-I . Otherwise, Bar is assumed to be a module from the standard library, and no dependencies are generated. For programs that span multiple -directories, it is recommended to pass +directories, it is recommended to pass .BR ocamldep (1) -the same -I options that are passed to the compiler. - +the same +.B \-I +options that are passed to the compiler. +.TP +.B \-modules +Output raw dependencies of the form +.IR filename : \ Module1\ Module2 \ ... \ ModuleN +where +.IR Module1 ,\ ..., \ ModuleN +are the names of the compilation +units referenced within the file +.IR filename , +but these names are not +resolved to source file names. Such raw dependencies cannot be used +by +.BR make (1), +but can be post-processed by other tools such as +.BR Omake (1). .TP .BI \-native Generate dependencies for a pure native-code program (no bytecode @@ -66,14 +83,30 @@ generates dependencies on the bytecode compiled file (.cmo file) to reflect interface changes. This can cause unnecessary bytecode recompilations for programs that are compiled to native-code only. The flag -.BR -native +.B \-native causes dependencies on native compiled files (.cmx) to be generated instead of on .cmo files. (This flag makes no difference if all source files have explicit .mli interface files.) +.TP +.BI \-pp \ command +Cause +.BR ocamldep (1) +to call the given +.I command +as a preprocessor for each source file. +.TP +.B \-slash +Under Unix, this option does nothing. +.TP +.B \-version +Print version and exit. +.TP +.BR \-help \ or \ \-\-help +Display a short usage summary and exit. .SH SEE ALSO .BR ocamlc (1), .BR ocamlopt (1). .br -.I The Objective Caml user's manual, +.IR The\ Objective\ Caml\ user's\ manual , chapter "Dependency generator". diff --git a/man/ocamldoc.m b/man/ocamldoc.m index 5dcc0a52..5d1ed6ad 100644 --- a/man/ocamldoc.m +++ b/man/ocamldoc.m @@ -1,13 +1,15 @@ -.TH OCAMLDOC 1 "February 6, 2004" "GNU/Linux" "User's Manual" +\" $Id: ocamldoc.m,v 1.5 2008/09/15 14:12:56 doligez Exp $ -.de Sh \" Subsection heading -.br -.if t .Sp -.ne 5 -.PP -\fB\\$1\fR -.PP -.. +.TH OCAMLDOC 1 + +\" .de Sh \" Subsection heading +\" .br +\" .if t .Sp +\" .ne 5 +\" .PP +\" \fB\\$1\fR +\" .PP +\" .. .SH NAME ocamldoc \- The Objective Caml documentation generator @@ -16,54 +18,9 @@ ocamldoc \- The Objective Caml documentation generator .SH SYNOPSIS .B ocamldoc [ -.B \-html -] -[ -.B \-latex -] -[ -.B \-texi -] -[ -.B \-man +.I options ] -[ -.B \-dot -] -[ -.BI \-g \ file -] -[ -.BI \-d \ dir -] -[ -.BI \-dump \ file -] -[ -.BI \-hide \ modules -] -[ -.B \-inv\-merge\-ml\-mli -] -[ -.B \-keep\-code -] -[ -.BI \-load \ file -] -[ -.BI \-m \ flags -] -[ -.BI \-o \ file -] -[ -.BI \-I \ directory -] -[ -.BI ... -] -.I filename ... +.IR filename \ ... .SH DESCRIPTION @@ -71,7 +28,7 @@ The Objective Caml documentation generator .BR ocamldoc (1) generates documentation from special comments embedded in source files. The comments used by OCamldoc are of the form -.I (**...*) +.I (** ... *) and follow the format described in the .IR "The Objective Caml user's manual" . @@ -82,7 +39,7 @@ dependency graphs. Moreover, users can add their own custom generators. In this manpage, we use the word -.IR element +.I element to refer to any of the following parts of an OCaml source file: a type declaration, a value, a module, an exception, a module type, a type constructor, a record field, a class, a class type, a class method, a class @@ -93,9 +50,7 @@ value or a class inheritance clause. The following command-line options determine the format for the generated documentation generated by .BR ocamldoc (1). - -.Sh "Options for choosing the output format" - +.SS "Options for choosing the output format" .TP .B \-html Generate documentation in HTML default format. The generated HTML pages are @@ -105,11 +60,10 @@ option. You can customize the style of the generated pages by editing the generated .I style.css file, or by providing your own style sheet using option -.B \-css\-style -. The file +.BR \-css\-style . +The file .I style.css is not generated if it already exists. - .TP .B \-latex Generate documentation in LaTeX default format. The generated LaTeX document @@ -123,7 +77,6 @@ This file is generated when using the .B \-latex option, if it does not already exist. You can change this file to customize the style of your LaTeX documentation. - .TP .B \-texi Generate documentation in TeXinfo default format. The generated LaTeX document @@ -132,18 +85,18 @@ is saved in file or in the file specified with the .B -o option. - .TP .B \-man Generate documentation as a set of Unix man pages. The generated pages are stored in the current directory, or in the directory specified with the .B \-d option. - .TP .B \-dot Generate a dependency graph for the toplevel modules, in a format suitable for -displaying and processing by dot. The +displaying and processing by +.IR dot (1). +The .IR dot (1) tool is available from .IR http://www.research.att.com/sw/tools/graphviz/ . @@ -154,75 +107,67 @@ or to the file specified with the option. Use .BI dot \ ocamldoc.out to display it. - .TP .BI \-g \ file Dynamically load the given file (which extension usually is .cmo or .cma), which defines a custom documentation generator. This option is supported by the .BR ocamldoc (1) command, but not by its native-code version -.BR ocamldoc.opt . +.BR ocamldoc.opt . If the given file is a simple one and does not exist in -the current directory, then ocamldoc looks for it in the custom -generators default directory. - +the current directory, then ocamldoc looks for it in the custom +generators default directory, and in the directories specified with the +.B \-i +option. .TP .BI \-customdir Display the custom generators default directory. - .TP .BI \-i \ directory Add the given directory to the path where to look for custom generators. - -.Sh "General options" - +.SS "General options" .TP .BI \-d \ dir Generate files in directory .IR dir , -rather than in the current directory. - +rather than the current directory. .TP .BI \-dump \ file -Dump collected information into file. This information can be read with the -.B -load +Dump collected information into +.IR file . +This information can be read with the +.B \-load option in a subsequent invocation of .BR ocamldoc (1). - .TP .BI \-hide \ modules Hide the given complete module names in the generated documentation. .I modules -is a list of complete module names are separated by ',', without blanks. For -instance: +is a list of complete module names are separated by commas (,), +without blanks. For instance: .IR Pervasives,M2.M3 . - .TP .B \-inv\-merge\-ml\-mli -Inverse implementations and interfaces when merging. All elements in -implementation files are kept, and the +Reverse the precedence of implementations and interfaces when merging. +All elements in implementation files are kept, and the .B \-m option indicates which parts of the comments in interface files are merged with the comments in implementation files. - .TP .B \-keep\-code Always keep the source code for values, methods and instance variables, when available. The source code is always kept when a .ml file is given, but is by default discarded when a .mli is given. This option allows to always keep the source code. - .TP .BI \-load \ file Load information from .IR file , which has been produced by -.B ocamldoc -.BR \-dump . +.BR ocamldoc\ \-dump . Several .B -load options can be given. - .TP .BI \-m flags Specify merge options between interfaces and implementations. @@ -236,7 +181,7 @@ merge description merge @author .B v -merge @version +merge @version .B l merge @see @@ -245,30 +190,27 @@ merge @see merge @since .B o -merge @deprecated +merge @deprecated .B p -merge @param +merge @param .B e -merge @raise +merge @raise .B r -merge @return +merge @return .B A -merge everything - +merge everything .TP .B \-no\-custom\-tags Do not allow custom @-tags. - .TP .B \-no\-stop Keep elements placed after the -.I (**/**) +.B (**/**) special comment. - .TP .BI \-o \ file Output the generated documentation to @@ -276,104 +218,97 @@ Output the generated documentation to instead of .IR ocamldoc.out . This option is meaningful only in conjunction with the -.BR \-latex , -.BR \-texi , -or -.B \-dot +.BR \-latex , \ \-texi ,\ or \ \-dot options. - .TP .BI \-pp \ command -Pipe sources through preprocessor command. - +Pipe sources through preprocessor +.IR command . .TP .B \-sort Sort the list of top-level modules before generating the documentation. - .TP .B \-stars Remove blank characters until the first asterisk ('*') in each line of comments. - .TP .BI \-t \ title Use .I title as the title for the generated documentation. - .TP .BI \-intro \ file Use content of .I file as ocamldoc text to use as introduction (HTML, LaTeX and TeXinfo only). For HTML, the file is used to create the whole "index.html" file. - .TP .B \-v Verbose mode. Display progress information. - .TP -.B \-warn-error -Treat warnings as errors. - -.Sh "Type-checking options" - +.B \-version +Print the version string and exit. +.TP +.B \-warn\-error +Treat Ocamldoc warnings as errors. +.TP +.B \-hide\-warnings +Do not print OCamldoc warnings. +.TP +.BR \-help \ or \ \-\-help +Display a short usage summary and exit. +.SS "Type-checking options" .BR ocamldoc (1) calls the Objective Caml type-checker to obtain type informations. The following options impact the type-checking phase. They have the same meaning as for the -.BR ocamlc (1) -and -.BR ocamlopt (1) +.BR ocamlc (1)\ and \ ocamlopt (1) commands. - .TP .BI \-I \ directory -Add directory to the list of directories search for compiled interface files -(.cmi files). - +Add +.I directory +to the list of directories search for compiled interface files (.cmi files). .TP .B \-nolabels Ignore non-optional labels in types. - .TP .B \-rectypes Allow arbitrary recursive types. (See the .B \-rectypes option to .BR ocamlc (1).) - -.Sh "Options for generating HTML pages" - +.SS "Options for generating HTML pages" The following options apply in conjunction with the .B \-html option: - .TP -.B \-all-params +.B \-all\-params Display the complete list of parameters for functions and methods. - .TP -.BI \-css-style \ filename -Use filename as the Cascading Style Sheet file. - +.BI \-css\-style \ filename +Use +.I filename +as the Cascading Style Sheet file. .TP -.B \-colorize-code +.B \-colorize\-code Colorize the OCaml code enclosed in [ ] and \\{[ ]\\}, using colors to emphasize keywords, etc. If the code fragments are not syntactically correct, no color is added. - .TP -.B \-index-only +.B \-index\-only Generate only index files. - -.Sh "Options for generating LaTeX files" - +.TP +.B \-short\-functors +Use a short form to display functors: +.B "module M : functor (A:Module) -> functor (B:Module2) -> sig .. end" +is displayed as +.BR "module M (A:Module) (B:Module2) : sig .. end" . +.SS "Options for generating LaTeX files" The following options apply in conjunction with the .B \-latex option: - .TP -.B \-latex-value-prefix prefix +.B \-latex\-value\-prefix prefix Give a prefix to use for the labels of the values in the generated LaTeX document. The default prefix is the empty string. You can also use the options .BR -latex-type-prefix , @@ -382,81 +317,67 @@ document. The default prefix is the empty string. You can also use the options .BR -latex-module-type-prefix , .BR -latex-class-prefix , .BR -latex-class-type-prefix , -.B -latex-attribute-prefix -and +.BR -latex-attribute-prefix ,\ and .BR -latex-method-prefix . These options are useful when you have, for example, a type and a value with the same name. If you do not specify prefixes, LaTeX will complain about multiply defined labels. - .TP .BI \-latextitle \ n,style Associate style number .I n -to the given LaTeX sectioning command style, e.g. section or subsection. +to the given LaTeX sectioning command +.IR style , +e.g. +.BR section or subsection . (LaTeX only.) This is useful when including the generated document in another LaTeX document, at a given sectioning level. The default association is 1 for section, 2 for subsection, 3 for subsubsection, 4 for paragraph and 5 for subparagraph. - .TP .B \-noheader Suppress header in generated documentation. - .TP .B \-notoc Do not generate a table of contents. - .TP .B \-notrailer Suppress trailer in generated documentation. - .TP .B \-sepfiles Generate one .tex file per toplevel module, instead of the global .I ocamldoc.out -file. - -.Sh "Options for generating TeXinfo files" - +file. +.SS "Options for generating TeXinfo files" The following options apply in conjunction with the .B -texi option: - .TP .B \-esc8 Escape accented characters in Info files. - .TP .B -\-info-entry +\-info\-entry Specify Info directory entry. - .TP -.B \-info-section +.B \-info\-section Specify section of Info directory. - .TP .B \-noheader Suppress header in generated documentation. - .TP .B \-noindex Do not build index for Info files. - .TP .B \-notrailer -Suppress trailer in generated documentation. - -.Sh "Options for generating dot graphs" - +Suppress trailer in generated documentation. +.SS "Options for generating dot graphs" The following options apply in conjunction with the .B \-dot option: - .TP -.BI \-dot-colors \ colors +.BI \-dot\-colors \ colors Specify the colors to use in the generated dot code. When generating module dependencies, .BR ocamldoc (1) @@ -464,46 +385,44 @@ uses different colors for modules, depending on the directories in which they reside. When generating types dependencies, .BR ocamldoc (1) uses different colors for types, depending on the modules in which they are -defined. colors is a list of color names separated by ',', as in -.IR Red,Blue,Green . +defined. +.I colors +is a list of color names separated by commas (,), as in +.BR Red,Blue,Green . The available colors are the ones supported by the .BR dot (1) tool. - .TP -.B \-dot-include-all +.B \-dot\-include\-all Include all modules in the .BR dot (1) output, not only modules given on the command line or loaded with the .B \-load option. - .TP -.B \-dot-reduce +.B \-dot\-reduce Perform a transitive reduction of the dependency graph before outputting the dot code. This can be useful if there are a lot of transitive dependencies that clutter the graph. - .TP -.B \-dot-types +.B \-dot\-types Output dot code describing the type dependency graph instead of the module dependency graph. - -.Sh "Options for generating man files" - +.SS "Options for generating man files" The following options apply in conjunction with the .B \-man option: - .TP -.B \-man-mini +.B \-man\-mini Generate man pages only for modules, module types, classes and class types, instead of pages for all elements. - .TP -.B \-man-suffix -Set the suffix used for generated man filenames. Default is 'o', like in +.BI \-man\-suffix suffix +Set the suffix used for generated man filenames. Default is o, as in .IR List.o . +.TP +.BI \-man\-section section +Set the section number used for generated man filenames. Default is 3. .SH SEE ALSO diff --git a/man/ocamllex.m b/man/ocamllex.m index 3b1340d3..128dc56c 100644 --- a/man/ocamllex.m +++ b/man/ocamllex.m @@ -1,3 +1,4 @@ +\" $Id: ocamllex.m,v 1.5 2008/09/15 14:12:56 doligez Exp $ .TH OCAMLLEX 1 .SH NAME @@ -25,7 +26,7 @@ Running .BR ocamllex (1) on the input file .IR lexer \&.mll -produces Caml code for a lexical analyzer in file +produces Caml code for a lexical analyzer in file .IR lexer \&.ml. This file defines one lexing function per entry point in the lexer @@ -39,33 +40,45 @@ Lexing.from_string and Lexing.from_function create lexer buffers that read from an input channel, a character string, or any reading function, respectively. -When used in conjunction with a parser generated by +When used in conjunction with a parser generated by .BR ocamlyacc (1), the semantic actions compute a value belonging to the type token defined by the generated parsing module. .SH OPTIONS -The +The .BR ocamllex (1) command recognizes the following options: - -.TP -.BI \-o \ output-file -Specify the output file name -.IR output-file -instead of the default naming convention. - .TP .B \-ml -Output code that does not use the Caml built-in automata +Output code that does not use OCaml's built-in automata interpreter. Instead, the automaton is encoded by Caml functions. -This option is useful for debugging +This option is mainly useful for debugging .BR ocamllex (1), using it for production lexers is not recommended. +.TP +.BI \-o \ output\-file +Specify the name of the output file produced by +.BR ocamllex (1). +The default is the input file name, with its extension replaced by .ml. +.TP +.B \-q +Quiet mode. +.BR ocamllex (1) +normally outputs informational messages +to standard output. They are suppressed if option +.B \-q +is used. +.TP +.BR \-v \ or \ \-version +Print version and exit. +.TP +.BR \-help \ or \ \-\-help +Display a short usage summary and exit. .SH SEE ALSO .BR ocamlyacc (1). .br -.I The Objective Caml user's manual, +.IR "The Objective Caml user's manual" , chapter "Lexer and parser generators". diff --git a/man/ocamlmktop.m b/man/ocamlmktop.m index 1a956329..7112d525 100644 --- a/man/ocamlmktop.m +++ b/man/ocamlmktop.m @@ -1,3 +1,4 @@ +\" $Id: ocamlmktop.m,v 1.3 2008/09/15 14:12:56 doligez Exp $ .TH OCAMLMKTOP 1 .SH NAME @@ -26,59 +27,53 @@ ocamlmktop \- Building custom toplevel systems .SH DESCRIPTION -The +The .BR ocamlmktop (1) command builds Objective Caml toplevels that contain user code preloaded at start-up. -The +The .BR ocamlmktop (1) command takes as argument a set of -.IR x \&.cmo +.IR x .cmo and -.IR x \&.cma -files, and links them with the object files that implement the Objective +.IR x .cma +files, and links them with the object files that implement the Objective Caml toplevel. If the -.B -custom +.B \-custom flag is given, C object files and libraries (.o and .a files) can also be given on the command line and are linked in the resulting toplevel. .SH OPTIONS -The following command-line options are recognized by +The following command-line options are recognized by .BR ocamlmktop (1). - .TP .B \-v Print the version number of the compiler. - .TP -.BI \-cclib\ -l libname -Pass the +.BI \-cclib\ \-l libname +Pass the .BI \-l libname option to the C linker when linking in ``custom runtime'' mode (see the corresponding option for .BR ocamlc (1). - .TP .B \-ccopt Pass the given option to the C compiler and linker, when linking in ``custom runtime'' mode. See the corresponding option for .BR ocamlc (1). - .TP .B \-custom Link in ``custom runtime'' mode. See the corresponding option for .BR ocamlc (1). - .TP -.BI \-I directory +.BI \-I \ directory Add the given directory to the list of directories searched for compiled interface files (.cmo and .cma). - .TP -.BI \-o \ exec-file +.BI \-o \ exec\-file Specify the name of the toplevel file produced by the linker. -The default is is +The default is is .BR a.out . .SH SEE ALSO diff --git a/man/ocamlopt.m b/man/ocamlopt.m index da7c5997..3872bd87 100644 --- a/man/ocamlopt.m +++ b/man/ocamlopt.m @@ -1,48 +1,33 @@ +\" $Id: ocamlopt.m,v 1.10 2008/09/15 14:12:56 doligez Exp $ .TH OCAMLOPT 1 .SH NAME -ocamlopt \- The Objective Caml native-code compiler +ocamlopt \- The Objective Caml native-code compiler .SH SYNOPSIS + .B ocamlopt [ -.B \-acivS -] -[ -.BI \-cclib \ libname -] -[ -.BI \-ccopt \ option -] -[ -.B \-compact +.I options ] -[ -.B \-unsafe -] -[ -.BI \-o \ exec-file -] -[ -.BI \-I \ lib-dir -] -.I filename ... +.IR filename \ ... .B ocamlopt.opt -.I (same options) +(same options) .SH DESCRIPTION + The Objective Caml high-performance -native-code compiler +native-code compiler .BR ocamlopt (1) compiles Caml source files to native code object files and link these object files to produce standalone executables. -The +The .BR ocamlopt (1) command has a command-line interface very close to that -of +of .BR ocamlc (1). It accepts the same types of arguments and processes them sequentially: @@ -51,39 +36,39 @@ Arguments ending in .mli are taken to be source files for compilation unit interfaces. Interfaces specify the names exported by compilation units: they declare value names with their types, define public data types, declare abstract data types, and so on. From the -file -.IR x \&.mli, -the +file +.IR x .mli, +the .BR ocamlopt (1) compiler produces a compiled interface -in the file -.IR x \&.cmi. +in the file +.IR x .cmi. The interface produced is identical to that -produced by the bytecode compiler +produced by the bytecode compiler .BR ocamlc (1). Arguments ending in .ml are taken to be source files for compilation unit implementations. Implementations provide definitions for the names exported by the unit, and also contain expressions to be -evaluated for their side-effects. From the file -.IR x \&.ml, -the +evaluated for their side-effects. From the file +.IR x .ml, +the .BR ocamlopt (1) -compiler produces two files: -.IR x \&.o, -containing native object code, and -.IR x \&.cmx, +compiler produces two files: +.IR x .o, +containing native object code, and +.IR x .cmx, containing extra information for linking and optimization of the clients of the unit. The compiled implementation -should always be referred to under the name -.IR x \&.cmx -(when given a .o file, +should always be referred to under the name +.IR x .cmx +(when given a .o file, .BR ocamlopt (1) assumes that it contains code compiled from C, not from Caml). -The implementation is checked against the interface file -.IR x \&.mli -(if it exists) as described in the manual for +The implementation is checked against the interface file +.IR x .mli +(if it exists) as described in the manual for .BR ocamlc (1). Arguments ending in .cmx are taken to be compiled object code. These @@ -93,17 +78,17 @@ library, to produce a native-code executable program. The order in which .cmx and .ml arguments are presented on the command line is relevant: compilation units are initialized in that order at run-time, and it is a link-time error to use a component of a unit -before having initialized it. Hence, a given -.IR x \&.cmx +before having initialized it. Hence, a given +.IR x .cmx file must come -before all .cmx files that refer to the unit +before all .cmx files that refer to the unit .IR x . Arguments ending in .cmxa are taken to be libraries of object code. Such a library packs in two files -.IR lib \&.cmxa -and -.IR lib \&.a +.IR lib .cmxa +and +.IR lib .a a set of object files (.cmx/.o files). Libraries are build with .B ocamlopt \-a (see the description of the @@ -121,7 +106,7 @@ Arguments ending in .o or .a are assumed to be C object files and libraries. They are linked with the program. The output of the linking phase is a regular Unix executable file. It -does not need +does not need .BR ocamlrun (1) to run. @@ -138,56 +123,100 @@ is not available in all installations of Objective Caml. .SH OPTIONS -The following command-line options are recognized by +The following command-line options are recognized by .BR ocamlopt (1). - .TP .B \-a Build a library (.cmxa/.a file) with the object files (.cmx/.o files) given on the command line, instead of linking them into an -executable file. The name of the library can be set with the +executable file. The name of the library must be set with the .B \-o -option. The default name is library.cmxa. +option. +If +.BR \-cclib \ or \ \-ccopt +options are passed on the command +line, these options are stored in the resulting .cmxa library. Then, +linking with this library automatically adds back the +\BR \-cclib \ and \ \-ccopt +options as if they had been provided on the +command line, unless the +.B \-noautolink +option is given. +.TP +.B \-annot +Dump detailed information about the compilation (types, bindings, +tail-calls, etc). The information for file +.IR src .ml +is put into file +.IR src .annot. +In case of a type error, dump all the information inferred by the +type-checker before the error. The +.IR src .annot +file can be used with the emacs commands given in +.B emacs/caml\-types.el +to display types and other annotations interactively. .TP .B \-c Compile only. Suppress the linking phase of the compilation. Source code files are turned into compiled files, but no executable file is produced. This option is useful to compile modules separately. - .TP -.BI \-cclib\ -l libname +.BI \-cc \ ccomp +Use +.I ccomp +as the C linker called to build the final executable and as the C +compiler for compiling .c source files. +.TP +.BI \-cclib\ \-l libname Pass the -.BI -l libname +.BI \-l libname option to the linker. This causes the given C library to be linked with the program. - .TP .BI \-ccopt \ option Pass the given option to the C compiler and linker. For instance, -.B -ccopt -L -.I dir +.BI \-ccopt\ \-L dir causes the C linker to search for C libraries in -directory +directory .IR dir . - .TP .B \-compact Optimize the produced code for space rather than for time. This results in smaller but slightly slower programs. The default is to optimize for speed. - +.TP +.B \-config +Print the version number of +.BR ocamlopt (1) +and a detailed summary of its configuration, then exit. +.TP +.BI \-for\-pack \ module\-path +Generate an object file (.cmx and .o files) that can later be included +as a sub-module (with the given access path) of a compilation unit +constructed with +.BR \-pack . +For instance, +.B ocamlopt\ \-for\-pack\ P\ \-c\ A.ml +will generate a.cmx and a.o files that can later be used with +.BR "ocamlopt -pack -o P.cmx a.cmx" . +.TP +.B \-g +Add debugging information while compiling and linking. This option is +required in order to produce stack backtraces when +the program terminates on an uncaught exception (see +.BR ocamlrun (1)). .TP .B \-i Cause the compiler to print all defined names (with their inferred types or their definitions) when compiling an implementation (.ml -file). This can be useful to check the types inferred by the +file). No compiled files (.cmo and .cmi files) are produced. +This can be useful to check the types inferred by the compiler. Also, since the output follows the syntax of interfaces, it can help in writing an explicit interface (.mli file) for a file: just 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 Add the given directory to the list of directories searched for @@ -197,35 +226,384 @@ standard library directory. Directories added with -I are searched after the current directory, in the order in which they were given on the command line, but before the standard library directory. +If the given directory starts with +.BR + , +it is taken relative to the +standard library directory. For instance, +.B \-I\ +labltk +adds the subdirectory +.B labltk +of the standard library to the search path. +.TP +.BI \-inline \ n +Set aggressiveness of inlining to +.IR n , +where +.I n +is a positive +integer. Specifying +.B \-inline 0 +prevents all functions from being +inlined, except those whose body is smaller than the call site. Thus, +inlining causes no expansion in code size. The default aggressiveness, +.BR \-inline\ 1 , +allows slightly larger functions to be inlined, resulting +in a slight expansion in code size. Higher values for the +.B \-inline +option cause larger and larger functions to become candidate for +inlining, but can result in a serious increase in code size. +.TP +.BI \-intf \ filename +Compile the file +.I filename +as an interface file, even if its extension is not .mli. +.TP +.BI \-intf\-suffix \ string +Recognize file names ending with +.I string +as interface files (instead of the default .mli). .TP -.BI \-o \ exec-file +.B \-labels +Labels are not ignored in types, labels may be used in applications, +and labelled parameters can be given in any order. This is the default. +.TP +.B \-linkall +Force all modules contained in libraries to be linked in. If this +flag is not given, unreferenced modules are not linked in. When +building a library +.RB ( \-a +flag), setting the +.B \-linkall +flag forces all +subsequent links of programs involving that library to link all the +modules contained in the library. +.TP +.B \-noassert +Do not compile assertion checks. Note that the special form +.B assert\ false +is always compiled because it is typed specially. +This flag has no effect when linking already-compiled files. +.TP +.B \-noautolink +When linking .cmxa libraries, ignore +.BR \-cclib \ and \ \-ccopt +options potentially contained in the libraries (if these options were +given when building the libraries). This can be useful if a library +contains incorrect specifications of C libraries or C options; in this +case, during linking, set +.B -noautolink +and pass the correct C libraries and options on the command line. +.TP +.B \-nodynlink +Allow the compiler to use some optimizations that are valid only for code +that is never dynlinked. +.TP +.B \-nolabels +Ignore non-optional labels in types. Labels cannot be used in +applications, and parameter order becomes strict. +.TP +.BI \-o \ exec\-file Specify the name of the output file produced by the linker. The -default output name is a.out, in keeping with the Unix tradition. If -the +default output name is a.out, in keeping with the Unix tradition. If the .B \-a -option is given, specify the name of the library produced. +option is given, specify the name of the library produced. If the +.B \-pack +option is given, specify the name of the packed object file produced. +If the +.B \-output\-obj +option is given, specify the name of the output file produced. If the +.B \-shared +option is given, specify the name of plugin file produced. +.TP +.B \-output\-obj +Cause the linker to produce a C object file instead of an executable +file. This is useful to wrap Caml code as a C library, +callable from any C program. The name of the output object file is +camlprog.o by default; it can be set with the +.B \-o +option. +This option can also be used to produce a compiled shared/dynamic +library (.so extension). +.TP +.B \-p +Generate extra code to write profile information when the program is +executed. The profile information can then be examined with the +analysis program +.BR gprof (1). +The +.B \-p +option must be given both at +compile-time and at link-time. Linking object files not compiled with +.B \-p +is possible, but results in less precise profiling. + +See the +.BR gprof (1) +man page for more information about the profiles. + +Full support for +.BR gprof (1) +is only available for certain platforms +(currently: Intel x86/Linux and Alpha/Digital Unix). +On other platforms, the +.B \-p +option will result in a less precise +profile (no call graph information, only a time profile). +.TP +.B \-pack +Build an object file (.cmx and .o files) and its associated compiled +interface (.cmi) that combines the .cmx object +files given on the command line, making them appear as sub-modules of +the output .cmx file. The name of the output .cmx file must be +given with the +.B \-o +option. For instance, +.B ocamlopt\ -pack\ -o\ P.cmx\ A.cmx\ B.cmx\ C.cmx +generates compiled files P.cmx, P.o and P.cmi describing a +compilation unit having three sub-modules A, B and C, +corresponding to the contents of the object files A.cmx, B.cmx and +C.cmx. These contents can be referenced as P.A, P.B and P.C +in the remainder of the program. + +The .cmx object files being combined must have been compiled with +the appropriate +.B \-for\-pack +option. In the example above, +A.cmx, B.cmx and C.cmx must have been compiled with +.BR ocamlopt\ \-for\-pack\ P . +Multiple levels of packing can be achieved by combining +.B \-pack +with +.BR \-for\-pack . +See +.IR "The Objective Caml user's manual" , +chapter "Native-code compilation" for more details. +.TP +.BI \-pp \ command +Cause the compiler to call the given +.I command +as a preprocessor for each source file. The output of +.I command +is redirected to +an intermediate file, which is compiled. If there are no compilation +errors, the intermediate file is deleted afterwards. +.TP +.B \-principal +Check information path during type-checking, to make sure that all +types are derived in a principal way. All programs accepted in +.B \-principal +mode are also accepted in default mode with equivalent +types, but different binary signatures. +.TP +.B \-rectypes +Allow arbitrary recursive types during type-checking. By default, +only recursive types where the recursion goes through an object type +are supported. Note that once you have created an interface using this +flag, you must use it again for all dependencies. .TP .B \-S Keep the assembly code produced during the compilation. The assembly -code for the source file -.IR x \&.ml -is saved in the file -.IR x \&.s. - +code for the source file +.IR x .ml +is saved in the file +.IR x .s. .TP -.B \-v -Print the version number of the compiler. - +.B \-shared +Build a plugin (usually .cmxs) that can be dynamically loaded with +the +.B Dynlink +module. The name of the plugin must be +set with the +.B \-o +option. A plugin can include a number of Caml +modules and libraries, and extra native objects (.o, .a files). +Building native plugins is only supported for some +operating system. Under some systems (currently, +only Linux AMD 64), all the Caml code linked in a plugin must have +been compiled without the +.B \-nodynlink +flag. Some constraints might also +apply to the way the extra native objects have been compiled (under +Linux AMD 64, they must contain only position-independent code). +.TP +.B \-thread +Compile or link multithreaded programs, in combination with the +system threads library described in +.IR "The Objective Caml user's manual" . .TP .B \-unsafe -Turn bound checking off on array and string accesses (the v.(i) and -s.[i] constructs). Programs compiled with -unsafe are therefore +Turn bound checking off for array and string accesses (the +.BR v.(i) and s.[i] +constructs). Programs compiled with +.B \-unsafe +are therefore faster, but unsafe: anything can happen if the program accesses an -array or string outside of its bounds. +array or string outside of its bounds. Additionally, turn off the +check for zero divisor in integer division and modulus operations. +With +.BR \-unsafe , +an integer division (or modulus) by zero can halt the +program or continue with an unspecified result instead of raising a +.B Division_by_zero +exception. +.TP +.B \-v +Print the version number of the compiler and the location of the +standard library directory, then exit. +.TP +.B \-verbose +Print all external commands before they are executed, in particular +invocations of the assembler, C compiler, and linker. +.TP +.B \-version +Print the version number of the compiler in short form (e.g. "3.11.0"), +then exit. +.TP +.BI \-w \ warning\-list +Enable or disable warnings according to the argument +.IR warning\-list . +The argument is a set of letters. If a letter is +uppercase, it enables the corresponding warnings; lowercase disables +the warnings. The correspondence is the following: + +.B A +\ \ all warnings + +.B C +\ \ start of comments that look like mistakes + +.B D +\ \ use of deprecated features + +.B E +\ \ fragile pattern matchings (matchings that will remain +complete even if additional constructors are added to one of the +variant types matched) + +.B F +\ \ partially applied functions (expressions whose result has +function type and is ignored) + +.B L +\ \ omission of labels in applications + +.B M +\ \ overriding of methods + +.B P +\ \ missing cases in pattern matchings (i.e. partial matchings) + +.B S +\ \ expressions in the left-hand side of a sequence that don't +have type +.B unit +(and that are not functions, see +.B F +above) + +.B U +\ \ redundant cases in pattern matching (unused cases) + +.B V +\ \ overriding of instance variables + +.B Y +\ \ unused variables that are bound with +.BR let \ or \ as , +and don't start with an underscore (_) character + +.B Z +\ \ all other cases of unused variables that don't start with an +underscore (_) character + +.B X +\ \ warnings that don't fit in the above categories (except +.BR A ) +.IP +The default setting is +.BR \-w\ Aelz , +enabling all warnings except fragile +pattern matchings, omitted labels, and innocuous unused variables. +Note that warnings +.BR F \ and \ S +are not always triggered, depending on the internals of the type checker. +.TP +.BI \-warn\-error \ warning\-list +Turn the warnings indicated in the argument +.I warning\-list +into errors. The compiler will stop with an error when one of these +warnings is emitted. The +.I warning\-list +has the same meaning as for +the "-w" option: an uppercase character turns the corresponding +warning into an error, a lowercase character leaves it as a warning. +The default setting is +.B \-warn\-error\ a +(none of the warnings is treated as an error). +.TP +.B \-where +Print the location of the standard library, then exit. +.TP +.BI \- \ file +Process +.I file +as a file name, even if it starts with a dash (-) character. +.TP +.BR \-help \ or \ \-\-help +Display a short usage summary and exit. + +.SH OPTIONS FOR THE IA32 ARCHITECTURE + +The IA32 code generator (Intel Pentium, AMD Athlon) supports the +following additional option: +.TP +.B \-ffast\-math +Use the IA32 instructions to compute +trigonometric and exponential functions, instead of calling the +corresponding library routines. The functions affected are: +.BR atan , +.BR atan2 , +.BR cos , +.BR log , +.BR log10 , +.BR sin , +.B sqrt +and +.BR tan . +The resulting code runs faster, but the range of supported arguments +and the precision of the result can be reduced. In particular, +trigonometric operations +.BR cos , +.BR sin , +.B tan +have their range reduced to [-2^64, 2^64]. + +.SH OPTIONS FOR THE AMD64 ARCHITECTURE + +The AMD64 code generator (64-bit versions of Intel Pentium and AMD +Athlon) supports the following additional options: +.TP +.B \-fPIC +Generate position-independent machine code. This is the default. +.TP +.B \-fno\-PIC +Generate position-dependent machine code. + +.SH OPTIONS FOR THE SPARC ARCHITECTURE +The Sparc code generator supports the following additional options: +.TP +.B \-march=v8 +Generate SPARC version 8 code. +.TP +.B \-march=v9 +Generate SPARC version 9 code. +.P +The default is to generate code for SPARC version 7, which runs on all +SPARC processors. .SH SEE ALSO .BR ocamlc (1). .br -.I The Objective Caml user's manual, +.IR "The Objective Caml user's manual" , chapter "Native-code compilation". diff --git a/man/ocamlprof.m b/man/ocamlprof.m index abc5301d..7b0fa104 100644 --- a/man/ocamlprof.m +++ b/man/ocamlprof.m @@ -1,3 +1,4 @@ +\" $Id: ocamlprof.m,v 1.6 2008/09/15 14:25:42 doligez Exp $ .TH OCAMLPROF 1 .SH NAME @@ -22,9 +23,9 @@ Objective Caml program instrumented with It produces a source listing of the program modules given as arguments where execution counts have been inserted as comments. For instance, -.P -ocamlprof foo.ml -.P + +.B ocamlprof foo.ml + prints the source code for the foo module, with comments indicating how many times the functions in this module have been called. Naturally, this information is accurate only if the source file has not been modified @@ -33,25 +34,40 @@ since the profiling execution took place. .SH OPTIONS .TP -.BI \-f \ dumpfile +.BI \-f \ dumpfile Specifies an alternate dump file of profiling information. -The default is the file ocamlprof.dump in the current directory. .TP .BI \-F \ string Specifies an additional string to be output with profiling information. By default, -.B ocamlprof +.BR ocamlprof (1) will annotate programs with comments of the form .BI (* \ n \ *) where .I n is the counter value for a profiling point. With option -.BI \-F \ string +.BI \-F \ s the annotation will be -.BI (* \ s\ n \ *) +.BI (* \ sn \ *) +.TP +.BI \-impl \ filename +Compile the file +.I filename +as an implementation file, even if its extension is not .ml. +.TP +.BI \-intf \ filename +Compile the file +.I filename +as an interface file, even if its extension is not .mli. +.TP +.B \-version +Print the version number of ocamlprof and exit. +.TP +.BR \-help \ or \ \-\-help +Display a short usage summary and exit. .SH SEE ALSO .BR ocamlcp (1). .br -.I The Objective Caml user's manual, +.IR "The Objective Caml user's manual" , chapter "Profiling". diff --git a/man/ocamlrun.m b/man/ocamlrun.m index 7db888bd..1b51e3ab 100644 --- a/man/ocamlrun.m +++ b/man/ocamlrun.m @@ -1,3 +1,4 @@ +\" $Id: ocamlrun.m,v 1.6 2008/09/15 14:12:56 doligez Exp $ .TH OCAMLRUN 1 .SH NAME @@ -6,15 +7,15 @@ ocamlrun \- The Objective Caml bytecode interpreter .SH SYNOPSIS .B ocamlrun [ -.B \-v +.I options ] .I filename argument ... .SH DESCRIPTION -The +The .BR ocamlrun (1) command executes bytecode files produced by the -linking phase of the +linking phase of the .BR ocamlc (1) command. @@ -22,54 +23,104 @@ The first non-option argument is taken to be the name of the file containing the executable bytecode. (That file is searched in the executable path as well as in the current directory.) The remaining arguments are passed to the Objective Caml program, in the string array -Sys.argv. Element 0 of this array is the name of the -bytecode executable file; elements 1 to +.BR Sys.argv . +Element 0 of this array is the name of the +bytecode executable file; elements 1 to .I n are the remaining arguments. In most cases, the bytecode -executable files produced by the +executable files produced by the .BR ocamlc (1) command are self-executable, -and manage to launch the +and manage to launch the .BR ocamlrun (1) command on themselves automatically. .SH OPTIONS -The following command-line option is recognized by +The following command-line options are recognized by .BR ocamlrun (1). - .TP -.B \-v -When set, the memory manager prints verbose messages on standard error -to signal garbage collections and heap extensions. +.B \-b +When the program aborts due to an uncaught exception, print a detailed +"back trace" of the execution, showing where the exception was +raised and which function calls were outstanding at this point. The +back trace is printed only if the bytecode executable contains +debugging information, i.e. was compiled and linked with the +.B \-g +option to +.BR ocamlc (1) +set. This option is equivalent to setting the +.B b +flag in the OCAMLRUNPARAM environment variable (see below). +.TP +.BI \-I \ dir +Search the directory +.I dir +for dynamically-loaded libraries, in addition to the standard search path. +.B \-p +Print the names of the primitives known to this version of +.BR ocamlrun (1) +and exit. +.TP +.B \-v +Direct the memory manager to print verbose messages on standard error. +This is equivalent to setting +.B v=63 +in the OCAMLRUNPARAM environment variable (see below). +.TP +.B \-version +Print version and exit. .SH ENVIRONMENT VARIABLES The following environment variable are also consulted: - .TP -.B OCAMLRUNPARAM -Set the garbage collection parameters. -(If -.B OCAMLRUNPARAM +.B CAML_LD_LIBRARY_PATH +Additional directories to search for dynamically-loaded libraries. +.TP +.B OCAMLLIB +The directory containing the Objective Caml standard +library. (If +.B OCAMLLIB is not set, -.B CAMLRUNPARAM -will be used instead.) +.B CAMLLIB +will be used instead.) Used to locate the ld.conf configuration file for +dynamic loading. If not set, +default to the library directory specified when compiling Objective Caml. +.TP +.B OCAMLRUNPARAM +Set the runtime system options and garbage collection parameters. +(If OCAMLRUNPARAM is not set, CAMLRUNPARAM will be used instead.) This variable must be a sequence of parameter specifications. A parameter specification is an option letter followed by an = -sign, a decimal number, and an optional multiplier. There are seven -options: -.TP -.BR b \ (backtrace) -Print a stack backtrace in case of an uncaught exception. +sign, a decimal number (or a hexadecimal number prefixed by +.BR 0x ), +and an optional multiplier. There are nine options, six of which +correspond to the fields of the +.B control +record documented in +.IR "The Objective Caml user's manual", +chapter "Standard Library", section "Gc". +.TP +.BR b +Trigger the printing of a stack backtrace +when an uncaught exception aborts the program. +This option takes no argument. +.TP +.BR p +Turn on debugging support for +.BR ocamlyacc -generated +parsers. When this option is on, +the pushdown automaton that executes the parsers prints a +trace of its actions. This option takes no argument. .TP .BR s \ (minor_heap_size) -Size of the minor heap. +The size of the minor heap (in words). .TP .BR i \ (major_heap_increment) -Minimum size increment for the major heap. +The default size increment for the major heap (in words). .TP .BR o \ (space_overhead) The major GC speed setting. @@ -86,48 +137,51 @@ The initial size of the major heap (in words). .BR v \ (verbose) What GC messages to print to stderr. This is a sum of values selected from the following: -.TP -.BR 1 + +.B 0x001 Start of major GC cycle. -.TP -.BR 2 + +.B 0x002 Minor collection and major GC slice. -.TP -.BR 4 + +.B 0x004 Growing and shrinking of the heap. -.TP -.BR 8 + +.B 0x008 Resizing of stacks and memory manager tables. -.TP -.BR 16 + +.B 0x010 Heap compaction. -.TP -.BR 32 + +.BR 0x020 Change of GC parameters. -.TP -.BR 64 + +.BR 0x040 Computation of major GC slice size. -.TP -.BR 128 -Calling of finalisation function. -.TP -.BR 256 -Startup messages. + +.BR 0x080 +Calling of finalisation functions. + +.BR 0x100 +Startup messages (loading the bytecode executable file, resolving +shared libraries). The multiplier is -.B k -, -.B M -, or -.B G -, for multiplication by 2^10, 2^20, and 2^30 respectively. +.BR k , +.BR M \ or +.BR G , +for multiplication by 2^10, 2^20, and 2^30 respectively. For example, on a 32-bit machine under bash, the command .B export OCAMLRUNPARAM='s=256k,v=1' tells a subsequent .B ocamlrun to set its initial minor heap size to 1 megabyte and to print a message at the start of each major GC cycle. - +.TP +.B CAMLRUNPARAM +If OCAMLRUNPARAM is not found in the environment, then CAMLRUNPARAM +will be used instead. If CAMLRUNPARAM is not found, then the default +values will be used. .TP .B PATH List of directories searched to find the bytecode executable file. @@ -135,5 +189,5 @@ List of directories searched to find the bytecode executable file. .SH SEE ALSO .BR ocamlc (1). .br -.I The Objective Caml user's manual, +.IR "The Objective Caml user's manual" , chapter "Runtime system". diff --git a/man/ocamlyacc.m b/man/ocamlyacc.m index fb6b2f34..463891a0 100644 --- a/man/ocamlyacc.m +++ b/man/ocamlyacc.m @@ -1,3 +1,4 @@ +\" $Id: ocamlyacc.m,v 1.4 2008/09/15 14:12:56 doligez Exp $ .TH OCAMLYACC 1 .SH NAME @@ -15,18 +16,18 @@ ocamlyacc \- The Objective Caml parser generator .SH DESCRIPTION -The +The .BR ocamlyacc (1) command produces a parser from a LALR(1) context-free grammar specification with attached semantic actions, in the style of .BR yacc (1). -Assuming the input file is +Assuming the input file is .IR grammar \&.mly, running .B ocamlyacc -produces Caml code for a parser in the file +produces Caml code for a parser in the file .IR grammar \&.ml, -and its interface in file +and its interface in file .IR grammar \&.mli. The generated module defines one parsing function per entry point in @@ -40,22 +41,14 @@ program. Lexer buffers are an abstract data type implemented in the standard library module Lexing. Tokens are values from the concrete type token, defined in the interface file .IR grammar \&.mli -produced by +produced by .BR ocamlyacc (1). .SH OPTIONS -The +The .BR ocamlyacc (1) command recognizes the following options: - -.TP -.B \-v -Generate a description of the parsing tables and a report on conflicts -resulting from ambiguities in the grammar. The description is put in -file -.IR grammar \&.output. - .TP .BI \-b prefix Name the output files @@ -63,9 +56,32 @@ Name the output files .IR prefix \&.mli, .IR prefix \&.output, instead of the default naming convention. +.TP +.B \-q +This option has no effect. +.TP +.B \-v +Generate a description of the parsing tables and a report on conflicts +resulting from ambiguities in the grammar. The description is put in +file +.IR grammar .output. +.TP +.B \-version +Print version and exit. +.TP +.B \- +Read the grammar specification from standard input. The default +output file names are stdin.ml and stdin.mli. +.TP +.BI \-\- \ file +Process +.I file +as the grammar specification, even if its name +starts with a dash (-) character. This option must be the last on the +command line. .SH SEE ALSO .BR ocamllex (1). .br -.I The Objective Caml user's manual, +.IR "The Objective Caml user's manual" , chapter "Lexer and parser generators". diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 6b0ab371..6050eb69 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,3 +1,17 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Nicolas Pouillard, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2007 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: myocamlbuild.ml,v 1.23 2008/10/03 15:41:25 ertai Exp $ *) + open Ocamlbuild_plugin open Command open Arch @@ -14,17 +28,17 @@ 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 mkdll out files opts = let s = Command.string_of_command_spec in - Cmd(Sh(C.mkdll out (s implib) (s files) (s opts))) + Cmd(Sh(Printf.sprintf "%s -o %s %s %s" C.mkdll out (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))) + Cmd(Sh(Printf.sprintf "%s -o %s %s %s" 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))) + Cmd(Sh(C.mklib out (s files) (s opts))) let syslib x = A(C.syslib x);; let syscamllib x = @@ -67,7 +81,7 @@ let add_exe_if_exists a = if Pathname.exists exe then exe else a;; let convert_command_for_windows_shell spec = - if not windows then spec else + if not windows then spec else let rec self specs acc = match specs with | N :: specs -> self specs acc @@ -149,7 +163,7 @@ dispatch begin function "toplevel"; "typing"; "utils"] in Ocamlbuild_pack.Configuration.parse_string (sprintf "<{%s}/**>: not_hygienic, -traverse" patt) - + | After_options -> begin Options.ocamlrun := ocamlrun; @@ -271,6 +285,7 @@ Pathname.define_context "toplevel" ["toplevel"; "parsing"; "typing"; "bytecomp"; 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 "otherlibs/dynlink/nat" ["otherlibs/dynlink/nat"; "stdlib"];; Pathname.define_context "asmcomp" ["asmcomp"; "bytecomp"; "parsing"; "typing"; "utils"; "stdlib"];; Pathname.define_context "ocamlbuild" ["ocamlbuild"; "stdlib"; "."];; Pathname.define_context "lex" ["lex"; "stdlib"];; @@ -378,6 +393,13 @@ rule "native stdlib in partial mode" Nop end;; +copy_rule' ~insert:`top "otherlibs/dynlink/natdynlink.ml" "otherlibs/dynlink/nat/dynlink.ml";; +copy_rule' ~insert:`top "otherlibs/dynlink/dynlink.mli" "otherlibs/dynlink/nat/dynlink.mli";; +copy_rule' ~insert:`top "otherlibs/dynlink/nat/dynlink.cmx" "otherlibs/dynlink/dynlink.cmx";; +copy_rule' ~insert:`top "otherlibs/dynlink/nat/dynlink.cmxa" "otherlibs/dynlink/dynlink.cmxa";; +copy_rule' ~insert:`top ("otherlibs/dynlink/nat/dynlink"-.-C.a) ("otherlibs/dynlink/dynlink"-.-C.a);; +dep ["ocaml"; "compile"; "native"; "file:otherlibs/dynlink/nat/dynlink.cmx"] ["otherlibs/dynlink/nat/dynlink.cmi"];; + rule "C files" ~prod:("%"-.-C.o) ~dep:"%.c" @@ -410,8 +432,8 @@ flag ["c"; "compile"; "otherlibs_num"] begin 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");; +flag [(* "ocaml" or "c"; *) "ocamlmklib"; "otherlibs_win32unix"] (S[A"-cclib"; Quote (syslib "ws2_32")]);; +flag ["c"; "link"; "dll"; "otherlibs_win32unix"] (syslib "ws2_32");; 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;; @@ -555,8 +577,8 @@ 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 | \ + 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;; @@ -565,9 +587,9 @@ rule "tools/opnames.ml" ~dep:"byterun/instruct.h" begin fun _ _ -> Cmd(Sh"unset LC_ALL || : ; \ - unset LC_CTYPE || : ; \ - unset LC_COLLATE LANG || : ; \ - sed -e '/\\/\\*/d' \ + unset LC_CTYPE || : ; \ + unset LC_COLLATE LANG || : ; \ + sed -e '/\\/\\*/d' \ -e '/^#/d' \ -e 's/enum \\(.*\\) {/let names_of_\\1 = [|/' \ -e 's/};$/ |]/' \ @@ -632,7 +654,7 @@ rule "ocaml C stubs on windows: dlib & d.o* -> dll" | 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)]) + mkdll dll (S[atomize objs; P("byterun/ocamlrun"-.-C.a)]) (T(tags_of_pathname dll++"dll"++"link"++"c")) end;; @@ -699,7 +721,6 @@ 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" @@ -772,6 +793,9 @@ let mk_camlp4_bin name ?unix:(link_unix=true) modules = let cmos = add_extensions ["cmo"] deps in let cmxs = add_extensions ["cmx"] deps in let objs = add_extensions [C.o] deps in + let dep_dynlink_native = + if partial then [] else [dynlink_dir/"dynlink.cmxa"; dynlink_dir/"dynlink"-.-C.a] + in rule byte ~deps:(camlp4lib_cma::cmos @ dep_unix_byte) ~prod:(add_exe byte) @@ -781,11 +805,11 @@ let mk_camlp4_bin name ?unix:(link_unix=true) modules = P camlp4lib_cma; A"-linkall"; atomize cmos; A"-o"; Px (add_exe byte)]) end; rule native - ~deps:(camlp4lib_cmxa :: camlp4lib_lib :: (cmxs @ objs @ dep_unix_native)) + ~deps:(camlp4lib_cmxa :: camlp4lib_lib :: (cmxs @ objs @ dep_unix_native @ dep_dynlink_native)) ~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"); + Cmd(S[ocamlopt; A"-I"; P dynlink_dir; A "dynlink.cmxa"; 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;; @@ -921,7 +945,7 @@ let builtins = let labltk_support = ["support"; "rawwidget"; "widget"; "protocol"; "textvariable"; "timer"; "fileevent"; "camltkwrap"];; -let labltk_generated_modules = +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"; diff --git a/myocamlbuild_config.mli b/myocamlbuild_config.mli index 506902ea..ce82607f 100644 --- a/myocamlbuild_config.mli +++ b/myocamlbuild_config.mli @@ -31,10 +31,10 @@ val nativeccprofopts : string val nativecclinkopts : string val nativeccrpath : string val nativecclibs : string +val packld : string val dllcccompopts : string -val asflags : string +val asm : string val aspp : string -val asppflags : string val asppprofflags : string val profiling : string val dynlinkopts : string @@ -42,10 +42,10 @@ 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 mkexe : string +val mkdll : string +val mkmaindll : string val mklib : string -> string -> string -> string val ext_lib : string val ext_obj : string diff --git a/ocamlbuild/Makefile b/ocamlbuild/Makefile index 66166c34..84dcc47b 100644 --- a/ocamlbuild/Makefile +++ b/ocamlbuild/Makefile @@ -43,7 +43,7 @@ ppcache: $(OCAMLBUILD) ppcache.byte ppcache.native doc: $(OCAMLBUILD) ocamlbuild.docdir/index.html - ln -sf $(BUILDDIR)/ocamlbuild.docdir doc + ln -s -f $(BUILDDIR)/ocamlbuild.docdir doc else all byte native: ocamlbuild.byte.start mkdir -p boot diff --git a/ocamlbuild/_tags b/ocamlbuild/_tags index 66056bd6..215d1127 100644 --- a/ocamlbuild/_tags +++ b/ocamlbuild/_tags @@ -1,13 +1,10 @@ # OCamlbuild tags file true: debug -<*.ml> or <*.mli>: warn_A, warn_error_A, dtypes +<*.ml> or <*.mli>: warn_A, warn_error_A, warn_e, 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/command.ml b/ocamlbuild/command.ml index e89de4ae..077e2ac9 100644 --- a/ocamlbuild/command.ml +++ b/ocamlbuild/command.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: command.ml,v 1.1.4.5 2007/12/18 08:55:22 ertai Exp $ *) +(* $Id: command.ml,v 1.8 2008/07/25 14:28:56 ertai Exp $ *) (* Original author: Nicolas Pouillard *) (* Command *) @@ -156,7 +156,8 @@ let string_of_command_spec x = string_of_command_spec_with_calls ignore ignore f let string_target_and_tags_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 union_rtags tags = rtags := Tags.union !rtags tags in + let s = string_of_command_spec_with_calls union_rtags ((:=) rtarget) true spec in let target = if !rtarget = "" then s else !rtarget in s, target, !rtags @@ -304,6 +305,19 @@ let iter_tags f x = | Seq(s) -> List.iter cmd s in cmd x +let fold_pathnames f x = + let rec spec = function + | N | A _ | Sh _ | V _ | Quote _ | T _ -> fun acc -> acc + | P p | Px p -> f p + | S l -> List.fold_right spec l + in + let rec cmd = function + | Nop -> fun acc -> acc + | Echo(_, p) -> f p + | Cmd(s) -> spec s + | Seq(s) -> List.fold_right cmd s in + cmd x + let rec reduce x = let rec self x acc = match x with @@ -332,6 +346,25 @@ let digest = | [x] -> x | xs -> Digest.string ("["^String.concat ";" xs^"]") +let all_deps_of_tags = ref [] + +let cons deps acc = + List.rev& + 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 to_string_for_digest x = let rec cmd_of_spec = diff --git a/ocamlbuild/command.mli b/ocamlbuild/command.mli index 5b9a70fc..389d6f3b 100644 --- a/ocamlbuild/command.mli +++ b/ocamlbuild/command.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: command.mli,v 1.1.4.4 2007/12/18 08:55:22 ertai Exp $ *) +(* $Id: command.mli,v 1.6 2008/07/25 14:25:20 ertai Exp $ *) (* Original author: Nicolas Pouillard *) (* Command *) @@ -23,6 +23,8 @@ val string_target_and_tags_of_command_spec : spec -> string * string * Tags.t val iter_tags : (Tags.t -> unit) -> t -> unit +val fold_pathnames : (pathname -> 'a -> 'a) -> t -> 'a -> 'a + (** Digest the given command. *) val digest : t -> Digest.t @@ -35,3 +37,9 @@ val tag_handler : (Tags.t -> spec) ref (** For system use only *) val dump_parallel_stats : unit -> unit + +val deps_of_tags : Tags.t -> pathname list + +(** [dep tags deps] Will build [deps] when [tags] will be activated. *) +val dep : Tags.elt list -> pathname list -> unit + diff --git a/ocamlbuild/configuration.ml b/ocamlbuild/configuration.ml index 1a25cb47..f57a6f0c 100644 --- a/ocamlbuild/configuration.ml +++ b/ocamlbuild/configuration.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: configuration.ml,v 1.1.4.1 2007/11/28 16:03:10 ertai Exp $ *) +(* $Id: configuration.ml,v 1.2 2007/11/28 16:03:48 ertai Exp $ *) (* Original author: Nicolas Pouillard *) open My_std open Log diff --git a/ocamlbuild/configuration.mli b/ocamlbuild/configuration.mli index 896a78e6..c27edc32 100644 --- a/ocamlbuild/configuration.mli +++ b/ocamlbuild/configuration.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: configuration.mli,v 1.1.4.1 2007/11/28 16:03:10 ertai Exp $ *) +(* $Id: configuration.mli,v 1.3 2008/01/11 16:13:16 doligez Exp $ *) (* Original author: Nicolas Pouillard *) (* Configuration *) diff --git a/ocamlbuild/display.ml b/ocamlbuild/display.ml index bd4bab0a..7d638b1d 100644 --- a/ocamlbuild/display.ml +++ b/ocamlbuild/display.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: display.ml,v 1.1.4.1 2007/11/26 13:28:35 ertai Exp $ *) +(* $Id: display.ml,v 1.3 2008/01/11 16:13:16 doligez Exp $ *) (* Original author: Berke Durak *) (* Display *) open My_std;; diff --git a/ocamlbuild/fda.ml b/ocamlbuild/fda.ml index 3ba80e45..21a81ae7 100644 --- a/ocamlbuild/fda.ml +++ b/ocamlbuild/fda.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: fda.ml,v 1.3.2.1 2007/11/22 18:28:43 ertai Exp $ *) +(* $Id: fda.ml,v 1.4 2007/11/22 18:29:31 ertai Exp $ *) (* Original author: Berke Durak *) (* FDA *) diff --git a/ocamlbuild/glob.ml b/ocamlbuild/glob.ml index ba3db5be..5a3bb1e8 100644 --- a/ocamlbuild/glob.ml +++ b/ocamlbuild/glob.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: glob.ml,v 1.2.2.1 2007/11/21 21:02:05 ertai Exp $ *) +(* $Id: glob.ml,v 1.5 2008/07/25 14:38:31 ertai Exp $ *) (* Original author: Berke Durak *) (* Glob *) open My_std;; @@ -270,7 +270,7 @@ module Brute = (match_character_class cl u.[i + k]) && check (k + 1) in check 0 - | Star p -> raise Too_hard + | Star _ -> raise Too_hard | Class cl -> n = 1 && match_character_class cl u.[i] | Concat(p1,p2) -> let rec scan j = diff --git a/ocamlbuild/glob.mli b/ocamlbuild/glob.mli index fe957708..102dd81a 100644 --- a/ocamlbuild/glob.mli +++ b/ocamlbuild/glob.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: glob.mli,v 1.1.4.1 2007/11/21 21:02:05 ertai Exp $ *) +(* $Id: glob.mli,v 1.2 2007/11/21 21:02:15 ertai Exp $ *) (* Original author: Berke Durak *) (* Glob *) diff --git a/ocamlbuild/glob_lexer.mll b/ocamlbuild/glob_lexer.mll index 6171a656..58616156 100644 --- a/ocamlbuild/glob_lexer.mll +++ b/ocamlbuild/glob_lexer.mll @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: glob_lexer.mll,v 1.1.4.3 2007/11/21 21:02:58 ertai Exp $ *) +(* $Id: glob_lexer.mll,v 1.4 2007/11/21 21:03:14 ertai Exp $ *) (* Original author: Berke Durak *) (* Glob *) { diff --git a/ocamlbuild/hygiene.ml b/ocamlbuild/hygiene.ml index ba506e61..7b0a135c 100644 --- a/ocamlbuild/hygiene.ml +++ b/ocamlbuild/hygiene.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: hygiene.ml,v 1.4.2.1 2007/11/22 18:28:43 ertai Exp $ *) +(* $Id: hygiene.ml,v 1.5 2007/11/22 18:29:32 ertai Exp $ *) (* Original author: Berke Durak *) (* Hygiene *) open My_std diff --git a/ocamlbuild/lexers.mli b/ocamlbuild/lexers.mli index 9c6aa9ac..a9b7ed43 100644 --- a/ocamlbuild/lexers.mli +++ b/ocamlbuild/lexers.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: lexers.mli,v 1.2.2.2 2007/11/21 21:02:58 ertai Exp $ *) +(* $Id: lexers.mli,v 1.5 2008/01/11 16:13:16 doligez Exp $ *) (* Original author: Nicolas Pouillard *) exception Error of string diff --git a/ocamlbuild/lexers.mll b/ocamlbuild/lexers.mll index b25fb754..2a6a2dbd 100644 --- a/ocamlbuild/lexers.mll +++ b/ocamlbuild/lexers.mll @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: lexers.mll,v 1.2.2.3 2007/11/26 13:27:56 ertai Exp $ *) +(* $Id: lexers.mll,v 1.7 2008/07/25 14:24:29 ertai Exp $ *) (* Original author: Nicolas Pouillard *) { exception Error of string @@ -28,6 +28,7 @@ let empty = { plus_flags = []; minus_flags = []; plus_tags = []; minus_tags = [] let newline = ('\n' | '\r' | "\r\n") let space = [' ' '\t' '\012'] +let space_or_esc_nl = (space | '\\' newline) let blank = newline | space let not_blank = [^' ' '\t' '\012' '\n' '\r'] let not_space_nor_comma = [^' ' '\t' '\012' ','] @@ -116,7 +117,7 @@ and conf_value pos err x = parse | (_ | 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 } + | space_or_esc_nl* ',' space_or_esc_nl* { 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)) } diff --git a/ocamlbuild/log.ml b/ocamlbuild/log.ml index 3cef4469..08899545 100644 --- a/ocamlbuild/log.ml +++ b/ocamlbuild/log.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: log.ml,v 1.1.4.1 2007/11/22 18:53:12 ertai Exp $ *) +(* $Id: log.ml,v 1.3 2008/01/11 16:13:16 doligez Exp $ *) (* Original author: Nicolas Pouillard *) open My_std diff --git a/ocamlbuild/log.mli b/ocamlbuild/log.mli index 3d3d154c..6e1c80ed 100644 --- a/ocamlbuild/log.mli +++ b/ocamlbuild/log.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: log.mli,v 1.1.4.1 2007/11/22 18:53:12 ertai Exp $ *) +(* $Id: log.mli,v 1.3 2008/01/11 16:13:16 doligez Exp $ *) (* Original author: Nicolas Pouillard *) (* Log *) diff --git a/ocamlbuild/main.ml b/ocamlbuild/main.ml index fd42b4d0..71ca30e2 100644 --- a/ocamlbuild/main.ml +++ b/ocamlbuild/main.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: main.ml,v 1.8.2.14 2007/12/18 08:58:02 ertai Exp $ *) +(* $Id: main.ml,v 1.21 2008/01/11 16:13:16 doligez Exp $ *) (* Original author: Berke Durak *) open My_std open Log diff --git a/ocamlbuild/my_std.ml b/ocamlbuild/my_std.ml index 94f2043e..bb809da8 100644 --- a/ocamlbuild/my_std.ml +++ b/ocamlbuild/my_std.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: my_std.ml,v 1.2.2.7 2007/12/18 08:56:11 ertai Exp $ *) +(* $Id: my_std.ml,v 1.10 2008/10/01 08:36:26 ertai Exp $ *) (* Original author: Nicolas Pouillard *) open Format @@ -127,10 +127,13 @@ module String = struct let print f s = fprintf f "%S" s let chomp s = + let is_nl_char = function '\n' | '\r' -> true | _ -> false in + let rec cut n = + if n = 0 then 0 else if is_nl_char s.[n-1] then cut (n-1) else n + in 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 n = cut ls in + if n = ls then s else sub s 0 n let before s pos = sub s 0 pos let after s pos = sub s pos (length s - pos) diff --git a/ocamlbuild/my_unix.ml b/ocamlbuild/my_unix.ml index 646c5e0c..29f2f5ac 100644 --- a/ocamlbuild/my_unix.ml +++ b/ocamlbuild/my_unix.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: my_unix.ml,v 1.2.2.2 2007/11/28 16:11:27 ertai Exp $ *) +(* $Id: my_unix.ml,v 1.5 2008/01/11 16:13:16 doligez Exp $ *) (* Original author: Nicolas Pouillard *) open My_std open Format diff --git a/ocamlbuild/my_unix.mli b/ocamlbuild/my_unix.mli index d1a4a183..670903b2 100644 --- a/ocamlbuild/my_unix.mli +++ b/ocamlbuild/my_unix.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: my_unix.mli,v 1.1.4.2 2007/11/28 16:11:27 ertai Exp $ *) +(* $Id: my_unix.mli,v 1.4 2008/01/11 16:13:16 doligez Exp $ *) (* Original author: Nicolas Pouillard *) type file_kind = | FK_dir diff --git a/ocamlbuild/ocaml_compiler.ml b/ocamlbuild/ocaml_compiler.ml index ddc62c8d..93adf5ab 100644 --- a/ocamlbuild/ocaml_compiler.ml +++ b/ocamlbuild/ocaml_compiler.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: ocaml_compiler.ml,v 1.5.2.6 2007/11/28 16:07:39 ertai Exp $ *) +(* $Id: ocaml_compiler.ml,v 1.10 2008/01/11 16:13:16 doligez Exp $ *) (* Original author: Nicolas Pouillard *) open My_std open Format diff --git a/ocamlbuild/ocaml_dependencies.ml b/ocamlbuild/ocaml_dependencies.ml index 893d97ad..8d9ee167 100644 --- a/ocamlbuild/ocaml_dependencies.ml +++ b/ocamlbuild/ocaml_dependencies.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: ocaml_dependencies.ml,v 1.1.4.1 2007/11/28 16:07:39 ertai Exp $ *) +(* $Id: ocaml_dependencies.ml,v 1.3 2008/01/11 16:13:16 doligez Exp $ *) (* Original author: Nicolas Pouillard *) open My_std open Log diff --git a/ocamlbuild/ocaml_specific.ml b/ocamlbuild/ocaml_specific.ml index bbf3b0eb..d2ad68dd 100644 --- a/ocamlbuild/ocaml_specific.ml +++ b/ocamlbuild/ocaml_specific.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: ocaml_specific.ml,v 1.6.2.21 2007/11/28 16:19:10 ertai Exp $ *) +(* $Id: ocaml_specific.ml,v 1.23 2008/08/05 13:06:56 ertai Exp $ *) (* Original author: Nicolas Pouillard *) open My_std open Format @@ -270,16 +270,6 @@ rule "ocamldoc: document ocaml project odocl & *odoc -> man|latex|dot..." (* 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"); - - rule "ocaml: menhir dependencies" - ~prod:"%.mly.depends" - ~dep:"%.mly" - (Ocaml_tools.menhir_ocamldep_command "%.mly" "%.mly.depends"); - (* Automatic handling of menhir modules, given a description file %.mlypack *) rule "ocaml: modular menhir (mlypack)" @@ -290,7 +280,17 @@ if !Options.use_menhir || Configuration.has_tag "use_menhir" then begin rule "ocaml: menhir modular dependencies" ~prod:"%.mlypack.depends" ~dep:"%.mlypack" - (Ocaml_tools.menhir_modular_ocamldep_command "%.mlypack" "%.mlypack.depends") + (Ocaml_tools.menhir_modular_ocamldep_command "%.mlypack" "%.mlypack.depends"); + + rule "ocaml: menhir" + ~prods:["%.ml"; "%.mli"] + ~deps:["%.mly"; "%.mly.depends"] + (Ocaml_tools.menhir "%.mly"); + + rule "ocaml: menhir dependencies" + ~prod:"%.mly.depends" + ~dep:"%.mly" + (Ocaml_tools.menhir_ocamldep_command "%.mly" "%.mly.depends"); end else rule "ocamlyacc" @@ -320,6 +320,11 @@ rule "ocaml: mltop -> top" ~dep:"%.mltop" (Ocaml_compiler.byte_toplevel_link_mltop "%.mltop" "%.top");; +rule "preprocess: ml -> pp.ml" + ~dep:"%.ml" + ~prod:"%.pp.ml" + (Ocaml_tools.camlp4 "pp.ml" "%.ml" "%.pp.ml");; + flag ["ocaml"; "pp"] begin S (List.fold_right (fun x acc -> Sh x :: acc) !Options.ocaml_ppflags []) end;; @@ -368,7 +373,7 @@ camlp4_flags' ["camlp4orr", S[A"camlp4of"; A"-parser"; A"reloaded"]; flag ["ocaml"; "pp"; "camlp4:no_quot"] (A"-no_quot");; -ocaml_lib ~extern:true ~native:false "dynlink";; +ocaml_lib ~extern:true "dynlink";; ocaml_lib ~extern:true "unix";; ocaml_lib ~extern:true "str";; ocaml_lib ~extern:true "bigarray";; @@ -387,6 +392,8 @@ flag ["ocaml"; "compile"; "use_camlp4_full"] (S[A"-I"; A"+camlp4/Camlp4Parsers"; A"-I"; A"+camlp4/Camlp4Printers"; A"-I"; A"+camlp4/Camlp4Filters"]);; +flag ["ocaml"; "use_camlp4_bin"; "link"; "byte"] (A"+camlp4/Camlp4Bin.cmo");; +flag ["ocaml"; "use_camlp4_bin"; "link"; "native"] (A"+camlp4/Camlp4Bin.cmx");; flag ["ocaml"; "debug"; "compile"; "byte"] (A "-g");; flag ["ocaml"; "debug"; "link"; "byte"; "program"] (A "-g");; @@ -402,6 +409,7 @@ flag ["ocaml"; "rectypes"; "infer_interface"] (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"; "link"; "library"; "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"]);; diff --git a/ocamlbuild/ocaml_tools.ml b/ocamlbuild/ocaml_tools.ml index a60ca8e0..6fa70e6b 100644 --- a/ocamlbuild/ocaml_tools.ml +++ b/ocamlbuild/ocaml_tools.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: ocaml_tools.ml,v 1.2.4.9 2007/11/22 18:49:38 ertai Exp $ *) +(* $Id: ocaml_tools.ml,v 1.12 2008/07/25 15:06:47 ertai Exp $ *) (* Original author: Nicolas Pouillard *) open My_std open Pathname.Operators @@ -71,9 +71,10 @@ let menhir_modular menhir_base mlypack mlypack_depends env build = let (tags,files) = import_mlypack build mlypack in let () = List.iter Outcome.ignore_good (build [[mlypack_depends]]) in Ocaml_compiler.prepare_compile build mlypack; + let ocamlc_tags = tags++"ocaml"++"byte"++"compile" in let tags = tags++"ocaml"++"parser"++"menhir" in Cmd(S[menhir ; - A "--ocamlc"; Quote(S[!Options.ocamlc; ocaml_include_flags mlypack]); + A "--ocamlc"; Quote(S[!Options.ocamlc; T ocamlc_tags; ocaml_include_flags mlypack]); T tags ; A "--infer" ; flags_of_pathname mlypack ; A "--base" ; Px menhir_base ; atomize_paths files]) @@ -151,3 +152,15 @@ let document_ocaml_project ?(ocamldoc=ocamldoc_l_file) odocl docout docdir env b 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 + +let camlp4 ?(default=A"camlp4o") tag i o env build = + let ml = env i and pp_ml = env o in + let tags = tags_of_pathname ml++"ocaml"++"pp"++tag in + let _ = Rule.build_deps_of_tags build tags in + let pp = Command.reduce (Flags.of_tags tags) in + let pp = + match pp with + | N -> default + | _ -> pp + in + Cmd(S[pp; P ml; A"-printer"; A"o"; A"-o"; Px pp_ml]) diff --git a/ocamlbuild/ocaml_tools.mli b/ocamlbuild/ocaml_tools.mli index c3f5acf4..8b30e6a4 100644 --- a/ocamlbuild/ocaml_tools.mli +++ b/ocamlbuild/ocaml_tools.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: ocaml_tools.mli,v 1.2.4.3 2007/11/21 20:46:46 ertai Exp $ *) +(* $Id: ocaml_tools.mli,v 1.7 2008/07/25 15:06:47 ertai Exp $ *) (* Original author: Nicolas Pouillard *) val ocamldoc_c : Tags.t -> string -> string -> Command.t @@ -29,3 +29,5 @@ val document_ocaml_implem : string -> string -> Rule.action val document_ocaml_project : ?ocamldoc:(Tags.t -> string list -> string -> string -> Command.t) -> string -> string -> string -> Rule.action + +val camlp4 : ?default:Command.spec -> Tags.elt -> Pathname.t -> Pathname.t -> Rule.action diff --git a/ocamlbuild/ocaml_utils.ml b/ocamlbuild/ocaml_utils.ml index 3c023c68..43aacd15 100644 --- a/ocamlbuild/ocaml_utils.ml +++ b/ocamlbuild/ocaml_utils.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: ocaml_utils.ml,v 1.3.2.3 2007/11/21 18:29:37 ertai Exp $ *) +(* $Id: ocaml_utils.ml,v 1.8 2008/07/25 14:49:03 ertai Exp $ *) (* Original author: Nicolas Pouillard *) open My_std open Format @@ -23,6 +23,11 @@ open Command;; module S = Set.Make(String) +let flag_and_dep tags cmd_spec = + flag tags cmd_spec; + let ps = Command.fold_pathnames (fun p ps -> p :: ps) (Cmd cmd_spec) [] in + dep tags ps + let stdlib_dir = lazy begin (* FIXME *) let ocamlc_where = sprintf "%s/ocamlc.where" (Pathname.pwd / !Options.build_dir) in @@ -102,12 +107,16 @@ let ocaml_lib ?(extern=false) ?(byte=true) ?(native=true) ?dir ?tag_name libpath | Some x -> x | None -> "use_" ^ Pathname.basename libpath in + let flag_and_dep tags lib = + flag tags (add_dir (A lib)); + if not extern then dep tags [lib] (* cannot happen? *) + 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"))); + flag_and_dep ["ocaml"; tag_name; "link"; "byte"] (libpath^".cma"); if native then - flag ["ocaml"; tag_name; "link"; "native"] (add_dir (A (libpath^".cmxa"))); + flag_and_dep ["ocaml"; tag_name; "link"; "native"] (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"; diff --git a/ocamlbuild/ocaml_utils.mli b/ocamlbuild/ocaml_utils.mli index 52b7af5e..8abc2233 100644 --- a/ocamlbuild/ocaml_utils.mli +++ b/ocamlbuild/ocaml_utils.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: ocaml_utils.mli,v 1.3.2.1 2007/11/21 18:29:37 ertai Exp $ *) +(* $Id: ocaml_utils.mli,v 1.6 2008/07/25 14:26:13 ertai Exp $ *) (* Original author: Nicolas Pouillard *) val stdlib_dir : Pathname.t Lazy.t val module_name_of_filename : Pathname.t -> string @@ -25,6 +25,7 @@ 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 flag_and_dep : Tags.elt list -> Command.spec -> unit exception Ocamldep_error of string diff --git a/ocamlbuild/ocamlbuild-presentation.rslide b/ocamlbuild/ocamlbuild-presentation.rslide index 31fd8c59..7fdec39f 100644 --- a/ocamlbuild/ocamlbuild-presentation.rslide +++ b/ocamlbuild/ocamlbuild-presentation.rslide @@ -5,7 +5,8 @@ usepackage :inputenc, :utf8 words "**OCaml**", "**ocamlbuild**", "_Makefile_" -title "ocamlbuild, a tool for automatic compilation of OCaml projects" +title "ocamlbuild" +subtitle "a compilation manager for OCaml projects" authors "Berke Durak", "Nicolas Pouillard" institute do > @@Berke.Durak@inria.fr@@ @@ -39,6 +40,8 @@ html_only do paragraph.huge1 "Warning: this presentation has a degraded style compared to the Beamer/PDF version" end +short_version = true + maketitle h1 "Introduction" @@ -115,6 +118,7 @@ slide "How does ocamlbuild manage all that?" do end end +unless short_version slide "Demo..." do box "Many projects can be compiled with a single command:" do * Menhir: _ocamlbuild -lib unix back.native_ @@ -128,6 +132,7 @@ slide "Demo..." do or _stdlib.ml_ file be generated beforehand. end end +end h1 "Dealing with exceptions to standard rules" @@ -154,7 +159,7 @@ end slide "The tags, our way to specify exceptions", 'fragile=singleslide' do list do - * The _tags file is made of lines + * Tagging is made in _tags files * Each line is made of a pattern and a list of signed tags * A line adds or removes tags from matching files * Patterns are boolean combinations of shell-like globbing expressions @@ -162,7 +167,6 @@ slide "The tags, our way to specify exceptions", 'fragile=singleslide' do 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 @@ -225,9 +229,11 @@ slide "Not a specific language, but plain OCaml code" do end end +unless short_version slide "A plugin example" do > Let's read it in live... end +end # slide "ocamlbuild scales" do # > Indeed ocamlbuild is used as an experimental replacement in OCaml itself. @@ -243,6 +249,7 @@ slide "Parallel execution where applicable" do * (Optimal scheduling would require a static graph) end +unless short_version slide "A status bar for your visual comfort" do list do * Compilation tools echo commands and their output @@ -285,6 +292,7 @@ slide "Hygiene and sterilization" do > Files or directories tagged as __not_hygienic__ or _precious_. end end +end slide "Some supported tools" do box "_Menhir_ as an _ocamlyacc_ replacement", '<1->' do @@ -321,6 +329,7 @@ slide "Resume" do end end +unless short_version slide "Acknowledgments" do box "For enlightening discussions about OCaml internals:", '<1->' do * Xavier Leroy @@ -338,3 +347,4 @@ slide "Conclusion", '<+->' do * ocamlbuild is not perfect but already damn useful * Try it now! It's in OCaml 3.10! end +end diff --git a/ocamlbuild/ocamlbuild.ml b/ocamlbuild/ocamlbuild.ml index 0f430be0..f0792d42 100644 --- a/ocamlbuild/ocamlbuild.ml +++ b/ocamlbuild/ocamlbuild.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: ocamlbuild.ml,v 1.1.4.1 2007/11/22 18:34:13 ertai Exp $ *) +(* $Id: ocamlbuild.ml,v 1.3 2008/01/11 16:13:16 doligez Exp $ *) (* Original author: Nicolas Pouillard *) Ocamlbuild_unix_plugin.setup (); Ocamlbuild_pack.Main.main () diff --git a/ocamlbuild/ocamlbuild.odocl b/ocamlbuild/ocamlbuild.odocl index 09c34475..a60120f2 100644 --- a/ocamlbuild/ocamlbuild.odocl +++ b/ocamlbuild/ocamlbuild.odocl @@ -34,6 +34,7 @@ Hooks Ocaml_utils Ocaml_tools Ocaml_compiler -Ocamldep Ocaml_dependencies +Exit_codes +Digest_cache Ocamlbuild_plugin diff --git a/ocamlbuild/ocamlbuild_executor.ml b/ocamlbuild/ocamlbuild_executor.ml index 37677c39..c432c19f 100644 --- a/ocamlbuild/ocamlbuild_executor.ml +++ b/ocamlbuild/ocamlbuild_executor.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: ocamlbuild_executor.ml,v 1.1.2.3 2007/11/28 17:21:00 ertai Exp $ *) +(* $Id: ocamlbuild_executor.ml,v 1.4 2007/11/28 17:21:59 ertai Exp $ *) (* Original author: Berke Durak *) (* Ocamlbuild_executor *) diff --git a/ocamlbuild/ocamlbuild_executor.mli b/ocamlbuild/ocamlbuild_executor.mli index d97d739f..d8f78169 100644 --- a/ocamlbuild/ocamlbuild_executor.mli +++ b/ocamlbuild/ocamlbuild_executor.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: ocamlbuild_executor.mli,v 1.1.2.3 2007/11/28 17:21:00 ertai Exp $ *) +(* $Id: ocamlbuild_executor.mli,v 1.4 2007/11/28 17:21:59 ertai Exp $ *) (* Original author: Berke Durak *) (* Ocamlbuild_executor *) diff --git a/ocamlbuild/ocamlbuild_plugin.ml b/ocamlbuild/ocamlbuild_plugin.ml index f4e3e4df..44e29dca 100644 --- a/ocamlbuild/ocamlbuild_plugin.ml +++ b/ocamlbuild/ocamlbuild_plugin.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: ocamlbuild_plugin.ml,v 1.2.2.5 2007/11/28 17:03:54 ertai Exp $ *) +(* $Id: ocamlbuild_plugin.ml,v 1.11 2008/07/25 14:42:28 ertai Exp $ *) (* Original author: Nicolas Pouillard *) open Ocamlbuild_pack @@ -31,10 +31,11 @@ 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 dep = Command.dep let copy_rule = Rule.copy_rule let ocaml_lib = Ocamlbuild_pack.Ocaml_utils.ocaml_lib let flag = Ocamlbuild_pack.Flags.flag +let flag_and_dep = Ocamlbuild_pack.Ocaml_utils.flag_and_dep 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 @@ -44,6 +45,7 @@ let tags_of_pathname = Ocamlbuild_pack.Tools.tags_of_pathname let hide_package_contents = Ocamlbuild_pack.Ocaml_compiler.hide_package_contents let tag_file = Ocamlbuild_pack.Configuration.tag_file let tag_any = Ocamlbuild_pack.Configuration.tag_any +let run_and_read = Ocamlbuild_pack.My_unix.run_and_read type hook = Ocamlbuild_pack.Hooks.message = | Before_hygiene | After_hygiene diff --git a/ocamlbuild/ocamlbuild_unix_plugin.ml b/ocamlbuild/ocamlbuild_unix_plugin.ml index 56b2885c..59bbbee7 100644 --- a/ocamlbuild/ocamlbuild_unix_plugin.ml +++ b/ocamlbuild/ocamlbuild_unix_plugin.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: ocamlbuild_unix_plugin.ml,v 1.1.2.1 2007/11/22 18:34:13 ertai Exp $ *) +(* $Id: ocamlbuild_unix_plugin.ml,v 1.3 2008/07/31 07:36:12 ertai Exp $ *) (* Original author: Nicolas Pouillard *) open Format open Ocamlbuild_pack @@ -52,9 +52,10 @@ let run_and_open s kont = | 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 res = try + kont ic + with e -> (close (); raise e) + in close (); res let stdout_isatty () = Unix.isatty Unix.stdout diff --git a/ocamlbuild/ocamlbuild_unix_plugin.mli b/ocamlbuild/ocamlbuild_unix_plugin.mli index 4cef10c2..682a9ad4 100644 --- a/ocamlbuild/ocamlbuild_unix_plugin.mli +++ b/ocamlbuild/ocamlbuild_unix_plugin.mli @@ -9,6 +9,6 @@ (* *) (***********************************************************************) -(* $Id: ocamlbuild_unix_plugin.mli,v 1.1.2.1 2007/11/22 18:34:13 ertai Exp $ *) +(* $Id: ocamlbuild_unix_plugin.mli,v 1.2 2007/11/22 18:34:22 ertai Exp $ *) (* Original author: Nicolas Pouillard *) val setup : unit -> unit diff --git a/ocamlbuild/ocamlbuild_where.mli b/ocamlbuild/ocamlbuild_where.mli index 13a7549f..e71809f1 100644 --- a/ocamlbuild/ocamlbuild_where.mli +++ b/ocamlbuild/ocamlbuild_where.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: ocamlbuild_where.mli,v 1.1.4.1 2007/03/04 16:13:53 pouillar Exp $ *) +(* $Id: ocamlbuild_where.mli,v 1.2 2007/10/08 14:19:34 doligez Exp $ *) (* Original author: Nicolas Pouillard *) diff --git a/ocamlbuild/options.ml b/ocamlbuild/options.ml index 668d2443..b3a03c51 100644 --- a/ocamlbuild/options.ml +++ b/ocamlbuild/options.ml @@ -9,10 +9,10 @@ (* *) (***********************************************************************) -(* $Id: options.ml,v 1.7.2.13 2007/11/28 16:09:46 ertai Exp $ *) +(* $Id: options.ml,v 1.16 2008/07/25 14:49:03 ertai Exp $ *) (* Original author: Nicolas Pouillard *) -let version = "ocamlbuild 0.1";; +let version = "ocamlbuild "^(Sys.ocaml_version);; type command_spec = Command.spec @@ -187,7 +187,7 @@ let spec = "-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"; + "-ocamlmktop", set_cmd ocamlmktop, " 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), diff --git a/ocamlbuild/pathname.ml b/ocamlbuild/pathname.ml index 11356122..584c3fd9 100644 --- a/ocamlbuild/pathname.ml +++ b/ocamlbuild/pathname.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: pathname.ml,v 1.1.4.5 2007/12/18 08:56:50 ertai Exp $ *) +(* $Id: pathname.ml,v 1.6 2008/01/11 16:13:16 doligez Exp $ *) (* Original author: Nicolas Pouillard *) open My_std open Format diff --git a/ocamlbuild/pathname.mli b/ocamlbuild/pathname.mli index 457ce43b..0a7acae6 100644 --- a/ocamlbuild/pathname.mli +++ b/ocamlbuild/pathname.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: pathname.mli,v 1.1.4.2 2007/12/18 08:56:50 ertai Exp $ *) +(* $Id: pathname.mli,v 1.4 2008/01/11 16:13:16 doligez Exp $ *) (* Original author: Nicolas Pouillard *) include Signatures.PATHNAME val link_to_dir : t -> t -> bool diff --git a/ocamlbuild/plugin.ml b/ocamlbuild/plugin.ml index 9f21e6ed..d0ded9ec 100644 --- a/ocamlbuild/plugin.ml +++ b/ocamlbuild/plugin.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: plugin.ml,v 1.1.4.2 2007/09/17 11:56:04 ertai Exp $ *) +(* $Id: plugin.ml,v 1.4 2008/01/11 16:13:16 doligez Exp $ *) (* Original author: Nicolas Pouillard *) open My_std open Format diff --git a/ocamlbuild/ppcache.ml b/ocamlbuild/ppcache.ml index 71d94994..41cca6f1 100644 --- a/ocamlbuild/ppcache.ml +++ b/ocamlbuild/ppcache.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: ppcache.ml,v 1.1.4.1 2007/11/21 20:55:26 ertai Exp $ *) +(* $Id: ppcache.ml,v 1.3 2008/01/11 16:13:16 doligez Exp $ *) (* Original author: Nicolas Pouillard *) open My_std open Command diff --git a/ocamlbuild/resource.ml b/ocamlbuild/resource.ml index 07448779..6326bdaf 100644 --- a/ocamlbuild/resource.ml +++ b/ocamlbuild/resource.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: resource.ml,v 1.1.4.7 2007/12/18 09:03:37 ertai Exp $ *) +(* $Id: resource.ml,v 1.9 2008/01/11 16:13:16 doligez Exp $ *) (* Original author: Nicolas Pouillard *) open My_std open Format diff --git a/ocamlbuild/resource.mli b/ocamlbuild/resource.mli index 85262cce..d80186ca 100644 --- a/ocamlbuild/resource.mli +++ b/ocamlbuild/resource.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: resource.mli,v 1.1.4.5 2007/12/18 08:58:02 ertai Exp $ *) +(* $Id: resource.mli,v 1.7 2008/01/11 16:13:16 doligez Exp $ *) (* Original author: Nicolas Pouillard *) open My_std diff --git a/ocamlbuild/rule.ml b/ocamlbuild/rule.ml index b6a44fde..3d6a110c 100644 --- a/ocamlbuild/rule.ml +++ b/ocamlbuild/rule.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: rule.ml,v 1.2.2.17 2007/12/18 08:58:02 ertai Exp $ *) +(* $Id: rule.ml,v 1.20 2008/07/25 14:50:47 ertai Exp $ *) (* Original author: Nicolas Pouillard *) open My_std open Format @@ -18,6 +18,7 @@ open Outcome module Resources = Resource.Resources exception Exit_rule_error of string +exception Failed type env = Pathname.t -> Pathname.t type builder = Pathname.t list list -> (Pathname.t, exn) Outcome.t list @@ -122,33 +123,14 @@ 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.rev& - 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 + match Command.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 = Command.iter_tags begin fun tags -> - match deps_of_tags tags with + match Command.deps_of_tags tags with | [] -> () | deps -> List.iter ignore_good (builder (List.map (fun x -> [x]) deps)) end diff --git a/ocamlbuild/rule.mli b/ocamlbuild/rule.mli index 7e9b5fd6..2afba6bc 100644 --- a/ocamlbuild/rule.mli +++ b/ocamlbuild/rule.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: rule.mli,v 1.2.2.8 2007/11/28 17:03:54 ertai Exp $ *) +(* $Id: rule.mli,v 1.12 2008/07/25 14:50:47 ertai Exp $ *) (* Original author: Nicolas Pouillard *) open My_std open Resource @@ -25,6 +25,10 @@ type rule_scheme = resource_pattern gen_rule type 'a rule_printer = (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a gen_rule -> unit +(** This exception can be raised inside the action of a rule to make the + algorithm skip this rule. *) +exception Failed + val name_of_rule : 'a gen_rule -> string val deps_of_rule : 'a gen_rule -> Pathname.t list val prods_of_rule : 'a gen_rule -> 'a list @@ -44,9 +48,6 @@ 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 diff --git a/ocamlbuild/shell.ml b/ocamlbuild/shell.ml index 2977c5a9..1e2664d4 100644 --- a/ocamlbuild/shell.ml +++ b/ocamlbuild/shell.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: shell.ml,v 1.1.4.2 2007/11/28 16:11:27 ertai Exp $ *) +(* $Id: shell.ml,v 1.4 2008/01/11 16:13:16 doligez Exp $ *) (* Original author: Nicolas Pouillard *) open My_std diff --git a/ocamlbuild/signatures.mli b/ocamlbuild/signatures.mli index 13398056..479e3e5a 100644 --- a/ocamlbuild/signatures.mli +++ b/ocamlbuild/signatures.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: signatures.mli,v 1.8.2.19 2007/12/18 08:55:23 ertai Exp $ *) +(* $Id: signatures.mli,v 1.28 2008/07/25 14:42:28 ertai Exp $ *) (* Original author: Nicolas Pouillard *) (** This module contains all module signatures that the user could use to build an ocamlbuild plugin. *) @@ -527,6 +527,14 @@ module type PLUGIN = sig ([command_spec]) when all [tags] will be activated. *) val flag : Tags.elt list -> Command.spec -> unit + (** [flag_and_dep tags command_spec] + Combines [flag] and [dep] function. + Basically it calls [flag tags command_spec], and calls [dep tags files] + where [files] is the list of all pathnames in [command_spec]. + Pathnames selected are those in the constructor [P] or [Px], or the + pathname argument of builtins like [Echo]. *) + val flag_and_dep : Tags.elt list -> Command.spec -> unit + (** [non_dependency module_path module_name] Example: [non_dependency "foo/bar/baz" "Goo"] @@ -609,6 +617,9 @@ module type PLUGIN = sig (** Returns the set of tags that applies to the given pathname. *) val tags_of_pathname : Pathname.t -> Tags.t + (** Run the given command and returns it's output as a string. *) + val run_and_read : string -> string + (** Here is the list of hooks that the dispatch function have to handle. Generally one respond to one or two hooks (like After_rules) and do nothing in the default case. *) diff --git a/ocamlbuild/solver.ml b/ocamlbuild/solver.ml index 78753896..ae48be04 100644 --- a/ocamlbuild/solver.ml +++ b/ocamlbuild/solver.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: solver.ml,v 1.1.4.5 2007/12/18 08:58:02 ertai Exp $ *) +(* $Id: solver.ml,v 1.8 2008/07/25 14:50:47 ertai Exp $ *) (* Original author: Nicolas Pouillard *) open My_std open Log @@ -70,7 +70,9 @@ let rec self depth on_the_go_orig target = | r :: rs -> try List.iter (force_self (depth + 1) on_the_go) (Rule.deps_of_rule r); - Rule.call (self_firsts (depth + 1) on_the_go) r + try + Rule.call (self_firsts (depth + 1) on_the_go) r + with Rule.Failed -> raise (Failed (Leaf target)) with Failed backtrace -> if rs = [] then failed target (Depth (target, Choice (backtrace :: backtraces))) else diff --git a/ocamlbuild/start.sh b/ocamlbuild/start.sh index dbbe72c5..331967cf 100755 --- a/ocamlbuild/start.sh +++ b/ocamlbuild/start.sh @@ -1,4 +1,19 @@ #!/bin/sh + +######################################################################### +# # +# Objective Caml # +# # +# Nicolas Pouillard, projet Gallium, INRIA Rocquencourt # +# # +# Copyright 2007 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +# $Id: start.sh,v 1.6 2008/01/11 16:13:16 doligez Exp $ + set -e set -x rm -rf _start diff --git a/ocamlbuild/tools.ml b/ocamlbuild/tools.ml index 5eddc893..458d59a2 100644 --- a/ocamlbuild/tools.ml +++ b/ocamlbuild/tools.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: tools.ml,v 1.2.4.1 2007/11/28 16:06:06 ertai Exp $ *) +(* $Id: tools.ml,v 1.4 2008/01/11 16:13:16 doligez Exp $ *) (* Original author: Nicolas Pouillard *) (* Tools *) diff --git a/ocamlbuild/tools.mli b/ocamlbuild/tools.mli index fa7ff428..2bc0854e 100644 --- a/ocamlbuild/tools.mli +++ b/ocamlbuild/tools.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: tools.mli,v 1.1.4.1 2007/11/28 16:06:06 ertai Exp $ *) +(* $Id: tools.mli,v 1.3 2008/01/11 16:13:16 doligez Exp $ *) (* Original author: Nicolas Pouillard *) (* Tools *) diff --git a/ocamldoc/.depend b/ocamldoc/.depend index 5e2196a5..f0b3e1ab 100644 --- a/ocamldoc/.depend +++ b/ocamldoc/.depend @@ -64,6 +64,8 @@ odoc_comments_global.cmo: odoc_comments_global.cmi odoc_comments_global.cmx: odoc_comments_global.cmi odoc_config.cmo: ../utils/config.cmi odoc_config.cmi odoc_config.cmx: ../utils/config.cmx odoc_config.cmi +odoc_control.cmo: +odoc_control.cmx: odoc_cross.cmo: odoc_value.cmo odoc_types.cmi odoc_type.cmo odoc_search.cmi \ odoc_scan.cmo odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \ odoc_misc.cmi odoc_messages.cmo odoc_exception.cmo odoc_class.cmo \ @@ -89,9 +91,9 @@ odoc_exception.cmx: ../typing/types.cmx odoc_types.cmx odoc_name.cmx odoc_global.cmo: ../utils/clflags.cmi odoc_global.cmi odoc_global.cmx: ../utils/clflags.cmx odoc_global.cmi odoc_html.cmo: odoc_text.cmi odoc_ocamlhtml.cmo odoc_messages.cmo \ - odoc_info.cmi odoc_dag2html.cmi odoc_args.cmi + odoc_info.cmi odoc_dag2html.cmi odoc_args.cmi ../parsing/asttypes.cmi odoc_html.cmx: odoc_text.cmx odoc_ocamlhtml.cmx odoc_messages.cmx \ - odoc_info.cmx odoc_dag2html.cmx odoc_args.cmx + odoc_info.cmx odoc_dag2html.cmx odoc_args.cmx ../parsing/asttypes.cmi odoc_info.cmo: ../typing/printtyp.cmi odoc_value.cmo odoc_types.cmi \ odoc_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 \ @@ -104,18 +106,22 @@ odoc_info.cmx: ../typing/printtyp.cmx odoc_value.cmx odoc_types.cmx \ odoc_misc.cmx odoc_messages.cmx odoc_global.cmx odoc_exception.cmx \ odoc_dep.cmx odoc_config.cmx odoc_comments.cmx odoc_class.cmx \ odoc_args.cmx odoc_analyse.cmx odoc_info.cmi +odoc_inherit.cmo: +odoc_inherit.cmx: odoc_latex.cmo: odoc_to_text.cmo odoc_messages.cmo odoc_latex_style.cmo \ - odoc_info.cmi + odoc_info.cmi ../parsing/asttypes.cmi odoc_latex.cmx: odoc_to_text.cmx odoc_messages.cmx odoc_latex_style.cmx \ - odoc_info.cmx + odoc_info.cmx ../parsing/asttypes.cmi +odoc_latex_style.cmo: +odoc_latex_style.cmx: odoc_lexer.cmo: odoc_parser.cmi odoc_messages.cmo odoc_comments_global.cmi \ odoc_args.cmi odoc_lexer.cmx: odoc_parser.cmx odoc_messages.cmx odoc_comments_global.cmx \ odoc_args.cmx odoc_man.cmo: odoc_str.cmi odoc_print.cmi odoc_misc.cmi odoc_messages.cmo \ - odoc_info.cmi odoc_args.cmi + odoc_info.cmi odoc_args.cmi ../parsing/asttypes.cmi odoc_man.cmx: odoc_str.cmx odoc_print.cmx odoc_misc.cmx odoc_messages.cmx \ - odoc_info.cmx odoc_args.cmx + odoc_info.cmx odoc_args.cmx ../parsing/asttypes.cmi odoc_merge.cmo: odoc_value.cmo odoc_types.cmi odoc_type.cmo \ odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_messages.cmo \ odoc_exception.cmo odoc_class.cmo odoc_args.cmi odoc_merge.cmi @@ -138,6 +144,8 @@ 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_ocamlhtml.cmo: +odoc_ocamlhtml.cmx: 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 \ @@ -166,28 +174,32 @@ odoc_see_lexer.cmo: odoc_parser.cmi odoc_see_lexer.cmx: odoc_parser.cmx odoc_sig.cmo: ../typing/types.cmi ../typing/typedtree.cmi ../typing/path.cmi \ ../parsing/parsetree.cmi odoc_value.cmo odoc_types.cmi odoc_type.cmo \ - odoc_print.cmi odoc_parameter.cmo odoc_name.cmi odoc_module.cmo \ - odoc_misc.cmi odoc_messages.cmo odoc_merge.cmi odoc_global.cmi \ - odoc_exception.cmo odoc_env.cmi odoc_class.cmo odoc_args.cmi \ - ../utils/misc.cmi ../parsing/location.cmi ../typing/btype.cmi \ - ../parsing/asttypes.cmi odoc_sig.cmi + odoc_parameter.cmo odoc_name.cmi odoc_module.cmo odoc_misc.cmi \ + odoc_messages.cmo odoc_merge.cmi odoc_global.cmi odoc_exception.cmo \ + odoc_env.cmi odoc_class.cmo odoc_args.cmi ../utils/misc.cmi \ + ../parsing/location.cmi ../typing/btype.cmi ../parsing/asttypes.cmi \ + odoc_sig.cmi odoc_sig.cmx: ../typing/types.cmx ../typing/typedtree.cmx ../typing/path.cmx \ ../parsing/parsetree.cmi odoc_value.cmx odoc_types.cmx odoc_type.cmx \ - odoc_print.cmx odoc_parameter.cmx odoc_name.cmx odoc_module.cmx \ - odoc_misc.cmx odoc_messages.cmx odoc_merge.cmx odoc_global.cmx \ - odoc_exception.cmx odoc_env.cmx odoc_class.cmx odoc_args.cmx \ - ../utils/misc.cmx ../parsing/location.cmx ../typing/btype.cmx \ - ../parsing/asttypes.cmi odoc_sig.cmi + odoc_parameter.cmx odoc_name.cmx odoc_module.cmx odoc_misc.cmx \ + odoc_messages.cmx odoc_merge.cmx odoc_global.cmx odoc_exception.cmx \ + odoc_env.cmx odoc_class.cmx odoc_args.cmx ../utils/misc.cmx \ + ../parsing/location.cmx ../typing/btype.cmx ../parsing/asttypes.cmi \ + odoc_sig.cmi odoc_str.cmo: ../typing/types.cmi ../typing/printtyp.cmi odoc_value.cmo \ odoc_type.cmo odoc_print.cmi odoc_name.cmi odoc_misc.cmi \ - odoc_messages.cmo odoc_exception.cmo odoc_class.cmo odoc_str.cmi + odoc_messages.cmo odoc_exception.cmo odoc_class.cmo \ + ../parsing/asttypes.cmi odoc_str.cmi odoc_str.cmx: ../typing/types.cmx ../typing/printtyp.cmx odoc_value.cmx \ odoc_type.cmx odoc_print.cmx odoc_name.cmx odoc_misc.cmx \ - odoc_messages.cmx odoc_exception.cmx odoc_class.cmx odoc_str.cmi + odoc_messages.cmx odoc_exception.cmx odoc_class.cmx \ + ../parsing/asttypes.cmi odoc_str.cmi odoc_test.cmo: odoc_info.cmi odoc_test.cmx: odoc_info.cmx -odoc_texi.cmo: odoc_to_text.cmo odoc_messages.cmo odoc_info.cmi -odoc_texi.cmx: odoc_to_text.cmx odoc_messages.cmx odoc_info.cmx +odoc_texi.cmo: odoc_to_text.cmo odoc_messages.cmo odoc_info.cmi \ + ../parsing/asttypes.cmi +odoc_texi.cmx: odoc_to_text.cmx odoc_messages.cmx odoc_info.cmx \ + ../parsing/asttypes.cmi odoc_text.cmo: odoc_types.cmi odoc_text_parser.cmi odoc_text_lexer.cmo \ odoc_text.cmi odoc_text.cmx: odoc_types.cmx odoc_text_parser.cmx odoc_text_lexer.cmx \ @@ -198,8 +210,10 @@ odoc_text_parser.cmo: odoc_types.cmi odoc_misc.cmi odoc_text_parser.cmi odoc_text_parser.cmx: odoc_types.cmx odoc_misc.cmx odoc_text_parser.cmi odoc_to_text.cmo: odoc_messages.cmo odoc_info.cmi odoc_to_text.cmx: odoc_messages.cmx odoc_info.cmx -odoc_type.cmo: ../typing/types.cmi odoc_types.cmi odoc_name.cmi -odoc_type.cmx: ../typing/types.cmx odoc_types.cmx odoc_name.cmx +odoc_type.cmo: ../typing/types.cmi odoc_types.cmi odoc_name.cmi \ + ../parsing/asttypes.cmi +odoc_type.cmx: ../typing/types.cmx odoc_types.cmx odoc_name.cmx \ + ../parsing/asttypes.cmi odoc_types.cmo: odoc_messages.cmo odoc_types.cmi odoc_types.cmx: odoc_messages.cmx odoc_types.cmi odoc_value.cmo: ../typing/types.cmi ../typing/printtyp.cmi odoc_types.cmi \ @@ -211,9 +225,12 @@ odoc_args.cmi: odoc_types.cmi odoc_module.cmo odoc_ast.cmi: ../typing/types.cmi ../typing/typedtree.cmi ../typing/path.cmi \ ../parsing/parsetree.cmi odoc_sig.cmi odoc_name.cmi odoc_module.cmo odoc_comments.cmi: odoc_types.cmi odoc_module.cmo +odoc_comments_global.cmi: +odoc_config.cmi: odoc_cross.cmi: odoc_types.cmi odoc_module.cmo odoc_dag2html.cmi: odoc_info.cmi odoc_env.cmi: ../typing/types.cmi odoc_name.cmi +odoc_global.cmi: odoc_info.cmi: ../typing/types.cmi odoc_value.cmo odoc_types.cmi \ odoc_type.cmo odoc_search.cmi odoc_parameter.cmo odoc_module.cmo \ odoc_exception.cmo odoc_class.cmo @@ -231,3 +248,4 @@ odoc_str.cmi: ../typing/types.cmi odoc_value.cmo odoc_type.cmo \ odoc_exception.cmo odoc_class.cmo odoc_text.cmi: odoc_types.cmi odoc_text_parser.cmi: odoc_types.cmi +odoc_types.cmi: diff --git a/ocamldoc/Makefile b/ocamldoc/Makefile index fcc4f518..0878a795 100644 --- a/ocamldoc/Makefile +++ b/ocamldoc/Makefile @@ -9,7 +9,7 @@ #(* *) #(***********************************************************************) -# $Id: Makefile,v 1.64.6.1 2007/11/12 08:51:29 guesdon Exp $ +# $Id: Makefile,v 1.66 2008/01/11 16:13:16 doligez Exp $ include ../config/Makefile @@ -69,7 +69,7 @@ INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \ INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP) COMPFLAGS=$(INCLUDES) -warn-error A -LINKFLAGS=$(INCLUDES) +LINKFLAGS=$(INCLUDES) -nostdlib CMOFILES= odoc_config.cmo \ odoc_global.cmo\ diff --git a/ocamldoc/Makefile.nt b/ocamldoc/Makefile.nt index 07187267..0b6e916c 100644 --- a/ocamldoc/Makefile.nt +++ b/ocamldoc/Makefile.nt @@ -9,7 +9,7 @@ #(* *) #(***********************************************************************) -# $Id: Makefile.nt,v 1.26 2006/09/20 11:14:36 doligez Exp $ +# $Id: Makefile.nt,v 1.27 2007/11/06 15:16:56 frisch Exp $ include ../config/Makefile @@ -63,7 +63,7 @@ INCLUDES_NODEP= -I $(OCAMLSRCDIR)/stdlib \ INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP) COMPFLAGS=$(INCLUDES) -LINKFLAGS=$(INCLUDES) +LINKFLAGS=$(INCLUDES) -nostdlib CMOFILES= odoc_config.cmo \ odoc_global.cmo\ diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index 43de024b..24cb064f 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_analyse.ml,v 1.14 2006/04/16 23:28:21 doligez Exp $ *) +(* $Id: odoc_analyse.ml,v 1.15 2007/12/04 13:38:58 doligez Exp $ *) (** Analysis of source files. This module is strongly inspired from driver/main.ml :-) *) @@ -158,35 +158,41 @@ module Sig_analyser = Odoc_sig.Analyser (Odoc_comments.Basic_info_retriever) let process_error exn = let report ppf = function | Lexer.Error(err, loc) -> - Location.print ppf loc; + Location.print_error ppf loc; Lexer.report_error ppf err | Syntaxerr.Error err -> Syntaxerr.report_error ppf err | Env.Error err -> + Location.print_error_cur_file ppf; Env.report_error ppf err - | Ctype.Tags(l, l') -> fprintf ppf + | Ctype.Tags(l, l') -> + Location.print_error_cur_file ppf; + fprintf ppf "In this program,@ variant constructors@ `%s and `%s@ \ have the same hash value." l l' | Typecore.Error(loc, err) -> - Location.print ppf loc; Typecore.report_error ppf err + Location.print_error ppf loc; Typecore.report_error ppf err | Typetexp.Error(loc, err) -> - Location.print ppf loc; Typetexp.report_error ppf err + Location.print_error ppf loc; Typetexp.report_error ppf err | Typedecl.Error(loc, err) -> - Location.print ppf loc; Typedecl.report_error ppf err + Location.print_error ppf loc; Typedecl.report_error ppf err | Includemod.Error err -> + Location.print_error_cur_file ppf; Includemod.report_error ppf err | Typemod.Error(loc, err) -> - Location.print ppf loc; Typemod.report_error ppf err + Location.print_error ppf loc; Typemod.report_error ppf err | Translcore.Error(loc, err) -> - Location.print ppf loc; Translcore.report_error ppf err + Location.print_error ppf loc; Translcore.report_error ppf err | Sys_error msg -> + Location.print_error_cur_file ppf; fprintf ppf "I/O error: %s" msg | Typeclass.Error(loc, err) -> - Location.print ppf loc; Typeclass.report_error ppf err + Location.print_error ppf loc; Typeclass.report_error ppf err | Translclass.Error(loc, err) -> - Location.print ppf loc; Translclass.report_error ppf err + Location.print_error ppf loc; Translclass.report_error ppf err | Warnings.Errors (n) -> - fprintf ppf "@.Error: error-enabled warnings (%d occurrences)" n + Location.print_error_cur_file ppf; + fprintf ppf "Error-enabled warnings (%d occurrences)" n | x -> fprintf ppf "@]"; fprintf ppf "Compilation error. Use the OCaml compiler to get more details." @@ -208,6 +214,7 @@ let process_file ppf sourcefile = match sourcefile with Odoc_args.Impl_file file -> ( + Location.input_name := file; try let (parsetree_typedtree_opt, input_file) = process_implementation_file ppf file in match parsetree_typedtree_opt with @@ -239,6 +246,7 @@ let process_file ppf sourcefile = ) | Odoc_args.Intf_file file -> ( + Location.input_name := file; try let (ast, signat, input_file) = process_interface_file ppf file in let file_module = Sig_analyser.analyse_signature file @@ -266,6 +274,7 @@ let process_file ppf sourcefile = None ) | Odoc_args.Text_file file -> + Location.input_name := file; try let mod_name = String.capitalize (Filename.basename (Filename.chop_extension file)) diff --git a/ocamldoc/odoc_args.ml b/ocamldoc/odoc_args.ml index 7e84db81..f82458a9 100644 --- a/ocamldoc/odoc_args.ml +++ b/ocamldoc/odoc_args.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* cvsid $Id: odoc_args.ml,v 1.20.6.1 2007/03/02 08:55:05 guesdon Exp $ *) +(* cvsid $Id: odoc_args.ml,v 1.22 2008/07/25 13:28:23 guesdon Exp $ *) (** Command-line arguments. *) @@ -108,6 +108,8 @@ let keep_code = ref false let inverse_merge_ml_mli = ref false +let filter_with_module_constraints = ref true + let title = ref (None : string option) let intro_file = ref (None : string option) @@ -229,6 +231,9 @@ let options = ref [ "-no-custom-tags", Arg.Set no_custom_tags, M.no_custom_tags ; "-stars", Arg.Set remove_stars, M.remove_stars ; "-inv-merge-ml-mli", Arg.Set inverse_merge_ml_mli, M.inverse_merge_ml_mli ; + "-no-module-constraint-filter", Arg.Clear filter_with_module_constraints, + M.no_filter_with_module_constraints ; + "-keep-code", Arg.Set keep_code, M.keep_code^"\n" ; "-dump", Arg.String (fun s -> dump := Some s), M.dump ; diff --git a/ocamldoc/odoc_args.mli b/ocamldoc/odoc_args.mli index 58377cf2..bd34ec52 100644 --- a/ocamldoc/odoc_args.mli +++ b/ocamldoc/odoc_args.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_args.mli,v 1.16 2006/09/20 11:14:36 doligez Exp $ *) +(* $Id: odoc_args.mli,v 1.17 2008/07/25 13:28:23 guesdon Exp $ *) (** Analysis of the command line arguments. *) @@ -69,6 +69,9 @@ val keep_code : bool ref (** To inverse implementation and interface files when merging. *) val inverse_merge_ml_mli : bool ref +(** To filter module elements according to module type constraints. *) +val filter_with_module_constraints : bool ref + (** The optional title to use in the generated documentation. *) val title : string option ref diff --git a/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index f2d793a4..c44f204d 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_ast.ml,v 1.29 2006/09/20 11:14:36 doligez Exp $ *) +(* $Id: odoc_ast.ml,v 1.32 2008/07/25 13:28:23 guesdon Exp $ *) (** Analysis of implementation files. *) open Misc @@ -192,6 +192,20 @@ module Typedtree_search = in iter cls.Typedtree.cl_field + let class_sig_of_cltype_decl = + let rec iter = function + Types.Tcty_constr (_, _, cty) -> iter cty + | Types.Tcty_signature s -> s + | Types.Tcty_fun (_,_, cty) -> iter cty + in + fun ct_decl -> iter ct_decl.Types.clty_type + + let search_virtual_attribute_type table ctname name = + let ct_decl = search_class_type_declaration table ctname in + let cls_sig = class_sig_of_cltype_decl ct_decl in + let (_,_,texp) = Types.Vars.find name cls_sig.cty_vars in + texp + let search_method_expression cls name = let rec iter = function | [] -> @@ -482,7 +496,7 @@ module Analyser = (** Analysis of a [Parsetree.class_struture] and a [Typedtree.class_structure] to get a couple (inherited classes, class elements). *) - let analyse_class_structure env current_class_name tt_class_sig last_pos pos_limit p_cls tt_cls = + let analyse_class_structure env current_class_name tt_class_sig last_pos pos_limit p_cls tt_cls table = let rec iter acc_inher acc_fields last_pos = function | [] -> let s = get_string_of_file last_pos pos_limit in @@ -523,13 +537,20 @@ module Analyser = p_clexp.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum q - | (Parsetree.Pcf_val (label, mutable_flag, _, loc) | - Parsetree.Pcf_valvirt (label, mutable_flag, _, loc)) :: q -> + | ((Parsetree.Pcf_val (label, mutable_flag, _, loc) | + Parsetree.Pcf_valvirt (label, mutable_flag, _, loc) ) as x) :: q -> + let virt = match x with Parsetree.Pcf_val _ -> false | _ -> true in let complete_name = Name.concat current_class_name label in let (info_opt, ele_comments) = get_comments_in_class last_pos loc.Location.loc_start.Lexing.pos_cnum in let type_exp = - try Typedtree_search.search_attribute_type tt_cls label - with Not_found -> raise (Failure (Odoc_messages.attribute_not_found_in_typedtree complete_name)) + try + if virt then + Typedtree_search.search_virtual_attribute_type table + (Name.simple current_class_name) label + else + Typedtree_search.search_attribute_type tt_cls label + with Not_found -> + raise (Failure (Odoc_messages.attribute_not_found_in_typedtree complete_name)) in let att = { @@ -542,6 +563,7 @@ module Analyser = val_loc = { loc_impl = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum) ; loc_inter = None } ; } ; att_mutable = mutable_flag = Asttypes.Mutable ; + att_virtual = virt ; } in iter acc_inher (acc_fields @ ele_comments @ [ Class_attribute att ]) loc.Location.loc_end.Lexing.pos_cnum q @@ -628,7 +650,7 @@ module Analyser = iter [] [] last_pos (snd p_cls) (** Analysis of a [Parsetree.class_expr] and a [Typedtree.class_expr] to get a a couple (class parameters, class kind). *) - let rec analyse_class_kind env current_class_name comment_opt last_pos p_class_expr tt_class_exp = + let rec analyse_class_kind env current_class_name comment_opt last_pos p_class_expr tt_class_exp table = match (p_class_expr.Parsetree.pcl_desc, tt_class_exp.Typedtree.cl_desc) with (Parsetree.Pcl_constr (lid, _), tt_class_exp_desc ) -> let name = @@ -672,6 +694,7 @@ module Analyser = p_class_expr.Parsetree.pcl_loc.Location.loc_end.Lexing.pos_cnum p_class_structure tt_class_structure + table in ([], Class_structure (inherited_classes, class_elements) ) @@ -710,7 +733,10 @@ module Analyser = in (new_param, tt_class_expr2) in - let (params, k) = analyse_class_kind env current_class_name comment_opt last_pos p_class_expr2 next_tt_class_exp in + let (params, k) = analyse_class_kind + env current_class_name comment_opt last_pos p_class_expr2 + next_tt_class_exp table + in (parameter :: params, k) | (Parsetree.Pcl_apply (p_class_expr2, _), Tclass_apply (tt_class_expr2, exp_opt_optional_list)) -> @@ -754,12 +780,17 @@ module Analyser = | (Parsetree.Pcl_let (_, _, p_class_expr2), Typedtree.Tclass_let (_, _, _, tt_class_expr2)) -> (* we don't care about these lets *) - analyse_class_kind env current_class_name comment_opt last_pos p_class_expr2 tt_class_expr2 + analyse_class_kind + env current_class_name comment_opt last_pos p_class_expr2 + tt_class_expr2 table | (Parsetree.Pcl_constraint (p_class_expr2, p_class_type2), Typedtree.Tclass_constraint (tt_class_expr2, _, _, _)) -> - let (l, class_kind) = analyse_class_kind env current_class_name comment_opt last_pos p_class_expr2 tt_class_expr2 in - (* A VOIR : analyse du class type ? on n'a pas toutes les infos. cf. Odoc_sig.analyse_class_type_kind *) + let (l, class_kind) = analyse_class_kind + env current_class_name comment_opt last_pos p_class_expr2 + tt_class_expr2 table + in + (* A VOIR : analyse du class type ? on n'a pas toutes les infos. cf. Odoc_sig.analyse_class_type_kind *) let class_type_kind = (*Sig.analyse_class_type_kind env @@ -777,7 +808,7 @@ module Analyser = raise (Failure "analyse_class_kind: Parsetree and typedtree don't match.") (** Analysis of a [Parsetree.class_declaration] and a [Typedtree.class_expr] to return a [t_class].*) - let analyse_class env current_module_name comment_opt p_class_decl tt_type_params tt_class_exp = + let analyse_class env current_module_name comment_opt p_class_decl tt_type_params tt_class_exp table = let name = p_class_decl.Parsetree.pci_name in let complete_name = Name.concat current_module_name name in let pos_start = p_class_decl.Parsetree.pci_expr.Parsetree.pcl_loc.Location.loc_start.Lexing.pos_cnum in @@ -791,6 +822,7 @@ module Analyser = pos_start p_class_decl.Parsetree.pci_expr tt_class_exp + table in let cl = { @@ -1129,6 +1161,7 @@ module Analyser = tt_type_decl.Types.type_params tt_type_decl.Types.type_variance ; ty_kind = kind ; + ty_private = tt_type_decl.Types.type_private; ty_manifest = (match tt_type_decl.Types.type_manifest with None -> None @@ -1390,6 +1423,7 @@ module Analyser = class_decl tt_type_params tt_class_exp + table in ele_comments @ ((Element_class new_class) :: (f last_pos2 q)) in @@ -1583,7 +1617,8 @@ module Analyser = 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; + if !Odoc_args.filter_with_module_constraints then + filter_module_with_module_type_constraint m_base2 tt_modtype; { m_base with m_type = tt_modtype ; diff --git a/ocamldoc/odoc_config.ml b/ocamldoc/odoc_config.ml index 86e9a341..f854b8d9 100644 --- a/ocamldoc/odoc_config.ml +++ b/ocamldoc/odoc_config.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_config.ml,v 1.1.20.2 2007/03/07 08:50:24 xleroy Exp $ *) +(* $Id: odoc_config.ml,v 1.2 2007/10/08 14:19:34 doligez Exp $ *) let custom_generators_path = Filename.concat Config.standard_library diff --git a/ocamldoc/odoc_config.mli b/ocamldoc/odoc_config.mli index a0bf45b3..eaadd909 100644 --- a/ocamldoc/odoc_config.mli +++ b/ocamldoc/odoc_config.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_config.mli,v 1.1.20.2 2007/03/07 08:50:05 xleroy Exp $ *) +(* $Id: odoc_config.mli,v 1.2 2007/10/08 14:19:34 doligez Exp $ *) (** Ocamldoc configuration contants. *) diff --git a/ocamldoc/odoc_cross.ml b/ocamldoc/odoc_cross.ml index c0714d19..9b7974db 100644 --- a/ocamldoc/odoc_cross.ml +++ b/ocamldoc/odoc_cross.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_cross.ml,v 1.17 2006/09/20 11:14:36 doligez Exp $ *) +(* $Id: odoc_cross.ml,v 1.18 2007/10/09 10:29:36 weis Exp $ *) (** Cross referencing. *) @@ -889,11 +889,11 @@ and assoc_comments_type module_list t = t.ty_info <- ao (assoc_comments_info parent module_list) t.ty_info ; (match t.ty_kind with Type_abstract -> () - | Type_variant (vl, _) -> + | Type_variant vl -> List.iter (fun vc -> vc.vc_text <- ao (assoc_comments_text parent module_list) vc.vc_text) vl - | Type_record (fl, _) -> + | Type_record fl -> List.iter (fun rf -> rf.rf_text <- ao (assoc_comments_text parent module_list) rf.rf_text) fl diff --git a/ocamldoc/odoc_dep.ml b/ocamldoc/odoc_dep.ml index 0f632fde..f975cbdc 100644 --- a/ocamldoc/odoc_dep.ml +++ b/ocamldoc/odoc_dep.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_dep.ml,v 1.6 2004/03/05 14:57:50 guesdon Exp $ *) +(* $Id: odoc_dep.ml,v 1.7 2007/10/09 10:29:36 weis Exp $ *) (** Top modules dependencies. *) @@ -147,7 +147,7 @@ let type_deps t = in (match t.T.ty_kind with T.Type_abstract -> () - | T.Type_variant (cl, _) -> + | T.Type_variant cl -> List.iter (fun c -> List.iter @@ -158,7 +158,7 @@ let type_deps t = c.T.vc_args ) cl - | T.Type_record (rl, _) -> + | T.Type_record rl -> List.iter (fun r -> let s = Odoc_print.string_of_type_expr r.T.rf_type in diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml index 053cabe6..aafd132c 100644 --- a/ocamldoc/odoc_html.ml +++ b/ocamldoc/odoc_html.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_html.ml,v 1.61.2.2 2007/11/12 09:10:35 guesdon Exp $ *) +(* $Id: odoc_html.ml,v 1.64 2008/07/23 08:55:36 guesdon Exp $ *) (** Generation of html documentation.*) @@ -1367,19 +1367,21 @@ class html = self#html_of_type_expr_param_list b father t; (match t.ty_parameters with [] -> () | _ -> bs b " "); bs b ((Name.simple t.ty_name)^" "); + let priv = t.ty_private = Asttypes.Private in ( match t.ty_manifest with None -> () | Some typ -> bs b "= "; + if priv then bs b "private "; self#html_of_type_expr b father typ; bs b " " ); (match t.ty_kind with Type_abstract -> bs b "" - | Type_variant (l, priv) -> + | Type_variant l -> bs b "= "; - if priv then bs b "private" ; + if priv then bs b "private "; bs b ( match t.ty_manifest with @@ -1423,7 +1425,7 @@ class html = print_concat b "\n" print_one l; bs b "\n" - | Type_record (l, priv) -> + | Type_record l -> bs b "= "; if priv then bs b "private " ; bs b "{"; @@ -1474,12 +1476,17 @@ class html = (* html mark *) bp b "" (Naming.attribute_target a); ( - if a.att_mutable then - bs b ((self#keyword Odoc_messages.mutab)^ " ") + if a.att_virtual then + bs b ((self#keyword "virtual")^ " ") else () ); ( + if a.att_mutable then + bs b ((self#keyword Odoc_messages.mutab)^ " ") + else + () + );( match a.att_value.val_code with None -> bs b (Name.simple a.att_value.val_name) | Some c -> @@ -1488,7 +1495,7 @@ class html = bp b "%s" file (Name.simple a.att_value.val_name); ); bs b " : "; - self#html_of_type_expr b module_name a.att_value.val_type; + self#html_of_type_expr b module_name a.att_value.val_type; bs b ""; self#html_of_info b a.att_value.val_info @@ -1814,7 +1821,7 @@ class html = (Naming.type_target { ty_name = c.cl_name ; ty_info = None ; ty_parameters = [] ; - ty_kind = Type_abstract ; ty_manifest = None ; + ty_kind = Type_abstract ; ty_private = Asttypes.Public; ty_manifest = None ; ty_loc = Odoc_info.dummy_loc ; ty_code = None ; } @@ -1861,7 +1868,7 @@ class html = (Naming.type_target { ty_name = ct.clt_name ; ty_info = None ; ty_parameters = [] ; - ty_kind = Type_abstract ; ty_manifest = None ; + ty_kind = Type_abstract ; ty_private = Asttypes.Public; ty_manifest = None ; ty_loc = Odoc_info.dummy_loc ; ty_code = None ; } diff --git a/ocamldoc/odoc_info.ml b/ocamldoc/odoc_info.ml index 12d515ae..55f20259 100644 --- a/ocamldoc/odoc_info.ml +++ b/ocamldoc/odoc_info.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_info.ml,v 1.23.6.1 2007/03/02 08:55:05 guesdon Exp $ *) +(* $Id: odoc_info.ml,v 1.24 2007/10/08 14:19:34 doligez Exp $ *) (** Interface for analysing documented OCaml source files and to the collected information. *) diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli index eb4b6ff8..375f4754 100644 --- a/ocamldoc/odoc_info.mli +++ b/ocamldoc/odoc_info.mli @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_info.mli,v 1.40.6.1 2007/03/02 08:55:05 guesdon Exp $ *) +(* $Id: odoc_info.mli,v 1.45 2008/07/25 13:28:23 guesdon Exp $ *) (** Interface to the information collected in source files. *) @@ -187,6 +187,9 @@ module Exception : (** Representation and manipulation of types.*) module Type : sig + type private_flag = Odoc_type.private_flag = + Private | Public + (** Description of a variant type constructor. *) type variant_constructor = Odoc_type.variant_constructor = { @@ -207,10 +210,10 @@ module Type : (** The various kinds of a type. *) type type_kind = Odoc_type.type_kind = Type_abstract (** Type is abstract, for example [type t]. *) - | Type_variant of variant_constructor list * bool - (** constructors * bool *) - | Type_record of record_field list * bool - (** fields * bool *) + | Type_variant of variant_constructor list + (** constructors *) + | Type_record of record_field list + (** fields *) (** Representation of a type. *) type t_type = Odoc_type.t_type = @@ -219,7 +222,8 @@ module Type : mutable ty_info : info option ; (** Information found in the optional associated comment. *) ty_parameters : (Types.type_expr * bool * bool) list ; (** type parameters: (type, covariant, contravariant) *) - ty_kind : type_kind ; (** Type kind. *) + ty_kind : type_kind; (** Type kind. *) + ty_private : private_flag; (** Private or public type. *) ty_manifest : Types.type_expr option; (** Type manifest. *) mutable ty_loc : location ; mutable ty_code : string option; @@ -247,6 +251,7 @@ module Value : { att_value : t_value ; (** an attribute has almost all the same information as a value *) att_mutable : bool ; (** [true] if the attribute is mutable. *) + att_virtual : bool ; (** [true] if the attribute is virtual. *) } (** Representation of a class method. *) @@ -940,6 +945,12 @@ module Args : (** The optional title to use in the generated documentation. *) val title : string option ref + (** To inverse [.ml] and [.mli] files while merging comments. *) + val inverse_merge_ml_mli : bool ref + + (** To filter module elements according to module type constraints. *) + val filter_with_module_constraints : bool ref + (** To keep the code while merging, when we have both .ml and .mli files for a module. *) val keep_code : bool ref diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml index 0df844ef..58571c26 100644 --- a/ocamldoc/odoc_latex.ml +++ b/ocamldoc/odoc_latex.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_latex.ml,v 1.40 2006/09/20 11:14:37 doligez Exp $ *) +(* $Id: odoc_latex.ml,v 1.41 2007/10/09 10:29:36 weis Exp $ *) (** Generation of LaTeX documentation. *) @@ -474,11 +474,12 @@ class latex = self#latex_of_type_params fmt2 mod_name t; (match t.ty_parameters with [] -> () | _ -> ps fmt2 " "); ps fmt2 s_name; + let priv = t.ty_private = Asttypes.Private in ( match t.ty_manifest with None -> () | Some typ -> - p fmt2 " = %s" (self#normal_type mod_name typ) + p fmt2 " = %s%s" (if priv then "private " else "") (self#normal_type mod_name typ) ); let s_type3 = p fmt2 @@ -486,8 +487,8 @@ class latex = ( match t.ty_kind with Type_abstract -> "" - | Type_variant (_, priv) -> "="^(if priv then " private" else "") - | Type_record (_, priv) -> "= "^(if priv then "private " else "")^"{" + | Type_variant _ -> "="^(if priv then " private" else "") + | Type_record _ -> "= "^(if priv then "private " else "")^"{" ) ; flush2 () in @@ -495,7 +496,7 @@ class latex = let defs = match t.ty_kind with Type_abstract -> [] - | Type_variant (l, _) -> + | Type_variant l -> (List.flatten (List.map (fun constr -> @@ -527,7 +528,7 @@ class latex = l ) ) - | Type_record (l, _) -> + | Type_record l -> (List.flatten (List.map (fun r -> diff --git a/ocamldoc/odoc_lexer.mll b/ocamldoc/odoc_lexer.mll index 7df10ce6..034767d0 100644 --- a/ocamldoc/odoc_lexer.mll +++ b/ocamldoc/odoc_lexer.mll @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_lexer.mll,v 1.4 2003/11/24 10:41:04 starynke Exp $ *) +(* $Id: odoc_lexer.mll,v 1.5 2008/07/23 11:14:22 guesdon Exp $ *) (** The lexer for special comments. *) @@ -33,7 +33,7 @@ let ajout_string = Buffer.add_string string_buffer let lecture_string () = Buffer.contents string_buffer -(** The variable which will contain the description string. +(** The variable which will contain the description string. Is initialized when we encounter the start of a special comment. *) let description = ref "" @@ -52,7 +52,7 @@ let remove_blanks s = let rec iter liste = match liste with h :: q -> - let h2 = Str.global_replace (Str.regexp ("^"^blank^"+")) "" h in + let h2 = Str.global_replace (Str.regexp ("^"^blank^"+")) "" h in if h2 = "" then ( print_DEBUG2 (h^" n'a que des blancs"); @@ -66,11 +66,11 @@ let remove_blanks s = [] in iter l in - let l3 = - let rec iter liste = + let l3 = + let rec iter liste = match liste with h :: q -> - let h2 = Str.global_replace (Str.regexp (blank^"+$")) "" h in + let h2 = Str.global_replace (Str.regexp (blank^"+$")) "" h in if h2 = "" then ( print_DEBUG2 (h^" n'a que des blancs"); @@ -91,16 +91,16 @@ let remove_blanks s = let remove_stars s = let s2 = Str.global_replace (Str.regexp ("^"^blank^"*\\*")) "" s in s2 -} +} let lowercase = ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] let uppercase = ['A'-'Z' '\192'-'\214' '\216'-'\222'] -let identchar = +let identchar = ['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9'] rule main = parse [' ' '\013' '\009' '\012'] + - { + { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); main lexbuf } @@ -109,36 +109,36 @@ rule main = parse { incr line_number; incr Odoc_comments_global.nb_chars; - main lexbuf + main lexbuf } | "(**)" { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); Description ("", None) - } + } | "(**"("*"+)")" { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); main lexbuf - } + } | "(***" { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); incr comments_level; main lexbuf - } + } | "(**" - { + { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); incr comments_level; if !comments_level = 1 then ( reset_string_buffer (); description := ""; - special_comment lexbuf + special_comment lexbuf ) else main lexbuf @@ -152,24 +152,24 @@ rule main = parse Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); decr comments_level ; main lexbuf - } + } | "(*" { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); incr comments_level ; main lexbuf - } + } | _ - { + { incr Odoc_comments_global.nb_chars; main lexbuf } and special_comment = parse | "*)" - { + { let s = Lexing.lexeme lexbuf in Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); if !comments_level = 1 then @@ -177,7 +177,7 @@ and special_comment = parse (* there is just a description *) let s2 = lecture_string () in let s3 = remove_blanks s2 in - let s4 = + let s4 = if !Odoc_args.remove_stars then remove_stars s3 else @@ -200,16 +200,16 @@ and special_comment = parse incr comments_level ; ajout_string s; special_comment lexbuf - } + } | "\\@" - { + { let s = Lexing.lexeme lexbuf in let c = (Lexing.lexeme_char lexbuf 1) in ajout_char_string c; Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); - special_comment lexbuf - } + special_comment lexbuf + } | "@"lowercase+ { @@ -219,38 +219,38 @@ and special_comment = parse reset_string_buffer (); let len = String.length (Lexing.lexeme lexbuf) in lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - len; - lexbuf.Lexing.lex_curr_p <- + lexbuf.Lexing.lex_curr_p <- { lexbuf.Lexing.lex_curr_p with pos_cnum = lexbuf.Lexing.lex_curr_p.pos_cnum - len } ; (* we don't increment the Odoc_comments_global.nb_chars *) special_comment_part2 lexbuf - } + } | _ - { + { let c = (Lexing.lexeme_char lexbuf 0) in ajout_char_string c; if c = '\010' then incr line_number; incr Odoc_comments_global.nb_chars; - special_comment lexbuf - } + special_comment lexbuf + } and special_comment_part2 = parse | "*)" - { + { let s = Lexing.lexeme lexbuf in Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); if !comments_level = 1 then (* finally we return the description we kept *) - let desc = + let desc = if !Odoc_args.remove_stars then remove_stars !description else !description in let remain = lecture_string () in - let remain2 = + let remain2 = if !Odoc_args.remove_stars then remove_stars remain else @@ -272,20 +272,20 @@ and special_comment_part2 = parse ajout_string s; incr comments_level ; special_comment_part2 lexbuf - } + } | _ - { + { let c = (Lexing.lexeme_char lexbuf 0) in ajout_char_string c; if c = '\010' then incr line_number; incr Odoc_comments_global.nb_chars; - special_comment_part2 lexbuf - } + special_comment_part2 lexbuf + } and elements = parse | [' ' '\013' '\009' '\012'] + - { + { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); elements lexbuf } @@ -297,14 +297,14 @@ and elements = parse elements lexbuf } | "@"lowercase+ - { + { let s = Lexing.lexeme lexbuf in Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); let s2 = String.sub s 1 ((String.length s) - 1) in print_DEBUG2 s2; match s2 with "param" -> - T_PARAM + T_PARAM | "author" -> T_AUTHOR | "version" -> @@ -324,25 +324,26 @@ and elements = parse raise (Failure (Odoc_messages.not_a_valid_tag s)) else T_CUSTOM s - } + } | ("\\@" | [^'@'])+ { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); let s = Lexing.lexeme lexbuf in - let s2 = remove_blanks s in - print_DEBUG2 ("Desc "^s2); - Desc s2 - } + let s = Str.global_replace (Str.regexp_string "\\@") "@" s in + let s = remove_blanks s in + print_DEBUG2 ("Desc "^s); + Desc s + } | eof { EOF - } - + } + and simple = parse [' ' '\013' '\009' '\012'] + - { + { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); simple lexbuf } @@ -350,32 +351,32 @@ and simple = parse | [ '\010' ] { incr line_number; incr Odoc_comments_global.nb_chars; - simple lexbuf + simple lexbuf } - | "(**"("*"+) + | "(**"("*"+) { Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length (Lexing.lexeme lexbuf)); incr comments_level; simple lexbuf - } + } | "(*"("*"+)")" { let s = Lexing.lexeme lexbuf in Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); simple lexbuf - } + } | "(**" { let s = Lexing.lexeme lexbuf in Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); incr comments_level; simple lexbuf - } + } | "(*" - { + { let s = Lexing.lexeme lexbuf in Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); incr comments_level; @@ -383,7 +384,7 @@ and simple = parse ( reset_string_buffer (); description := ""; - special_comment lexbuf + special_comment lexbuf ) else ( @@ -401,7 +402,7 @@ and simple = parse Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s); decr comments_level ; simple lexbuf - } + } | _ { diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml index 02a0f2cb..a550118c 100644 --- a/ocamldoc/odoc_man.ml +++ b/ocamldoc/odoc_man.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_man.ml,v 1.26 2006/01/04 16:55:50 doligez Exp $ *) +(* $Id: odoc_man.ml,v 1.28 2008/07/23 08:55:36 guesdon Exp $ *) (** The man pages generator. *) open Odoc_info @@ -410,17 +410,19 @@ class man = ); bs b (Name.simple t.ty_name); bs b " \n"; + let priv = t.ty_private = Asttypes.Private in ( match t.ty_manifest with None -> () | Some typ -> bs b "= "; + if priv then bs b "private "; self#man_of_type_expr b father typ ); ( match t.ty_kind with Type_abstract -> () - | Type_variant (l, priv) -> + | Type_variant l -> bs b "="; if priv then bs b " private"; bs b "\n "; @@ -448,7 +450,7 @@ class man = ) ) l - | Type_record (l, priv) -> + | Type_record l -> bs b "= "; if priv then bs b "private "; bs b "{"; @@ -477,6 +479,7 @@ class man = (** Print groff string for a class attribute. *) method man_of_attribute b a = bs b ".I val "; + if a.att_virtual then bs b ("virtual "); if a.att_mutable then bs b (Odoc_messages.mutab^" "); bs b ((Name.simple a.att_value.val_name)^" : "); self#man_of_type_expr b (Name.father a.att_value.val_name) a.att_value.val_type; diff --git a/ocamldoc/odoc_merge.ml b/ocamldoc/odoc_merge.ml index bc88edcd..15838d41 100644 --- a/ocamldoc/odoc_merge.ml +++ b/ocamldoc/odoc_merge.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_merge.ml,v 1.12 2006/09/20 11:14:37 doligez Exp $ *) +(* $Id: odoc_merge.ml,v 1.13 2007/10/09 10:29:36 weis Exp $ *) (** Merge of information from [.ml] and [.mli] for a module.*) @@ -196,7 +196,7 @@ let merge_types merge_options mli ml = Type_abstract, _ -> () - | Type_variant (l1, _), Type_variant (l2, _) -> + | Type_variant l1, Type_variant l2 -> let f cons = try let cons2 = List.find @@ -224,7 +224,7 @@ let merge_types merge_options mli ml = in List.iter f l1 - | Type_record (l1, _), Type_record (l2, _) -> + | Type_record l1, Type_record l2 -> let f record = try let record2= List.find diff --git a/ocamldoc/odoc_messages.ml b/ocamldoc/odoc_messages.ml index fd874406..f288da10 100644 --- a/ocamldoc/odoc_messages.ml +++ b/ocamldoc/odoc_messages.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_messages.ml,v 1.30.6.1 2007/03/02 08:55:05 guesdon Exp $ *) +(* $Id: odoc_messages.ml,v 1.32 2008/07/25 13:28:23 guesdon Exp $ *) (** The messages of the application. *) @@ -167,6 +167,7 @@ let no_custom_tags = "\n\t\tDo not allow custom @-tags" let remove_stars = "\tRemove beginning blanks of comment lines, until the first '*'" let keep_code = "\tAlways keep code when available" let inverse_merge_ml_mli = "\n\t\tInverse implementations and interfaces when merging" +let no_filter_with_module_constraints = "\n\t\tDo not filter module elements using module type constraints" let merge_description = ('d', "merge description") let merge_author = ('a', "merge @author") let merge_version = ('v', "merge @version") diff --git a/ocamldoc/odoc_ocamlhtml.mll b/ocamldoc/odoc_ocamlhtml.mll index 40a32d6d..05cda08a 100644 --- a/ocamldoc/odoc_ocamlhtml.mll +++ b/ocamldoc/odoc_ocamlhtml.mll @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_ocamlhtml.mll,v 1.9.18.1 2007/11/12 09:09:54 guesdon Exp $ *) +(* $Id: odoc_ocamlhtml.mll,v 1.10 2008/01/11 16:13:16 doligez Exp $ *) (** Generation of html code to display OCaml code. *) open Lexing diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index d1575e17..329e23b4 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_sig.ml,v 1.39 2007/02/09 13:31:15 doligez Exp $ *) +(* $Id: odoc_sig.ml,v 1.41 2008/07/23 08:55:36 guesdon Exp $ *) (** Analysis of interface files. *) @@ -172,9 +172,9 @@ module Analyser = let name_comment_from_type_kind pos_end pos_limit tk = match tk with - Parsetree.Ptype_abstract | Parsetree.Ptype_private -> + Parsetree.Ptype_abstract -> (0, []) - | Parsetree.Ptype_variant (cons_core_type_list_list, _) -> + | Parsetree.Ptype_variant cons_core_type_list_list -> let rec f acc cons_core_type_list_list = match cons_core_type_list_list with [] -> @@ -197,7 +197,7 @@ module Analyser = in f [] cons_core_type_list_list - | Parsetree.Ptype_record (name_mutable_type_list, _) (* of (string * mutable_flag * core_type) list*) -> + | Parsetree.Ptype_record name_mutable_type_list (* of (string * mutable_flag * core_type) list*) -> let rec f = function [] -> [] @@ -220,7 +220,7 @@ module Analyser = Types.Type_abstract -> Odoc_type.Type_abstract - | Types.Type_variant (l, priv) -> + | Types.Type_variant l -> let f (constructor_name, type_expr_list) = let comment_opt = try @@ -235,9 +235,9 @@ module Analyser = vc_text = comment_opt } in - Odoc_type.Type_variant (List.map f l, priv = Asttypes.Private) + Odoc_type.Type_variant (List.map f l) - | Types.Type_record (l, _, priv) -> + | Types.Type_record (l, _) -> let f (field_name, mutable_flag, type_expr) = let comment_opt = try @@ -253,17 +253,12 @@ module Analyser = rf_text = comment_opt } in - Odoc_type.Type_record (List.map f l, priv = Asttypes.Private) + Odoc_type.Type_record (List.map f l) (** Analysis of the elements of a class, from the information in the parsetree and in the class signature. @return the couple (inherited_class list, elements).*) let analyse_class_elements env current_class_name last_pos pos_limit class_type_field_list class_signature = - print_DEBUG "Types.Tcty_signature class_signature"; - let f_DEBUG var (mutable_flag, type_exp) = print_DEBUG var in - Types.Vars.iter f_DEBUG class_signature.Types.cty_vars; - print_DEBUG ("Type de la classe "^current_class_name^" : "); - print_DEBUG (Odoc_print.string_of_type_expr class_signature.Types.cty_self); let get_pos_limit2 q = match q with [] -> pos_limit @@ -330,7 +325,7 @@ module Analyser = in ([], ele_comments) - | Parsetree.Pctf_val (name, mutable_flag, _, _, loc) :: q -> + | Parsetree.Pctf_val (name, mutable_flag, virtual_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 @@ -353,6 +348,7 @@ module Analyser = val_loc = { loc_impl = None ; loc_inter = Some (!file_name, loc.Location.loc_start.Lexing.pos_cnum)} ; } ; att_mutable = mutable_flag = Asttypes.Mutable ; + att_virtual = virtual_flag = Asttypes.Virtual ; } in let pos_limit2 = get_pos_limit2 q in @@ -609,7 +605,8 @@ module Analyser = ) sig_type_decl.Types.type_params sig_type_decl.Types.type_variance; - ty_kind = type_kind ; + ty_kind = type_kind; + ty_private = sig_type_decl.Types.type_private; ty_manifest = (match sig_type_decl.Types.type_manifest with None -> None @@ -1180,11 +1177,6 @@ module Analyser = ([], k) | (Parsetree.Pcty_signature (_, class_type_field_list), Types.Tcty_signature class_signature) -> - print_DEBUG "Types.Tcty_signature class_signature"; - let f_DEBUG var (mutable_flag, type_exp) = print_DEBUG var in - Types.Vars.iter f_DEBUG class_signature.Types.cty_vars; - print_DEBUG ("Type de la classe "^current_class_name^" : "); - print_DEBUG (Odoc_print.string_of_type_expr class_signature.Types.cty_self); (* we get the elements of the class in class_type_field_list *) let (inher_l, ele) = analyse_class_elements env current_class_name last_pos @@ -1234,11 +1226,6 @@ module Analyser = k | (Parsetree.Pcty_signature (_, class_type_field_list), Types.Tcty_signature class_signature) -> - print_DEBUG "Types.Tcty_signature class_signature"; - let f_DEBUG var (mutable_flag, type_exp) = print_DEBUG var in - Types.Vars.iter f_DEBUG class_signature.Types.cty_vars; - print_DEBUG ("Type de la classe "^current_class_name^" : "); - print_DEBUG (Odoc_print.string_of_type_expr class_signature.Types.cty_self); (* we get the elements of the class in class_type_field_list *) let (inher_l, ele) = analyse_class_elements env current_class_name last_pos diff --git a/ocamldoc/odoc_str.ml b/ocamldoc/odoc_str.ml index 33ae73b0..2aad6fb3 100644 --- a/ocamldoc/odoc_str.ml +++ b/ocamldoc/odoc_str.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_str.ml,v 1.11 2005/03/24 17:20:53 doligez Exp $ *) +(* $Id: odoc_str.ml,v 1.13 2008/07/23 08:55:36 guesdon Exp $ *) (** The functions to get a string from different kinds of elements (types, modules, ...). *) @@ -150,6 +150,10 @@ let string_of_class_params c = iter c.Odoc_class.cl_type; Buffer.contents b +let bool_of_private = function + | Asttypes.Private -> true + | _ -> false + let string_of_type t = let module M = Odoc_type in "type "^ @@ -162,15 +166,18 @@ let string_of_type t = t.M.ty_parameters ) )^ + let priv = bool_of_private (t.M.ty_private) in (Name.simple t.M.ty_name)^" "^ (match t.M.ty_manifest with None -> "" - | Some typ -> "= "^(Odoc_print.string_of_type_expr typ)^" " + | Some typ -> + "= " ^ (if priv then "private " else "" ) ^ + (Odoc_print.string_of_type_expr typ)^" " )^ (match t.M.ty_kind with M.Type_abstract -> "" - | M.Type_variant (l, priv) -> + | M.Type_variant l -> "="^(if priv then " private" else "")^"\n"^ (String.concat "" (List.map @@ -192,7 +199,7 @@ let string_of_type t = l ) ) - | M.Type_record (l, priv) -> + | M.Type_record l -> "= "^(if priv then "private " else "")^"{\n"^ (String.concat "" (List.map @@ -249,6 +256,7 @@ let string_of_value v = let string_of_attribute a = let module M = Odoc_value in "val "^ + (if a.M.att_virtual then "virtual " else "")^ (if a.M.att_mutable then Odoc_messages.mutab^" " else "")^ (Name.simple a.M.att_value.M.val_name)^" : "^ (Odoc_print.string_of_type_expr a.M.att_value.M.val_type)^"\n"^ @@ -266,4 +274,4 @@ let string_of_method m = None -> "" | Some i -> Odoc_misc.string_of_info i) -(* eof $Id: odoc_str.ml,v 1.11 2005/03/24 17:20:53 doligez Exp $ *) +(* eof $Id: odoc_str.ml,v 1.13 2008/07/23 08:55:36 guesdon Exp $ *) diff --git a/ocamldoc/odoc_texi.ml b/ocamldoc/odoc_texi.ml index b5c20f9a..1c7d5fd2 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.22 2007/02/12 10:27:29 ertai Exp $ *) +(* $Id: odoc_texi.ml,v 1.24 2008/07/23 08:55:36 guesdon Exp $ *) (** Generation of Texinfo documentation. *) @@ -577,6 +577,7 @@ class texi = let t = [ self#fixedblock [ Newline ; minus ; Raw "val " ; + Raw (if a.att_virtual then "virtual " else "") ; Raw (if a.att_mutable then "mutable " else "") ; Raw (Name.simple a.att_value.val_name) ; Raw " :\n" ; @@ -631,15 +632,17 @@ class texi = [ Newline ; minus ; Raw "type " ; Raw (self#string_of_type_parameters ty) ; Raw (Name.simple ty.ty_name) ] @ + let priv = ty.ty_private = Asttypes.Private in ( match ty.ty_manifest with | None -> [] | Some typ -> - (Raw " = ") :: (self#text_of_short_type_expr - (Name.father ty.ty_name) typ) ) @ + (Raw " = ") :: + (Raw (if priv then "private " else "")) :: + (self#text_of_short_type_expr (Name.father ty.ty_name) typ) ) @ ( match ty.ty_kind with | Type_abstract -> [ Newline ] - | Type_variant (l, priv) -> + | Type_variant l -> (Raw (" ="^(if priv then " private" else "")^"\n")) :: (List.flatten (List.map @@ -652,7 +655,7 @@ class texi = ((Raw (indent 5 "\n(* ")) :: (self#soft_fix_linebreaks 8 t)) @ [ Raw " *)" ; Newline ] ) ) l ) ) - | Type_record (l, priv) -> + | Type_record l -> (Raw (" = "^(if priv then "private " else "")^"{\n")) :: (List.flatten (List.map diff --git a/ocamldoc/odoc_to_text.ml b/ocamldoc/odoc_to_text.ml index 50ff68a0..0c636e1c 100644 --- a/ocamldoc/odoc_to_text.ml +++ b/ocamldoc/odoc_to_text.ml @@ -9,14 +9,14 @@ (* *) (***********************************************************************) -(* $Id: odoc_to_text.ml,v 1.16 2004/08/20 17:04:35 doligez Exp $ *) +(* $Id: odoc_to_text.ml,v 1.17 2008/07/23 08:55:36 guesdon Exp $ *) (** Text generation. - This module contains the class [to_text] with methods used to transform + This module contains the class [to_text] with methods used to transform information about elements to a [text] structure.*) -open Odoc_info +open Odoc_info open Exception open Type open Value @@ -28,7 +28,7 @@ open Parameter class virtual info = object (self) (** The list of pairs [(tag, f)] where [f] is a function taking - the [text] associated to [tag] and returning a [text]. + the [text] associated to [tag] and returning a [text]. Add a pair here to handle a tag.*) val mutable tag_functions = ([] : (string * (Odoc_info.text -> Odoc_info.text)) list) @@ -40,8 +40,8 @@ class virtual info = | _ -> [ Bold [Raw (Odoc_messages.authors^": ")] ; Raw (String.concat ", " l) ; - Newline - ] + Newline + ] (** @return [text] value for the given optional version information.*) method text_of_version_opt v_opt = @@ -58,19 +58,19 @@ class virtual info = None -> [] | Some s -> [ Bold [Raw (Odoc_messages.since^": ")] ; Raw s ; - Newline + Newline ] (** @return [text] value for the given list of raised exceptions.*) method text_of_raised_exceptions l = match l with [] -> [] - | (s, t) :: [] -> + | (s, t) :: [] -> [ Bold [ Raw Odoc_messages.raises ] ; Raw " " ; Code s ; Raw " " - ] + ] @ t @ [ Newline ] | _ -> @@ -82,28 +82,28 @@ class virtual info = l ) ; Newline - ] + ] (** Return [text] value for the given "see also" reference. *) method text_of_see (see_ref, t) = - let t_ref = + let t_ref = match see_ref with Odoc_info.See_url s -> [ Odoc_info.Link (s, t) ] | Odoc_info.See_file s -> (Odoc_info.Code s) :: (Odoc_info.Raw " ") :: t | Odoc_info.See_doc s -> (Odoc_info.Italic [Odoc_info.Raw s]) :: (Odoc_info.Raw " ") :: t in t_ref - + (** Return [text] value for the given list of "see also" references.*) method text_of_sees l = match l with [] -> [] - | see :: [] -> - (Bold [ Raw Odoc_messages.see_also ]) :: - (Raw " ") :: + | see :: [] -> + (Bold [ Raw Odoc_messages.see_also ]) :: + (Raw " ") :: (self#text_of_see see) @ [ Newline ] | _ -> - (Bold [ Raw Odoc_messages.see_also ]) :: + (Bold [ Raw Odoc_messages.see_also ]) :: [ List (List.map (fun see -> self#text_of_see see) @@ -120,7 +120,7 @@ class virtual info = (** Return a [text] for the given list of custom tagged texts. *) method text_of_custom l = - List.fold_left + List.fold_left (fun acc -> fun (tag, text) -> try let f = List.assoc tag tag_functions in @@ -141,7 +141,7 @@ class virtual info = None -> [] | Some info -> - let t = + let t = (match info.i_deprecated with None -> [] | Some t -> ( Italic [Raw (Odoc_messages.deprecated^" ")] ) :: t @@ -160,8 +160,8 @@ class virtual info = (self#text_of_custom info.i_custom) in if block then - [Block t] - else + [Block t] + else t end @@ -172,11 +172,11 @@ class virtual to_text = method virtual label : ?no_: bool -> string -> string - (** Take a string and return the string where fully qualified idents + (** Take a string and return the string where fully qualified idents have been replaced by idents relative to the given module name. Also remove the "hidden modules".*) method relative_idents m_name s = - let f str_t = + let f str_t = let match_s = Str.matched_string str_t in let rel = Name.get_relative m_name match_s in Odoc_info.apply_if_equal Odoc_info.use_hidden_modules match_s rel @@ -188,11 +188,11 @@ class virtual to_text = in s2 - (** Take a string and return the string where fully qualified idents + (** Take a string and return the string where fully qualified idents have been replaced by idents relative to the given module name. Also remove the "hidden modules".*) method relative_module_idents m_name s = - let f str_t = + let f str_t = let match_s = Str.matched_string str_t in let rel = Name.get_relative m_name match_s in Odoc_info.apply_if_equal Odoc_info.use_hidden_modules match_s rel @@ -228,41 +228,41 @@ class virtual to_text = (** Get a string for the parameters of a class (with arrows) where all idents are relative. *) method normal_class_params m_name c = let s = Odoc_info.string_of_class_params c in - self#relative_idents m_name + self#relative_idents m_name (Odoc_info.remove_ending_newline s) (** @return [text] value to represent a [Types.type_expr].*) method text_of_type_expr module_name t = - let t = List.flatten + let t = List.flatten (List.map (fun s -> [Code s ; Newline ]) - (Str.split (Str.regexp "\n") + (Str.split (Str.regexp "\n") (self#normal_type module_name t)) ) in t (** Return [text] value for a given short [Types.type_expr].*) - method text_of_short_type_expr module_name t = + method text_of_short_type_expr module_name t = [ Code (self#normal_type module_name t) ] (** Return [text] value or the given list of [Types.type_expr], with the given separator. *) method text_of_type_expr_list module_name sep l = - [ Code (self#normal_type_list module_name sep l) ] + [ Code (self#normal_type_list module_name sep l) ] - (** Return [text] value or the given list of [Types.type_expr], + (** Return [text] value or the given list of [Types.type_expr], as type parameters of a class of class type. *) method text_of_class_type_param_expr_list module_name l = - [ Code (self#normal_class_type_param_list module_name l) ] + [ Code (self#normal_class_type_param_list module_name l) ] (** @return [text] value to represent parameters of a class (with arraows).*) method text_of_class_params module_name c = - let t = Odoc_info.text_concat + let t = Odoc_info.text_concat [Newline] (List.map (fun s -> [Code s]) - (Str.split (Str.regexp "\n") + (Str.split (Str.regexp "\n") (self#normal_class_params module_name c)) ) in @@ -274,18 +274,18 @@ class virtual to_text = (Str.split (Str.regexp "\n") (Odoc_info.string_of_module_type t)) in [ Code s ] - + (** @return [text] value for a value. *) method text_of_value v = let name = v.val_name in let s_name = Name.simple name in - let s = + let s = Format.fprintf Format.str_formatter "@[val %s :@ %s" s_name (self#normal_type (Name.father v.val_name) v.val_type); Format.flush_str_formatter () in - [ CodePre s ] @ + [ CodePre s ] @ [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @ (self#text_of_info v.val_info) @@ -293,14 +293,15 @@ class virtual to_text = method text_of_attribute a = let s_name = Name.simple a.att_value.val_name in let mod_name = Name.father a.att_value.val_name in - let s = - Format.fprintf Format.str_formatter "@[val %s%s :@ %s" + let s = + Format.fprintf Format.str_formatter "@[val %s%s%s :@ %s" + (if a.att_virtual then "virtual " else "") (if a.att_mutable then "mutable " else "") s_name (self#normal_type mod_name a.att_value.val_type); Format.flush_str_formatter () in - (CodePre s) :: + (CodePre s) :: [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @ (self#text_of_info a.att_value.val_info) @@ -308,11 +309,11 @@ class virtual to_text = method text_of_method m = let s_name = Name.simple m.met_value.val_name in let mod_name = Name.father m.met_value.val_name in - let s = + let s = Format.fprintf Format.str_formatter "@[method %s%s%s :@ %s" (if m.met_private then "private " else "") (if m.met_virtual then "virtual " else "") - s_name + s_name (self#normal_type mod_name m.met_value.val_type); Format.flush_str_formatter () in @@ -327,18 +328,18 @@ class virtual to_text = Format.fprintf Format.str_formatter "@[exception %s" s_name ; (match e.ex_args with [] -> () - | _ -> + | _ -> Format.fprintf Format.str_formatter "@ of " ); - let s = self#normal_type_list - ~par: false (Name.father e.ex_name) " * " e.ex_args + let s = self#normal_type_list + ~par: false (Name.father e.ex_name) " * " e.ex_args in - let s2 = + let s2 = Format.fprintf Format.str_formatter "%s" s ; (match e.ex_alias with None -> () - | Some ea -> - Format.fprintf Format.str_formatter " = %s" + | Some ea -> + Format.fprintf Format.str_formatter " = %s" ( match ea.ea_ex with None -> ea.ea_name @@ -377,7 +378,7 @@ class virtual to_text = ) l2 ) - ] + ] (** Return [text] value for a list of parameters. *) @@ -396,13 +397,13 @@ class virtual to_text = | s -> Code s ) :: [Code " : "] @ - (self#text_of_short_type_expr m_name (Parameter.typ p)) @ + (self#text_of_short_type_expr m_name (Parameter.typ p)) @ [Newline] @ (self#text_of_parameter_description p) ) l ) - ] + ] (** Return [text] value for a list of module parameters. *) method text_of_module_parameter_list l = @@ -410,7 +411,7 @@ class virtual to_text = [] -> [] | _ -> - [ Newline ; + [ Newline ; Bold [Raw Odoc_messages.parameters] ; Raw ":" ; List @@ -424,18 +425,18 @@ class virtual to_text = ) l ) - ] + ] (**/**) (** Return [text] value for the given [class_kind].*) method text_of_class_kind father ckind = match ckind with - Class_structure _ -> + Class_structure _ -> [Code Odoc_messages.object_end] | Class_apply capp -> - [Code + [Code ( ( match capp.capp_class with @@ -448,13 +449,13 @@ class virtual to_text = (fun s -> "("^s^")") capp.capp_params_code)) ) - ] - + ] + | Class_constr cco -> ( match cco.cco_type_parameters with [] -> [] - | l -> + | l -> (Code "["):: (self#text_of_type_expr_list father ", " l)@ [Code "] "] @@ -465,7 +466,7 @@ class virtual to_text = | Some (Cl cl) -> Name.get_relative father cl.cl_name | Some (Cltype (clt,_)) -> Name.get_relative father clt.clt_name ) - ] + ] | Class_constraint (ck, ctk) -> [Code "( "] @ @@ -478,11 +479,11 @@ class virtual to_text = (** Return [text] value for the given [class_type_kind].*) method text_of_class_type_kind father ctkind = match ctkind with - Class_type cta -> + Class_type cta -> ( match cta.cta_type_parameters with [] -> [] - | l -> + | l -> (Code "[") :: (self#text_of_class_type_param_expr_list father l) @ [Code "] "] @@ -490,16 +491,16 @@ class virtual to_text = ( match cta.cta_class with None -> [ Code cta.cta_name ] - | Some (Cltype (clt, _)) -> - let rel = Name.get_relative father clt.clt_name in + | Some (Cltype (clt, _)) -> + let rel = Name.get_relative father clt.clt_name in [Code rel] - | Some (Cl cl) -> + | Some (Cl cl) -> let rel = Name.get_relative father cl.cl_name in [Code rel] ) | Class_signature _ -> [Code Odoc_messages.object_end] - + (** Return [text] value for a [module_kind]. *) method text_of_module_kind ?(with_def_syntax=true) k = match k with @@ -518,12 +519,12 @@ class virtual to_text = [Code " ( "] @ (self#text_of_module_kind ~with_def_syntax: false k2) @ [Code " ) "] - + | Module_with (tk, code) -> (if with_def_syntax then [Code " : "] else []) @ (self#text_of_module_type_kind ~with_def_syntax: false tk) @ [Code code] - + | Module_constraint (k, tk) -> (if with_def_syntax then [Code " : "] else []) @ [Code "( "] @ @@ -531,7 +532,7 @@ class virtual to_text = [Code " : "] @ (self#text_of_module_type_kind ~with_def_syntax: false tk) @ [Code " )"] - + | Module_struct _ -> [Code ((if with_def_syntax then " : " else "")^ Odoc_messages.struct_end^" ")] @@ -550,14 +551,14 @@ class virtual to_text = | Module_type_functor (p, k) -> let t1 = - [Code ("("^p.mp_name^" : ")] @ + [Code ("("^p.mp_name^" : ")] @ (self#text_of_module_type_kind p.mp_kind) @ [Code ") -> "] in let t2 = self#text_of_module_type_kind ~with_def_syntax: false k in (if with_def_syntax then [Code " = "] else []) @ t1 @ t2 - - | Module_type_with (tk2, code) -> + + | Module_type_with (tk2, code) -> let t = self#text_of_module_type_kind ~with_def_syntax: false tk2 in (if with_def_syntax then [Code " = "] else []) @ t @ [Code code] @@ -567,7 +568,7 @@ class virtual to_text = (match mt_alias.mta_module with None -> mt_alias.mta_name | Some mt -> mt.mt_name)) - ] + ] end diff --git a/ocamldoc/odoc_type.ml b/ocamldoc/odoc_type.ml index fdbbeac9..3d4a663e 100644 --- a/ocamldoc/odoc_type.ml +++ b/ocamldoc/odoc_type.ml @@ -9,18 +9,21 @@ (* *) (***********************************************************************) -(* $Id: odoc_type.ml,v 1.5 2003/11/24 10:44:07 starynke Exp $ *) +(* $Id: odoc_type.ml,v 1.7 2008/05/21 05:56:39 guesdon Exp $ *) (** Representation and manipulation of a type, but not class nor module type.*) module Name = Odoc_name +type private_flag = Asttypes.private_flag = + Private | Public + (** Description of a variant type constructor. *) type variant_constructor = { vc_name : string ; vc_args : Types.type_expr list ; (** arguments of the constructor *) mutable vc_text : Odoc_types.text option ; (** optional user description *) - } + } (** Description of a record type field. *) type record_field = { @@ -28,25 +31,26 @@ type record_field = { rf_mutable : bool ; (** true if mutable *) rf_type : Types.type_expr ; mutable rf_text : Odoc_types.text option ; (** optional user description *) - } + } (** The various kinds of type. *) -type type_kind = +type type_kind = Type_abstract - | Type_variant of variant_constructor list * bool - (** constructors * bool *) - | Type_record of record_field list * bool - (** fields * bool *) + | Type_variant of variant_constructor list + (** constructors *) + | Type_record of record_field list + (** fields *) (** Representation of a type. *) type t_type = { ty_name : Name.t ; mutable ty_info : Odoc_types.info option ; (** optional user information *) - ty_parameters : (Types.type_expr * bool * bool) list ; + ty_parameters : (Types.type_expr * bool * bool) list ; (** type parameters: (type, covariant, contravariant) *) ty_kind : type_kind ; + ty_private : private_flag; ty_manifest : Types.type_expr option; (** type manifest *) mutable ty_loc : Odoc_types.location ; mutable ty_code : string option; - } + } diff --git a/ocamldoc/odoc_value.ml b/ocamldoc/odoc_value.ml index 12fde19f..05714faa 100644 --- a/ocamldoc/odoc_value.ml +++ b/ocamldoc/odoc_value.ml @@ -9,7 +9,7 @@ (* *) (***********************************************************************) -(* $Id: odoc_value.ml,v 1.6 2004/07/13 12:25:12 xleroy Exp $ *) +(* $Id: odoc_value.ml,v 1.7 2008/07/23 08:55:36 guesdon Exp $ *) (** Representation and manipulation of values, class attributes and class methods. *) @@ -26,22 +26,23 @@ type t_value = { mutable val_parameters : Odoc_parameter.parameter list ; mutable val_code : string option ; mutable val_loc : Odoc_types.location ; - } + } (** Representation of a class attribute. *) type t_attribute = { att_value : t_value ; (** an attribute has almost all the same information as a value *) - att_mutable : bool ; - } + att_mutable : bool ; + att_virtual : bool ; + } (** Representation of a class method. *) type t_method = { met_value : t_value ; (** a method has almost all the same information as a value *) - met_private : bool ; + met_private : bool ; met_virtual : bool ; - } + } (** Functions *) @@ -60,27 +61,27 @@ let value_parameter_text_by_name v name = (** Update the parameters text of a t_value, according to the val_info field. *) let update_value_parameters_text v = - let f p = - Odoc_parameter.update_parameter_text (value_parameter_text_by_name v) p + let f p = + Odoc_parameter.update_parameter_text (value_parameter_text_by_name v) p in List.iter f v.val_parameters -(** Create a list of (parameter name, typ) from a type, according to the arrows. +(** Create a list of (parameter name, typ) from a type, according to the arrows. [parameter_list_from_arrows t = [ a ; b ]] if t = a -> b -> c.*) let parameter_list_from_arrows typ = - let rec iter t = + let rec iter t = match t.Types.desc with Types.Tarrow (l, t1, t2, _) -> (l, t1) :: (iter t2) - | Types.Tlink texp + | Types.Tlink texp | Types.Tsubst texp -> iter texp | Types.Tpoly (texp, _) -> iter texp | Types.Tvar - | Types.Ttuple _ - | Types.Tconstr _ + | Types.Ttuple _ + | Types.Tconstr _ | Types.Tobject _ - | Types.Tfield _ + | Types.Tfield _ | Types.Tnil | Types.Tunivar | Types.Tvariant _ -> @@ -88,16 +89,16 @@ let parameter_list_from_arrows typ = in iter typ -(** Create a list of parameters with dummy names "??" from a type list. +(** Create a list of parameters with dummy names "??" from a type list. Used when we want to merge the parameters of a value, from the .ml and the .mli file. In the .mli file we don't have parameter names so there is nothing to merge. With this dummy list we can merge the parameter names from the .ml and the type from the .mli file. *) let dummy_parameter_list typ = - let normal_name s = - match s with + let normal_name s = + match s with "" -> s - | _ -> + | _ -> match s.[0] with '?' -> String.sub s 1 ((String.length s) - 1) | _ -> s @@ -106,26 +107,26 @@ let dummy_parameter_list typ = let liste_param = parameter_list_from_arrows typ in let rec iter (label, t) = match t.Types.desc with - | Types.Ttuple l -> + | Types.Ttuple l -> if label = "" then - Odoc_parameter.Tuple + Odoc_parameter.Tuple (List.map (fun t2 -> iter ("", t2)) l, t) else (* if there is a label, then we don't want to decompose the tuple *) - Odoc_parameter.Simple_name + Odoc_parameter.Simple_name { Odoc_parameter.sn_name = normal_name label ; Odoc_parameter.sn_type = t ; Odoc_parameter.sn_text = None } - | Types.Tlink t2 + | Types.Tlink t2 | Types.Tsubst t2 -> (iter (label, t2)) | _ -> - Odoc_parameter.Simple_name + Odoc_parameter.Simple_name { Odoc_parameter.sn_name = normal_name label ; Odoc_parameter.sn_type = t ; Odoc_parameter.sn_text = None } - in + in List.map iter liste_param (** Return true if the value is a function, i.e. has a functional type.*) @@ -141,4 +142,4 @@ let is_function v = in f v.val_type - + diff --git a/otherlibs/Makefile b/otherlibs/Makefile new file mode 100644 index 00000000..2c4afdcc --- /dev/null +++ b/otherlibs/Makefile @@ -0,0 +1,24 @@ +######################################################################### +# # +# 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,v 1.4 2007/11/08 09:17:47 frisch Exp $ + +# Common Makefile for otherlibs on the Unix ports + +CAMLC=$(ROOTDIR)/ocamlcomp.sh +CAMLOPT=$(ROOTDIR)/ocamlcompopt.sh +CFLAGS=-I$(ROOTDIR)/byterun -O $(SHAREDCCCOMPOPTS) $(EXTRACFLAGS) + +include ../Makefile.shared +# Note .. is the current directory (this makefile is included from +# a subdirectory) diff --git a/otherlibs/Makefile.nt b/otherlibs/Makefile.nt new file mode 100644 index 00000000..7ea9d4f3 --- /dev/null +++ b/otherlibs/Makefile.nt @@ -0,0 +1,25 @@ +######################################################################### +# # +# 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.nt,v 1.3 2007/11/08 09:17:48 frisch Exp $ + +# Common Makefile for otherlibs on the Win32/MinGW ports + +CAMLC=$(CAMLRUN) $(ROOTDIR)/ocamlc -nostdlib -I $(ROOTDIR)/stdlib -w s +CAMLOPT=$(CAMLRUN) $(ROOTDIR)/ocamlopt -nostdlib -I $(ROOTDIR)/stdlib -w s +CFLAGS=-I$(ROOTDIR)/byterun $(SHAREDCCCOMPOPTS) $(EXTRACFLAGS) + +include ../Makefile.shared +# Note .. is the current directory (this makefile is included from +# a subdirectory) + diff --git a/otherlibs/Makefile.shared b/otherlibs/Makefile.shared new file mode 100644 index 00000000..527cb6b7 --- /dev/null +++ b/otherlibs/Makefile.shared @@ -0,0 +1,90 @@ +######################################################################### +# # +# 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.shared,v 1.3 2008/07/15 15:31:32 frisch Exp $ + +# Common Makefile for otherlibs + +ROOTDIR=../.. +include $(ROOTDIR)/config/Makefile + +# Compilation options +CC=$(BYTECC) +CAMLRUN=$(ROOTDIR)/boot/ocamlrun +COMPFLAGS=-warn-error A -g $(EXTRACAMLFLAGS) +MKLIB=$(CAMLRUN) $(ROOTDIR)/tools/ocamlmklib + +# Variables to be defined by individual libraries: +#LIBNAME= +#CLIBNAME= +#CMIFILES= +#CAMLOBJS= +#COBJS= +#EXTRACFLAGS= +#EXTRACAMLFLAGS= +#LINKOPTS= +#LDOPTS= +#HEADERS= + +CMIFILES ?= $(CAMLOBJS:.cmo=.cmi) +CAMLOBJS_NAT ?= $(CAMLOBJS:.cmo=.cmx) +CLIBNAME ?= $(LIBNAME) + +all: lib$(CLIBNAME).$(A) $(LIBNAME).cma $(CMIFILES) + +allopt: lib$(CLIBNAME).$(A) $(LIBNAME).cmxa $(LIBNAME).$(CMXS) $(CMIFILES) + +$(LIBNAME).cma: $(CAMLOBJS) + $(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlc '$(CAMLC)' -linkall $(CAMLOBJS) $(LINKOPTS) + +$(LIBNAME).cmxa: $(CAMLOBJS_NAT) + $(MKLIB) -o $(LIBNAME) -oc $(CLIBNAME) -ocamlopt '$(CAMLOPT)' -linkall $(CAMLOBJS_NAT) $(LINKOPTS) + +$(LIBNAME).cmxs: $(LIBNAME).cmxa lib$(CLIBNAME).$(A) + $(CAMLOPT) -shared -o $(LIBNAME).cmxs -I . $(LIBNAME).cmxa + +lib$(CLIBNAME).$(A): $(COBJS) + $(MKLIB) -oc $(CLIBNAME) $(COBJS) $(LDOPTS) + +install:: + if test -f dll$(CLIBNAME)$(EXT_DLL); then \ + cp dll$(CLIBNAME)$(EXT_DLL) $(STUBLIBDIR)/; fi + cp lib$(CLIBNAME).$(A) $(LIBDIR)/ + cd $(LIBDIR); $(RANLIB) lib$(CLIBNAME).$(A) + cp $(LIBNAME).cma $(CMIFILES) $(CMIFILES:.cmi=.mli) $(LIBDIR)/ + if test -n "$(HEADERS)"; then cp $(HEADERS) $(LIBDIR)/caml/; fi + +installopt: + cp $(CAMLOBJS_NAT) $(LIBNAME).cmxa $(LIBNAME).$(A) $(LIBDIR)/ + cd $(LIBDIR); $(RANLIB) $(LIBNAME).a + if test -f $(LIBNAME).cmxs; then cp $(LIBNAME).cmxs $(LIBDIR)/; fi + +partialclean: + rm -f *.cm* + +clean:: partialclean + rm -f *.dll *.so *.a *.lib *.o *.obj + +.SUFFIXES: .ml .mli .cmi .cmo .cmx .$(O) + +.mli.cmi: + $(CAMLC) -c $(COMPFLAGS) $< + +.ml.cmo: + $(CAMLC) -c $(COMPFLAGS) $< + +.ml.cmx: + $(CAMLOPT) -c $(COMPFLAGS) $< + +.c.$(O): + $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $< diff --git a/otherlibs/bigarray/.depend b/otherlibs/bigarray/.depend index c7b0e420..eb76fc5f 100644 --- a/otherlibs/bigarray/.depend +++ b/otherlibs/bigarray/.depend @@ -1,44 +1,32 @@ bigarray_stubs.o: bigarray_stubs.c ../../byterun/alloc.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 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/misc.h ../../byterun/config.h ../../byterun/../config/m.h \ + ../../byterun/../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/config.h ../../byterun/misc.h bigarray.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/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/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 +mmap_unix.o: mmap_unix.c bigarray.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/mlvalues.h ../../byterun/config.h ../../byterun/misc.h \ + ../../byterun/config.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/sys.h ../../byterun/misc.h +mmap_win32.o: mmap_win32.c bigarray.h ../../byterun/config.h \ + ../../byterun/../config/m.h ../../byterun/../config/s.h \ + ../../byterun/mlvalues.h ../../byterun/config.h ../../byterun/misc.h \ + ../../byterun/config.h ../../byterun/alloc.h ../../byterun/misc.h \ + ../../byterun/mlvalues.h ../../byterun/custom.h \ + ../../byterun/mlvalues.h ../../byterun/fail.h ../../byterun/misc.h \ ../../byterun/mlvalues.h ../../byterun/sys.h ../../byterun/misc.h \ ../unix/unixsupport.h +bigarray.cmi: bigarray.cmo: bigarray.cmi bigarray.cmx: bigarray.cmi diff --git a/otherlibs/bigarray/Makefile b/otherlibs/bigarray/Makefile index 7bea40a1..9a323c94 100644 --- a/otherlibs/bigarray/Makefile +++ b/otherlibs/bigarray/Makefile @@ -11,64 +11,19 @@ # # ######################################################################### -# $Id: Makefile,v 1.23 2007/02/07 10:31:36 ertai Exp $ +# $Id: Makefile,v 1.25 2008/01/04 09:52:27 xleroy Exp $ -include ../../config/Makefile +LIBNAME=bigarray +EXTRACFLAGS=-I../unix -DIN_OCAML_BIGARRAY -DCAML_NAME_SPACE +EXTRACAMLFLAGS=-I ../unix +COBJS=bigarray_stubs.$(O) mmap_unix.$(O) +CAMLOBJS=bigarray.cmo +HEADERS=bigarray.h -CC=$(BYTECC) -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 -g - -C_OBJS=bigarray_stubs.o mmap_unix.o - -CAML_OBJS=bigarray.cmo - -all: libbigarray.a bigarray.cma - -allopt: libbigarray.a bigarray.cmxa - -libbigarray.a: $(C_OBJS) - $(MKLIB) -o bigarray $(C_OBJS) - -bigarray.cma: $(CAML_OBJS) - $(MKLIB) -ocamlc '$(CAMLC)' -linkall -o bigarray $(CAML_OBJS) - -bigarray.cmxa: $(CAML_OBJS:.cmo=.cmx) - $(MKLIB) -ocamlopt '$(CAMLOPT)' -linkall -o bigarray \ - $(CAML_OBJS:.cmo=.cmx) - -install: - if test -f dllbigarray.so; then cp dllbigarray.so $(STUBLIBDIR)/dllbigarray.so; fi - cp bigarray.cmi bigarray.mli libbigarray.a bigarray.cma $(LIBDIR) - cd $(LIBDIR); $(RANLIB) libbigarray.a - cp bigarray.h $(LIBDIR)/caml/bigarray.h - -installopt: - cp bigarray.a $(CAML_OBJS:.cmo=.cmx) bigarray.cmxa $(LIBDIR) - cd $(LIBDIR); $(RANLIB) bigarray.a - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.o *.so *.a - -.SUFFIXES: .ml .mli .cmo .cmi .cmx - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< +include ../Makefile depend: - gcc -MM -I../../byterun -I../unix *.c > .depend + gcc -MM $(CFLAGS) *.c > .depend ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend include .depend diff --git a/otherlibs/bigarray/Makefile.nt b/otherlibs/bigarray/Makefile.nt index d07208d1..7a43f5f6 100644 --- a/otherlibs/bigarray/Makefile.nt +++ b/otherlibs/bigarray/Makefile.nt @@ -11,72 +11,16 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.11 2007/01/29 12:11:16 xleroy Exp $ +# $Id: Makefile.nt,v 1.13 2008/01/04 15:01:48 xleroy Exp $ -include ../../config/Makefile +LIBNAME=bigarray +EXTRACFLAGS=-I../win32unix -DIN_OCAML_BIGARRAY -DCAML_NAME_SPACE +EXTRACAMLFLAGS=-I ../win32unix +COBJS=bigarray_stubs.$(O) mmap_win32.$(O) +CAMLOBJS=bigarray.cmo +HEADERS=bigarray.h -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 - -CAML_OBJS=bigarray.cmo - -all: dllbigarray.dll libbigarray.$(A) bigarray.cma - -allopt: libbigarray.$(A) bigarray.cmxa - -dllbigarray.dll: $(C_OBJS:.obj=.$(DO)) - $(call MKDLL,dllbigarray.dll,dllbigarray.$(A),\ - $(C_OBJS:.obj=.$(DO)) ../../byterun/ocamlrun.$(A)) - -libbigarray.$(A): $(C_OBJS:.obj=.$(SO)) - $(call MKLIB,libbigarray.$(A),$(C_OBJS:.obj=.$(SO))) - -bigarray.cma: $(CAML_OBJS) - $(CAMLC) -a -linkall -o bigarray.cma $(CAML_OBJS) \ - -dllib -lbigarray -cclib -lbigarray - -bigarray.cmxa: $(CAML_OBJS:.cmo=.cmx) - $(CAMLOPT) -a -linkall -o bigarray.cmxa \ - $(CAML_OBJS:.cmo=.cmx) -cclib -lbigarray - -install: - cp dllbigarray.dll $(STUBLIBDIR) - cp libbigarray.$(A) dllbigarray.$(A) $(LIBDIR) - cp bigarray.cmi bigarray.mli bigarray.cma $(LIBDIR) - cp bigarray.h $(LIBDIR)/caml/bigarray.h - -installopt: - cp bigarray.$(A) $(CAML_OBJS:.cmo=.cmx) bigarray.cmxa $(LIBDIR) - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.dll *.$(A) *.$(O) - -.SUFFIXES: .ml .mli .cmo .cmi .cmx .$(DO) .$(SO) - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.c.$(DO): - $(BYTECC) $(DLLCCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(DO) - -.c.$(SO): - $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(SO) +include ../Makefile.nt depend: gcc -MM $(CFLAGS) *.c > .depend diff --git a/otherlibs/bigarray/bigarray.ml b/otherlibs/bigarray/bigarray.ml index 6cd39805..4c2960f1 100644 --- a/otherlibs/bigarray/bigarray.ml +++ b/otherlibs/bigarray/bigarray.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: bigarray.ml,v 1.18 2007/02/21 15:16:53 xleroy Exp $ *) +(* $Id: bigarray.ml,v 1.20 2008/07/14 09:09:53 xleroy Exp $ *) (* Module [Bigarray]: large, multi-dimensional, numerical arrays *) @@ -107,6 +107,8 @@ module Array1 = struct Genarray.create kind layout [|dim|] 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" + external unsafe_get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_unsafe_ref_1" + external unsafe_set: ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_unsafe_set_1" let dim a = Genarray.nth_dim a 0 external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" external layout: ('a, 'b, 'c) t -> 'c layout = "caml_ba_layout" @@ -116,7 +118,7 @@ module Array1 = struct 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; + for i = 0 to Array.length data - 1 do unsafe_set ba (i + ofs) data.(i) done; ba let map_file fd ?pos kind layout shared dim = Genarray.map_file fd ?pos kind layout shared [|dim|] @@ -128,6 +130,8 @@ module Array2 = struct Genarray.create kind layout [|dim1; dim2|] 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" + external unsafe_get: ('a, 'b, 'c) t -> int -> int -> 'a = "%caml_ba_unsafe_ref_2" + external unsafe_set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "%caml_ba_unsafe_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 = "caml_ba_kind" @@ -151,7 +155,7 @@ module Array2 = struct if Array.length row <> dim2 then invalid_arg("Bigarray.Array2.of_array: non-rectangular data"); for j = 0 to dim2 - 1 do - set ba (i + ofs) (j + ofs) row.(j) + unsafe_set ba (i + ofs) (j + ofs) row.(j) done done; ba @@ -166,6 +170,8 @@ module Array3 = struct 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" + external unsafe_get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "%caml_ba_unsafe_ref_3" + external unsafe_set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit = "%caml_ba_unsafe_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 @@ -197,7 +203,7 @@ module Array3 = struct if Array.length col <> dim3 then invalid_arg("Bigarray.Array3.of_array: non-cubic data"); for k = 0 to dim3 - 1 do - set ba (i + ofs) (j + ofs) (k + ofs) col.(k) + unsafe_set ba (i + ofs) (j + ofs) (k + ofs) col.(k) done done done; @@ -238,3 +244,10 @@ let _ = let _ = Array2.get in let _ = Array3.get in () + +external get1: unit -> unit = "caml_ba_get_1" +external get2: unit -> unit = "caml_ba_get_2" +external get3: unit -> unit = "caml_ba_get_3" +external set1: unit -> unit = "caml_ba_set_1" +external set2: unit -> unit = "caml_ba_set_2" +external set3: unit -> unit = "caml_ba_set_3" diff --git a/otherlibs/bigarray/bigarray.mli b/otherlibs/bigarray/bigarray.mli index 312cc4fd..ed77a6a4 100644 --- a/otherlibs/bigarray/bigarray.mli +++ b/otherlibs/bigarray/bigarray.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: bigarray.mli,v 1.25 2007/02/21 15:16:53 xleroy Exp $ *) +(* $Id: bigarray.mli,v 1.27.2.1 2008/10/08 13:07:13 doligez Exp $ *) (** Large, multi-dimensional, numerical arrays. @@ -227,7 +227,7 @@ module Genarray : 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 + [Genarray.create] raises [Invalid_argument] if the number of dimensions is not in the range 1 to 16 inclusive, or if one of the dimensions is negative. *) @@ -243,7 +243,7 @@ module Genarray : big array [a]. The first dimension corresponds to [n = 0]; the second dimension corresponds to [n = 1]; the last dimension, to [n = Genarray.num_dims a - 1]. - Raise [Invalid_arg] if [n] is less than 0 or greater or equal than + Raise [Invalid_argument] if [n] is less than 0 or greater or equal than [Genarray.num_dims a]. *) external kind: ('a, 'b, 'c) t -> ('a, 'b) kind = "caml_ba_kind" @@ -262,7 +262,7 @@ module Genarray : 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] + Raise [Invalid_argument] 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 @@ -280,7 +280,7 @@ module Genarray : 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. + otherwise, [Invalid_argument] is raised. If [N > 3], alternate syntax is provided: you can write [a.{i1, i2, ..., iN} <- v] instead of @@ -304,7 +304,7 @@ module Genarray : array [a]. [Genarray.sub_left] applies only to big arrays in C layout. - Raise [Invalid_arg] if [ofs] and [len] do not designate + Raise [Invalid_argument] if [ofs] and [len] do not designate a valid sub-array of [a], that is, if [ofs < 0], or [len < 0], or [ofs + len > Genarray.nth_dim a 0]. *) @@ -324,7 +324,7 @@ module Genarray : array [a]. [Genarray.sub_right] applies only to big arrays in Fortran layout. - Raise [Invalid_arg] if [ofs] and [len] do not designate + Raise [Invalid_argument] if [ofs] and [len] do not designate a valid sub-array of [a], that is, if [ofs < 1], or [len < 0], or [ofs + len > Genarray.nth_dim a (Genarray.num_dims a - 1)]. *) @@ -343,7 +343,7 @@ module Genarray : 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|]] + Raise [Invalid_argument] if [M >= N], or if [[|i1; ... ; iM|]] is outside the bounds of [a]. *) external slice_right: @@ -361,7 +361,7 @@ module Genarray : 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|]] + Raise [Invalid_argument] if [M >= N], or if [[|i1; ... ; iM|]] is outside the bounds of [a]. *) external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit @@ -391,7 +391,7 @@ module Genarray : the file descriptor [fd] (as opened previously with [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). + it defaults 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 @@ -458,14 +458,14 @@ module Array1 : sig [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. *) + [Array1.dim a]. Otherwise, [Invalid_argument] is raised. *) 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 {!Bigarray.Array1.get}; - otherwise, [Invalid_arg] is raised. *) + otherwise, [Invalid_argument] is raised. *) external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t = "caml_ba_sub" @@ -489,6 +489,18 @@ module Array1 : sig 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. *) + + external unsafe_get: ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_unsafe_ref_1" + (** Like {!Bigarray.Array1.get}, but bounds checking is not always performed. + Use with caution and only when the program logic guarantees that + the access is within bounds. *) + + external unsafe_set: ('a, 'b, 'c) t -> int -> 'a -> unit + = "%caml_ba_unsafe_set_1" + (** Like {!Bigarray.Array1.set}, but bounds checking is not always performed. + Use with caution and only when the program logic guarantees that + the access is within bounds. *) + end @@ -527,14 +539,14 @@ module Array2 : 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}; - otherwise, [Invalid_arg] is raised. *) + otherwise, [Invalid_argument] is raised. *) 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], as described for {!Bigarray.Genarray.set}; - otherwise, [Invalid_arg] is raised. *) + otherwise, [Invalid_argument] is raised. *) external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "caml_ba_sub" @@ -583,7 +595,17 @@ module Array2 : (** Memory mapping of a file as a two-dimensional big array. See {!Bigarray.Genarray.map_file} for more details. *) - end + external unsafe_get: ('a, 'b, 'c) t -> int -> int -> 'a + = "%caml_ba_unsafe_ref_2" + (** Like {!Bigarray.Array2.get}, but bounds checking is not always + performed. *) + + external unsafe_set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit + = "%caml_ba_unsafe_set_2" + (** Like {!Bigarray.Array2.set}, but bounds checking is not always + performed. *) + +end (** {6 Three-dimensional arrays} *) @@ -623,7 +645,7 @@ module Array3 : 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}; - otherwise, [Invalid_arg] is raised. *) + otherwise, [Invalid_argument] is raised. *) external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit = "%caml_ba_set_3" @@ -631,7 +653,7 @@ module Array3 : stores the value [v] at coordinates ([x], [y], [z]) in [a]. [x], [y] and [z] must be within the bounds of [a], as described for {!Bigarray.Genarray.set}; - otherwise, [Invalid_arg] is raised. *) + otherwise, [Invalid_argument] is raised. *) external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "caml_ba_sub" @@ -700,7 +722,18 @@ module Array3 : 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 + + external unsafe_get: ('a, 'b, 'c) t -> int -> int -> int -> 'a + = "%caml_ba_unsafe_ref_3" + (** Like {!Bigarray.Array3.get}, but bounds checking is not always + performed. *) + + external unsafe_set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit + = "%caml_ba_unsafe_set_3" + (** Like {!Bigarray.Array3.set}, but bounds checking is not always + performed. *) + +end (** {6 Coercions between generic big arrays and fixed-dimension big arrays} *) @@ -721,17 +754,17 @@ external genarray_of_array3 : val array1_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array1.t (** Return the one-dimensional big array corresponding to the given - generic big array. Raise [Invalid_arg] if the generic big array + generic big array. Raise [Invalid_argument] if the generic big array does not have exactly one dimension. *) val array2_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array2.t (** Return the two-dimensional big array corresponding to the given - generic big array. Raise [Invalid_arg] if the generic big array + generic big array. Raise [Invalid_argument] if the generic big array does not have exactly two dimensions. *) val array3_of_genarray : ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array3.t (** Return the three-dimensional big array corresponding to the given - generic big array. Raise [Invalid_arg] if the generic big array + generic big array. Raise [Invalid_argument] if the generic big array does not have exactly three dimensions. *) @@ -751,7 +784,7 @@ val reshape : ('a, 'b, 'c) Genarray.t -> int array -> ('a, 'b, 'c) Genarray.t The returned big array must have exactly the same number of elements as the original big array [b]. That is, the product of the dimensions of [b] must be equal to [i1 * ... * iN]. - Otherwise, [Invalid_arg] is raised. *) + Otherwise, [Invalid_argument] is raised. *) val reshape_1 : ('a, 'b, 'c) Genarray.t -> int -> ('a, 'b, 'c) Array1.t (** Specialized version of {!Bigarray.reshape} for reshaping to diff --git a/otherlibs/bigarray/bigarray_stubs.c b/otherlibs/bigarray/bigarray_stubs.c index 4f405fe5..3ec50637 100644 --- a/otherlibs/bigarray/bigarray_stubs.c +++ b/otherlibs/bigarray/bigarray_stubs.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: bigarray_stubs.c,v 1.22 2006/01/27 14:33:42 doligez Exp $ */ +/* $Id: bigarray_stubs.c,v 1.23 2008/01/04 09:52:27 xleroy Exp $ */ #include #include @@ -24,12 +24,17 @@ #include "memory.h" #include "mlvalues.h" +#define int8 caml_ba_int8 +#define uint8 caml_ba_uint8 +#define int16 caml_ba_int16 +#define uint16 caml_ba_uint16 + 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 caml_ba_num_elts(struct caml_bigarray * b) +static uintnat caml_ba_num_elts(struct caml_ba_array * b) { uintnat num_elts; int i; @@ -51,7 +56,7 @@ int caml_ba_element_size[] = /* Compute the number of bytes for the elements of a big array */ -uintnat caml_ba_byte_size(struct caml_bigarray * b) +uintnat caml_ba_byte_size(struct caml_ba_array * b) { return caml_ba_num_elts(b) * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK]; @@ -132,11 +137,11 @@ caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim) uintnat num_elts, size; int overflow, i; value res; - struct caml_bigarray * b; - intnat dimcopy[MAX_NUM_DIMS]; + struct caml_ba_array * b; + intnat dimcopy[CAML_BA_MAX_NUM_DIMS]; - Assert(num_dims >= 1 && num_dims <= MAX_NUM_DIMS); - Assert((flags & BIGARRAY_KIND_MASK) <= BIGARRAY_COMPLEX64); + Assert(num_dims >= 1 && num_dims <= CAML_BA_MAX_NUM_DIMS); + Assert((flags & CAML_BA_KIND_MASK) <= CAML_BA_COMPLEX64); for (i = 0; i < num_dims; i++) dimcopy[i] = dim[i]; size = 0; if (data == NULL) { @@ -146,18 +151,18 @@ caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim) num_elts = caml_ba_multov(num_elts, dimcopy[i], &overflow); } size = caml_ba_multov(num_elts, - caml_ba_element_size[flags & BIGARRAY_KIND_MASK], + caml_ba_element_size[flags & CAML_BA_KIND_MASK], &overflow); - if (overflow) raise_out_of_memory(); + if (overflow) caml_raise_out_of_memory(); data = malloc(size); - if (data == NULL && size != 0) raise_out_of_memory(); - flags |= BIGARRAY_MANAGED; + if (data == NULL && size != 0) caml_raise_out_of_memory(); + flags |= CAML_BA_MANAGED; } - res = alloc_custom(&caml_ba_ops, - sizeof(struct caml_ba_array) - + (num_dims - 1) * sizeof(intnat), - size, CAML_BA_MAX_MEMORY); - b = Bigarray_val(res); + res = caml_alloc_custom(&caml_ba_ops, + sizeof(struct caml_ba_array) + + (num_dims - 1) * sizeof(intnat), + size, CAML_BA_MAX_MEMORY); + b = Caml_ba_array_val(res); b->data = data; b->num_dims = num_dims; b->flags = flags; @@ -172,7 +177,7 @@ caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim) CAMLexport value caml_ba_alloc_dims(int flags, int num_dims, void * data, ...) { va_list ap; - intnat dim[MAX_NUM_DIMS]; + intnat dim[CAML_BA_MAX_NUM_DIMS]; int i; value res; @@ -187,17 +192,17 @@ CAMLexport value caml_ba_alloc_dims(int flags, int num_dims, void * data, ...) CAMLprim value caml_ba_create(value vkind, value vlayout, value vdim) { - intnat dim[MAX_NUM_DIMS]; + intnat dim[CAML_BA_MAX_NUM_DIMS]; mlsize_t num_dims; int i, flags; num_dims = Wosize_val(vdim); - if (num_dims < 1 || num_dims > MAX_NUM_DIMS) - invalid_argument("Bigarray.create: bad number of dimensions"); + if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS) + caml_invalid_argument("Bigarray.create: bad number of dimensions"); for (i = 0; i < num_dims; i++) { dim[i] = Long_val(Field(vdim, i)); - if (dim[i] < 0 || dim[i] > 0x7FFFFFFFL) - invalid_argument("Bigarray.create: negative dimension"); + if (dim[i] < 0) + caml_invalid_argument("Bigarray.create: negative dimension"); } flags = Int_val(vkind) | Int_val(vlayout); return caml_ba_alloc(flags, num_dims, NULL, dim); @@ -213,18 +218,18 @@ static long caml_ba_offset(struct caml_ba_array * b, intnat * index) int i; offset = 0; - if ((b->flags & BIGARRAY_LAYOUT_MASK) == BIGARRAY_C_LAYOUT) { + if ((b->flags & CAML_BA_LAYOUT_MASK) == CAML_BA_C_LAYOUT) { /* C-style layout: row major, indices start at 0 */ for (i = 0; i < b->num_dims; i++) { if ((uintnat) index[i] >= (uintnat) b->dim[i]) - array_bound_error(); + caml_array_bound_error(); offset = offset * b->dim[i] + index[i]; } } else { /* Fortran-style layout: column major, indices start at 1 */ for (i = b->num_dims - 1; i >= 0; i--) { if ((uintnat) (index[i] - 1) >= (uintnat) b->dim[i]) - array_bound_error(); + caml_array_bound_error(); offset = offset * b->dim[i] + (index[i] - 1); } } @@ -235,7 +240,7 @@ static long caml_ba_offset(struct caml_ba_array * b, intnat * index) static value copy_two_doubles(double d0, double d1) { - value res = alloc_small(2 * Double_wosize, Double_array_tag); + value res = caml_alloc_small(2 * Double_wosize, Double_array_tag); Store_double_field(res, 0, d0); Store_double_field(res, 1, d1); return res; @@ -245,46 +250,46 @@ static value copy_two_doubles(double d0, double d1) value caml_ba_get_N(value vb, value * vind, int nind) { - struct caml_bigarray * b = Bigarray_val(vb); - intnat index[MAX_NUM_DIMS]; + struct caml_ba_array * b = Caml_ba_array_val(vb); + intnat index[CAML_BA_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.get: wrong number of indices"); + caml_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 = caml_ba_offset(b, index); /* Perform read */ - switch ((b->flags) & BIGARRAY_KIND_MASK) { + switch ((b->flags) & CAML_BA_KIND_MASK) { default: Assert(0); - case BIGARRAY_FLOAT32: - return copy_double(((float *) b->data)[offset]); - case BIGARRAY_FLOAT64: - return copy_double(((double *) b->data)[offset]); - case BIGARRAY_SINT8: + case CAML_BA_FLOAT32: + return caml_copy_double(((float *) b->data)[offset]); + case CAML_BA_FLOAT64: + return caml_copy_double(((double *) b->data)[offset]); + case CAML_BA_SINT8: return Val_int(((int8 *) b->data)[offset]); - case BIGARRAY_UINT8: + case CAML_BA_UINT8: return Val_int(((uint8 *) b->data)[offset]); - case BIGARRAY_SINT16: + case CAML_BA_SINT16: return Val_int(((int16 *) b->data)[offset]); - case BIGARRAY_UINT16: + case CAML_BA_UINT16: return Val_int(((uint16 *) b->data)[offset]); - case BIGARRAY_INT32: - return copy_int32(((int32 *) b->data)[offset]); - case BIGARRAY_INT64: - return copy_int64(((int64 *) b->data)[offset]); - case BIGARRAY_NATIVE_INT: - return copy_nativeint(((intnat *) b->data)[offset]); - case BIGARRAY_CAML_INT: + case CAML_BA_INT32: + return caml_copy_int32(((int32 *) b->data)[offset]); + case CAML_BA_INT64: + return caml_copy_int64(((int64 *) b->data)[offset]); + case CAML_BA_NATIVE_INT: + return caml_copy_nativeint(((intnat *) b->data)[offset]); + case CAML_BA_CAML_INT: return Val_long(((intnat *) b->data)[offset]); - case BIGARRAY_COMPLEX32: + case CAML_BA_COMPLEX32: { float * p = ((float *) b->data) + offset * 2; return copy_two_doubles(p[0], p[1]); } - case BIGARRAY_COMPLEX64: + case CAML_BA_COMPLEX64: { double * p = ((double *) b->data) + offset * 2; return copy_two_doubles(p[0], p[1]); } } @@ -346,46 +351,46 @@ CAMLprim value caml_ba_get_generic(value vb, value vind) 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]; + struct caml_ba_array * b = Caml_ba_array_val(vb); + intnat index[CAML_BA_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"); + caml_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 = caml_ba_offset(b, index); /* Perform write */ - switch (b->flags & BIGARRAY_KIND_MASK) { + switch (b->flags & CAML_BA_KIND_MASK) { default: Assert(0); - case BIGARRAY_FLOAT32: + case CAML_BA_FLOAT32: ((float *) b->data)[offset] = Double_val(newval); break; - case BIGARRAY_FLOAT64: + case CAML_BA_FLOAT64: ((double *) b->data)[offset] = Double_val(newval); break; - case BIGARRAY_SINT8: - case BIGARRAY_UINT8: + case CAML_BA_SINT8: + case CAML_BA_UINT8: ((int8 *) b->data)[offset] = Int_val(newval); break; - case BIGARRAY_SINT16: - case BIGARRAY_UINT16: + case CAML_BA_SINT16: + case CAML_BA_UINT16: ((int16 *) b->data)[offset] = Int_val(newval); break; - case BIGARRAY_INT32: + case CAML_BA_INT32: ((int32 *) b->data)[offset] = Int32_val(newval); break; - case BIGARRAY_INT64: + case CAML_BA_INT64: ((int64 *) b->data)[offset] = Int64_val(newval); break; - case BIGARRAY_NATIVE_INT: + case CAML_BA_NATIVE_INT: ((intnat *) b->data)[offset] = Nativeint_val(newval); break; - case BIGARRAY_CAML_INT: + case CAML_BA_CAML_INT: ((intnat *) b->data)[offset] = Long_val(newval); break; - case BIGARRAY_COMPLEX32: + case CAML_BA_COMPLEX32: { float * p = ((float *) b->data) + offset * 2; p[0] = Double_field(newval, 0); p[1] = Double_field(newval, 1); break; } - case BIGARRAY_COMPLEX64: + case CAML_BA_COMPLEX64: { double * p = ((double *) b->data) + offset * 2; p[0] = Double_field(newval, 0); p[1] = Double_field(newval, 1); @@ -457,7 +462,7 @@ CAMLprim value caml_ba_set_generic(value vb, value vind, value newval) CAMLprim value caml_ba_num_dims(value vb) { - struct caml_bigarray * b = Bigarray_val(vb); + struct caml_ba_array * b = Caml_ba_array_val(vb); return Val_long(b->num_dims); } @@ -465,9 +470,9 @@ CAMLprim value caml_ba_num_dims(value vb) CAMLprim value caml_ba_dim(value vb, value vn) { - struct caml_bigarray * b = Bigarray_val(vb); + struct caml_ba_array * b = Caml_ba_array_val(vb); intnat n = Long_val(vn); - if (n >= b->num_dims) invalid_argument("Bigarray.dim"); + if (n >= b->num_dims) caml_invalid_argument("Bigarray.dim"); return Val_long(b->dim[n]); } @@ -475,42 +480,42 @@ CAMLprim value caml_ba_dim(value vb, value vn) CAMLprim value caml_ba_kind(value vb) { - return Val_int(Bigarray_val(vb)->flags & BIGARRAY_KIND_MASK); + return Val_int(Caml_ba_array_val(vb)->flags & CAML_BA_KIND_MASK); } /* Return the layout of a big array */ CAMLprim value caml_ba_layout(value vb) { - return Val_int(Bigarray_val(vb)->flags & BIGARRAY_LAYOUT_MASK); + return Val_int(Caml_ba_array_val(vb)->flags & CAML_BA_LAYOUT_MASK); } /* Finalization of a big array */ static void caml_ba_finalize(value v) { - struct caml_bigarray * b = Bigarray_val(v); + struct caml_ba_array * b = Caml_ba_array_val(v); - switch (b->flags & BIGARRAY_MANAGED_MASK) { - case BIGARRAY_EXTERNAL: + switch (b->flags & CAML_BA_MANAGED_MASK) { + case CAML_BA_EXTERNAL: break; - case BIGARRAY_MANAGED: + case CAML_BA_MANAGED: if (b->proxy == NULL) { free(b->data); } else { if (-- b->proxy->refcount == 0) { free(b->proxy->data); - stat_free(b->proxy); + caml_stat_free(b->proxy); } } break; - case BIGARRAY_MAPPED_FILE: + case CAML_BA_MAPPED_FILE: if (b->proxy == NULL) { caml_ba_unmap_file(b->data, caml_ba_byte_size(b)); } else { if (-- b->proxy->refcount == 0) { caml_ba_unmap_file(b->proxy->data, b->proxy->size); - stat_free(b->proxy); + caml_stat_free(b->proxy); } } break; @@ -521,8 +526,8 @@ static void caml_ba_finalize(value v) static int caml_ba_compare(value v1, value v2) { - struct caml_bigarray * b1 = Bigarray_val(v1); - struct caml_bigarray * b2 = Bigarray_val(v2); + struct caml_ba_array * b1 = Caml_ba_array_val(v1); + struct caml_ba_array * b2 = Caml_ba_array_val(v2); uintnat n, num_elts; int i; @@ -553,7 +558,7 @@ static int caml_ba_compare(value v1, value v2) if (e1 < e2) return -1; \ if (e1 > e2) return 1; \ if (e1 != e2) { \ - compare_unordered = 1; \ + caml_compare_unordered = 1; \ if (e1 == e1) return 1; \ if (e2 == e2) return -1; \ } \ @@ -561,26 +566,26 @@ static int caml_ba_compare(value v1, value v2) return 0; \ } - switch (b1->flags & BIGARRAY_KIND_MASK) { - case BIGARRAY_COMPLEX32: + switch (b1->flags & CAML_BA_KIND_MASK) { + case CAML_BA_COMPLEX32: num_elts *= 2; /*fallthrough*/ - case BIGARRAY_FLOAT32: + case CAML_BA_FLOAT32: DO_FLOAT_COMPARISON(float); - case BIGARRAY_COMPLEX64: + case CAML_BA_COMPLEX64: num_elts *= 2; /*fallthrough*/ - case BIGARRAY_FLOAT64: + case CAML_BA_FLOAT64: DO_FLOAT_COMPARISON(double); - case BIGARRAY_SINT8: + case CAML_BA_SINT8: DO_INTEGER_COMPARISON(int8); - case BIGARRAY_UINT8: + case CAML_BA_UINT8: DO_INTEGER_COMPARISON(uint8); - case BIGARRAY_SINT16: + case CAML_BA_SINT16: DO_INTEGER_COMPARISON(int16); - case BIGARRAY_UINT16: + case CAML_BA_UINT16: DO_INTEGER_COMPARISON(uint16); - case BIGARRAY_INT32: + case CAML_BA_INT32: DO_INTEGER_COMPARISON(int32); - case BIGARRAY_INT64: + case CAML_BA_INT64: #ifdef ARCH_INT64_TYPE DO_INTEGER_COMPARISON(int64); #else @@ -595,8 +600,8 @@ static int caml_ba_compare(value v1, value v2) return 0; } #endif - case BIGARRAY_CAML_INT: - case BIGARRAY_NATIVE_INT: + case CAML_BA_CAML_INT: + case CAML_BA_NATIVE_INT: DO_INTEGER_COMPARISON(intnat); default: Assert(0); @@ -610,7 +615,7 @@ static int caml_ba_compare(value v1, value v2) static intnat caml_ba_hash(value v) { - struct caml_bigarray * b = Bigarray_val(v); + struct caml_ba_array * b = Caml_ba_array_val(v); intnat num_elts, n, h; int i; @@ -621,37 +626,37 @@ static intnat caml_ba_hash(value v) #define COMBINE(h,v) ((h << 4) + h + (v)) - switch (b->flags & BIGARRAY_KIND_MASK) { - case BIGARRAY_SINT8: - case BIGARRAY_UINT8: { + switch (b->flags & CAML_BA_KIND_MASK) { + case CAML_BA_SINT8: + case CAML_BA_UINT8: { uint8 * p = b->data; for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++); break; } - case BIGARRAY_SINT16: - case BIGARRAY_UINT16: { + case CAML_BA_SINT16: + case CAML_BA_UINT16: { uint16 * p = b->data; for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++); break; } - case BIGARRAY_FLOAT32: - case BIGARRAY_COMPLEX32: - case BIGARRAY_INT32: + case CAML_BA_FLOAT32: + case CAML_BA_COMPLEX32: + case CAML_BA_INT32: #ifndef ARCH_SIXTYFOUR - case BIGARRAY_CAML_INT: - case BIGARRAY_NATIVE_INT: + case CAML_BA_CAML_INT: + case CAML_BA_NATIVE_INT: #endif { uint32 * p = b->data; for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++); break; } - case BIGARRAY_FLOAT64: - case BIGARRAY_COMPLEX64: - case BIGARRAY_INT64: + case CAML_BA_FLOAT64: + case CAML_BA_COMPLEX64: + case CAML_BA_INT64: #ifdef ARCH_SIXTYFOUR - case BIGARRAY_CAML_INT: - case BIGARRAY_NATIVE_INT: + case CAML_BA_CAML_INT: + case CAML_BA_NATIVE_INT: #endif #ifdef ARCH_SIXTYFOUR { @@ -688,15 +693,16 @@ static void caml_ba_serialize_longarray(void * data, if (*p < min_val || *p > max_val) { overflow_32 = 1; break; } } if (overflow_32) { - serialize_int_1(1); - serialize_block_8(data, num_elts); + caml_serialize_int_1(1); + caml_serialize_block_8(data, num_elts); } else { - serialize_int_1(0); - for (n = 0, p = data; n < num_elts; n++, p++) serialize_int_4((int32) *p); + caml_serialize_int_1(0); + for (n = 0, p = data; n < num_elts; n++, p++) + caml_serialize_int_4((int32) *p); } #else - serialize_int_1(0); - serialize_block_4(data, num_elts); + caml_serialize_int_1(0); + caml_serialize_block_4(data, num_elts); #endif } @@ -704,121 +710,126 @@ static void caml_ba_serialize(value v, uintnat * wsize_32, uintnat * wsize_64) { - struct caml_bigarray * b = Bigarray_val(v); + struct caml_ba_array * b = Caml_ba_array_val(v); intnat num_elts; int i; /* Serialize header information */ - serialize_int_4(b->num_dims); - serialize_int_4(b->flags & (BIGARRAY_KIND_MASK | BIGARRAY_LAYOUT_MASK)); - for (i = 0; i < b->num_dims; i++) serialize_int_4(b->dim[i]); + caml_serialize_int_4(b->num_dims); + caml_serialize_int_4(b->flags & (CAML_BA_KIND_MASK | CAML_BA_LAYOUT_MASK)); + /* On a 64-bit machine, if any of the dimensions is >= 2^32, + the size of the marshaled data will be >= 2^32 and + extern_value() will fail. So, it is safe to write the dimensions + as 32-bit unsigned integers. */ + for (i = 0; i < b->num_dims; i++) caml_serialize_int_4(b->dim[i]); /* Compute total number of elements */ num_elts = 1; for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i]; /* Serialize elements */ - switch (b->flags & BIGARRAY_KIND_MASK) { - case BIGARRAY_SINT8: - case BIGARRAY_UINT8: - serialize_block_1(b->data, num_elts); break; - case BIGARRAY_SINT16: - case BIGARRAY_UINT16: - serialize_block_2(b->data, num_elts); break; - case BIGARRAY_FLOAT32: - case BIGARRAY_INT32: - serialize_block_4(b->data, num_elts); break; - case BIGARRAY_COMPLEX32: - serialize_block_4(b->data, num_elts * 2); break; - case BIGARRAY_FLOAT64: - case BIGARRAY_INT64: - serialize_block_8(b->data, num_elts); break; - case BIGARRAY_COMPLEX64: - serialize_block_8(b->data, num_elts * 2); break; - case BIGARRAY_CAML_INT: + switch (b->flags & CAML_BA_KIND_MASK) { + case CAML_BA_SINT8: + case CAML_BA_UINT8: + caml_serialize_block_1(b->data, num_elts); break; + case CAML_BA_SINT16: + case CAML_BA_UINT16: + caml_serialize_block_2(b->data, num_elts); break; + case CAML_BA_FLOAT32: + case CAML_BA_INT32: + caml_serialize_block_4(b->data, num_elts); break; + case CAML_BA_COMPLEX32: + caml_serialize_block_4(b->data, num_elts * 2); break; + case CAML_BA_FLOAT64: + case CAML_BA_INT64: + caml_serialize_block_8(b->data, num_elts); break; + case CAML_BA_COMPLEX64: + caml_serialize_block_8(b->data, num_elts * 2); break; + case CAML_BA_CAML_INT: caml_ba_serialize_longarray(b->data, num_elts, -0x40000000, 0x3FFFFFFF); break; - case BIGARRAY_NATIVE_INT: + case CAML_BA_NATIVE_INT: caml_ba_serialize_longarray(b->data, num_elts, -0x80000000, 0x7FFFFFFF); break; } - /* Compute required size in Caml heap. Assumes struct caml_bigarray + /* Compute required size in Caml heap. Assumes struct caml_ba_array is exactly 4 + num_dims words */ - Assert(sizeof(struct caml_bigarray) == 5 * sizeof(value)); + Assert(sizeof(struct caml_ba_array) == 5 * sizeof(value)); *wsize_32 = (4 + b->num_dims) * 4; *wsize_64 = (4 + b->num_dims) * 8; } static void caml_ba_deserialize_longarray(void * dest, intnat num_elts) { - int sixty = deserialize_uint_1(); + int sixty = caml_deserialize_uint_1(); #ifdef ARCH_SIXTYFOUR if (sixty) { - deserialize_block_8(dest, num_elts); + caml_deserialize_block_8(dest, num_elts); } else { intnat * p, n; - for (n = 0, p = dest; n < num_elts; n++, p++) *p = deserialize_sint_4(); + for (n = 0, p = dest; n < num_elts; n++, p++) + *p = caml_deserialize_sint_4(); } #else if (sixty) - deserialize_error("input_value: cannot read bigarray " + caml_deserialize_error("input_value: cannot read bigarray " "with 64-bit Caml ints"); - deserialize_block_4(dest, num_elts); + caml_deserialize_block_4(dest, num_elts); #endif } uintnat caml_ba_deserialize(void * dst) { - struct caml_bigarray * b = dst; + struct caml_ba_array * b = dst; int i, elt_size; uintnat num_elts; /* Read back header information */ - b->num_dims = deserialize_uint_4(); - b->flags = deserialize_uint_4() | BIGARRAY_MANAGED; + b->num_dims = caml_deserialize_uint_4(); + b->flags = caml_deserialize_uint_4() | CAML_BA_MANAGED; b->proxy = NULL; - for (i = 0; i < b->num_dims; i++) b->dim[i] = deserialize_uint_4(); + for (i = 0; i < b->num_dims; i++) b->dim[i] = caml_deserialize_uint_4(); /* Compute total number of elements */ 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 = caml_ba_element_size[b->flags & BIGARRAY_KIND_MASK]; + if ((b->flags & CAML_BA_KIND_MASK) > CAML_BA_COMPLEX64) + caml_deserialize_error("input_value: bad bigarray kind"); + elt_size = caml_ba_element_size[b->flags & CAML_BA_KIND_MASK]; /* Allocate room for data */ b->data = malloc(elt_size * num_elts); if (b->data == NULL) - deserialize_error("input_value: out of memory for bigarray"); + caml_deserialize_error("input_value: out of memory for bigarray"); /* Read data */ - switch (b->flags & BIGARRAY_KIND_MASK) { - case BIGARRAY_SINT8: - case BIGARRAY_UINT8: - deserialize_block_1(b->data, num_elts); break; - case BIGARRAY_SINT16: - case BIGARRAY_UINT16: - deserialize_block_2(b->data, num_elts); break; - case BIGARRAY_FLOAT32: - case BIGARRAY_INT32: - deserialize_block_4(b->data, num_elts); break; - case BIGARRAY_COMPLEX32: - deserialize_block_4(b->data, num_elts * 2); break; - case BIGARRAY_FLOAT64: - case BIGARRAY_INT64: - deserialize_block_8(b->data, num_elts); break; - case BIGARRAY_COMPLEX64: - deserialize_block_8(b->data, num_elts * 2); break; - case BIGARRAY_CAML_INT: - case BIGARRAY_NATIVE_INT: + switch (b->flags & CAML_BA_KIND_MASK) { + case CAML_BA_SINT8: + case CAML_BA_UINT8: + caml_deserialize_block_1(b->data, num_elts); break; + case CAML_BA_SINT16: + case CAML_BA_UINT16: + caml_deserialize_block_2(b->data, num_elts); break; + case CAML_BA_FLOAT32: + case CAML_BA_INT32: + caml_deserialize_block_4(b->data, num_elts); break; + case CAML_BA_COMPLEX32: + caml_deserialize_block_4(b->data, num_elts * 2); break; + case CAML_BA_FLOAT64: + case CAML_BA_INT64: + caml_deserialize_block_8(b->data, num_elts); break; + case CAML_BA_COMPLEX64: + caml_deserialize_block_8(b->data, num_elts * 2); break; + case CAML_BA_CAML_INT: + case CAML_BA_NATIVE_INT: caml_ba_deserialize_longarray(b->data, num_elts); break; } - return sizeof(struct caml_bigarray) + (b->num_dims - 1) * sizeof(intnat); + return sizeof(struct caml_ba_array) + (b->num_dims - 1) * sizeof(intnat); } /* Create / update proxy to indicate that b2 is a sub-array of b1 */ -static void caml_ba_update_proxy(struct caml_bigarray * b1, - struct caml_bigarray * b2) +static void caml_ba_update_proxy(struct caml_ba_array * b1, + struct caml_ba_array * b2) { - struct caml_bigarray_proxy * proxy; + struct caml_ba_proxy * proxy; /* Nothing to do for un-managed arrays */ - if ((b1->flags & BIGARRAY_MANAGED_MASK) == BIGARRAY_EXTERNAL) return; + if ((b1->flags & CAML_BA_MANAGED_MASK) == CAML_BA_EXTERNAL) return; if (b1->proxy != NULL) { /* If b1 is already a proxy for a larger array, increment refcount of proxy */ @@ -826,11 +837,11 @@ static void caml_ba_update_proxy(struct caml_bigarray * b1, ++ b1->proxy->refcount; } else { /* Otherwise, create proxy and attach it to both b1 and b2 */ - proxy = stat_alloc(sizeof(struct caml_bigarray_proxy)); + proxy = caml_stat_alloc(sizeof(struct caml_ba_proxy)); proxy->refcount = 2; /* original array + sub array */ proxy->data = b1->data; proxy->size = - b1->flags & BIGARRAY_MAPPED_FILE ? caml_ba_byte_size(b1) : 0; + b1->flags & CAML_BA_MAPPED_FILE ? caml_ba_byte_size(b1) : 0; b1->proxy = proxy; b2->proxy = proxy; } @@ -841,9 +852,9 @@ static void caml_ba_update_proxy(struct caml_bigarray * b1, CAMLprim value caml_ba_slice(value vb, value vind) { CAMLparam2 (vb, vind); - #define b ((struct caml_bigarray *) Bigarray_val(vb)) + #define b ((struct caml_ba_array *) Caml_ba_array_val(vb)) CAMLlocal1 (res); - intnat index[MAX_NUM_DIMS]; + intnat index[CAML_BA_MAX_NUM_DIMS]; int num_inds, i; intnat offset; intnat * sub_dims; @@ -852,9 +863,9 @@ CAMLprim value caml_ba_slice(value vb, value vind) /* Check number of indices < number of dimensions of array */ num_inds = Wosize_val(vind); if (num_inds >= b->num_dims) - invalid_argument("Bigarray.slice: too many indices"); + caml_invalid_argument("Bigarray.slice: too many indices"); /* Compute offset and check bounds */ - if ((b->flags & BIGARRAY_LAYOUT_MASK) == BIGARRAY_C_LAYOUT) { + if ((b->flags & CAML_BA_LAYOUT_MASK) == CAML_BA_C_LAYOUT) { /* 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; @@ -870,11 +881,11 @@ CAMLprim value caml_ba_slice(value vb, value vind) } sub_data = (char *) b->data + - offset * caml_ba_element_size[b->flags & BIGARRAY_KIND_MASK]; + offset * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK]; /* Allocate a Caml bigarray to hold the result */ - res = alloc_bigarray(b->flags, b->num_dims - num_inds, sub_data, sub_dims); + res = caml_ba_alloc(b->flags, b->num_dims - num_inds, sub_data, sub_dims); /* Create or update proxy in case of managed bigarray */ - caml_ba_update_proxy(b, Bigarray_val(res)); + caml_ba_update_proxy(b, Caml_ba_array_val(res)); /* Return result */ CAMLreturn (res); @@ -887,7 +898,7 @@ CAMLprim value caml_ba_sub(value vb, value vofs, value vlen) { CAMLparam3 (vb, vofs, vlen); CAMLlocal1 (res); - #define b ((struct caml_bigarray *) Bigarray_val(vb)) + #define b ((struct caml_ba_array *) Caml_ba_array_val(vb)) intnat ofs = Long_val(vofs); intnat len = Long_val(vlen); int i, changed_dim; @@ -895,7 +906,7 @@ CAMLprim value caml_ba_sub(value vb, value vofs, value vlen) char * sub_data; /* Compute offset and check bounds */ - if ((b->flags & BIGARRAY_LAYOUT_MASK) == BIGARRAY_C_LAYOUT) { + if ((b->flags & CAML_BA_LAYOUT_MASK) == CAML_BA_C_LAYOUT) { /* We reduce the first dimension */ mul = 1; for (i = 1; i < b->num_dims; i++) mul *= b->dim[i]; @@ -908,16 +919,16 @@ CAMLprim value caml_ba_sub(value vb, value vofs, value vlen) ofs--; /* Fortran arrays start at 1 */ } if (ofs < 0 || len < 0 || ofs + len > b->dim[changed_dim]) - invalid_argument("Bigarray.sub: bad sub-array"); + caml_invalid_argument("Bigarray.sub: bad sub-array"); sub_data = (char *) b->data + - ofs * mul * caml_ba_element_size[b->flags & BIGARRAY_KIND_MASK]; + ofs * mul * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK]; /* Allocate a Caml bigarray to hold the result */ - res = alloc_bigarray(b->flags, b->num_dims, sub_data, b->dim); + res = caml_ba_alloc(b->flags, b->num_dims, sub_data, b->dim); /* Doctor the changed dimension */ - Bigarray_val(res)->dim[changed_dim] = len; + Caml_ba_array_val(res)->dim[changed_dim] = len; /* Create or update proxy in case of managed bigarray */ - caml_ba_update_proxy(b, Bigarray_val(res)); + caml_ba_update_proxy(b, Caml_ba_array_val(res)); /* Return result */ CAMLreturn (res); @@ -928,8 +939,8 @@ CAMLprim value caml_ba_sub(value vb, value vofs, value vlen) CAMLprim value caml_ba_blit(value vsrc, value vdst) { - struct caml_bigarray * src = Bigarray_val(vsrc); - struct caml_bigarray * dst = Bigarray_val(vdst); + struct caml_ba_array * src = Caml_ba_array_val(vsrc); + struct caml_ba_array * dst = Caml_ba_array_val(vdst); int i; intnat num_bytes; @@ -940,12 +951,12 @@ CAMLprim value caml_ba_blit(value vsrc, value vdst) /* Compute number of bytes in array data */ num_bytes = caml_ba_num_elts(src) - * caml_ba_element_size[src->flags & BIGARRAY_KIND_MASK]; + * caml_ba_element_size[src->flags & CAML_BA_KIND_MASK]; /* Do the copying */ memmove (dst->data, src->data, num_bytes); return Val_unit; blit_error: - invalid_argument("Bigarray.blit: dimension mismatch"); + caml_invalid_argument("Bigarray.blit: dimension mismatch"); return Val_unit; /* not reached */ } @@ -953,70 +964,70 @@ CAMLprim value caml_ba_blit(value vsrc, value vdst) CAMLprim value caml_ba_fill(value vb, value vinit) { - struct caml_bigarray * b = Bigarray_val(vb); + struct caml_ba_array * b = Caml_ba_array_val(vb); intnat num_elts = caml_ba_num_elts(b); - switch (b->flags & BIGARRAY_KIND_MASK) { + switch (b->flags & CAML_BA_KIND_MASK) { default: Assert(0); - case BIGARRAY_FLOAT32: { + case CAML_BA_FLOAT32: { float init = Double_val(vinit); float * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } - case BIGARRAY_FLOAT64: { + case CAML_BA_FLOAT64: { double init = Double_val(vinit); double * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } - case BIGARRAY_SINT8: - case BIGARRAY_UINT8: { + case CAML_BA_SINT8: + case CAML_BA_UINT8: { int init = Int_val(vinit); char * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } - case BIGARRAY_SINT16: - case BIGARRAY_UINT16: { + case CAML_BA_SINT16: + case CAML_BA_UINT16: { int init = Int_val(vinit); int16 * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } - case BIGARRAY_INT32: { + case CAML_BA_INT32: { int32 init = Int32_val(vinit); int32 * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } - case BIGARRAY_INT64: { + case CAML_BA_INT64: { int64 init = Int64_val(vinit); int64 * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } - case BIGARRAY_NATIVE_INT: { + case CAML_BA_NATIVE_INT: { intnat init = Nativeint_val(vinit); intnat * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } - case BIGARRAY_CAML_INT: { + case CAML_BA_CAML_INT: { intnat init = Long_val(vinit); intnat * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } - case BIGARRAY_COMPLEX32: { + case CAML_BA_COMPLEX32: { float init0 = Double_field(vinit, 0); float init1 = Double_field(vinit, 1); float * p; for (p = b->data; num_elts > 0; num_elts--) { *p++ = init0; *p++ = init1; } break; } - case BIGARRAY_COMPLEX64: { + case CAML_BA_COMPLEX64: { double init0 = Double_field(vinit, 0); double init1 = Double_field(vinit, 1); double * p; @@ -1034,39 +1045,39 @@ CAMLprim value caml_ba_reshape(value vb, value vdim) { CAMLparam2 (vb, vdim); CAMLlocal1 (res); - #define b ((struct caml_bigarray *) Bigarray_val(vb)) - intnat dim[MAX_NUM_DIMS]; +#define b ((struct caml_ba_array *) Caml_ba_array_val(vb)) + intnat dim[CAML_BA_MAX_NUM_DIMS]; mlsize_t num_dims; uintnat num_elts; int i; num_dims = Wosize_val(vdim); - if (num_dims < 1 || num_dims > MAX_NUM_DIMS) - invalid_argument("Bigarray.reshape: bad number of dimensions"); + if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS) + caml_invalid_argument("Bigarray.reshape: bad number of dimensions"); num_elts = 1; for (i = 0; i < num_dims; i++) { dim[i] = Long_val(Field(vdim, i)); if (dim[i] < 0 || dim[i] > 0x7FFFFFFFL) - invalid_argument("Bigarray.reshape: negative dimension"); + caml_invalid_argument("Bigarray.reshape: negative dimension"); num_elts *= dim[i]; } /* Check that sizes agree */ if (num_elts != caml_ba_num_elts(b)) - invalid_argument("Bigarray.reshape: size mismatch"); + caml_invalid_argument("Bigarray.reshape: size mismatch"); /* Create bigarray with same data and new dimensions */ - res = alloc_bigarray(b->flags, num_dims, b->data, dim); + res = caml_ba_alloc(b->flags, num_dims, b->data, dim); /* Create or update proxy in case of managed bigarray */ - caml_ba_update_proxy(b, Bigarray_val(res)); + caml_ba_update_proxy(b, Caml_ba_array_val(res)); /* Return result */ CAMLreturn (res); - #undef b +#undef b } /* Initialization */ CAMLprim value caml_ba_init(value unit) { - register_custom_operations(&caml_ba_ops); + caml_register_custom_operations(&caml_ba_ops); return Val_unit; } diff --git a/otherlibs/bigarray/mmap_unix.c b/otherlibs/bigarray/mmap_unix.c index 599792d4..06631051 100644 --- a/otherlibs/bigarray/mmap_unix.c +++ b/otherlibs/bigarray/mmap_unix.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: mmap_unix.c,v 1.10 2006/06/10 14:15:42 xleroy Exp $ */ +/* $Id: mmap_unix.c,v 1.11 2008/01/04 15:01:48 xleroy Exp $ */ #include #include @@ -43,7 +43,7 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, { int fd, flags, major_dim, shared; intnat num_dims, i; - intnat dim[MAX_NUM_DIMS]; + intnat dim[CAML_BA_MAX_NUM_DIMS]; file_offset currpos, startpos, file_size, data_size; uintnat array_size, page, delta; char c; @@ -53,44 +53,44 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, 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; + major_dim = flags & CAML_BA_FORTRAN_LAYOUT ? num_dims - 1 : 0; /* Extract dimensions from Caml array */ num_dims = Wosize_val(vdim); - if (num_dims < 1 || num_dims > MAX_NUM_DIMS) - invalid_argument("Bigarray.mmap: bad number of dimensions"); + if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS) + caml_invalid_argument("Bigarray.mmap: bad number of dimensions"); for (i = 0; i < num_dims; i++) { dim[i] = Long_val(Field(vdim, i)); if (dim[i] == -1 && i == major_dim) continue; - if (dim[i] < 0 || dim[i] > 0x7FFFFFFFL) - invalid_argument("Bigarray.create: negative dimension"); + if (dim[i] < 0) + caml_invalid_argument("Bigarray.create: negative dimension"); } /* Determine file size */ currpos = lseek(fd, 0, SEEK_CUR); - if (currpos == -1) sys_error(NO_ARG); + if (currpos == -1) caml_sys_error(NO_ARG); file_size = lseek(fd, 0, SEEK_END); - if (file_size == -1) sys_error(NO_ARG); + if (file_size == -1) caml_sys_error(NO_ARG); /* 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]; + array_size = caml_ba_element_size[flags & CAML_BA_KIND_MASK]; for (i = 0; i < num_dims; i++) if (dim[i] != -1) array_size *= dim[i]; /* Check if the major dimension is unknown */ if (dim[major_dim] == -1) { /* Determine major dimension from file size */ if (file_size < startpos) - failwith("Bigarray.mmap: file position exceeds file size"); + caml_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"); + caml_failwith("Bigarray.mmap: file size doesn't match array dimensions"); } else { /* Check that file is large enough, and grow it otherwise */ if (file_size < startpos + array_size) { if (lseek(fd, startpos + array_size - 1, SEEK_SET) == -1) - sys_error(NO_ARG); + caml_sys_error(NO_ARG); c = 0; - if (write(fd, &c, 1) != 1) sys_error(NO_ARG); + if (write(fd, &c, 1) != 1) caml_sys_error(NO_ARG); } } /* Restore original file position */ @@ -102,10 +102,10 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, shared = Bool_val(vshared) ? MAP_SHARED : MAP_PRIVATE; addr = mmap(NULL, array_size + delta, PROT_READ | PROT_WRITE, shared, fd, startpos - delta); - if (addr == (void *) MAP_FAILED) sys_error(NO_ARG); + if (addr == (void *) MAP_FAILED) caml_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); + return caml_ba_alloc(flags | CAML_BA_MAPPED_FILE, num_dims, addr, dim); } #else diff --git a/otherlibs/bigarray/mmap_win32.c b/otherlibs/bigarray/mmap_win32.c index dde90068..6256fb60 100644 --- a/otherlibs/bigarray/mmap_win32.c +++ b/otherlibs/bigarray/mmap_win32.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: mmap_win32.c,v 1.10 2006/10/01 15:40:28 xleroy Exp $ */ +/* $Id: mmap_win32.c,v 1.12 2008/01/15 14:55:15 frisch Exp $ */ #include #include @@ -49,7 +49,7 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, HANDLE fd, fmap; int flags, major_dim, mode, perm; intnat num_dims, i; - intnat dim[MAX_NUM_DIMS]; + intnat dim[CAML_BA_MAX_NUM_DIMS]; __int64 currpos, startpos, file_size, data_size; uintnat array_size, page, delta; char c; @@ -61,16 +61,16 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, 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; + major_dim = flags & CAML_BA_FORTRAN_LAYOUT ? num_dims - 1 : 0; /* Extract dimensions from Caml array */ num_dims = Wosize_val(vdim); - if (num_dims < 1 || num_dims > MAX_NUM_DIMS) - invalid_argument("Bigarray.mmap: bad number of dimensions"); + if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS) + caml_invalid_argument("Bigarray.mmap: bad number of dimensions"); for (i = 0; i < num_dims; i++) { dim[i] = Long_val(Field(vdim, i)); if (dim[i] == -1 && i == major_dim) continue; - if (dim[i] < 0 || dim[i] > 0x7FFFFFFFL) - invalid_argument("Bigarray.create: negative dimension"); + if (dim[i] < 0) + caml_invalid_argument("Bigarray.create: negative dimension"); } /* Determine file size */ currpos = caml_ba_set_file_pointer(fd, 0, FILE_CURRENT); @@ -79,19 +79,19 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, 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]; + array_size = caml_ba_element_size[flags & CAML_BA_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 */ if (dim[major_dim] == -1) { /* Determine first/last dimension from file size */ if (file_size < startpos) - failwith("Bigarray.mmap: file position exceeds file size"); + caml_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"); + caml_failwith("Bigarray.mmap: file size doesn't match array dimensions"); } /* Restore original file position */ caml_ba_set_file_pointer(fd, currpos, FILE_BEGIN); @@ -118,7 +118,7 @@ CAMLprim value caml_ba_map_file(value vfd, value vkind, value vlayout, /* Close the file mapping */ CloseHandle(fmap); /* Build and return the Caml bigarray */ - return alloc_bigarray(flags | BIGARRAY_MAPPED_FILE, num_dims, addr, dim); + return caml_ba_alloc(flags | CAML_BA_MAPPED_FILE, num_dims, addr, dim); } CAMLprim value caml_ba_map_file_bytecode(value * argv, int argn) @@ -151,5 +151,5 @@ static void caml_ba_sys_error(void) sizeof(buffer), NULL)) sprintf(buffer, "Unknown error %ld\n", errnum); - raise_sys_error(copy_string(buffer)); + caml_raise_sys_error(caml_copy_string(buffer)); } diff --git a/otherlibs/dbm/.depend b/otherlibs/dbm/.depend index 6fa318ee..2092fbac 100644 --- a/otherlibs/dbm/.depend +++ b/otherlibs/dbm/.depend @@ -1,2 +1,3 @@ +dbm.cmi: dbm.cmo: dbm.cmi dbm.cmx: dbm.cmi diff --git a/otherlibs/dbm/Makefile b/otherlibs/dbm/Makefile index 6ca2a2ee..68fd200a 100644 --- a/otherlibs/dbm/Makefile +++ b/otherlibs/dbm/Makefile @@ -11,61 +11,19 @@ # # ######################################################################### -# $Id: Makefile,v 1.25 2004/11/29 14:53:32 doligez Exp $ +# $Id: Makefile,v 1.26 2007/11/06 15:16:56 frisch Exp $ # Makefile for the ndbm library -include ../../config/Makefile - -# Compilation optiosn -CC=$(BYTECC) -g -CAMLC=../../ocamlcomp.sh -CAMLOPT=../../ocamlcompopt.sh -MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-warn-error A - -CFLAGS=$(DBM_INCLUDES) -I../../byterun -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) +LIBNAME=dbm +CLIBNAME=mldbm +CAMLOBJS=dbm.cmo COBJS=cldbm.o +EXTRACFLAGS=$(DBM_INCLUDES) +LINKOPTS=$(DBM_LINK) -all: libmldbm.a dbm.cmi dbm.cma - -allopt: libmldbm.a dbm.cmi dbm.cmxa - -libmldbm.a: $(COBJS) - $(MKLIB) -oc mldbm $(COBJS) $(DBM_LINK) - -dbm.cma: dbm.cmo - $(MKLIB) -ocamlc '$(CAMLC)' -o dbm -oc mldbm dbm.cmo $(DBM_LINK) - -dbm.cmxa: dbm.cmx - $(MKLIB) -ocamlopt '$(CAMLOPT)' -o dbm -oc mldbm dbm.cmx $(DBM_LINK) - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.a *.o *.so - -install: - if test -f dllmldbm.so; then cp dllmldbm.so $(STUBLIBDIR)/dllmldbm.so; fi - cp libmldbm.a $(LIBDIR)/libmldbm.a - cd $(LIBDIR); $(RANLIB) libmldbm.a - cp dbm.cma dbm.cmi dbm.mli $(LIBDIR) - -installopt: - cp dbm.cmx dbm.cmxa dbm.a $(LIBDIR) - cd $(LIBDIR); $(RANLIB) dbm.a - -.SUFFIXES: .ml .mli .cmo .cmi .cmx - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< +include ../Makefile -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< depend: ../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml > .depend diff --git a/otherlibs/dynlink/.depend b/otherlibs/dynlink/.depend deleted file mode 100644 index 1aa2131f..00000000 --- a/otherlibs/dynlink/.depend +++ /dev/null @@ -1,8 +0,0 @@ -dynlink.cmo: ../../bytecomp/symtable.cmi ../../bytecomp/opcodes.cmo \ - ../../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/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 f3562a4b..bcfe3319 100644 --- a/otherlibs/dynlink/Makefile +++ b/otherlibs/dynlink/Makefile @@ -11,13 +11,14 @@ # # ######################################################################### -# $Id: Makefile,v 1.31 2006/09/19 12:41:33 xleroy Exp $ +# $Id: Makefile,v 1.34 2008/04/16 06:50:31 frisch Exp $ # Makefile for the dynamic link library include ../../config/Makefile CAMLC=../../boot/ocamlrun ../../ocamlc +CAMLOPT=../../ocamlcompopt.sh INCLUDES=-I ../../utils -I ../../typing -I ../../bytecomp COMPFLAGS=-warn-error A -I ../../stdlib $(INCLUDES) @@ -39,30 +40,46 @@ COMPILEROBJS=\ ../../bytecomp/dll.cmo ../../bytecomp/meta.cmo \ ../../bytecomp/symtable.cmo +NATOBJS=dynlink.cmx + all: dynlink.cma extract_crc -allopt: +allopt: dynlink.cmxa dynlink.cma: $(OBJS) - $(CAMLC) $(COMPFLAGS) -a -o dynlink.cma $(OBJS) + $(CAMLC) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cma $(OBJS) + +dynlink.cmxa: $(NATOBJS) + $(CAMLOPT) $(COMPFLAGS) -ccopt "$(NATDYNLINKOPTS)" -a -o dynlink.cmxa $(NATOBJS) -dynlinkaux.cmo dynlinkaux.cmi: $(COMPILEROBJS) +dynlinkaux.cmo: $(COMPILEROBJS) $(CAMLC) $(COMPFLAGS) -pack -o dynlinkaux.cmo $(COMPILEROBJS) +dynlinkaux.cmi: dynlinkaux.cmo + +dynlink.cmx: dynlink.cmi natdynlink.ml + cp natdynlink.ml dynlink.mlopt + $(CAMLOPT) -c $(COMPFLAGS) -impl dynlink.mlopt + rm -f dynlink.mlopt + extract_crc: dynlink.cma extract_crc.cmo $(CAMLC) $(COMPFLAGS) -o extract_crc dynlink.cma extract_crc.cmo install: - cp dynlink.cmi dynlink.cma dynlink.mli extract_crc $(LIBDIR) + cp dynlink.cmi dynlink.cma dynlink.mli $(LIBDIR) + cp extract_crc $(LIBDIR)/extract_crc$(EXE) installopt: + cp $(NATOBJS) dynlink.cmxa dynlink.$(A) $(LIBDIR) + cd $(LIBDIR); $(RANLIB) dynlink.$(A) partialclean: - rm -f extract_crc *.cm[ioa] + rm -f extract_crc *.cm[ioax] *.cmxa clean: partialclean + rm -f *.$(A) *.$(O) *.so *.dll dynlink.mlopt -.SUFFIXES: .ml .mli .cmo .cmi +.SUFFIXES: .ml .mli .cmo .cmi .cmx .mli.cmi: $(CAMLC) -c $(COMPFLAGS) $< @@ -70,6 +87,9 @@ clean: partialclean .ml.cmo: $(CAMLC) -c $(COMPFLAGS) $< +.ml.cmx: + $(CAMLOPT) -c $(COMPFLAGS) $< + depend: dynlink.cmo: dynlinkaux.cmi dynlink.cmi diff --git a/otherlibs/dynlink/Makefile.nt b/otherlibs/dynlink/Makefile.nt index 12bc42e6..eca546e6 100644 --- a/otherlibs/dynlink/Makefile.nt +++ b/otherlibs/dynlink/Makefile.nt @@ -11,67 +11,8 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.16 2006/09/19 12:41:42 xleroy Exp $ +# $Id: Makefile.nt,v 1.17 2007/11/06 15:16:56 frisch Exp $ # Makefile for the dynamic link library -include ../../config/Makefile - -CAMLC=../../boot/ocamlrun ../../ocamlc -INCLUDES=-I ../../utils -I ../../typing -I ../../bytecomp -COMPFLAGS=-warn-error A -I ../../stdlib $(INCLUDES) - -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 $(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 - -install: - cp dynlink.cmi dynlink.cma dynlink.mli $(LIBDIR) - cp extract_crc $(LIBDIR)/extract_crc.exe - -installopt: - -partialclean: - rm -f extract_crc *.cm[ioa] - -clean: partialclean - -.SUFFIXES: .ml .mli .cmo .cmi - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -depend: - -dynlink.cmo: dynlinkaux.cmi dynlink.cmi -extract_crc.cmo: dynlink.cmi +include Makefile diff --git a/otherlibs/dynlink/dynlink.ml b/otherlibs/dynlink/dynlink.ml index 24e0e0ad..cbea1175 100644 --- a/otherlibs/dynlink/dynlink.ml +++ b/otherlibs/dynlink/dynlink.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: dynlink.ml,v 1.34 2006/09/28 21:36:38 xleroy Exp $ *) +(* $Id: dynlink.ml,v 1.36 2008/04/22 12:24:10 frisch Exp $ *) (* Dynamic loading of .cmo files *) @@ -32,6 +32,7 @@ type error = | Corrupted_interface of string | File_not_found of string | Cannot_open_dll of string + | Inconsistent_implementation of string exception Error of error @@ -94,9 +95,20 @@ let default_available_units () = (* Initialize the linker tables and everything *) +let inited = ref false + let init () = - default_crcs := Symtable.init_toplevel(); - default_available_units () + if not !inited then begin + default_crcs := Symtable.init_toplevel(); + default_available_units (); + inited := true; + end + +let clear_available_units () = init(); clear_available_units () +let allow_only l = init(); allow_only l +let prohibit l = init(); prohibit l +let add_available_units l = init(); add_available_units l +let default_available_units () = init(); default_available_units () (* Read the CRC of an interface from its .cmi file *) @@ -184,6 +196,7 @@ let load_compunit ic file_name compunit = end let loadfile file_name = + init(); let ic = open_in_bin file_name in try let buffer = String.create (String.length Config.cmo_magic_number) in @@ -211,6 +224,7 @@ let loadfile file_name = close_in ic; raise exc let loadfile_private file_name = + init(); let initial_symtable = Symtable.current_state() and initial_crc = !crc_interfaces in try @@ -248,3 +262,8 @@ let error_message = function "cannot find file " ^ name ^ " in search path" | Cannot_open_dll reason -> "error loading shared library: " ^ reason + | Inconsistent_implementation name -> + "implementation mismatch on " ^ name + +let is_native = false +let adapt_filename f = f diff --git a/otherlibs/dynlink/dynlink.mli b/otherlibs/dynlink/dynlink.mli index 1bcf7cb1..25d6414a 100644 --- a/otherlibs/dynlink/dynlink.mli +++ b/otherlibs/dynlink/dynlink.mli @@ -11,21 +11,22 @@ (* *) (***********************************************************************) -(* $Id: dynlink.mli,v 1.21 2002/11/17 16:42:11 xleroy Exp $ *) +(* $Id: dynlink.mli,v 1.23 2008/04/22 12:24:10 frisch Exp $ *) -(** Dynamic loading of bytecode object files. *) +(** Dynamic loading of object files. *) -(** {6 Initialization} *) +val is_native: bool +(** [true] if the program is native, + [false] if the program is bytecode. *) -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} *) +(** {6 Dynamic loading of compiled 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. +(** In bytecode: load the given bytecode object file ([.cmo] file) or + bytecode library file ([.cma] file), and link it with the running + program. In native code: load the given OCaml plugin file (usually + [.cmxs]), 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 @@ -37,6 +38,10 @@ val loadfile_private : string -> unit are hidden (cannot be referenced) from other modules dynamically loaded afterwards. *) +val adapt_filename : string -> string +(** In bytecode, the identity function. In native code, replace the last + extension with [.cmxs]. *) + (** {6 Access control} *) val allow_only: string list -> unit @@ -68,7 +73,8 @@ val allow_unsafe_modules : bool -> unit 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. *) + not allowed. In native code, this function does nothing; object files + with external functions are always allowed to be dynamically linked. *) (** {6 Deprecated, low-level API for access control} *) @@ -77,7 +83,8 @@ val allow_unsafe_modules : bool -> unit 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. *) + below are provided for backward compatibility only and are not + available in native code. *) val add_interfaces : string list -> string list -> unit (** [add_interfaces units path] grants dynamically-linked object @@ -97,6 +104,12 @@ val clear_available_units : unit -> unit (** Empty the list of compilation units accessible to dynamically-linked programs. *) +(** {6 Deprecated, initialization} *) + +val init : unit -> unit +(** @deprecated Initialize the [Dynlink] library. This function is called + automatically when needed. *) + (** {6 Error reporting} *) type linking_error = @@ -113,6 +126,7 @@ type error = | Corrupted_interface of string | File_not_found of string | Cannot_open_dll of string + | Inconsistent_implementation of string exception Error of error (** Errors in dynamic linking are reported by raising the [Error] diff --git a/otherlibs/dynlink/natdynlink.ml b/otherlibs/dynlink/natdynlink.ml new file mode 100644 index 00000000..9015c739 --- /dev/null +++ b/otherlibs/dynlink/natdynlink.ml @@ -0,0 +1,259 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Gallium, 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: natdynlink.ml,v 1.6 2008/08/28 22:17:51 frisch Exp $ *) + +(* Dynamic loading of .cmx files *) + +type handle + +external ndl_open: string -> bool -> handle * string = "caml_natdynlink_open" +external ndl_run: handle -> string -> unit = "caml_natdynlink_run" +external ndl_getmap: unit -> string = "caml_natdynlink_getmap" +external ndl_globals_inited: unit -> int = "caml_natdynlink_globals_inited" + +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 + | Inconsistent_implementation of string + +exception Error of error + +(* Copied from other places to avoid dependencies *) + +type dynunit = { + name: string; + crc: Digest.t; + imports_cmi: (string * Digest.t) list; + imports_cmx: (string * Digest.t) list; + defines: string list; +} + +type dynheader = { + magic: string; + units: dynunit list; +} + +let dyn_magic_number = "Caml2007D001" + +let dll_filename fname = + if Filename.is_implicit fname then Filename.concat (Sys.getcwd ()) fname + else fname + +let read_file filename priv = + let dll = dll_filename filename in + if not (Sys.file_exists dll) then raise (Error (File_not_found dll)); + + let (handle,data) as res = ndl_open dll (not priv) in + if Obj.tag (Obj.repr res) = Obj.string_tag + then raise (Error (Cannot_open_dll (Obj.magic res))); + + let header : dynheader = Marshal.from_string data 0 in + if header.magic <> dyn_magic_number + then raise(Error(Not_a_bytecode_file dll)); + (dll, handle, header.units) + +let cmx_not_found_crc = + "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000" + + +(* Management of interface and implementation CRCs *) + +module StrMap = Map.Make(String) + +type implem_state = + | Loaded + | Check_inited of int + +type state = { + ifaces: (string*string) StrMap.t; + implems: (string*string*implem_state) StrMap.t; +} + +let empty_state = { + ifaces = StrMap.empty; + implems = StrMap.empty; +} + +let global_state = ref empty_state + +let allow_extension = ref true + +let inited = ref false + +let default_available_units () = + let map : (string*Digest.t*Digest.t*string list) list = + Marshal.from_string (ndl_getmap ()) 0 in + let exe = Sys.executable_name in + let rank = ref 0 in + global_state := + List.fold_left + (fun st (name,crc_intf,crc_impl,syms) -> + rank := !rank + List.length syms; + { + ifaces = StrMap.add name (crc_intf,exe) st.ifaces; + implems = StrMap.add name (crc_impl,exe,Check_inited !rank) st.implems; + } + ) + empty_state + map; + allow_extension := true; + inited := true + +let init () = + if not !inited then default_available_units () + +let add_check_ifaces allow_ext filename ui ifaces = + List.fold_left + (fun ifaces (name, crc) -> + if name = ui.name + then StrMap.add name (crc,filename) ifaces + else + try + let (old_crc,old_src) = StrMap.find name ifaces in + if old_crc <> crc + then raise(Error(Inconsistent_import(name))) + else ifaces + with Not_found -> + if allow_ext then StrMap.add name (crc,filename) ifaces + else raise (Error(Unavailable_unit name)) + ) ifaces ui.imports_cmi + +let check_implems filename ui implems = + List.iter + (fun (name, crc) -> + match name with + |"Out_of_memory" + |"Sys_error" + |"Failure" + |"Invalid_argument" + |"End_of_file" + |"Division_by_zero" + |"Not_found" + |"Match_failure" + |"Stack_overflow" + |"Sys_blocked_io" + |"Assert_failure" + |"Undefined_recursive_module" -> () + | _ -> + try + let (old_crc,old_src,state) = StrMap.find name implems in + if crc <> cmx_not_found_crc && old_crc <> crc + then raise(Error(Inconsistent_implementation(name))) + else match state with + | Check_inited i -> + if ndl_globals_inited() < i + then raise(Error(Unavailable_unit name)) + | Loaded -> () + with Not_found -> + raise (Error(Unavailable_unit name)) + ) ui.imports_cmx + +let loadunits filename handle units state = + let new_ifaces = + List.fold_left + (fun accu ui -> add_check_ifaces !allow_extension filename ui accu) + state.ifaces units in + let new_implems = + List.fold_left + (fun accu ui -> + check_implems filename ui accu; + StrMap.add ui.name (ui.crc,filename,Loaded) accu) + state.implems units in + + let defines = List.flatten (List.map (fun ui -> ui.defines) units) in + + ndl_run handle "_shared_startup"; + List.iter (ndl_run handle) defines; + { implems = new_implems; ifaces = new_ifaces } + +let load priv filename = + init(); + let (filename,handle,units) = read_file filename priv in + let nstate = loadunits filename handle units !global_state in + if not priv then global_state := nstate + +let loadfile filename = load false filename +let loadfile_private filename = load true filename + +let allow_only names = + init(); + let old = !global_state.ifaces in + let ifaces = + List.fold_left + (fun ifaces name -> + try StrMap.add name (StrMap.find name old) ifaces + with Not_found -> ifaces) + StrMap.empty names in + global_state := { !global_state with ifaces = ifaces }; + allow_extension := false + +let prohibit names = + init(); + let ifaces = List.fold_right StrMap.remove names !global_state.ifaces in + global_state := { !global_state with ifaces = ifaces }; + allow_extension := false + +let digest_interface _ _ = + failwith "Dynlink.digest_interface: not implemented in native code" +let add_interfaces _ _ = + failwith "Dynlink.add_interfaces: not implemented in native code" +let add_available_units _ = + failwith "Dynlink.add_available_units: not implemented in native code" +let clear_available_units _ = + failwith "Dynlink.clear_available_units: not implemented in native code" +let allow_unsafe_modules _ = + () + +(* Error report *) + +let error_message = function + Not_a_bytecode_file name -> + name ^ " is not an 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 + | Inconsistent_implementation name -> + "implementation mismatch on " ^ name + +let is_native = true +let adapt_filename f = Filename.chop_extension f ^ ".cmxs" diff --git a/otherlibs/graph/.depend b/otherlibs/graph/.depend index 32bfc323..d8905153 100644 --- a/otherlibs/graph/.depend +++ b/otherlibs/graph/.depend @@ -144,6 +144,8 @@ text.o: text.c libgraph.h \ ../../byterun/config.h ../../byterun/alloc.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ ../../byterun/mlvalues.h +graphics.cmi: +graphicsX11.cmi: 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 8fe421a9..9a6c7ee1 100644 --- a/otherlibs/graph/Makefile +++ b/otherlibs/graph/Makefile @@ -11,62 +11,21 @@ # # ######################################################################### -# $Id: Makefile,v 1.40 2007/01/29 12:11:16 xleroy Exp $ +# $Id: Makefile,v 1.42 2007/11/08 09:23:06 frisch Exp $ # Makefile for the portable graphics library -include ../../config/Makefile - -CC=$(BYTECC) -CFLAGS=-I../../byterun $(X11_INCLUDES) -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -CAMLC=../../ocamlcomp.sh -CAMLOPT=../../ocamlcompopt.sh -MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-warn-error A -g - -OBJS=open.o draw.o fill.o color.o text.o \ +LIBNAME=graphics +COBJS=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 - CAMLOBJS=graphics.cmo graphicsX11.cmo +LINKOPTS=-cclib "\"$(X11_LINK)\"" +LDOPTS=-ldopt "$(X11_LINK)" -all: libgraphics.a graphics.cmi graphics.cma - -allopt: libgraphics.a graphics.cmi graphics.cmxa - -libgraphics.a: $(OBJS) - $(MKLIB) -o graphics $(OBJS) $(X11_LINK) - -graphics.cma: $(CAMLOBJS) - $(MKLIB) -ocamlc '$(CAMLC)' -o graphics $(CAMLOBJS) $(X11_LINK) - -graphics.cmxa: $(CAMLOBJS:.cmo=.cmx) - $(MKLIB) -ocamlopt '$(CAMLOPT)' -o graphics $(CAMLOBJS:.cmo=.cmx) $(X11_LINK) - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.a *.so *.o - -install: - if test -f dllgraphics.so; then cp dllgraphics.so $(STUBLIBDIR)/dllgraphics.so; fi - cp libgraphics.a $(LIBDIR)/libgraphics.a - cd $(LIBDIR); $(RANLIB) libgraphics.a - cp graphics.cm[ia] graphicsX11.cmi graphics.mli graphicsX11.mli $(LIBDIR) - -installopt: - cp graphics.cmx graphics.cmxa graphics.a $(LIBDIR) - cd $(LIBDIR); $(RANLIB) graphics.a - -.SUFFIXES: .ml .mli .cmo .cmi .cmx +EXTRACFLAGS=$(X11_INCLUDES) -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< +include ../Makefile depend: gcc -MM $(CFLAGS) *.c | sed -e 's, /usr[^ ]*\.h,,g' > .depend diff --git a/otherlibs/labltk/Makefile b/otherlibs/labltk/Makefile index 83ecabe7..358de5b3 100644 --- a/otherlibs/labltk/Makefile +++ b/otherlibs/labltk/Makefile @@ -32,7 +32,9 @@ allopt: byte: all opt: allopt -.PHONY: labltk camltk examples_labltk examples_camltk +.PHONY: all allopt byte opt +.PHONY: labltk camltk examples examples_labltk examples_camltk +.PHONY: install installopt partialclean clean depend labltk: Widgets.src compiler/tkcompiler -outdir labltk diff --git a/otherlibs/labltk/Makefile.nt b/otherlibs/labltk/Makefile.nt index bcbfc3d3..45d53919 100644 --- a/otherlibs/labltk/Makefile.nt +++ b/otherlibs/labltk/Makefile.nt @@ -2,6 +2,8 @@ include ../../config/Makefile + + SUBDIRS=compiler support lib labltk camltk jpf frx tkanim examples_labltk examples_camltk browser all: @@ -28,13 +30,15 @@ allopt: cd frx ; $(MAKEREC) opt cd tkanim ; $(MAKEREC) opt -example: examples_labltk/all examples_camltk/all +.PHONY: examples_labltk examples_camltk + +examples: examples_labltk examples_camltk -examples_labltk/all: - cd examples_labltk ; $(MAKEREC) all +examples_labltk: + cd examples_labltk; $(MAKE) all -examples_camltk/all: - cd examples_camltk ; $(MAKEREC) all +examples_camltk: + cd examples_camltk; $(MAKE) all install: cd labltk ; $(MAKEREC) install diff --git a/otherlibs/labltk/browser/.depend b/otherlibs/labltk/browser/.depend index 558ccdd2..49120116 100644 --- a/otherlibs/labltk/browser/.depend +++ b/otherlibs/labltk/browser/.depend @@ -1,19 +1,19 @@ -editor.cmo: fileselect.cmi jg_bind.cmi jg_button.cmo jg_menu.cmo \ - jg_message.cmi jg_text.cmi jg_tk.cmo jg_toplevel.cmo lexical.cmi \ - mytypes.cmi searchid.cmi searchpos.cmi setpath.cmi shell.cmi \ - typecheck.cmi viewer.cmi editor.cmi -editor.cmx: fileselect.cmx jg_bind.cmx jg_button.cmx jg_menu.cmx \ - jg_message.cmx jg_text.cmx jg_tk.cmx jg_toplevel.cmx lexical.cmx \ - mytypes.cmi searchid.cmx searchpos.cmx setpath.cmx shell.cmx \ - typecheck.cmx viewer.cmx editor.cmi -fileselect.cmo: jg_box.cmo jg_entry.cmo jg_memo.cmi jg_toplevel.cmo list2.cmo \ - setpath.cmi useunix.cmi fileselect.cmi -fileselect.cmx: jg_box.cmx jg_entry.cmx jg_memo.cmx jg_toplevel.cmx list2.cmx \ - setpath.cmx useunix.cmx fileselect.cmi +editor.cmo: viewer.cmi typecheck.cmi shell.cmi setpath.cmi searchpos.cmi \ + searchid.cmi mytypes.cmi lexical.cmi jg_toplevel.cmo jg_tk.cmo \ + jg_text.cmi jg_message.cmi jg_menu.cmo jg_button.cmo jg_bind.cmi \ + fileselect.cmi editor.cmi +editor.cmx: viewer.cmx typecheck.cmx shell.cmx setpath.cmx searchpos.cmx \ + searchid.cmx mytypes.cmi lexical.cmx jg_toplevel.cmx jg_tk.cmx \ + jg_text.cmx jg_message.cmx jg_menu.cmx jg_button.cmx jg_bind.cmx \ + fileselect.cmx editor.cmi +fileselect.cmo: useunix.cmi setpath.cmi list2.cmo jg_toplevel.cmo jg_memo.cmi \ + jg_entry.cmo jg_box.cmo fileselect.cmi +fileselect.cmx: useunix.cmx setpath.cmx list2.cmx jg_toplevel.cmx jg_memo.cmx \ + jg_entry.cmx jg_box.cmx fileselect.cmi jg_bind.cmo: jg_bind.cmi jg_bind.cmx: jg_bind.cmi -jg_box.cmo: jg_bind.cmi jg_completion.cmi -jg_box.cmx: jg_bind.cmx jg_completion.cmx +jg_box.cmo: jg_completion.cmi jg_bind.cmi +jg_box.cmx: jg_completion.cmx jg_bind.cmx jg_completion.cmo: jg_completion.cmi jg_completion.cmx: jg_completion.cmi jg_config.cmo: jg_tk.cmo jg_config.cmi @@ -22,45 +22,45 @@ jg_entry.cmo: jg_bind.cmi jg_entry.cmx: jg_bind.cmx jg_memo.cmo: jg_memo.cmi jg_memo.cmx: jg_memo.cmi -jg_message.cmo: jg_bind.cmi jg_text.cmi jg_tk.cmo jg_toplevel.cmo \ +jg_message.cmo: jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_bind.cmi \ jg_message.cmi -jg_message.cmx: jg_bind.cmx jg_text.cmx jg_tk.cmx jg_toplevel.cmx \ +jg_message.cmx: jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_bind.cmx \ jg_message.cmi -jg_multibox.cmo: jg_bind.cmi jg_completion.cmi jg_multibox.cmi -jg_multibox.cmx: jg_bind.cmx jg_completion.cmx jg_multibox.cmi -jg_text.cmo: jg_bind.cmi jg_button.cmo jg_tk.cmo jg_toplevel.cmo jg_text.cmi -jg_text.cmx: jg_bind.cmx jg_button.cmx jg_tk.cmx jg_toplevel.cmx jg_text.cmi +jg_multibox.cmo: jg_completion.cmi jg_bind.cmi jg_multibox.cmi +jg_multibox.cmx: jg_completion.cmx jg_bind.cmx jg_multibox.cmi +jg_text.cmo: jg_toplevel.cmo jg_tk.cmo jg_button.cmo jg_bind.cmi jg_text.cmi +jg_text.cmx: jg_toplevel.cmx jg_tk.cmx jg_button.cmx jg_bind.cmx jg_text.cmi lexical.cmo: jg_tk.cmo lexical.cmi lexical.cmx: jg_tk.cmx lexical.cmi -main.cmo: editor.cmi jg_config.cmi searchid.cmi searchpos.cmi shell.cmi \ - viewer.cmi -main.cmx: editor.cmx jg_config.cmx searchid.cmx searchpos.cmx shell.cmx \ - viewer.cmx +main.cmo: viewer.cmi shell.cmi searchpos.cmi searchid.cmi jg_config.cmi \ + editor.cmi +main.cmx: viewer.cmx shell.cmx searchpos.cmx searchid.cmx jg_config.cmx \ + editor.cmx searchid.cmo: list2.cmo searchid.cmi searchid.cmx: list2.cmx searchid.cmi -searchpos.cmo: jg_bind.cmi jg_memo.cmi jg_message.cmi jg_text.cmi jg_tk.cmo \ - lexical.cmi searchid.cmi searchpos.cmi -searchpos.cmx: jg_bind.cmx jg_memo.cmx jg_message.cmx jg_text.cmx jg_tk.cmx \ - lexical.cmx searchid.cmx searchpos.cmi -setpath.cmo: jg_bind.cmi jg_box.cmo jg_button.cmo jg_toplevel.cmo list2.cmo \ - useunix.cmi setpath.cmi -setpath.cmx: jg_bind.cmx jg_box.cmx jg_button.cmx jg_toplevel.cmx list2.cmx \ - useunix.cmx setpath.cmi -shell.cmo: dummy.cmi fileselect.cmi jg_memo.cmi jg_menu.cmo jg_message.cmi \ - jg_text.cmi jg_tk.cmo jg_toplevel.cmo lexical.cmi list2.cmo shell.cmi -shell.cmx: dummy.cmi fileselect.cmx jg_memo.cmx jg_menu.cmx jg_message.cmx \ - jg_text.cmx jg_tk.cmx jg_toplevel.cmx lexical.cmx list2.cmx shell.cmi -typecheck.cmo: jg_message.cmi jg_text.cmi jg_tk.cmo mytypes.cmi typecheck.cmi -typecheck.cmx: jg_message.cmx jg_text.cmx jg_tk.cmx mytypes.cmi typecheck.cmi +searchpos.cmo: searchid.cmi lexical.cmi jg_tk.cmo jg_text.cmi jg_message.cmi \ + jg_memo.cmi jg_bind.cmi searchpos.cmi +searchpos.cmx: searchid.cmx lexical.cmx jg_tk.cmx jg_text.cmx jg_message.cmx \ + jg_memo.cmx jg_bind.cmx searchpos.cmi +setpath.cmo: useunix.cmi list2.cmo jg_toplevel.cmo jg_button.cmo jg_box.cmo \ + jg_bind.cmi setpath.cmi +setpath.cmx: useunix.cmx list2.cmx jg_toplevel.cmx jg_button.cmx jg_box.cmx \ + jg_bind.cmx setpath.cmi +shell.cmo: list2.cmo lexical.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi \ + jg_message.cmi jg_menu.cmo jg_memo.cmi fileselect.cmi dummy.cmi shell.cmi +shell.cmx: list2.cmx lexical.cmx jg_toplevel.cmx jg_tk.cmx jg_text.cmx \ + jg_message.cmx jg_menu.cmx jg_memo.cmx fileselect.cmx dummy.cmi shell.cmi +typecheck.cmo: mytypes.cmi jg_tk.cmo jg_text.cmi jg_message.cmi typecheck.cmi +typecheck.cmx: mytypes.cmi jg_tk.cmx jg_text.cmx jg_message.cmx typecheck.cmi useunix.cmo: useunix.cmi useunix.cmx: useunix.cmi -viewer.cmo: help.cmo jg_bind.cmi jg_box.cmo jg_button.cmo jg_completion.cmi \ - jg_entry.cmo jg_menu.cmo jg_message.cmi jg_multibox.cmi jg_text.cmi \ - jg_tk.cmo jg_toplevel.cmo mytypes.cmi searchid.cmi searchpos.cmi \ - setpath.cmi shell.cmi useunix.cmi viewer.cmi -viewer.cmx: help.cmx jg_bind.cmx jg_box.cmx jg_button.cmx jg_completion.cmx \ - jg_entry.cmx jg_menu.cmx jg_message.cmx jg_multibox.cmx jg_text.cmx \ - jg_tk.cmx jg_toplevel.cmx mytypes.cmi searchid.cmx searchpos.cmx \ - setpath.cmx shell.cmx useunix.cmx viewer.cmi +viewer.cmo: useunix.cmi shell.cmi setpath.cmi searchpos.cmi searchid.cmi \ + mytypes.cmi jg_toplevel.cmo jg_tk.cmo jg_text.cmi jg_multibox.cmi \ + jg_message.cmi jg_menu.cmo jg_entry.cmo jg_completion.cmi jg_button.cmo \ + jg_box.cmo jg_bind.cmi help.cmo viewer.cmi +viewer.cmx: useunix.cmx shell.cmx setpath.cmx searchpos.cmx searchid.cmx \ + mytypes.cmi jg_toplevel.cmx jg_tk.cmx jg_text.cmx jg_multibox.cmx \ + jg_message.cmx jg_menu.cmx jg_entry.cmx jg_completion.cmx jg_button.cmx \ + jg_box.cmx jg_bind.cmx help.cmx viewer.cmi mytypes.cmi: shell.cmi typecheck.cmi: mytypes.cmi diff --git a/otherlibs/labltk/browser/Makefile b/otherlibs/labltk/browser/Makefile index c1daed94..81a153b4 100644 --- a/otherlibs/labltk/browser/Makefile +++ b/otherlibs/labltk/browser/Makefile @@ -1,64 +1,6 @@ -include ../support/Makefile.common - -LABLTKLIB=-I ../labltk -I ../lib -I ../support -#OTHERSLIB=-I $(OTHERS)/win32unix -I $(OTHERS)/systhreads -I $(OTHERS)/str OTHERSLIB=-I $(OTHERS)/unix -I $(OTHERS)/str -OCAMLTOPLIB=-I $(TOPDIR)/parsing -I $(TOPDIR)/utils -I $(TOPDIR)/typing -INCLUDES=$(OTHERSLIB) $(LABLTKLIB) $(OCAMLTOPLIB) - -OBJ = list2.cmo useunix.cmo setpath.cmo lexical.cmo \ - fileselect.cmo searchid.cmo searchpos.cmo shell.cmo \ - help.cmo \ - viewer.cmo typecheck.cmo editor.cmo main.cmo - -JG = jg_tk.cmo jg_config.cmo jg_bind.cmo jg_completion.cmo \ - jg_box.cmo \ - jg_button.cmo jg_toplevel.cmo jg_text.cmo jg_message.cmo \ - jg_menu.cmo jg_entry.cmo jg_multibox.cmo jg_memo.cmo - -# Default rules - -.SUFFIXES: .ml .mli .cmo .cmi .cmx - -.ml.cmo: - $(CAMLCOMP) $(INCLUDES) $< - -.mli.cmi: - $(CAMLCOMP) $(INCLUDES) $< - -all: ocamlbrowser$(EXE) -ocamlbrowser$(EXE): $(TOPDIR)/toplevel/toplevellib.cma jglib.cma $(OBJ) \ - ../support/lib$(LIBNAME).a - $(CAMLC) -o ocamlbrowser$(EXE) $(INCLUDES) \ - $(TOPDIR)/toplevel/toplevellib.cma \ - unix.cma str.cma $(LIBNAME).cma jglib.cma $(OBJ) - -ocamlbrowser.cma: jglib.cma $(OBJ) - $(CAMLC) -a -o $@ -linkall jglib.cma $(OBJ) - -jglib.cma: $(JG) - $(CAMLCOMP) -a -o jglib.cma $(JG) - -help.ml: - echo 'let text = "\\' > $@ - sed -e 's/^ /\\032/' -e 's/$$/\\n\\/' help.txt >> $@ - echo '";;' >> $@ - -install: - if test -f ocamlbrowser$(EXE); then : ; \ - cp ocamlbrowser$(EXE) $(BINDIR); fi - -clean: - rm -f *.cm? ocamlbrowser$(EXE) dummy.mli *~ *.orig - -depend: - $(CAMLDEP) *.ml *.mli > .depend +include Makefile.shared dummy.mli: - rm -f $@ - ln -s dummyUnix.mli $@ -shell.cmo: dummy.cmi -setpath.cmo fileselect.cmo lexical.cmi searchid.cmi typecheck.cmi: $(TOPDIR)/toplevel/toplevellib.cma - -include .depend + cp dummyUnix.mli dummy.mli diff --git a/otherlibs/labltk/browser/Makefile.nt b/otherlibs/labltk/browser/Makefile.nt index 6de29fcf..12550fe8 100644 --- a/otherlibs/labltk/browser/Makefile.nt +++ b/otherlibs/labltk/browser/Makefile.nt @@ -1,9 +1,5 @@ -include ../support/Makefile.common.nt - -LABLTKLIB=-I ../labltk -I ../lib -I ../support OTHERSLIB=-I $(OTHERS)/win32unix -I $(OTHERS)/str -I $(OTHERS)/systhreads -OCAMLTOPLIB=-I $(TOPDIR)/parsing -I $(TOPDIR)/utils -I $(TOPDIR)/typing -INCLUDES=$(OTHERSLIB) $(LABLTKLIB) $(OCAMLTOPLIB) + CCFLAGS=-I../../../byterun $(TK_DEFS) ifeq ($(CCOMPTYPE),cc) @@ -12,59 +8,9 @@ else WINDOWS_APP=-ccopt "/link /subsystem:windows" endif -OBJS = list2.cmo useunix.cmo setpath.cmo lexical.cmo \ - fileselect.cmo searchid.cmo searchpos.cmo shell.cmo \ - help.cmo \ - viewer.cmo typecheck.cmo editor.cmo main.cmo - -JG = jg_tk.cmo jg_config.cmo jg_bind.cmo jg_completion.cmo \ - jg_box.cmo \ - jg_button.cmo jg_toplevel.cmo jg_text.cmo jg_message.cmo \ - jg_menu.cmo jg_entry.cmo jg_multibox.cmo jg_memo.cmo - -# Default rules - -.SUFFIXES: .ml .mli .cmo .cmi .cmx .c .$(O) - -.ml.cmo: - $(CAMLCOMP) $(INCLUDES) $< - -.mli.cmi: - $(CAMLCOMP) $(INCLUDES) $< - -.c.$(O): - $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $< +OCAMLBR=threads.cma winmain.$(O) $(WINDOWS_APP) -all: ocamlbrowser.exe - -ocamlbrowser.exe: $(TOPDIR)/toplevel/toplevellib.cma \ - ../support/lib$(LIBNAME).$(A) -ocamlbrowser.exe: jglib.cma $(OBJS) winmain.$(O) - $(CAMLC) -o ocamlbrowser.exe -custom $(INCLUDES) \ - $(TOPDIR)/toplevel/toplevellib.cma \ - unix.cma threads.cma str.cma $(LIBNAME).cma jglib.cma $(OBJS) \ - winmain.$(O) $(WINDOWS_APP) - -jglib.cma: $(JG) - $(CAMLCOMP) -a -o jglib.cma $(JG) - -help.ml: - echo 'let text = "\\' > $@ - sed -e 's/^ /\\032/' -e 's/$$/\\n\\/' help.txt >> $@ - echo '";;' >> $@ - -install: - if test -f ocamlbrowser.exe; then cp ocamlbrowser.exe $(BINDIR); fi - -clean: - rm -f *.cm? ocamlbrowser.exe dummy.mli *~ *.orig *.$(O) - -depend: - $(CAMLDEP) *.ml *.mli > .depend +include Makefile.shared dummy.mli: cp dummyWin.mli dummy.mli -shell.cmo: dummy.cmi -setpath.cmo fileselect.cmo lexical.cmi searchid.cmi typecheck.cmi: $(TOPDIR)/toplevel/toplevellib.cma - -include .depend diff --git a/otherlibs/labltk/browser/Makefile.shared b/otherlibs/labltk/browser/Makefile.shared new file mode 100644 index 00000000..c5080b7c --- /dev/null +++ b/otherlibs/labltk/browser/Makefile.shared @@ -0,0 +1,63 @@ +include ../support/Makefile.common + +LABLTKLIB=-I ../labltk -I ../lib -I ../support +OCAMLTOPLIB=-I $(TOPDIR)/parsing -I $(TOPDIR)/utils -I $(TOPDIR)/typing +INCLUDES=$(OTHERSLIB) $(LABLTKLIB) $(OCAMLTOPLIB) + +OBJ = list2.cmo useunix.cmo setpath.cmo lexical.cmo \ + fileselect.cmo searchid.cmo searchpos.cmo shell.cmo \ + help.cmo \ + viewer.cmo typecheck.cmo editor.cmo main.cmo + +JG = jg_tk.cmo jg_config.cmo jg_bind.cmo jg_completion.cmo \ + jg_box.cmo \ + jg_button.cmo jg_toplevel.cmo jg_text.cmo jg_message.cmo \ + jg_menu.cmo jg_entry.cmo jg_multibox.cmo jg_memo.cmo + +# Default rules + +.SUFFIXES: .ml .mli .cmo .cmi .cmx .c .$(O) + +.ml.cmo: + $(CAMLCOMP) $(INCLUDES) $< + +.mli.cmi: + $(CAMLCOMP) $(INCLUDES) $< + +.c.$(O): + $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $< + +all: ocamlbrowser$(EXE) + +ocamlbrowser$(EXE): $(TOPDIR)/toplevel/toplevellib.cma jglib.cma $(OBJ) \ + ../support/lib$(LIBNAME).$(A) + $(CAMLC) -o ocamlbrowser$(EXE) $(INCLUDES) \ + $(TOPDIR)/toplevel/toplevellib.cma \ + unix.cma str.cma $(OCAMLBR) $(LIBNAME).cma jglib.cma $(OBJ) + +ocamlbrowser.cma: jglib.cma $(OBJ) + $(CAMLC) -a -o $@ -linkall jglib.cma $(OBJ) + +jglib.cma: $(JG) + $(CAMLC) -a -o $@ $(JG) + +help.ml: + echo 'let text = "\\' > $@ + sed -e 's/^ /\\032/' -e 's/$$/\\n\\/' help.txt >> $@ + echo '";;' >> $@ + +install: + if test -f ocamlbrowser$(EXE); then : ; \ + cp ocamlbrowser$(EXE) $(BINDIR); fi + +clean: + rm -f *.cm? ocamlbrowser$(EXE) dummy.mli *~ *.orig *.$(O) + +depend: + $(CAMLDEP) *.ml *.mli > .depend + +shell.cmo: dummy.cmi +setpath.cmo fileselect.cmo lexical.cmi searchid.cmi typecheck.cmi: $(TOPDIR)/toplevel/toplevellib.cma +mytypes.cmi searchpos.cmi searchpos.cmo typecheck.cmo: $(TOPDIR)/typing/stypes.cmi + +include .depend diff --git a/otherlibs/labltk/browser/mytypes.mli b/otherlibs/labltk/browser/mytypes.mli index d2141adb..233d0ff2 100644 --- a/otherlibs/labltk/browser/mytypes.mli +++ b/otherlibs/labltk/browser/mytypes.mli @@ -12,7 +12,7 @@ (* *) (*************************************************************************) -(* $Id: mytypes.mli,v 1.6 2003/04/02 06:56:05 garrigue Exp $ *) +(* $Id: mytypes.mli,v 1.7 2007/05/16 08:21:40 doligez Exp $ *) open Widget @@ -23,7 +23,7 @@ type edit_window = modified: Textvariable.textVariable; mutable shell: (string * Shell.shell) option; mutable structure: Typedtree.structure; - mutable type_info: Stypes.type_info list; + mutable type_info: Stypes.annotation list; mutable signature: Types.signature; mutable psignature: Parsetree.signature; number: string } diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml index 8d1e537a..22877350 100644 --- a/otherlibs/labltk/browser/searchid.ml +++ b/otherlibs/labltk/browser/searchid.ml @@ -12,7 +12,7 @@ (* *) (*************************************************************************) -(* $Id: searchid.ml,v 1.23 2005/01/28 16:13:11 doligez Exp $ *) +(* $Id: searchid.ml,v 1.25 2008/07/09 14:03:08 mauny Exp $ *) open StdLabels open Location @@ -228,9 +228,9 @@ let rec search_type_in_signature t ~sign ~prefix ~mode = end || begin match td.type_kind with Type_abstract -> false - | Type_variant(l, priv) -> + | Type_variant l -> List.exists l ~f:(fun (_, l) -> List.exists l ~f:matches) - | Type_record(l, rep, priv) -> + | Type_record(l, rep) -> List.exists l ~f:(fun (_, _, t) -> matches t) end then [lid_of_id id, Ptype] else [] @@ -421,6 +421,7 @@ let rec bound_variables pat = | Ppat_or (pat1,pat2) -> bound_variables pat1 @ bound_variables pat2 | Ppat_constraint (pat,_) -> bound_variables pat + | Ppat_lazy pat -> bound_variables pat let search_structure str ~name ~kind ~prefix = let loc = ref 0 in diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml index 377143ee..e32ea84b 100644 --- a/otherlibs/labltk/browser/searchpos.ml +++ b/otherlibs/labltk/browser/searchpos.ml @@ -12,7 +12,7 @@ (* *) (*************************************************************************) -(* $Id: searchpos.ml,v 1.49 2006/04/05 02:28:13 garrigue Exp $ *) +(* $Id: searchpos.ml,v 1.52 2008/07/09 14:03:08 mauny Exp $ *) open StdLabels open Support @@ -165,11 +165,11 @@ let search_pos_type_decl td ~pos ~env = | None -> () end; let rec search_tkind = function - Ptype_abstract | Ptype_private -> () - | Ptype_variant (dl, _) -> + Ptype_abstract -> () + | Ptype_variant dl -> List.iter dl ~f:(fun (_, tl, _) -> List.iter tl ~f:(search_pos_type ~pos ~env)) - | Ptype_record (dl, _) -> + | Ptype_record dl -> List.iter dl ~f:(fun (_, _, t, _) -> search_pos_type t ~pos ~env) in search_tkind td.ptype_kind; List.iter td.ptype_cstrs ~f: @@ -825,6 +825,7 @@ and search_pos_pat ~pos ~env pat = add_found_str (`Exp(`Val (Pident id), pat.pat_type)) ~env ~loc:pat.pat_loc | Tpat_alias (pat, _) -> search_pos_pat pat ~pos ~env + | Tpat_lazy pat -> search_pos_pat pat ~pos ~env | Tpat_constant _ -> add_found_str (`Exp(`Const, pat.pat_type)) ~env ~loc:pat.pat_loc | Tpat_tuple l -> @@ -871,6 +872,7 @@ let search_pos_ti ~pos = function | Ti_expr e -> search_pos_expr ~pos e | Ti_class c -> search_pos_class_expr ~pos c | Ti_mod m -> search_pos_module_expr ~pos m + | _ -> () let rec search_pos_info ~pos = function [] -> [] diff --git a/otherlibs/labltk/browser/searchpos.mli b/otherlibs/labltk/browser/searchpos.mli index bcec9241..d04dac6e 100644 --- a/otherlibs/labltk/browser/searchpos.mli +++ b/otherlibs/labltk/browser/searchpos.mli @@ -12,7 +12,7 @@ (* *) (*************************************************************************) -(* $Id: searchpos.mli,v 1.12 2003/04/02 06:56:05 garrigue Exp $ *) +(* $Id: searchpos.mli,v 1.13 2007/05/16 08:21:40 doligez Exp $ *) open Widget @@ -67,7 +67,7 @@ val search_pos_structure : pos:int -> Typedtree.structure_item list -> (fkind * Env.t * Location.t) list val search_pos_info : - pos:int -> Stypes.type_info list -> (fkind * Env.t * Location.t) list + pos:int -> Stypes.annotation list -> (fkind * Env.t * Location.t) list val view_type : fkind -> env:Env.t -> unit val view_type_menu : fkind -> env:Env.t -> parent:'a widget -> menu widget diff --git a/otherlibs/labltk/browser/typecheck.ml b/otherlibs/labltk/browser/typecheck.ml index ba8e81e6..1518931f 100644 --- a/otherlibs/labltk/browser/typecheck.ml +++ b/otherlibs/labltk/browser/typecheck.ml @@ -12,7 +12,7 @@ (* *) (*************************************************************************) -(* $Id: typecheck.ml,v 1.15 2003/04/02 06:56:06 garrigue Exp $ *) +(* $Id: typecheck.ml,v 1.16 2007/05/16 08:21:40 doligez Exp $ *) open StdLabels open Tk @@ -92,7 +92,7 @@ let f txt = txt.signature <- []; txt.psignature <- []; ignore (Stypes.get_info ()); - Clflags.save_types := true; + Clflags.annotations := true; begin try @@ -109,7 +109,7 @@ let f txt = List.iter psl ~f: begin function Ptop_def pstr -> - let str, sign, env' = Typemod.type_structure !env pstr in + let str, sign, env' = Typemod.type_structure !env pstr Location.none in txt.structure <- txt.structure @ str; txt.signature <- txt.signature @ sign; env := env' diff --git a/otherlibs/labltk/browser/winmain.c b/otherlibs/labltk/browser/winmain.c index 4e82d1e2..b647fb79 100644 --- a/otherlibs/labltk/browser/winmain.c +++ b/otherlibs/labltk/browser/winmain.c @@ -3,10 +3,10 @@ #include #include -extern int __argc; -extern char **__argv; -extern void caml_expand_command_line(int * argcp, char *** argvp); -extern void caml_main (char **); +CAMLextern int __argc; +CAMLextern char **__argv; +CAMLextern void caml_expand_command_line(int * argcp, char *** argvp); +/* extern void caml_main (char **); */ int WINAPI WinMain(HINSTANCE h, HINSTANCE HPrevInstance, LPSTR lpCmdLine, int nCmdShow) diff --git a/otherlibs/labltk/camltk/Makefile b/otherlibs/labltk/camltk/Makefile index afa6f3af..19300ead 100644 --- a/otherlibs/labltk/camltk/Makefile +++ b/otherlibs/labltk/camltk/Makefile @@ -1,8 +1,6 @@ include ../support/Makefile.common -COMPFLAGS= -I ../support - -TOPDEPS = $(TOPDIR)/toplevel/toplevellib.cma $(TOPDIR)/toplevel/topmain.cmo +COMPFLAGS= -I ../support -I $(OTHERS)/win32unix -I $(OTHERS)/unix all: camltkobjs @@ -20,12 +18,12 @@ camltkobjsx: $(CAMLTKOBJSX) clean: $(MAKE) -f Makefile.gen clean -install: $(CAMLTKOBJS) +install: if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi cp $(CAMLTKOBJS:.cmo=.cmi) $(CWIDGETOBJS:.cmo=.mli) $(INSTALLDIR) chmod 644 $(INSTALLDIR)/*.cmi -installopt: $(CAMLTKOBJSX) +installopt: @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi cp $(CAMLTKOBJSX) $(INSTALLDIR) chmod 644 $(INSTALLDIR)/*.cmx diff --git a/otherlibs/labltk/camltk/Makefile.gen b/otherlibs/labltk/camltk/Makefile.gen index 6b547884..bedc9c59 100644 --- a/otherlibs/labltk/camltk/Makefile.gen +++ b/otherlibs/labltk/camltk/Makefile.gen @@ -2,10 +2,12 @@ include ../support/Makefile.common all: cTk.ml camltk.ml .depend -_tkgen.ml: ../Widgets.src ../compiler/tkcompiler - cd ..; $(CAMLRUNGEN) compiler/tkcompiler -camltk -outdir camltk +_tkgen.ml: ../Widgets.src ../compiler/tkcompiler$(EXE) + cd ..; $(CAMLRUNGEN) compiler/tkcompiler$(EXE) -camltk -outdir camltk -cTk.ml camltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp #../builtin/builtin_*.ml +#cTk.ml camltk.ml .depend: generate + +cTk.ml camltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp$(EXE) #../builtin/builtin_*.ml (echo '##define CAMLTK'; \ echo 'include Camltkwrap'; \ echo 'open Widget'; \ @@ -34,13 +36,17 @@ cTk.ml camltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp #../buil ) > _cTk.ml $(CAMLRUN) ../compiler/pp < _cTk.ml > cTk.ml rm -f _cTk.ml - $(CAMLDEP) -I ../support [a-z]*.mli [a-z]*.ml > .depend + $(CAMLDEP) -slash -I ../support [a-z]*.mli [a-z]*.ml > .depend + +../compiler/pp$(EXE): + cd ../compiler; $(MAKE) pp($EXE) -../compiler/pp: - cd ../compiler; $(MAKE) pp +../compiler/tkcompiler$(EXE): + cd ../compiler; $(MAKE) tkcompiler($EXE) # All .{ml,mli} files are generated in this directory clean: - rm -f *.cm* *.ml *.mli *.o *.a .depend - + rm -f *.cm* *.ml *.mli *.$(O) *.$(A) .depend # rm -f modules + +.PHONY: all generate clean diff --git a/otherlibs/labltk/camltk/Makefile.gen.nt b/otherlibs/labltk/camltk/Makefile.gen.nt index 4fdba771..046b8782 100644 --- a/otherlibs/labltk/camltk/Makefile.gen.nt +++ b/otherlibs/labltk/camltk/Makefile.gen.nt @@ -1,46 +1 @@ -include ../support/Makefile.common.nt - -all: cTk.ml camltk.ml .depend - -_tkgen.ml: ../Widgets.src ../compiler/tkcompiler.exe - cd .. ; $(CAMLRUNGEN) compiler/tkcompiler.exe -camltk -outdir camltk - -# dependencies are broken: wouldn't work with gmake 3.77 - -cTk.ml camltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp.exe #../builtin/builtin_*.ml - (echo '##define CAMLTK'; \ - echo 'include Camltkwrap'; \ - echo 'open Widget'; \ - echo 'open Protocol'; \ - echo 'open Textvariable'; \ - echo ; \ - cat ../builtin/report.ml; \ - echo ; \ - cat ../builtin/builtin_*.ml; \ - echo ; \ - cat _tkgen.ml; \ - echo ; \ - echo ; \ - echo 'module Tkintf = struct'; \ - cat ../builtin/builtini_*.ml; \ - cat _tkigen.ml; \ - echo 'end (* module Tkintf *)'; \ - echo ; \ - echo ; \ - echo 'open Tkintf' ;\ - echo ; \ - echo ; \ - cat ../builtin/builtinf_*.ml; \ - cat _tkfgen.ml; \ - echo ; \ - ) > _cTk.ml - $(CAMLRUN) ../compiler/pp < _cTk.ml > cTk.ml - rm -f _cTk.ml - $(CAMLDEP) -slash -I ../support [a-z]*.mli [a-z]*.ml > .depend - -../compiler/pp.exe: - cd ../compiler; $(MAKEREC) pp.exe - -clean: - rm -f *.cm* *.ml *.mli *.$(O) *.$(A) -# rm -f modules .depend +include Makefile.gen diff --git a/otherlibs/labltk/camltk/Makefile.nt b/otherlibs/labltk/camltk/Makefile.nt index 6c81dbc4..2b0b5ab5 100644 --- a/otherlibs/labltk/camltk/Makefile.nt +++ b/otherlibs/labltk/camltk/Makefile.nt @@ -1,43 +1 @@ -include ../support/Makefile.common.nt - -COMPFLAGS= -I ../support - -all: camltkobjs - -opt: camltkobjsx - -# All .{ml,mli} files are generated in this directory -clean : - rm -f *.cm* *.ml *.mli *.$(A) *.$(O) - $(MAKE) -f Makefile.gen.nt clean - -include ./modules - -CAMLTKOBJS = $(WIDGETOBJS) cTk.cmo camltk.cmo -CAMLTKOBJSX = $(CAMLTKOBJS:.cmo=.cmx) - -camltkobjs: $(CAMLTKOBJS) - -camltkobjsx: $(CAMLTKOBJSX) - -install: $(CAMLTKOBJS) - mkdir -p $(INSTALLDIR) - cp *.cmi [a-z]*.mli $(INSTALLDIR) - -installopt: $(CAMLTKOBJSX) - mkdir -p $(INSTALLDIR) - cp $(CAMLTKOBJSX) $(INSTALLDIR) - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmx .cmo .mlp - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -include .depend +include Makefile diff --git a/otherlibs/labltk/compiler/Makefile.nt b/otherlibs/labltk/compiler/Makefile.nt index 3c936ba4..2b0b5ab5 100644 --- a/otherlibs/labltk/compiler/Makefile.nt +++ b/otherlibs/labltk/compiler/Makefile.nt @@ -1,63 +1 @@ -include ../support/Makefile.common.nt - -OBJS= ../support/support.cmo flags.cmo copyright.cmo \ - tsort.cmo tables.cmo printer.cmo lexer.cmo \ - pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo \ - parser.cmo compile.cmo intf.cmo maincompile.cmo - -PPOBJS= pplex.cmo ppyac.cmo ppexec.cmo ppparse.cmo pp.cmo - -all: tkcompiler.exe pp.exe - -tkcompiler.exe : $(OBJS) - $(CAMLC) $(LINKFLAGS) -o tkcompiler.exe $(OBJS) - -pp.exe : $(PPOBJS) - $(CAMLC) $(LINKFLAGS) -o pp.exe $(PPOBJS) - -lexer.ml: lexer.mll - $(CAMLLEX) lexer.mll - -parser.ml parser.mli: parser.mly - $(CAMLYACC) -v parser.mly - -pplex.ml: pplex.mll - $(CAMLLEX) pplex.mll - -pplex.mli: ppyac.cmi - -ppyac.ml ppyac.mli: ppyac.mly - $(CAMLYACC) -v ppyac.mly - -copyright.ml: copyright - (echo "let copyright=\"\\"; \ - cat copyright; \ - echo "\""; \ - echo "let write ~w = w copyright;;") > copyright.ml - -clean : - rm -f *.cm* parser.ml parser.mli lexer.ml copyright.ml - rm -f pplex.ml ppyac.ml ppyac.mli ppyac.output - rm -f tkcompiler.exe pp.exe parser.output - -scratch : - rm -f *.cm* parser.ml parser.mli lexer.ml tkcompiler.exe - rm -f *.cm* pplex.ml ppyac.ml ppyac.mli pp.exe - -install: - cp tkcompiler.exe $(INSTALLDIR) - cp pp.exe $(INSTALLDIR) - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo .mlp - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) -I ../support $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) -I ../support $< - -depend: parser.ml parser.mli lexer.ml pplex.ml ppyac.ml ppyac.mli - $(CAMLDEP) *.mli *.ml > .depend - -include .depend +include Makefile diff --git a/otherlibs/labltk/frx/Makefile b/otherlibs/labltk/frx/Makefile index 226ba129..0f9c9e3f 100644 --- a/otherlibs/labltk/frx/Makefile +++ b/otherlibs/labltk/frx/Makefile @@ -1,6 +1,6 @@ include ../support/Makefile.common -COMPFLAGS=-I ../camltk -I ../support -I $(OTHERS)/unix +COMPFLAGS=-I ../camltk -I ../support OBJS= frx_misc.cmo frx_widget.cmo frx_font.cmo frx_entry.cmo frx_text.cmo \ frx_listbox.cmo frx_req.cmo frx_fillbox.cmo frx_focus.cmo \ @@ -19,14 +19,14 @@ frxlib.cma: $(OBJS) frxlib.cmxa: $(OBJSX) $(CAMLOPTLIBR) -o frxlib.cmxa $(OBJSX) -install: frxlib.cma +install: cp *.cmi *.mli frxlib.cma $(INSTALLDIR) -installopt: frxlib.cmxa - cp frxlib.cmxa frxlib.a $(INSTALLDIR) +installopt: + cp frxlib.cmxa frxlib.$(A) $(INSTALLDIR) clean: - rm -f *.cm* *.o *.a + rm -f *.cm* *.$(O) *.$(A) $(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma diff --git a/otherlibs/labltk/frx/Makefile.nt b/otherlibs/labltk/frx/Makefile.nt index 2f37a4cb..2b0b5ab5 100644 --- a/otherlibs/labltk/frx/Makefile.nt +++ b/otherlibs/labltk/frx/Makefile.nt @@ -1,53 +1 @@ -include ../support/Makefile.common.nt - -COMPFLAGS=-I ../camltk -I ../support - -OBJS= frx_misc.cmo frx_widget.cmo frx_font.cmo frx_entry.cmo frx_text.cmo \ - frx_listbox.cmo frx_req.cmo frx_fillbox.cmo frx_focus.cmo \ - frx_dialog.cmo frx_mem.cmo frx_rpc.cmo frx_synth.cmo frx_selection.cmo \ - frx_after.cmo frx_fit.cmo frx_ctext.cmo frx_color.cmo - -OBJSX = $(OBJS:.cmo=.cmx) - -all: libfrx.cma - -opt: libfrx.cmxa - -libfrx.cma: $(OBJS) - $(CAMLLIBR) -o libfrx.cma $(OBJS) - -libfrx.cmxa: $(OBJSX) - $(CAMLOPTLIBR) -o libfrx.cmxa $(OBJSX) - - -install: libfrx.cma - cp *.cmi *.mli libfrx.cma $(INSTALLDIR) - -installopt: libfrx.cmxa - cp libfrx.cmxa libfrx.$(A) $(INSTALLDIR) - - -clean: - rm -f *.cm* *.$(O) *.$(A) *~ *test - -$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma - -$(OBJSX): ../lib/$(LIBNAME).cmxa - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo .cmx - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - - -depend: - $(CAMLDEP) *.mli *.ml > .depend - -include .depend +include Makefile diff --git a/otherlibs/labltk/jpf/Makefile b/otherlibs/labltk/jpf/Makefile index 1c499356..0d33f414 100644 --- a/otherlibs/labltk/jpf/Makefile +++ b/otherlibs/labltk/jpf/Makefile @@ -1,6 +1,6 @@ include ../support/Makefile.common -COMPFLAGS=-I ../labltk -I ../support -I $(OTHERS)/unix -I $(OTHERS)/str +COMPFLAGS=-I ../labltk -I ../support -I $(OTHERS)/win32unix -I $(OTHERS)/unix -I $(OTHERS)/str OBJS= fileselect.cmo balloon.cmo shell.cmo jpf_font.cmo @@ -20,14 +20,14 @@ jpflib.cma: $(OBJS) jpflib.cmxa: $(OBJSX) $(CAMLOPTLIBR) -o jpflib.cmxa $(OBJSX) -install: jpflib.cma +install: cp $(OBJS:.cmo=.cmi) $(OBJS:.cmo=.mli) jpflib.cma $(INSTALLDIR) -installopt: jpflib.cmxa - cp jpflib.cmxa jpflib.a $(OBJS:.cmo=.cmx) $(INSTALLDIR) +installopt: + cp jpflib.cmxa jpflib.$(A) $(OBJS:.cmo=.cmx) $(INSTALLDIR) clean: - rm -f *.cm* *.o *.a *~ *test + rm -f *.cm* *.$(O) *.$(A) *~ *test $(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma diff --git a/otherlibs/labltk/jpf/Makefile.nt b/otherlibs/labltk/jpf/Makefile.nt index 7501a01d..2b0b5ab5 100644 --- a/otherlibs/labltk/jpf/Makefile.nt +++ b/otherlibs/labltk/jpf/Makefile.nt @@ -1,75 +1 @@ -include ../support/Makefile.common.nt - -COMPFLAGS=-I ../labltk -I ../support -I $(OTHERS)/win32unix -I $(OTHERS)/str - -OBJS= fileselect.cmo balloon.cmo - -OBJSX = $(OBJS:.cmo=.cmx) - -all: libjpf.cma - -opt: libjpf.cmxa - -test: balloontest - -testopt: balloontest.opt - -libjpf.cma: $(OBJS) - $(CAMLLIBR) -o libjpf.cma $(OBJS) - -libjpf.cmxa: $(OBJSX) - $(CAMLOPTLIBR) -o libjpf.cmxa $(OBJSX) - -install: libjpf.cma - cp $(OBJS:.cmo=.cmi) $(OBJS:.cmo=.mli) libjpf.cma $(INSTALLDIR) - -installopt: libjpf.cmxa - cp libjpf.cmxa libjpf.$(A) $(INSTALLDIR) - -clean: - rm -f *.cm* *.$(O) *.$(A) *~ *test - -$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma - -$(OBJSX): ../lib/$(LIBNAME).cmxa - -### Tests - -balloontest: balloontest.cmo - $(CAMLC) -o balloontest -I ../support -I ../labltk -I ../lib \ - -custom $(LIBNAME).cma libjpf.cma balloontest.cmo $(TKLINKOPT) - -balloontest.opt: balloontest.cmx - $(CAMLOPT) -o balloontest.opt -I ../support -I ../labltk -I ../lib \ - $(LIBNAME).cmxa libjpf.cmxa balloontest.cmx $(TKLINKOPT) - -balloontest.cmo : balloon.cmo libjpf.cma - -balloontest.cmx : balloon.cmx libjpf.cmxa - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmx .cmo - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -depend: - mv Makefile Makefile.bak - (sed -n -e '1,/^### DO NOT DELETE THIS LINE/p' Makefile.bak; \ - $(CAMLDEP) *.mli *.ml) > Makefile - - -### EVERYTHING THAT GOES BEYOND THIS COMMENT IS GENERATED -### DO NOT DELETE THIS LINE -balloon.cmo: balloon.cmi -balloon.cmx: balloon.cmi -balloontest.cmo: balloon.cmi -balloontest.cmx: balloon.cmx -fileselect.cmo: fileselect.cmi -fileselect.cmx: fileselect.cmi +include Makefile diff --git a/otherlibs/labltk/labltk/Makefile b/otherlibs/labltk/labltk/Makefile index 53276dd1..f678954e 100644 --- a/otherlibs/labltk/labltk/Makefile +++ b/otherlibs/labltk/labltk/Makefile @@ -1,6 +1,6 @@ include ../support/Makefile.common -COMPFLAGS= -I ../support +COMPFLAGS= -I ../support -I $(OTHERS)/win32unix -I $(OTHERS)/unix all: labltkobjs @@ -15,12 +15,12 @@ labltkobjs: $(LABLTKOBJS) labltkobjsx: $(LABLTKOBJSX) -install: $(LABLTKOBJS) +install: if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi cp $(LABLTKOBJS:.cmo=.cmi) $(WIDGETOBJS:.cmo=.mli) $(INSTALLDIR) chmod 644 $(INSTALLDIR)/*.cmi -installopt: $(LABLTKOBJSX) +installopt: @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi cp $(LABLTKOBJSX) $(INSTALLDIR) chmod 644 $(INSTALLDIR)/*.cmx diff --git a/otherlibs/labltk/labltk/Makefile.gen b/otherlibs/labltk/labltk/Makefile.gen index 6853d0cb..d73bb345 100644 --- a/otherlibs/labltk/labltk/Makefile.gen +++ b/otherlibs/labltk/labltk/Makefile.gen @@ -2,12 +2,14 @@ include ../support/Makefile.common all: tk.ml labltk.ml .depend -_tkgen.ml: ../Widgets.src ../compiler/tkcompiler - cd ..; $(CAMLRUNGEN) compiler/tkcompiler -outdir labltk +_tkgen.ml: ../Widgets.src ../compiler/tkcompiler$(EXE) + cd ..; $(CAMLRUNGEN) compiler/tkcompiler$(EXE) -outdir labltk # dependencies are broken: wouldn't work with gmake 3.77 -tk.ml labltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp #../builtin/builtin_*.ml +#tk.ml labltk.ml .depend: generate + +tk.ml labltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp$(EXE) #../builtin/builtin_*.ml (echo 'open StdLabels'; \ echo 'open Widget'; \ echo 'open Protocol'; \ @@ -33,13 +35,18 @@ tk.ml labltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp #../built ) > _tk.ml $(CAMLRUN) ../compiler/pp < _tk.ml > tk.ml rm -f _tk.ml - $(CAMLDEP) -I ../support [a-z]*.mli [a-z]*.ml > .depend + $(CAMLDEP) -slash -I ../support [a-z]*.mli [a-z]*.ml > .depend + +../compiler/pp$(EXE): + cd ../compiler; $(MAKE) pp$(EXE) -../compiler/pp: - cd ../compiler; $(MAKE) pp +../compiler/tkcompiler$(EXE): + cd ../compiler; $(MAKE) tkcompiler$(EXE) # All .{ml,mli} files are generated in this directory clean: - rm -f *.cm* *.ml *.mli *.o *.a .depend + rm -f *.cm* *.ml *.mli *.$(O) *.$(A) .depend # rm -f modules + +.PHONY: all generate clean diff --git a/otherlibs/labltk/labltk/Makefile.gen.nt b/otherlibs/labltk/labltk/Makefile.gen.nt index 8c652240..046b8782 100644 --- a/otherlibs/labltk/labltk/Makefile.gen.nt +++ b/otherlibs/labltk/labltk/Makefile.gen.nt @@ -1,40 +1 @@ -include ../support/Makefile.common.nt - -all: tk.ml labltk.ml .depend - -_tkgen.ml: ../Widgets.src ../compiler/tkcompiler.exe - cd .. ; $(CAMLRUNGEN) compiler/tkcompiler.exe -outdir labltk - -# dependencies are broken: wouldn't work with gmake 3.77 - -tk.ml labltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp.exe #../builtin/builtin_*.ml - (echo 'open StdLabels'; \ - echo 'open Widget'; \ - echo 'open Protocol'; \ - echo 'open Support'; \ - echo 'open Textvariable'; \ - cat ../builtin/report.ml; \ - cat ../builtin/builtin_*.ml; \ - cat _tkgen.ml; \ - echo ; \ - echo ; \ - echo 'module Tkintf = struct'; \ - cat ../builtin/builtini_*.ml; \ - cat _tkigen.ml; \ - echo 'end (* module Tkintf *)'; \ - echo ; \ - echo ; \ - echo 'open Tkintf' ;\ - echo ; \ - echo ; \ - cat ../builtin/builtinf_*.ml; \ - cat _tkfgen.ml; \ - echo ; \ - ) > _tk.ml - $(CAMLRUN) ../compiler/pp < _tk.ml > tk.ml - rm -f _tk.ml - $(CAMLDEP) -slash -I ../support [a-z]*.mli [a-z]*.ml > .depend - -clean: - rm -f *.cm* *.ml *.mli *.$(O) *.$(A) -# rm -f modules .depend +include Makefile.gen diff --git a/otherlibs/labltk/labltk/Makefile.nt b/otherlibs/labltk/labltk/Makefile.nt index a8f4f694..2b0b5ab5 100644 --- a/otherlibs/labltk/labltk/Makefile.nt +++ b/otherlibs/labltk/labltk/Makefile.nt @@ -1,43 +1 @@ -include ../support/Makefile.common.nt - -COMPFLAGS= -I ../support - -all: labltkobjs - -opt: labltkobjsx - -# All .{ml,mli} files are generated in this directory -clean : - rm -f *.cm* *.ml *.mli *.$(A) *.$(O) - $(MAKE) -f Makefile.gen.nt clean - -include ./modules - -LABLTKOBJS = $(WIDGETOBJS) tk.cmo labltk.cmo -LABLTKOBJSX = $(LABLTKOBJS:.cmo=.cmx) - -labltkobjs: $(LABLTKOBJS) - -labltkobjsx: $(LABLTKOBJSX) - -install: $(LABLTKOBJS) - mkdir -p $(INSTALLDIR) - cp *.cmi [a-z]*.mli $(INSTALLDIR) - -installopt: $(LABLTKOBJSX) - mkdir -p $(INSTALLDIR) - cp $(LABLTKOBJSX) $(INSTALLDIR) - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmx .cmo - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -include .depend +include Makefile diff --git a/otherlibs/labltk/lib/Makefile b/otherlibs/labltk/lib/Makefile index 225c3d1c..e2fe5f16 100644 --- a/otherlibs/labltk/lib/Makefile +++ b/otherlibs/labltk/lib/Makefile @@ -5,12 +5,12 @@ all: $(LIBNAME).cma $(LIBNAME)top$(EXE) $(LIBNAME) opt: $(LIBNAME).cmxa clean: - rm -f $(LIBNAME)top$(EXE) $(LIBNAME) *.cm* *.a + rm -f $(LIBNAME)top$(EXE) $(LIBNAME) *.cm* *.$(A) superclean: - if test -f tk.cmo; then \ echo We have changes... Now lib directory has no .cmo files; \ - rm -f *.cm* *.o; \ + rm -f *.cm* *.$(O); \ fi include ../labltk/modules @@ -32,9 +32,9 @@ $(LIBNAME).cma: $(SUPPORT) ../Widgets.src $(MAKE) superclean cd ../labltk; $(MAKE) cd ../camltk; $(MAKE) - $(MKLIB) -ocamlc '$(CAMLC)' -o $(LIBNAME) -oc $(LIBNAME) \ + $(MKLIB) -ocamlc '$(CAMLC)' -o $(LIBNAME) \ -I ../labltk -I ../camltk $(TKOBJS) \ - $(TK_LINK) + -ccopt "\"$(TK_LINK)\"" $(LIBNAME).cmxa: $(SUPPORT:.cmo=.cmx) ../Widgets.src $(MAKE) superclean @@ -42,13 +42,13 @@ $(LIBNAME).cmxa: $(SUPPORT:.cmo=.cmx) ../Widgets.src cd ../camltk; $(MAKE) opt $(MKLIB) -ocamlopt '$(CAMLOPT)' -o $(LIBNAME) -oc $(LIBNAME) \ -I ../labltk -I ../camltk $(TKOBJS:.cmo=.cmx) \ - $(TK_LINK) + -ccopt "\"$(TK_LINK)\"" -$(LIBNAME)top$(EXE) : $(TOPDEPS) $(LIBNAME).cma ../support/lib$(LIBNAME).a +$(LIBNAME)top$(EXE) : $(TOPDEPS) $(LIBNAME).cma ../support/lib$(LIBNAME).$(A) $(CAMLC) -verbose -linkall -o $(LIBNAME)top$(EXE) -I ../support \ -I $(TOPDIR)/toplevel toplevellib.cma \ + -I $(OTHERS)/unix -I $(OTHERS)/win32unix unix.cma \ -I ../labltk -I ../camltk $(LIBNAME).cma \ - -I $(OTHERS)/unix unix.cma \ -I $(OTHERS)/str str.cma \ topstart.cmo @@ -68,7 +68,7 @@ install: installopt: @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi - cp $(LIBNAME).cmxa $(LIBNAME).a $(INSTALLDIR) - cd $(INSTALLDIR); $(RANLIB) $(LIBNAME).a + cp $(LIBNAME).cmxa $(LIBNAME).$(A) $(INSTALLDIR) + cd $(INSTALLDIR); $(RANLIB) $(LIBNAME).$(A) chmod 644 $(INSTALLDIR)/$(LIBNAME).cmxa - chmod 644 $(INSTALLDIR)/$(LIBNAME).a + chmod 644 $(INSTALLDIR)/$(LIBNAME).$(A) diff --git a/otherlibs/labltk/lib/Makefile.nt b/otherlibs/labltk/lib/Makefile.nt index 4ce22aca..67bf904e 100644 --- a/otherlibs/labltk/lib/Makefile.nt +++ b/otherlibs/labltk/lib/Makefile.nt @@ -1,60 +1 @@ -include ../support/Makefile.common.nt - -all: $(LIBNAME).cma - -opt: $(LIBNAME).cmxa - -clean: - rm -f $(LIBNAME).cma $(LIBNAME).cmxa *.$(A) - -include ../labltk/modules -LABLTKOBJS=tk.cmo $(WIDGETOBJS) - -include ../camltk/modules -CAMLTKOBJS=cTk.cmo $(CWIDGETOBJS) labltk.cmo camltk.cmo - -SUPPORT=../support/support.cmo ../support/rawwidget.cmo \ - ../support/widget.cmo ../support/protocol.cmo \ - ../support/textvariable.cmo ../support/timer.cmo \ - ../support/fileevent.cmo ../support/camltkwrap.cmo - -TKOBJS=$(SUPPORT) $(LABLTKOBJS) $(CAMLTKOBJS) - -TOPDEPS = $(TOPDIR)/toplevel/toplevellib.cma $(TOPDIR)/toplevel/topmain.cmo - -UNIXLIB = $(call SYSLIB,wsock32) - -$(LIBNAME).cma: $(SUPPORT) - cd ../labltk ; $(MAKEREC) - cd ../camltk ; $(MAKEREC) - $(CAMLLIBR) -o $(LIBNAME).cma -I ../labltk -I ../camltk $(TKOBJS) \ - -dllib -l$(LIBNAME) -cclib -l$(LIBNAME) \ - -cclib "$(TK_LINK)" -cclib $(UNIXLIB) - -$(LIBNAME).cmxa: $(SUPPORT:.cmo=.cmx) - cd ../labltk; $(MAKEREC) opt - cd ../camltk; $(MAKEREC) opt - $(CAMLOPTLIBR) -o $(LIBNAME).cmxa -I ../labltk -I ../camltk \ - $(TKOBJS:.cmo=.cmx) -cclib -l$(LIBNAME) \ - -cclib "$(TK_LINK)" -cclib $(UNIXLIB) - -# $(LIBNAME)top$(EXE) : $(TOPDEPS) $(LIBNAME).cma ../support/lib$(LIBNAME).a -# $(CAMLC) -linkall -o $(LIBNAME)top$(EXE) -I ../support \ -# -I $(TOPDIR)/toplevel toplevellib.cma \ -# -I ../labltk -I ../camltk $(LIBNAME).cma \ -# -I $(OTHERS)/unix unix.cma \ -# -I $(OTHERS)/str str.cma \ -# topmain.cmo -# -# $(LIBNAME): Makefile $(TOPDIR)/config/Makefile -# @echo Generate $@ -# @echo "#!/bin/sh" > $@ -# @echo 'exec $(INSTALLDIR)/$(LIBNAME)top$(EXE) -I $(INSTALLDIR) $$*' >> $@ - -install: all - mkdir -p $(INSTALLDIR) - cp $(LIBNAME).cma $(INSTALLDIR) - -installopt: opt - mkdir -p $(INSTALLDIR) - cp $(LIBNAME).cmxa $(LIBNAME).$(A) $(INSTALLDIR) +include Makefile \ No newline at end of file diff --git a/otherlibs/labltk/support/.depend b/otherlibs/labltk/support/.depend index f8489f60..069735be 100644 --- a/otherlibs/labltk/support/.depend +++ b/otherlibs/labltk/support/.depend @@ -1,26 +1,27 @@ -camltkwrap.cmi: protocol.cmi textvariable.cmi timer.cmi widget.cmi +camltkwrap.cmi: widget.cmi timer.cmi textvariable.cmi protocol.cmi protocol.cmi: widget.cmi -textvariable.cmi: protocol.cmi widget.cmi +textvariable.cmi: widget.cmi protocol.cmi +tkthread.cmi: widget.cmi widget.cmi: rawwidget.cmi -camltkwrap.cmo: fileevent.cmi protocol.cmi rawwidget.cmi textvariable.cmi \ - timer.cmi camltkwrap.cmi -camltkwrap.cmx: fileevent.cmx protocol.cmx rawwidget.cmx textvariable.cmx \ - timer.cmx camltkwrap.cmi -fileevent.cmo: protocol.cmi support.cmi fileevent.cmi -fileevent.cmx: protocol.cmx support.cmx fileevent.cmi -protocol.cmo: support.cmi widget.cmi protocol.cmi -protocol.cmx: support.cmx widget.cmx protocol.cmi +camltkwrap.cmo: timer.cmi textvariable.cmi rawwidget.cmi protocol.cmi \ + fileevent.cmi camltkwrap.cmi +camltkwrap.cmx: timer.cmx textvariable.cmx rawwidget.cmx protocol.cmx \ + fileevent.cmx camltkwrap.cmi +fileevent.cmo: support.cmi protocol.cmi fileevent.cmi +fileevent.cmx: support.cmx protocol.cmx fileevent.cmi +protocol.cmo: widget.cmi support.cmi protocol.cmi +protocol.cmx: widget.cmx support.cmx protocol.cmi rawwidget.cmo: support.cmi rawwidget.cmi rawwidget.cmx: support.cmx rawwidget.cmi slave.cmo: widget.cmi slave.cmx: widget.cmx support.cmo: support.cmi support.cmx: support.cmi -textvariable.cmo: protocol.cmi support.cmi widget.cmi textvariable.cmi -textvariable.cmx: protocol.cmx support.cmx widget.cmx textvariable.cmi -timer.cmo: protocol.cmi support.cmi timer.cmi -timer.cmx: protocol.cmx support.cmx timer.cmi -tkthread.cmo: protocol.cmi timer.cmi widget.cmi tkthread.cmi -tkthread.cmx: protocol.cmx timer.cmx widget.cmx tkthread.cmi +textvariable.cmo: widget.cmi support.cmi protocol.cmi textvariable.cmi +textvariable.cmx: widget.cmx support.cmx protocol.cmx textvariable.cmi +timer.cmo: support.cmi protocol.cmi timer.cmi +timer.cmx: support.cmx protocol.cmx timer.cmi +tkthread.cmo: widget.cmi timer.cmi protocol.cmi tkthread.cmi +tkthread.cmx: widget.cmx timer.cmx protocol.cmx tkthread.cmi widget.cmo: rawwidget.cmi widget.cmi widget.cmx: rawwidget.cmx widget.cmi diff --git a/otherlibs/labltk/support/Makefile b/otherlibs/labltk/support/Makefile index 3e315bfc..dd037a2b 100644 --- a/otherlibs/labltk/support/Makefile +++ b/otherlibs/labltk/support/Makefile @@ -2,48 +2,49 @@ include Makefile.common all: support.cmo rawwidget.cmo widget.cmo protocol.cmo \ textvariable.cmo timer.cmo fileevent.cmo camltkwrap.cmo \ - tkthread.cmo lib$(LIBNAME).a + tkthread.cmo lib$(LIBNAME).$(A) opt: support.cmx rawwidget.cmx widget.cmx protocol.cmx \ textvariable.cmx timer.cmx fileevent.cmx camltkwrap.cmx \ - tkthread.cmx lib$(LIBNAME).a + tkthread.cmx lib$(LIBNAME).$(A) -COBJS=cltkCaml.o cltkUtf.o cltkEval.o cltkEvent.o cltkFile.o cltkMain.o \ - cltkMisc.o cltkTimer.o cltkVar.o cltkWait.o cltkImg.o +COBJS=cltkCaml.$(O) cltkUtf.$(O) cltkEval.$(O) cltkEvent.$(O) \ + cltkFile.$(O) cltkMain.$(O) cltkMisc.$(O) cltkTimer.$(O) \ + cltkVar.$(O) cltkWait.$(O) cltkImg.$(O) CCFLAGS=-I../../../byterun $(TK_DEFS) $(SHAREDCCCOMPOPTS) -COMPFLAGS=-I $(OTHERS)/unix +COMPFLAGS=-I $(OTHERS)/win32unix -I $(OTHERS)/unix THFLAGS=-I $(OTHERS)/systhreads -I $(OTHERS)/threads -lib$(LIBNAME).a : $(COBJS) - $(MKLIB) -o $(LIBNAME) $(COBJS) $(TK_LINK) +lib$(LIBNAME).$(A): $(COBJS) + $(MKLIB) -o $(LIBNAME) $(COBJS) -ldopt "$(TK_LINK)" PUBMLI=fileevent.mli protocol.mli textvariable.mli timer.mli \ rawwidget.mli widget.mli PUB= $(PUBMLI) $(PUBMLI:.mli=.cmi) tkthread.mli tkthread.cmi tkthread.cmo -install: lib$(LIBNAME).a $(PUB) +install: if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi - cp $(PUB) lib$(LIBNAME).a $(INSTALLDIR) - cd $(INSTALLDIR); $(RANLIB) lib$(LIBNAME).a - cd $(INSTALLDIR); chmod 644 $(PUB) lib$(LIBNAME).a - if test -f dll$(LIBNAME).so; then \ - cp dll$(LIBNAME).so $(STUBLIBDIR)/dll$(LIBNAME).so; fi + cp $(PUB) lib$(LIBNAME).$(A) $(INSTALLDIR) + cd $(INSTALLDIR); $(RANLIB) lib$(LIBNAME).$(A) + cd $(INSTALLDIR); chmod 644 $(PUB) lib$(LIBNAME).$(A) + if test -f dll$(LIBNAME)$(EXT_DLL); then \ + cp dll$(LIBNAME)$(EXT_DLL) $(STUBLIBDIR)/; fi -installopt: opt +installopt: @if test -d $(INSTALLDIR); then : ; else mkdir $(INSTALLDIR); fi cp $(PUBMLI:.mli=.cmx) $(INSTALLDIR) - if test -f tkthread.cmx; then \ - cp tkthread.cmx tkthread.o $(INSTALLDIR); \ - chmod 644 $(INSTALLDIR)/tkthread.cmx $(INSTALLDIR)/tkthread.o; \ + if test -f tkthread.$(O); then \ + cp tkthread.cmx tkthread.$(O) $(INSTALLDIR); \ + chmod 644 $(INSTALLDIR)/tkthread.cmx $(INSTALLDIR)/tkthread.$(O); \ fi -clean : - rm -f *.cm* *.o *.a *.so +clean: + rm -f *.cm* *.o *.a *.so *.obj *.lib *.dll *.exp -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo .cmx .mlp .c .o +.SUFFIXES: +.SUFFIXES: .mli .ml .cmi .cmo .cmx .mlp .c .$(O) .mli.cmi: $(CAMLCOMP) $(COMPFLAGS) $< @@ -54,7 +55,7 @@ clean : .ml.cmx: $(CAMLOPT) -c $(COMPFLAGS) $< -.c.o: +.c.$(O): $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $< tkthread.cmi: tkthread.mli diff --git a/otherlibs/labltk/support/Makefile.common b/otherlibs/labltk/support/Makefile.common index b8aa786f..21580482 100644 --- a/otherlibs/labltk/support/Makefile.common +++ b/otherlibs/labltk/support/Makefile.common @@ -2,7 +2,7 @@ ## Where you compiled Objective Caml TOPDIR=../../.. ## Path to the otherlibs subdirectory -OTHERS=../.. +OTHERS=$(TOPDIR)/otherlibs LIBNAME=labltk @@ -13,8 +13,8 @@ INSTALLDIR=$(LIBDIR)/$(LIBNAME) ## Tools from the Objective Caml distribution CAMLRUN=$(TOPDIR)/boot/ocamlrun -CAMLC=$(TOPDIR)/ocamlcomp.sh -CAMLOPT=$(TOPDIR)/ocamlcompopt.sh +CAMLC=$(CAMLRUN) $(TOPDIR)/ocamlc -nostdlib -I $(TOPDIR)/stdlib +CAMLOPT=$(CAMLRUN) $(TOPDIR)/ocamlopt -nostdlib -I $(TOPDIR)/stdlib CAMLCOMP=$(CAMLC) -c -warn-error A CAMLYACC=$(TOPDIR)/boot/ocamlyacc -v CAMLLEX=$(CAMLRUN) $(TOPDIR)/boot/ocamllex diff --git a/otherlibs/labltk/support/Makefile.common.nt b/otherlibs/labltk/support/Makefile.common.nt deleted file mode 100644 index 3f37dda0..00000000 --- a/otherlibs/labltk/support/Makefile.common.nt +++ /dev/null @@ -1,30 +0,0 @@ -## Paths are relative to subdirectories -## Where you compiled Objective Caml -TOPDIR=../../.. -## Where to find OCaml binaries -EXEDIR=$(TOPDIR) -## Path to the otherlibs subdirectory -OTHERS=../.. - -LIBNAME=labltk - -include $(TOPDIR)/config/Makefile - -INSTALLDIR=$(LIBDIR)/$(LIBNAME) -TKLINKOPT=$(STATIC) - -## Tools from the Objective Caml distribution - -CAMLRUN=$(EXEDIR)/boot/ocamlrun -CAMLC=$(CAMLRUN) $(TOPDIR)/ocamlc -I $(TOPDIR)/stdlib -CAMLCOMP=$(CAMLC) -c -CAMLYACC=$(EXEDIR)/boot/ocamlyacc -v -CAMLLEX=$(CAMLRUN) $(TOPDIR)/boot/ocamllex -CAMLLIBR=$(CAMLC) -a -CAMLDEP=$(CAMLRUN) $(TOPDIR)/tools/ocamldep -COMPFLAGS= -LINKFLAGS= - -CAMLOPT=$(CAMLRUN) $(TOPDIR)/ocamlopt -I $(TOPDIR)/stdlib -CAMLOPTLIBR=$(CAMLOPT) -a -CAMLRUNGEN=../../boot/ocamlrun diff --git a/otherlibs/labltk/support/Makefile.nt b/otherlibs/labltk/support/Makefile.nt index 64188e3c..2b0b5ab5 100644 --- a/otherlibs/labltk/support/Makefile.nt +++ b/otherlibs/labltk/support/Makefile.nt @@ -1,80 +1 @@ -include Makefile.common.nt - -all: support.cmo rawwidget.cmo widget.cmo protocol.cmo \ - textvariable.cmo timer.cmo fileevent.cmo camltkwrap.cmo \ - tkthread.cmo dll$(LIBNAME).dll lib$(LIBNAME).$(A) - -opt: support.cmx rawwidget.cmx widget.cmx protocol.cmx \ - textvariable.cmx timer.cmx fileevent.cmx camltkwrap.cmx \ - tkthread.cmx lib$(LIBNAME).$(A) - -COBJS=cltkCaml.o cltkUtf.o cltkEval.o cltkEvent.o cltkFile.o \ - cltkMain.o cltkMisc.o cltkTimer.o cltkVar.o cltkWait.o cltkImg.o -DCOBJS=$(COBJS:.o=.$(DO)) -SCOBJS=$(COBJS:.o=.$(SO)) - -CCFLAGS=-I../../../byterun -I../../win32unix $(TK_DEFS) -DIN_CAMLTKSUPPORT - -COMPFLAGS=-I $(OTHERS)/win32unix -THFLAGS=-I $(OTHERS)/systhreads -I $(OTHERS)/threads - -dll$(LIBNAME).dll : $(DCOBJS) - $(call MKDLL,dll$(LIBNAME).dll,dll$(LIBNAME).$(A),\ - $(DCOBJS) ../../../byterun/ocamlrun.$(A) \ - $(TK_LINK) $(call SYSLIB,wsock32)) - -lib$(LIBNAME).$(A) : $(SCOBJS) - $(call MKLIB,lib$(LIBNAME).$(A), $(SCOBJS)) - -PUBMLI=fileevent.mli protocol.mli textvariable.mli timer.mli \ - rawwidget.mli widget.mli tkthread.mli -PUB= $(PUBMLI) $(PUBMLI:.mli=.cmi) tkthread.cmo - -install: - mkdir -p $(INSTALLDIR) - cp $(PUB) $(INSTALLDIR) - cp dll$(LIBNAME).dll $(STUBLIBDIR)/dll$(LIBNAME).dll - cp dll$(LIBNAME).$(A) lib$(LIBNAME).$(A) $(INSTALLDIR) - -installopt: - @mkdir -p $(INSTALLDIR) - cp $(PUBMLI:.mli=.cmx) $(INSTALLDIR) - cp tkthread.$(O) $(INSTALLDIR) - -clean : - rm -f *.cm* *.$(O) *.dll *.$(A) *.exp - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo .cmx .mlp .c .$(DO) .$(SO) - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.c.$(DO): - $(BYTECC) $(DLLCCCOMPOPTS) $(CCFLAGS) -c $< - mv $*.$(O) $*.$(DO) - -.c.$(SO): - $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $< - mv $*.$(O) $*.$(SO) - -tkthread.cmi: tkthread.mli - $(CAMLCOMP) $(COMPFLAGS) $(THFLAGS) $< -tkthread.cmo: tkthread.ml - $(CAMLCOMP) $(COMPFLAGS) $(THFLAGS) $< -tkthread.cmx: tkthread.ml - if test -f $(OTHERS)/systhreads/threads.cmxa; then \ - $(CAMLOPT) -c $(COMPFLAGS) $(THFLAGS) $< ; \ - fi -depend: - $(CAMLDEP) *.mli *.ml > .depend - -$(DCOBJS) $(SCOBJS): camltk.h - -include .depend +include Makefile diff --git a/otherlibs/labltk/support/camltk.h b/otherlibs/labltk/support/camltk.h index e8c5fc64..ba52fd1d 100644 --- a/otherlibs/labltk/support/camltk.h +++ b/otherlibs/labltk/support/camltk.h @@ -14,7 +14,7 @@ /* */ /*************************************************************************/ -/* $Id: camltk.h,v 1.11 2003/07/10 09:18:02 xleroy Exp $ */ +/* $Id: camltk.h,v 1.13 2008/09/26 07:35:24 garrigue Exp $ */ #if defined(_WIN32) && defined(CAML_DLL) && defined(IN_CAMLTKSUPPORT) #define CAMLTKextern CAMLexport @@ -22,6 +22,11 @@ #define CAMLTKextern CAMLextern #endif +/* compatibility with earlier versions of Tcl/Tk */ +#ifndef CONST84 +#define CONST84 +#endif + /* cltkMisc.c */ /* copy a Caml string to the C heap. Must be deallocated with stat_free */ extern char *string_to_c(value s); @@ -32,14 +37,14 @@ extern char * caml_string_to_tcl( value ); /* cltkEval.c */ CAMLTKextern Tcl_Interp *cltclinterp; /* The Tcl interpretor */ -extern value copy_string_list(int argc, char ** argv); +extern value copy_string_list(int argc, char **argv); /* cltkCaml.c */ /* pointers to Caml values */ extern value *tkerror_exn; extern value *handler_code; extern int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp, - int argc, char *argv[]); + int argc, CONST84 char *argv[]); CAMLTKextern void tk_error(char * errmsg) Noreturn; /* cltkMain.c */ diff --git a/otherlibs/labltk/support/cltkCaml.c b/otherlibs/labltk/support/cltkCaml.c index a1e28691..00a4d016 100644 --- a/otherlibs/labltk/support/cltkCaml.c +++ b/otherlibs/labltk/support/cltkCaml.c @@ -14,7 +14,7 @@ /* */ /***********************************************************************/ -/* $Id: cltkCaml.c,v 1.8 2002/04/26 12:16:17 furuse Exp $ */ +/* $Id: cltkCaml.c,v 1.10 2008/09/26 07:35:24 garrigue Exp $ */ #include #include @@ -28,7 +28,8 @@ value * tkerror_exn = NULL; value * handler_code = NULL; /* The Tcl command for evaluating callback in Caml */ -int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp, int argc, char **argv) +int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp, + int argc, CONST84 char **argv) { CheckInit(); @@ -38,7 +39,8 @@ int CamlCBCmd(ClientData clientdata, Tcl_Interp *interp, int argc, char **argv) int id; if (Tcl_GetInt(interp, argv[1], &id) != TCL_OK) return TCL_ERROR; - callback2(*handler_code,Val_int(id),copy_string_list(argc - 2,&argv[2])); + callback2(*handler_code,Val_int(id), + copy_string_list(argc - 2,(char **)&argv[2])); /* Never fails (Caml would have raised an exception) */ /* but result may have been set by callback */ return TCL_OK; diff --git a/otherlibs/labltk/support/cltkDMain.c b/otherlibs/labltk/support/cltkDMain.c index ae03ee87..1790e4e7 100644 --- a/otherlibs/labltk/support/cltkDMain.c +++ b/otherlibs/labltk/support/cltkDMain.c @@ -14,10 +14,10 @@ /* */ /*************************************************************************/ -/* $Id: cltkDMain.c,v 1.6 2001/12/07 13:40:08 xleroy Exp $ */ +/* $Id: cltkDMain.c,v 1.7 2008/07/01 09:55:52 weis Exp $ */ #include -#include +#include #include #include #include "gc.h" @@ -34,7 +34,7 @@ #endif -/* +/* * Dealing with signals: when a signal handler is defined in Caml, * the actual execution of the signal handler upon reception of the * signal is delayed until we are sure we are out of the GC. @@ -48,7 +48,7 @@ int signal_events = 0; /* do we have a pending timer */ -void invoke_pending_caml_signals (clientdata) +void invoke_pending_caml_signals (clientdata) ClientData clientdata; { signal_events = 0; @@ -203,7 +203,7 @@ int Caml_Init(interp) cltclinterp = interp; /* Create the camlcallback command */ Tcl_CreateCommand(cltclinterp, - CAMLCB, CamlCBCmd, + CAMLCB, CamlCBCmd, (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL); /* This is required by "unknown" and thus autoload */ @@ -220,7 +220,7 @@ int Caml_Init(interp) strcat(f, home); strcat(f, "/"); strcat(f, RCNAME); - if (0 == access(f,R_OK)) + if (0 == access(f,R_OK)) if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) { stat_free(f); tk_error(cltclinterp->result); @@ -228,7 +228,7 @@ int Caml_Init(interp) stat_free(f); } } - + /* Initialisations from caml_main */ { int verbose_init = 0, diff --git a/otherlibs/labltk/support/cltkEval.c b/otherlibs/labltk/support/cltkEval.c index 03843195..9dd212e0 100644 --- a/otherlibs/labltk/support/cltkEval.c +++ b/otherlibs/labltk/support/cltkEval.c @@ -14,7 +14,7 @@ /* */ /***********************************************************************/ -/* $Id: cltkEval.c,v 1.14 2004/05/17 17:10:00 doligez Exp $ */ +/* $Id: cltkEval.c,v 1.15 2008/07/01 09:55:52 weis Exp $ */ #include #include @@ -63,7 +63,7 @@ CAMLprim value camltk_tcl_eval(value str) char *cmd = NULL; CheckInit(); - + /* Tcl_Eval may write to its argument, so we take a copy * If the evaluation raises a Caml exception, we have a space * leak @@ -83,8 +83,7 @@ CAMLprim value camltk_tcl_eval(value str) } } - -/* +/* * Calling Tcl from Caml * direct call, argument is TkArgs vect type TkArgs = @@ -94,8 +93,8 @@ CAMLprim value camltk_tcl_eval(value str) * NO PARSING, NO SUBSTITUTION */ -/* - * Compute the size of the argument (of type TkArgs). +/* + * Compute the size of the argument (of type TkArgs). * TkTokenList must be expanded, * TkQuote count for one. */ @@ -119,14 +118,14 @@ int argv_size(value v) } /* Fill a preallocated vector arguments, doing expansion and all. - * Assumes Tcl will + * Assumes Tcl will * not tamper with our strings * make copies if strings are "persistent" */ int fill_args (char **argv, int where, value v) { value l; - + switch (Tag_val(v)) { case 0: argv[where] = caml_string_to_tcl(Field(v,0)); /* must free by stat_free */ @@ -144,10 +143,10 @@ int fill_args (char **argv, int where, value v) fill_args(tmpargv,0,Field(v,0)); tmpargv[size] = NULL; merged = Tcl_Merge(size,tmpargv); - for(i = 0 ; iresult); diff --git a/otherlibs/labltk/support/cltkImg.c b/otherlibs/labltk/support/cltkImg.c index 445338e0..d8d5dd3d 100644 --- a/otherlibs/labltk/support/cltkImg.c +++ b/otherlibs/labltk/support/cltkImg.c @@ -38,10 +38,10 @@ CAMLprim value camltk_getimgdata (value imgname) /* ML */ int code,size; #if (TK_MAJOR_VERSION < 8) - if (NULL == (ph = Tk_FindPhoto(String_val(imgname)))) + if (NULL == (ph = Tk_FindPhoto(String_val(imgname)))) tk_error("no such image"); #else - if (NULL == (ph = Tk_FindPhoto(cltclinterp, String_val(imgname)))) + if (NULL == (ph = Tk_FindPhoto(cltclinterp, String_val(imgname)))) tk_error("no such image"); #endif @@ -76,17 +76,17 @@ CAMLprim value camltk_getimgdata (value imgname) /* ML */ } CAMLprim void -camltk_setimgdata_native (value imgname, value pixmap, value x, value y, +camltk_setimgdata_native (value imgname, value pixmap, value x, value y, value w, value h) /* ML */ { Tk_PhotoHandle ph; Tk_PhotoImageBlock pib; #if (TK_MAJOR_VERSION < 8) - if (NULL == (ph = Tk_FindPhoto(String_val(imgname)))) + if (NULL == (ph = Tk_FindPhoto(String_val(imgname)))) tk_error("no such image"); #else - if (NULL == (ph = Tk_FindPhoto(cltclinterp, String_val(imgname)))) + if (NULL == (ph = Tk_FindPhoto(cltclinterp, String_val(imgname)))) tk_error("no such image"); #endif @@ -98,11 +98,15 @@ camltk_setimgdata_native (value imgname, value pixmap, value x, value y, pib.offset[0] = 0; pib.offset[1] = 1; pib.offset[2] = 2; - Tk_PhotoPutBlock(ph,&pib,Int_val(x),Int_val(y),Int_val(w),Int_val(h) + Tk_PhotoPutBlock( +#if (TK_MAJOR_VERSION == 8 && TK_MINOR_VERSION >= 5 || TK_MAJOR_VERSION > 8) + NULL, +#endif +ph,&pib,Int_val(x),Int_val(y),Int_val(w),Int_val(h) #if (TK_MAJOR_VERSION == 8 && TK_MINOR_VERSION >= 4 || TK_MAJOR_VERSION > 8) , TK_PHOTO_COMPOSITE_SET #endif - ); + ); } CAMLprim void camltk_setimgdata_bytecode(argv,argn) diff --git a/otherlibs/labltk/support/cltkMain.c b/otherlibs/labltk/support/cltkMain.c index 2f5a6e3f..f4cf1e08 100644 --- a/otherlibs/labltk/support/cltkMain.c +++ b/otherlibs/labltk/support/cltkMain.c @@ -14,7 +14,7 @@ /* */ /***********************************************************************/ -/* $Id: cltkMain.c,v 1.14 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: cltkMain.c,v 1.15 2008/07/01 09:55:52 weis Exp $ */ #include #include @@ -34,7 +34,7 @@ #define R_OK 4 #endif -/* +/* * Dealing with signals: when a signal handler is defined in Caml, * the actual execution of the signal handler upon reception of the * signal is delayed until we are sure we are out of the GC. @@ -122,7 +122,7 @@ CAMLprim value camltk_opentk(value argv) tmp = Field(tmp, 1); i++; } - + sprintf( argcstr, "%d", argc ); Tcl_SetVar(cltclinterp, "argc", argcstr, TCL_GLOBAL_ONLY); args = Tcl_Merge(argc, tkargv); /* args must be freed by Tcl_Free */ @@ -139,13 +139,13 @@ CAMLprim value camltk_opentk(value argv) if (NULL == cltk_mainWindow) tk_error(cltclinterp->result); - + Tk_GeometryRequest(cltk_mainWindow,200,200); } /* Create the camlcallback command */ Tcl_CreateCommand(cltclinterp, - CAMLCB, CamlCBCmd, + CAMLCB, CamlCBCmd, (ClientData)NULL,(Tcl_CmdDeleteProc *)NULL); /* This is required by "unknown" and thus autoload */ @@ -162,7 +162,7 @@ CAMLprim value camltk_opentk(value argv) strcat(f, home); strcat(f, "/"); strcat(f, RCNAME); - if (0 == access(f,R_OK)) + if (0 == access(f,R_OK)) if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) { stat_free(f); tk_error(cltclinterp->result); diff --git a/otherlibs/labltk/support/tkthread.ml b/otherlibs/labltk/support/tkthread.ml index 1d33b982..d4a03ee2 100644 --- a/otherlibs/labltk/support/tkthread.ml +++ b/otherlibs/labltk/support/tkthread.ml @@ -12,7 +12,7 @@ (* *) (***********************************************************************) -(* $Id: tkthread.ml,v 1.1.16.2 2007/08/05 23:53:05 garrigue Exp $ *) +(* $Id: tkthread.ml,v 1.3 2008/01/11 16:13:16 doligez Exp $ *) let jobs : (unit -> unit) Queue.t = Queue.create () let m = Mutex.create () diff --git a/otherlibs/labltk/support/tkthread.mli b/otherlibs/labltk/support/tkthread.mli index 15a62b9a..6fef9129 100644 --- a/otherlibs/labltk/support/tkthread.mli +++ b/otherlibs/labltk/support/tkthread.mli @@ -12,7 +12,7 @@ (* *) (***********************************************************************) -(* $Id: tkthread.mli,v 1.2.16.2 2007/08/05 23:53:05 garrigue Exp $ *) +(* $Id: tkthread.mli,v 1.4 2008/01/11 16:13:16 doligez Exp $ *) (* Helper functions for using LablTk with threads. To use, add tkthread.cmo or tkthread.cmx to your command line *) diff --git a/otherlibs/labltk/tkanim/Makefile b/otherlibs/labltk/tkanim/Makefile index be7e8a7b..574069ea 100644 --- a/otherlibs/labltk/tkanim/Makefile +++ b/otherlibs/labltk/tkanim/Makefile @@ -1,32 +1,33 @@ +# tkAnimGIF.c used the function Tk_ImageObjCmd, which is not available +# in a plain Tk installation. Should we disable this subdirectory ? + include ../support/Makefile.common -COMPFLAGS=-I ../../../byterun -I ../support -I ../camltk -I ../../unix +COMPFLAGS=-I ../support -I ../camltk -I ../../unix -I ../../win32unix CCFLAGS=-I../../../byterun -I../support $(TK_DEFS) $(SHAREDCCCOMPOPTS) -all: tkanim.cma libtkanim.a -opt: tkanim.cmxa libtkanim.a -example: gifanimtest +all: tkanim.cma libtkanim.$(A) +opt: tkanim.cmxa libtkanim.$(A) +example: gifanimtest$(EXE) OBJS=tkanim.cmo -COBJS= cltkaniminit.o tkAnimGIF.o +COBJS= cltkaniminit.$(O) tkAnimGIF.$(O) tkanim.cma: $(OBJS) - $(MKLIB) -ocamlc '$(CAMLC)' -o tkanim -oc tkanim \ - $(OBJS) $(TK_LINK) + $(MKLIB) -ocamlc '$(CAMLC)' -o tkanim $(OBJS) tkanim.cmxa: $(OBJS:.cmo=.cmx) - $(MKLIB) -ocamlopt '$(CAMLOPT)' -o tkanim -oc tkanim \ - $(OBJS:.cmo=.cmx) $(TK_LINK) + $(MKLIB) -ocamlopt '$(CAMLOPT)' -o tkanim $(OBJS:.cmo=.cmx) -libtkanim.a: $(COBJS) - $(MKLIB) -o tkanim $(COBJS) $(TK_LINK) +libtkanim.$(A): $(COBJS) + $(MKLIB) -o tkanim $(COBJS) -gifanimtest-static: all gifanimtest.cmo - $(CAMLC) -custom -o $@ -I ../lib -I ../support -I ../../unix -dllpath ../support -dllpath . unix.cma -ccopt -L. $(LIBNAME).cma tkanim.cma gifanimtest.cmo +gifanimtest-static$(EXE): all gifanimtest.cmo + $(CAMLC) -custom -o $@ -I ../lib -I ../support -I ../../win32unix -I ../../unix -dllpath ../support -dllpath . unix.cma -ccopt -L. $(LIBNAME).cma tkanim.cma gifanimtest.cmo # dynamic loading -gifanimtest: all gifanimtest.cmo - $(CAMLC) -o $@ -I ../lib -I ../support -I ../../unix -dllpath ../support -dllpath . unix.cma $(LIBNAME).cma tkanim.cma gifanimtest.cmo +gifanimtest$(EXE): all gifanimtest.cmo + $(CAMLC) -o $@ -I ../lib -I ../support -I ../../win32unix -I ../../unix -dllpath ../support -dllpath . unix.cma $(LIBNAME).cma tkanim.cma gifanimtest.cmo #animwish: $(TKANIM_LIB) tkAppInit.o # $(CC) -o $@ tkAppInit.o $(TK_LINK) $(X11_LINK) \ @@ -37,10 +38,10 @@ $(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma $(OBJS:.cmo=.cmx): ../lib/$(LIBNAME).cmxa clean: - rm -f *.cm* *.o *.a dlltkanim.so gifanimtest gifanimtest-static + rm -f *.cm* *.$(O) *.$(A) dlltkanim$(EXT_DLL) gifanimtest$(EXE) gifanimtest-static$(EXE) .SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo .mlp .cmx .c .o +.SUFFIXES : .mli .ml .cmi .cmo .mlp .cmx .c .$(O) .mli.cmi: $(CAMLCOMP) $(COMPFLAGS) $< @@ -51,18 +52,18 @@ clean: .ml.cmx: $(CAMLOPT) -c $(COMPFLAGS) $< -.c.o: +.c.$(O): $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $< -install: tkanim.cma - cp tkanim.cma *.cmi *.mli libtkanim.a $(INSTALLDIR) - if [ -f dlltkanim.so ]; then \ - cp dlltkanim.so $(STUBLIBDIR)/dlltkanim.so; \ +install: + cp tkanim.cma *.cmi *.mli libtkanim.$(A) $(INSTALLDIR) + if [ -f dlltkanim$(EXT_DLL) ]; then \ + cp dlltkanim$(EXT_DLL) $(STUBLIBDIR)/; \ fi -installopt: tkanim.cmxa - cp tkanim.cmxa tkanim.a $(INSTALLDIR) +installopt: + cp tkanim.cmxa tkanim.$(A) $(INSTALLDIR) depend: tkanim.ml $(CAMLDEP) *.mli *.ml > .depend diff --git a/otherlibs/labltk/tkanim/Makefile.nt b/otherlibs/labltk/tkanim/Makefile.nt index 9c6da7ee..2b0b5ab5 100644 --- a/otherlibs/labltk/tkanim/Makefile.nt +++ b/otherlibs/labltk/tkanim/Makefile.nt @@ -1,78 +1 @@ -include ../support/Makefile.common.nt - -CCFLAGS=-I../support -I../../../byterun $(TK_DEFS) - -COMPFLAGS=-I $(OTHERS)/win32unix -I ../support -I ../camltk - -all: tkanim.cma dlltkanim.dll libtkanim.$(A) -opt: tkanim.cmxa libtkanim.$(A) -example: gifanimtest.exe - -OBJS=tkanim.cmo -COBJS= cltkaniminit.obj tkAnimGIF.obj -DCOBJS=$(COBJS:.obj=.$(DO)) -SCOBJS=$(COBJS:.obj=.$(SO)) - -tkanim.cma: $(OBJS) - $(CAMLLIBR) -o tkanim.cma $(OBJS) \ - -dllib -ltkanim -cclib -ltkanim -cclib "$(TK_LINK)" - -tkanim.cmxa: $(OBJS:.cmo=.cmx) - $(CAMLOPTLIBR) -o tkanim.cmxa $(OBJS:.cmo=.cmx) \ - -cclib -ltkanim -cclib "$(TK_LINK)" - -libtkanim.$(A): $(SCOBJS) - $(call MKLIB,libtkanim.$(A), $(SCOBJS)) - -dlltkanim.dll: $(DCOBJS) - $(call MKDLL,dlltkanim.dll,tmp.$(A), \ - $(DCOBJS) ../support/dll$(LIBNAME).$(A) \ - ../../../byterun/ocamlrun.$(A) \ - $(TK_LINK) $(call SYSLIB,wsock32)) - rm tmp.* - -gifanimtest.exe: all gifanimtest.cmo - $(CAMLC) -custom -o $@ -I ../lib -I ../camltk -I ../support unix.cma $(LIBNAME).cma tkanim.cma gifanimtest.cmo - -# animwish: $(TKANIM_LIB) tkAppInit.o -# $(CC) -o $@ tkAppInit.o $(TK_LINK) $(X11_LINK) \ -# -L. -ltkanim $(LIBS) - -clean: - rm -f *.cm* *.$(O) *.$(A) *.dll gifanimtest.exe - -$(OBJS) $(OBJS:.cmo=.cmi): ../lib/$(LIBNAME).cma - -$(OBJS:.cmo=.cmx): ../lib/$(LIBNAME).cmxa - -.SUFFIXES : -.SUFFIXES : .mli .ml .cmi .cmo .mlp .cmx .c .$(DO) .$(SO) - -.mli.cmi: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLCOMP) $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.c.$(DO): - $(BYTECC) $(DLLCCCOMPOPTS) $(CCFLAGS) -c $< - mv $*.$(O) $*.$(DO) - -.c.$(SO): - $(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $< - mv $*.$(O) $*.$(SO) - -install: tkanim.cma - cp dlltkanim.dll $(STUBLIBDIR)/dlltkanim.dll - cp tkanim.cma *.cmi *.mli libtkanim.$(A) $(INSTALLDIR) - -installopt: tkanim.cmxa - cp tkanim.cmxa tkanim.$(A) $(INSTALLDIR) - -depend: tkanim.ml - $(CAMLDEP) *.mli *.ml > .depend - -include .depend +include Makefile diff --git a/otherlibs/labltk/tkanim/tkAnimGIF.c b/otherlibs/labltk/tkanim/tkAnimGIF.c index d8eb11eb..8a6ef52e 100644 --- a/otherlibs/labltk/tkanim/tkAnimGIF.c +++ b/otherlibs/labltk/tkanim/tkAnimGIF.c @@ -334,7 +334,11 @@ FileReadGIF(interp, f, fileName, formatString) goto error; } } - Tk_PhotoPutBlock(photoHandle, &block, 0, 0, imageWidth, imageHeight + Tk_PhotoPutBlock( +#if (TK_MAJOR_VERSION == 8 && TK_MINOR_VERSION >= 5 || TK_MAJOR_VERSION > 8) + NULL, +#endif +photoHandle, &block, 0, 0, imageWidth, imageHeight #if (TK_MAJOR_VERSION == 8 && TK_MINOR_VERSION >= 4 || TK_MAJOR_VERSION > 8) , TK_PHOTO_COMPOSITE_SET #endif diff --git a/otherlibs/num/.depend b/otherlibs/num/.depend index 6fa1caf7..51dcc1cf 100644 --- a/otherlibs/num/.depend +++ b/otherlibs/num/.depend @@ -27,7 +27,11 @@ nat_stubs.o: nat_stubs.c ../../byterun/alloc.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 +arith_flags.cmi: +arith_status.cmi: big_int.cmi: nat.cmi +int_misc.cmi: +nat.cmi: num.cmi: ratio.cmi nat.cmi big_int.cmi ratio.cmi: nat.cmi big_int.cmi arith_flags.cmo: arith_flags.cmi diff --git a/otherlibs/num/Makefile b/otherlibs/num/Makefile index cb461bab..9c377caf 100644 --- a/otherlibs/num/Makefile +++ b/otherlibs/num/Makefile @@ -11,72 +11,24 @@ # # ######################################################################### -# $Id: Makefile,v 1.35 2007/01/29 12:11:16 xleroy Exp $ +# $Id: Makefile,v 1.37 2008/09/10 16:10:43 weis Exp $ # Makefile for the "num" (exact rational arithmetic) library -include ../../config/Makefile - -# Compilation options -CC=$(BYTECC) -CFLAGS=-O -I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) \ - -DBNG_ARCH_$(BNG_ARCH) -DBNG_ASM_LEVEL=$(BNG_ASM_LEVEL) -CAMLC=../../ocamlcomp.sh -CAMLOPT=../../ocamlcompopt.sh -MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-warn-error A -g - +LIBNAME=nums +EXTRACFLAGS=-DBNG_ARCH_$(BNG_ARCH) -DBNG_ASM_LEVEL=$(BNG_ASM_LEVEL) CAMLOBJS=int_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \ ratio.cmo num.cmo arith_status.cmo - CMIFILES=big_int.cmi nat.cmi num.cmi ratio.cmi arith_status.cmi +COBJS=bng.$(O) nat_stubs.$(O) -COBJS=bng.o nat_stubs.o - -all: libnums.a nums.cma $(CMIFILES) - -allopt: libnums.a nums.cmxa $(CMIFILES) - -nums.cma: $(CAMLOBJS) - $(MKLIB) -ocamlc '$(CAMLC)' -o nums $(CAMLOBJS) - -nums.cmxa: $(CAMLOBJS:.cmo=.cmx) - $(MKLIB) -ocamlopt '$(CAMLOPT)' -o nums $(CAMLOBJS:.cmo=.cmx) - -libnums.a: $(COBJS) - $(MKLIB) -o nums $(COBJS) +include ../Makefile -$(CAMLOBJS:.cmo=.cmx): ../../ocamlopt - -install: - if test -f dllnums.so; then cp dllnums.so $(STUBLIBDIR)/dllnums.so; fi - cp libnums.a $(LIBDIR)/libnums.a - cd $(LIBDIR); $(RANLIB) libnums.a - cp nums.cma $(CMIFILES) $(CMIFILES:.cmi=.mli) $(LIBDIR) - -installopt: - cp $(CAMLOBJS:.cmo=.cmx) nums.cmxa nums.a $(LIBDIR) - cd $(LIBDIR); $(RANLIB) nums.a - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.a *.o *.so +clean:: + rm -f *~ cd test; $(MAKE) clean -.SUFFIXES: .ml .mli .cmi .cmo .cmx - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -bng.o: bng.h bng_digit.c \ +bng.$(O): bng.h bng_digit.c \ bng_alpha.c bng_amd64.c bng_ia32.c bng_mips.c bng_ppc.c bng_sparc.c depend: diff --git a/otherlibs/num/Makefile.nt b/otherlibs/num/Makefile.nt index 22a4f536..00490e6d 100644 --- a/otherlibs/num/Makefile.nt +++ b/otherlibs/num/Makefile.nt @@ -11,87 +11,26 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.21 2007/01/29 12:11:16 xleroy Exp $ +# $Id: Makefile.nt,v 1.22 2007/11/06 15:16:56 frisch Exp $ # Makefile for the "num" (exact rational arithmetic) library -include ../../config/Makefile - -# Compilation options -CC=$(BYTECC) -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 - +LIBNAME=nums +EXTRACFLAGS=-DBNG_ARCH_$(BNG_ARCH) -DBNG_ASM_LEVEL=$(BNG_ASM_LEVEL) CAMLOBJS=int_misc.cmo nat.cmo big_int.cmo arith_flags.cmo \ ratio.cmo num.cmo arith_status.cmo - CMIFILES=big_int.cmi nat.cmi num.cmi ratio.cmi arith_status.cmi +COBJS=bng.$(O) nat_stubs.$(O) -DCOBJS=bng.$(DO) nat_stubs.$(DO) -SCOBJS=bng.$(SO) nat_stubs.$(SO) - -all: dllnums.dll libnums.$(A) nums.cma $(CMIFILES) - -allopt: libnums.$(A) nums.cmxa $(CMIFILES) - -nums.cma: $(CAMLOBJS) - $(CAMLC) -a -o nums.cma $(CAMLOBJS) -dllib -lnums -cclib -lnums - -nums.cmxa: $(CAMLOBJS:.cmo=.cmx) - $(CAMLOPT) -a -o nums.cmxa $(CAMLOBJS:.cmo=.cmx) -cclib -lnums - -dllnums.dll: $(DCOBJS) - $(call MKDLL,dllnums.dll,tmp.$(A),\ - $(DCOBJS) ../../byterun/ocamlrun.$(A)) - rm tmp.* - -libnums.$(A): $(SCOBJS) - $(call MKLIB,libnums.$(A),$(SCOBJS)) - -$(CAMLOBJS:.cmo=.cmx): ../../ocamlopt +include ../Makefile.nt -install: - cp dllnums.dll $(STUBLIBDIR)/dllnums.dll - cp libnums.$(A) $(LIBDIR)/libnums.$(A) - cp nums.cma $(CMIFILES) $(LIBDIR) - -installopt: - cp $(CAMLOBJS:.cmo=.cmx) nums.cmxa nums.$(A) $(LIBDIR) - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.dll *.$(A) *.$(O) +clean:: cd test ; $(MAKEREC) clean -.SUFFIXES: .ml .mli .cmi .cmo .cmx .$(DO) .$(SO) - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.c.$(DO): - $(BYTECC) $(DLLCCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(DO) - -.c.$(SO): - $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(SO) - -bng.$(DO) bng.$(SO): bng.h bng_digit.c \ +bng.$(O): bng.h bng_digit.c \ bng_alpha.c bng_amd64.c bng_ia32.c bng_mips.c bng_ppc.c bng_sparc.c depend: - sed -e 's/\.o/.$(DO)/g' .depend > .depend.nt - sed -e 's/\.o/.$(SO)/g' .depend >> .depend.nt + sed -e 's/\.o/.$(O)/g' .depend > .depend.nt include .depend.nt diff --git a/otherlibs/num/big_int.ml b/otherlibs/num/big_int.ml index 9802f803..dd8c3364 100644 --- a/otherlibs/num/big_int.ml +++ b/otherlibs/num/big_int.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: big_int.ml,v 1.22 2005/08/13 20:59:37 doligez Exp $ *) +(* $Id: big_int.ml,v 1.24 2008/08/03 09:04:40 xleroy Exp $ *) open Int_misc open Nat @@ -327,6 +327,74 @@ let int_of_big_int bi = if eq_big_int bi monster_big_int then monster_int else failwith "int_of_big_int";; +let big_int_of_nativeint i = + if i = 0n then + zero_big_int + else if i > 0n then begin + let res = create_nat 1 in + set_digit_nat_native res 0 i; + { sign = 1; abs_value = res } + end else begin + let res = create_nat 1 in + set_digit_nat_native res 0 (Nativeint.neg i); + { sign = -1; abs_value = res } + end + +let nativeint_of_big_int bi = + if num_digits_big_int bi > 1 then failwith "nativeint_of_big_int"; + let i = nth_digit_nat_native bi.abs_value 0 in + if bi.sign >= 0 then + if i >= 0n then i else failwith "nativeint_of_big_int" + else + if i >= 0n || i = Nativeint.min_int + then Nativeint.neg i + else failwith "nativeint_of_big_int" + +let big_int_of_int32 i = big_int_of_nativeint (Nativeint.of_int32 i) + +let int32_of_big_int bi = + let i = nativeint_of_big_int bi in + if i <= 0x7FFF_FFFFn && i >= -0x8000_0000n + then Nativeint.to_int32 i + else failwith "int32_of_big_int" + +let big_int_of_int64 i = + if Sys.word_size = 64 then + big_int_of_nativeint (Int64.to_nativeint i) + else begin + let (sg, absi) = + if i = 0L then (0, 0L) + else if i > 0L then (1, i) + else (-1, Int64.neg i) in + let res = create_nat 2 in + set_digit_nat_native res 0 (Int64.to_nativeint i); + set_digit_nat_native res 1 (Int64.to_nativeint (Int64.shift_right i 32)); + { sign = sg; abs_value = res } + end + +let int64_of_big_int bi = + if Sys.word_size = 64 then + Int64.of_nativeint (nativeint_of_big_int bi) + else begin + let i = + match num_digits_big_int bi with + | 1 -> Int64.of_nativeint (nth_digit_nat_native bi.abs_value 0) + | 2 -> Int64.logor + (Int64.logand + (Int64.of_nativeint (nth_digit_nat_native bi.abs_value 0)) + 0xFFFFFFFFL) + (Int64.shift_left + (Int64.of_nativeint (nth_digit_nat_native bi.abs_value 1)) + 32) + | _ -> failwith "int64_of_big_int" in + if bi.sign >= 0 then + if i >= 0L then i else failwith "int64_of_big_int" + else + if i >= 0L || i = Int64.min_int + then Int64.neg i + else failwith "int64_of_big_int" + end + (* Coercion with nat type *) let nat_of_big_int bi = if bi.sign = -1 @@ -553,14 +621,14 @@ let round_futur_last_digit s off_set length = if Char.code(String.get s l) >= Char.code '5' then let rec round_rec l = - let current_char = String.get s l in - if current_char = '9' - then - (String.set s l '0'; - if l = off_set then true else round_rec (pred l)) - else - (String.set s l (Char.chr (succ (Char.code current_char))); - false) + if l < off_set then true else begin + let current_char = String.get s l in + if current_char = '9' then + (String.set s l '0'; round_rec (pred l)) + else + (String.set s l (Char.chr (succ (Char.code current_char))); + false) + end in round_rec (pred l) else false diff --git a/otherlibs/num/big_int.mli b/otherlibs/num/big_int.mli index 7fd13692..bd477f39 100644 --- a/otherlibs/num/big_int.mli +++ b/otherlibs/num/big_int.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: big_int.mli,v 1.10 2002/03/14 20:12:54 xleroy Exp $ *) +(* $Id: big_int.mli,v 1.11 2008/01/04 13:15:52 xleroy Exp $ *) (** Operations on arbitrary-precision integers. @@ -128,6 +128,26 @@ val int_of_big_int : big_int -> int (** Convert a big integer to a small integer (type [int]). Raises [Failure "int_of_big_int"] if the big integer is not representable as a small integer. *) + +val big_int_of_int32 : int32 -> big_int + (** Convert a 32-bit integer to a big integer. *) +val big_int_of_nativeint : nativeint -> big_int + (** Convert a native integer to a big integer. *) +val big_int_of_int64 : int64 -> big_int + (** Convert a 64-bit integer to a big integer. *) +val int32_of_big_int : big_int -> int32 + (** Convert a big integer to a 32-bit integer. + Raises [Failure] if the big integer is outside the + range [[-2{^31}, 2{^31}-1]]. *) +val nativeint_of_big_int : big_int -> nativeint + (** Convert a big integer to a native integer. + Raises [Failure] if the big integer is outside the + range [[Nativeint.min_int, Nativeint.max_int]]. *) +val int64_of_big_int : big_int -> int64 + (** Convert a big integer to a 64-bit integer. + Raises [Failure] if the big integer is outside the + range [[-2{^63}, 2{^63}-1]]. *) + val float_of_big_int : big_int -> float (** Returns a floating-point number approximating the given big integer. *) diff --git a/otherlibs/num/nat.ml b/otherlibs/num/nat.ml index 639674aa..36401d93 100644 --- a/otherlibs/num/nat.ml +++ b/otherlibs/num/nat.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: nat.ml,v 1.15 2005/01/21 14:15:44 maranget Exp $ *) +(* $Id: nat.ml,v 1.16 2008/01/04 13:15:52 xleroy Exp $ *) open Int_misc @@ -22,6 +22,8 @@ external set_to_zero_nat: nat -> int -> int -> unit = "set_to_zero_nat" external blit_nat: nat -> int -> nat -> int -> int -> unit = "blit_nat" external set_digit_nat: nat -> int -> int -> unit = "set_digit_nat" external nth_digit_nat: nat -> int -> int = "nth_digit_nat" +external set_digit_nat_native: nat -> int -> nativeint -> unit = "set_digit_nat_native" +external nth_digit_nat_native: nat -> int -> nativeint = "nth_digit_nat_native" external num_digits_nat: nat -> int -> int -> int = "num_digits_nat" external num_leading_zero_bits_in_digit: nat -> int -> int = "num_leading_zero_bits_in_digit" external is_digit_int: nat -> int -> bool = "is_digit_int" @@ -568,4 +570,3 @@ let sys_nat_of_string base s off len = let nat_of_string s = sys_nat_of_string 10 s 0 (String.length s) let float_of_nat nat = float_of_string(string_of_nat nat) - diff --git a/otherlibs/num/nat.mli b/otherlibs/num/nat.mli index b3cb6da2..68142037 100644 --- a/otherlibs/num/nat.mli +++ b/otherlibs/num/nat.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: nat.mli,v 1.11 2003/11/07 07:59:09 xleroy Exp $ *) +(* $Id: nat.mli,v 1.12 2008/01/04 13:15:52 xleroy Exp $ *) (* Module [Nat]: operations on natural numbers *) @@ -27,6 +27,8 @@ external blit_nat: nat -> int -> nat -> int -> int -> unit = "blit_nat" val copy_nat: nat -> int -> int -> nat external set_digit_nat: nat -> int -> int -> unit = "set_digit_nat" external nth_digit_nat: nat -> int -> int = "nth_digit_nat" +external set_digit_nat_native: nat -> int -> nativeint -> unit = "set_digit_nat_native" +external nth_digit_nat_native: nat -> int -> nativeint = "nth_digit_nat_native" val length_nat : nat -> int external num_digits_nat: nat -> int -> int -> int = "num_digits_nat" external num_leading_zero_bits_in_digit: nat -> int -> int = "num_leading_zero_bits_in_digit" diff --git a/otherlibs/num/nat_stubs.c b/otherlibs/num/nat_stubs.c index 40db80d9..2318ab3d 100644 --- a/otherlibs/num/nat_stubs.c +++ b/otherlibs/num/nat_stubs.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: nat_stubs.c,v 1.16.10.1 2007/10/25 09:23:30 xleroy Exp $ */ +/* $Id: nat_stubs.c,v 1.18 2008/01/11 16:13:16 doligez Exp $ */ #include "alloc.h" #include "config.h" @@ -84,6 +84,17 @@ CAMLprim value nth_digit_nat(value nat, value ofs) return Val_long(Digit_val(nat, Long_val(ofs))); } +CAMLprim value set_digit_nat_native(value nat, value ofs, value digit) +{ + Digit_val(nat, Long_val(ofs)) = Nativeint_val(digit); + return Val_unit; +} + +CAMLprim value nth_digit_nat_native(value nat, value ofs) +{ + return caml_copy_nativeint(Digit_val(nat, Long_val(ofs))); +} + CAMLprim value num_digits_nat(value nat, value ofs, value len) { return Val_long(bng_num_digits(&Digit_val(nat, Long_val(ofs)), diff --git a/otherlibs/num/num.ml b/otherlibs/num/num.ml index c2ad78a9..64eaed0e 100644 --- a/otherlibs/num/num.ml +++ b/otherlibs/num/num.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: num.ml,v 1.7 2005/01/21 14:15:44 maranget Exp $ *) +(* $Id: num.ml,v 1.8 2008/09/10 16:12:05 weis Exp $ *) open Int_misc open Nat @@ -26,7 +26,7 @@ let biggest_INT = big_int_of_int biggest_int and least_INT = big_int_of_int least_int (* Coercion big_int -> num *) -let num_of_big_int bi = +let num_of_big_int bi = if le_big_int bi biggest_INT && ge_big_int bi least_INT then Int (int_of_big_int bi) else Big_int bi @@ -49,8 +49,8 @@ let normalize_num = function let cautious_normalize_num_when_printing n = if (!normalize_ratio_when_printing_flag) then (normalize_num n) else n -let num_of_ratio r = - ignore (normalize_ratio r); +let num_of_ratio r = + ignore (normalize_ratio r); if not (is_integer_ratio r) then Ratio r else if is_int_big_int (numerator_ratio r) then Int (int_of_big_int (numerator_ratio r)) @@ -85,7 +85,7 @@ let add_num a b = match (a,b) with let ( +/ ) = add_num -let minus_num = function +let minus_num = function Int i -> if i = monster_int then Big_int (minus_big_int (big_int_of_int i)) else Int (-i) @@ -100,7 +100,7 @@ let mult_num a b = match (a,b) with ((Int int1), (Int int2)) -> if num_bits_int int1 + num_bits_int int2 < length_of_int then Int (int1 * int2) - else num_of_big_int (mult_big_int (big_int_of_int int1) + else num_of_big_int (mult_big_int (big_int_of_int int1) (big_int_of_int int2)) | ((Int i), (Big_int bi)) -> @@ -113,7 +113,7 @@ let mult_num a b = match (a,b) with | ((Ratio r), (Int i)) -> num_of_ratio (mult_int_ratio i r) - | ((Big_int bi1), (Big_int bi2)) -> + | ((Big_int bi1), (Big_int bi2)) -> num_of_big_int (mult_big_int bi1 bi2) | ((Big_int bi), (Ratio r)) -> @@ -127,7 +127,7 @@ let mult_num a b = match (a,b) with let ( */ ) = mult_num let square_num = function - Int i -> if 2 * num_bits_int i < length_of_int + Int i -> if 2 * num_bits_int i < length_of_int then Int (i * i) else num_of_big_int (square_big_int (big_int_of_int i)) | Big_int bi -> Big_int (square_big_int bi) @@ -162,9 +162,57 @@ let floor_num = function | Big_int bi as n -> n | Ratio r -> num_of_big_int (floor_ratio r) -let quo_num x y = floor_num (div_num x y) +(* The function [quo_num] is equivalent to -let mod_num x y = sub_num x (mult_num y (quo_num x y)) + let quo_num x y = floor_num (div_num x y);; + + However, this definition is vastly inefficient (cf PR #3473): + we define here a better way of computing the same thing. + *) +let quo_num n1 n2 = + match n1 with + | Int i1 -> + begin match n2 with + | Int i2 -> Int (i1 / i2) + | Big_int bi2 -> num_of_big_int (div_big_int (big_int_of_int i1) bi2) + | Ratio r2 -> num_of_big_int (floor_ratio (div_int_ratio i1 r2)) end + + | Big_int bi1 -> + begin match n2 with + | Int i2 -> num_of_big_int (div_big_int bi1 (big_int_of_int i2)) + | Big_int bi2 -> num_of_big_int (div_big_int bi1 bi2) + | Ratio r2 -> num_of_big_int (floor_ratio (div_big_int_ratio bi1 r2)) end + + | Ratio r1 -> + begin match n2 with + | Int i2 -> num_of_big_int (floor_ratio (div_ratio_int r1 i2)) + | Big_int bi2 -> num_of_big_int (floor_ratio (div_ratio_big_int r1 bi2)) + | Ratio r2 -> num_of_big_int (floor_ratio (div_ratio r1 r2)) end +;; + +(* The function [mod_num] is equivalent to: + + let mod_num x y = sub_num x (mult_num y (quo_num x y));; + + However, as for [quo_num] above, this definition is inefficient: + we define here a better way of computing the same thing. + *) +let mod_num n1 n2 = + match n1 with + | Int i1 -> + begin match n2 with + | Int i2 -> Int (i1 mod i2) + | Big_int bi2 -> num_of_big_int (mod_big_int (big_int_of_int i1) bi2) + | Ratio _r2 -> sub_num n1 (mult_num n2 (quo_num n1 n2)) end + + | Big_int bi1 -> + begin match n2 with + | Int i2 -> num_of_big_int (mod_big_int bi1 (big_int_of_int i2)) + | Big_int bi2 -> num_of_big_int (mod_big_int bi1 bi2) + | Ratio _r2 -> sub_num n1 (mult_num n2 (quo_num n1 n2)) end + + | Ratio _r1 -> sub_num n1 (mult_num n2 (quo_num n1 n2)) +;; let power_num_int a b = match (a,b) with ((Int i), n) -> @@ -173,7 +221,7 @@ let power_num_int a b = match (a,b) with | 1 -> num_of_big_int (power_int_positive_int i n) | _ -> Ratio (create_normalized_ratio unit_big_int (power_int_positive_int i (-n)))) -| ((Big_int bi), n) -> +| ((Big_int bi), n) -> (match sign_int n with 0 -> Int 1 | 1 -> num_of_big_int (power_big_int_positive_int bi n) @@ -183,29 +231,29 @@ let power_num_int a b = match (a,b) with (match sign_int n with 0 -> Int 1 | 1 -> Ratio (power_ratio_positive_int r n) - | _ -> Ratio (power_ratio_positive_int + | _ -> Ratio (power_ratio_positive_int (inverse_ratio r) (-n))) let power_num_big_int a b = match (a,b) with - ((Int i), n) -> + ((Int i), n) -> (match sign_big_int n with 0 -> Int 1 | 1 -> num_of_big_int (power_int_positive_big_int i n) | _ -> Ratio (create_normalized_ratio - unit_big_int + unit_big_int (power_int_positive_big_int i (minus_big_int n)))) -| ((Big_int bi), n) -> +| ((Big_int bi), n) -> (match sign_big_int n with 0 -> Int 1 | 1 -> num_of_big_int (power_big_int_positive_big_int bi n) | _ -> Ratio (create_normalized_ratio - unit_big_int + unit_big_int (power_big_int_positive_big_int bi (minus_big_int n)))) | ((Ratio r), n) -> (match sign_big_int n with 0 -> Int 1 | 1 -> Ratio (power_ratio_positive_big_int r n) - | _ -> Ratio (power_ratio_positive_big_int + | _ -> Ratio (power_ratio_positive_big_int (inverse_ratio r) (minus_big_int n))) let power_num a b = match (a,b) with @@ -221,7 +269,7 @@ let is_integer_num = function | Ratio r -> is_integer_ratio r (* integer_num, floor_num, round_num, ceiling_num rendent des nums *) -let integer_num = function +let integer_num = function Int i as n -> n | Big_int bi as n -> n | Ratio r -> num_of_big_int (integer_ratio r) @@ -300,7 +348,7 @@ let int_of_num = function | Big_int bi -> int_of_big_int bi | Ratio r -> int_of_ratio r -and num_of_int i = +and num_of_int i = if i = monster_int then Big_int (big_int_of_int i) else Int i @@ -312,7 +360,7 @@ let nat_of_num = function | Ratio r -> nat_of_ratio r and num_of_nat nat = - if (is_nat_int nat 0 (length_nat nat)) + if (is_nat_int nat 0 (length_nat nat)) then Int (nth_digit_nat nat 0) else Big_int (big_int_of_nat nat) @@ -326,10 +374,11 @@ let big_int_of_num = function let ratio_of_num = function Int i -> ratio_of_int i | Big_int bi -> ratio_of_big_int bi -| Ratio r -> r;; +| Ratio r -> r +;; let string_of_big_int_for_num bi = - if !approx_printing_flag + if !approx_printing_flag then approx_big_int !floating_precision bi else string_of_big_int bi @@ -340,7 +389,7 @@ let string_of_big_int_for_num bi = let string_of_normalized_num = function Int i -> string_of_int i | Big_int bi -> string_of_big_int_for_num bi -| Ratio r -> string_of_ratio r +| Ratio r -> string_of_ratio r let string_of_num n = string_of_normalized_num (cautious_normalize_num_when_printing n) let num_of_string s = @@ -349,7 +398,7 @@ let num_of_string s = normalize_ratio_flag := true; let r = ratio_of_string s in normalize_ratio_flag := flag; - if eq_big_int (denominator_ratio r) unit_big_int + if eq_big_int (denominator_ratio r) unit_big_int then num_of_big_int (numerator_ratio r) else Ratio r with Failure _ -> diff --git a/otherlibs/num/ratio.ml b/otherlibs/num/ratio.ml index 3ee228a6..e587efe3 100644 --- a/otherlibs/num/ratio.ml +++ b/otherlibs/num/ratio.ml @@ -425,55 +425,54 @@ let approx_ratio_fix n r = let sign_r = sign_ratio r in if sign_r = 0 then "+0" (* r = 0 *) - else (* r.numerator and r.denominator are not null numbers - s contains one more digit than desired for the round off operation - and to have enough room in s when including the decimal point *) - if n >= 0 then - let s = - let nat = + else + (* r.numerator and r.denominator are not null numbers + s1 contains one more digit than desired for the round off operation *) + if n >= 0 then begin + let s1 = + string_of_nat (nat_of_big_int (div_big_int (base_power_big_int 10 (succ n) (abs_big_int r.numerator)) - r.denominator)) - in (if sign_r = -1 then "-" else "+") ^ string_of_nat nat in - let l = String.length s in - if round_futur_last_digit s 1 (pred l) - then begin (* if one more char is needed in s *) - let str = (String.make (succ l) '0') in - String.set str 0 (if sign_r = -1 then '-' else '+'); - String.set str 1 '1'; - String.set str (l - n) '.'; - str - end else (* s can contain the final result *) - if l > n + 2 - then begin (* |r| >= 1, set decimal point *) - let l2 = (pred l) - n in - String.blit s l2 s (succ l2) n; - String.set s l2 '.'; s - end else begin (* |r| < 1, there must be 0-characters *) - (* before the significant development, *) - (* with care to the sign of the number *) - let size = n + 3 in - let m = size - l + 2 - and str = String.make size '0' in - - (String.blit (if sign_r = 1 then "+0." else "-0.") 0 str 0 3); - (String.blit s 1 str m (l - 2)); - str - end - else begin - let s = string_of_big_int - (div_big_int - (abs_big_int r.numerator) - (base_power_big_int - 10 (-n) r.denominator)) in - let len = succ (String.length s) in - let s' = String.make len '0' in - String.set s' 0 (if sign_r = -1 then '-' else '+'); - String.blit s 0 s' 1 (pred len); - s' + r.denominator)) in + (* Round up and add 1 in front if needed *) + let s2 = + if round_futur_last_digit s1 0 (String.length s1) + then "1" ^ s1 + else s1 in + let l2 = String.length s2 - 1 in + (* if s2 without last digit is xxxxyyy with n 'yyy' digits: + xxxx . yyy + if s2 without last digit is yy with <= n digits: + 0 . 0yy *) + if l2 > n then begin + let s = String.make (l2 + 2) '0' in + String.set s 0 (if sign_r = -1 then '-' else '+'); + String.blit s2 0 s 1 (l2 - n); + String.set s (l2 - n + 1) '.'; + String.blit s2 (l2 - n) s (l2 - n + 2) n; + s + end else begin + let s = String.make (n + 3) '0' in + String.set s 0 (if sign_r = -1 then '-' else '+'); + String.set s 2 '.'; + String.blit s2 0 s (n + 3 - l2) l2; + s end + end else begin + (* Dubious; what is this code supposed to do? *) + let s = string_of_big_int + (div_big_int + (abs_big_int r.numerator) + (base_power_big_int + 10 (-n) r.denominator)) in + let len = succ (String.length s) in + let s' = String.make len '0' in + String.set s' 0 (if sign_r = -1 then '-' else '+'); + String.blit s 0 s' 1 (pred len); + s' + end (* Number of digits of the decimal representation of an int *) let num_decimal_digits_int n = diff --git a/otherlibs/num/test/Makefile b/otherlibs/num/test/Makefile index db832b26..92f6a06f 100644 --- a/otherlibs/num/test/Makefile +++ b/otherlibs/num/test/Makefile @@ -11,17 +11,18 @@ # # ######################################################################### -# $Id: Makefile,v 1.10 2005/09/22 14:21:50 xleroy Exp $ +# $Id: Makefile,v 1.13 2008/09/10 16:02:52 weis Exp $ include ../../../config/Makefile -CAMLC=../../../boot/ocamlrun ../../../ocamlc -I ../../../stdlib +CAMLC=../../../boot/ocamlrun ../../../ocamlc -I ../../../stdlib -w A -warn-error A CAMLOPT=../../../boot/ocamlrun ../../../ocamlopt -I ../../../stdlib CC=$(BYTECC) CFLAGS=-I.. -I../../../byterun $(BYTECCCOMPOPTS) -test: test.byt test.opt - if $(SUPPORTS_SHARED_LIBRARIES); then ../../../byterun/ocamlrun -I .. ./test.byt; else ./test.byt; fi +test: test.byt test.opt test_pi + if $(SUPPORTS_SHARED_LIBRARIES); \ + then ../../../byterun/ocamlrun -I .. ./test.byt; else ./test.byt; fi ./test.opt TESTFILES=test.cmo \ @@ -31,20 +32,34 @@ TESTFILES=test.cmo \ TESTOPTFILES=$(TESTFILES:.cmo=.cmx) test.byt: $(TESTFILES) ../nums.cma ../libnums.a - $(CAMLC) -ccopt -L.. -o test.byt ../nums.cma $(TESTFILES) + $(CAMLC) -ccopt -L.. -I .. -o test.byt -g ../nums.cma $(TESTFILES) test.opt: $(TESTOPTFILES) ../nums.cmxa ../libnums.a - $(CAMLOPT) -ccopt -L.. -o test.opt ../nums.cmxa $(TESTOPTFILES) + $(CAMLOPT) -ccopt -L.. -I .. -o test.opt ../nums.cmxa $(TESTOPTFILES) test_bng: test_bng.o $(CC) $(CFLAGS) -o test_bng ../bng.o test_bng.o -lbignum $(TESTOPTFILES): ../../../ocamlopt +test_pi: test_pi.byt test_pi.bin + +test_pi.byt: pi_big_int.cmo pi_num.cmo + $(CAMLC) -ccopt -L.. -I .. -o pi_big_int.byt -g ../nums.cma pi_big_int.cmo + $(CAMLC) -ccopt -L.. -I .. -o pi_num.byt -g ../nums.cma pi_num.cmo + ./pi_big_int.byt 1000 + ./pi_num.byt 1000 + +test_pi.bin: pi_big_int.cmx pi_num.cmx + $(CAMLOPT) -ccopt -L.. -I .. -o pi_big_int.bin -g ../nums.cmxa pi_big_int.cmx + $(CAMLOPT) -ccopt -L.. -I .. -o pi_num.bin -g ../nums.cmxa pi_num.cmx + ./pi_big_int.bin 1000 + ./pi_num.bin 1000 + .SUFFIXES: .ml .cmo .cmx .ml.cmo: - $(CAMLC) -I .. -c $< + $(CAMLC) -I .. -c -g $< .ml.cmx: $(CAMLOPT) -I .. -c $< @@ -53,7 +68,7 @@ ocamlnum: ocamlmktop -o ocamlnum -custom ../nums.cma ../libnums.a clean: - rm -f test.byt test.opt test_bng *.o *.cm? ocamlnum + rm -f *.byt *.opt *.bin test_bng *.o *.cm? ocamlnum *~ depend: ocamldep *.ml > .depend diff --git a/otherlibs/num/test/pi_big_int.ml b/otherlibs/num/test/pi_big_int.ml new file mode 100644 index 00000000..22872ba4 --- /dev/null +++ b/otherlibs/num/test/pi_big_int.ml @@ -0,0 +1,78 @@ +(* Pi digits computed with the sreaming algorithm given on pages 4, 6 + & 7 of "Unbounded Spigot Algorithms for the Digits of Pi", Jeremy + Gibbons, August 2004. *) + +open Printf;; +open Big_int;; + +let ( !$ ) = Big_int.big_int_of_int +and ( +$ ) = Big_int.add_big_int +and ( *$ ) = Big_int.mult_big_int +and ( =$ ) = Big_int.eq_big_int +;; + +let zero = Big_int.zero_big_int +and one = Big_int.unit_big_int +and three = !$ 3 +and four = !$ 4 +and ten = !$ 10 +and neg_ten = !$(-10) +;; + +(* Linear Fractional (aka M=F6bius) Transformations *) +module LFT = struct + + let floor_ev (q, r, s, t) x = div_big_int (q *$ x +$ r) (s *$ x +$ t);; + + let unit = (one, zero, zero, one);; + + let comp (q, r, s, t) (q', r', s', t') = + (q *$ q' +$ r *$ s', q *$ r' +$ r *$ t', + s *$ q' +$ t *$ s', s *$ r' +$ t *$ t') +;; + +end +;; + +let next z = LFT.floor_ev z three +and safe z n = (n =$ LFT.floor_ev z four) +and prod z n = LFT.comp (ten, neg_ten *$ n, zero, one) z +and cons z k = + let den = 2 * k + 1 in + LFT.comp z (!$ k, !$(2 * den), zero, !$ den) +;; + +let rec digit k z n row col = + if n > 0 then + let y = next z in + if safe z y then + if col = 10 then ( + let row = row + 10 in + printf "\t:%i\n%s" row (string_of_big_int y); + digit k (prod z y) (n - 1) row 1 + ) + else ( + print_string(string_of_big_int y); + digit k (prod z y) (n - 1) row (col + 1) + ) + else digit (k + 1) (cons z k) n row col + else + printf "%*s\t:%i\n" (10 - col) "" (row + col) +;; + +let digits n = digit 1 LFT.unit n 0 0 +;; + +let usage () = + prerr_endline "Usage: pi_big_int "; + exit 2 +;; + +let main () = + let args = Sys.argv in + if Array.length args <> 2 then usage () else + digits (int_of_string Sys.argv.(1)) +;; + +main () +;; diff --git a/otherlibs/num/test/pi_num.ml b/otherlibs/num/test/pi_num.ml new file mode 100644 index 00000000..b3625082 --- /dev/null +++ b/otherlibs/num/test/pi_num.ml @@ -0,0 +1,73 @@ + +(* Pi digits computed with the sreaming algorithm given on pages 4, 6 + & 7 of "Unbounded Spigot Algorithms for the Digits of Pi", Jeremy + Gibbons, August 2004. *) + +open Printf;; +open Num;; + +let zero = num_of_int 0 +and one = num_of_int 1 +and three = num_of_int 3 +and four = num_of_int 4 +and ten = num_of_int 10 +and neg_ten = num_of_int(-10) +;; + +(* Linear Fractional Transformation *) +module LFT = struct + + let floor_ev (q, r, s, t) x = quo_num (q */ x +/ r) (s */ x +/ t);; + + let unit = (one, zero, zero, one);; + + let comp (q, r, s, t) (q', r', s', t') = + (q */ q' +/ r */ s', q */ r' +/ r */ t', + s */ q' +/ t */ s', s */ r' +/ t */ t') +;; + +end +;; + +let next z = LFT.floor_ev z three +and safe z n = (n =/ LFT.floor_ev z four) +and prod z n = LFT.comp (ten, neg_ten */ n, zero, one) z +and cons z k = + let den = 2 * k + 1 in + LFT.comp z (num_of_int k, num_of_int(2 * den), zero, num_of_int den) +;; + +let rec digit k z n row col = + if n > 0 then + let y = next z in + if safe z y then + if col = 10 then ( + let row = row + 10 in + printf "\t:%i\n%s" row (string_of_num y); + digit k (prod z y) (n-1) row 1 + ) + else ( + print_string(string_of_num y); + digit k (prod z y) (n-1) row (col + 1) + ) + else digit (k + 1) (cons z k) n row col + else + printf "%*s\t:%i\n" (10 - col) "" (row + col) +;; + +let digits n = digit 1 LFT.unit n 0 0 +;; + +let usage () = + prerr_endline "Usage: pi_num "; + exit 2 +;; + +let main () = + let args = Sys.argv in + if Array.length args <> 2 then usage () else + digits (int_of_string Sys.argv.(1)) +;; + +main () +;; diff --git a/otherlibs/num/test/test.ml b/otherlibs/num/test/test.ml index 8426e0ae..f26ea82c 100644 --- a/otherlibs/num/test/test.ml +++ b/otherlibs/num/test/test.ml @@ -9,7 +9,9 @@ let immediate_failure = ref true;; let error () = if !immediate_failure then exit 2 else begin - error_occurred := true; flush_all (); false + error_occurred := true; + flush_all (); + false end;; let success () = flush_all (); true;; @@ -71,7 +73,10 @@ let end_tests () = end;; let eq = (==);; -let eq_int = (==);; -let eq_string = (=);; +let eq_int (i: int) (j: int) = (i = j);; +let eq_string (i: string) (j: string) = (i = j);; +let eq_nativeint (i: nativeint) (j: nativeint) = (i = j);; +let eq_int32 (i: int32) (j: int32) = (i = j);; +let eq_int64 (i: int64) (j: int64) = (i = j);; let sixtyfour = (1 lsl 31) <> 0;; diff --git a/otherlibs/num/test/test_big_ints.ml b/otherlibs/num/test/test_big_ints.ml index 9d699bd0..f3080e5d 100644 --- a/otherlibs/num/test/test_big_ints.ml +++ b/otherlibs/num/test/test_big_ints.ml @@ -299,6 +299,24 @@ testing_function "int_of_big_int";; test 1 eq_int (int_of_big_int (big_int_of_int 1), 1);; +test 2 +eq_int (int_of_big_int (big_int_of_int(-1)), -1);; +test 3 +eq_int (int_of_big_int zero_big_int, 0);; +test 4 +eq_int (int_of_big_int (big_int_of_int max_int), max_int);; +test 5 +eq_int (int_of_big_int (big_int_of_int min_int), min_int);; +failwith_test 6 + (fun () -> int_of_big_int (succ_big_int (big_int_of_int max_int))) + () (Failure "int_of_big_int");; +failwith_test 7 + (fun () -> int_of_big_int (pred_big_int (big_int_of_int min_int))) + () (Failure "int_of_big_int");; +failwith_test 8 + (fun () -> int_of_big_int (mult_big_int (big_int_of_int min_int) + (big_int_of_int 2))) + () (Failure "int_of_big_int");; testing_function "is_int_big_int";; @@ -673,3 +691,82 @@ test 3 eq_big_int (square_big_int (big_int_of_string "-1"), big_int_of_string "1");; test 4 eq_big_int (square_big_int (big_int_of_string "-7"), big_int_of_string "49");; + + +testing_function "big_int_of_nativeint";; + +test 1 eq_big_int + (big_int_of_nativeint 0n, zero_big_int);; +test 2 eq_big_int + (big_int_of_nativeint 1234n, big_int_of_string "1234");; +test 3 eq_big_int + (big_int_of_nativeint (-1234n), big_int_of_string "-1234");; + +testing_function "nativeint_of_big_int";; + +test 1 eq_nativeint + (nativeint_of_big_int zero_big_int, 0n);; +test 2 eq_nativeint + (nativeint_of_big_int (big_int_of_string "1234"), 1234n);; +test 2 eq_nativeint + (nativeint_of_big_int (big_int_of_string "-1234"), -1234n);; + +testing_function "big_int_of_int32";; + +test 1 eq_big_int + (big_int_of_int32 0l, zero_big_int);; +test 2 eq_big_int + (big_int_of_int32 2147483647l, big_int_of_string "2147483647");; +test 3 eq_big_int + (big_int_of_int32 (-2147483648l), big_int_of_string "-2147483648");; + +testing_function "int32_of_big_int";; + +test 1 eq_int32 + (int32_of_big_int zero_big_int, 0l);; +test 2 eq_int32 + (int32_of_big_int (big_int_of_string "2147483647"), 2147483647l);; +test 3 eq_int32 + (int32_of_big_int (big_int_of_string "-2147483648"), -2147483648l);; +test 4 eq_int32 + (int32_of_big_int (big_int_of_string "-2147"), -2147l);; +let should_fail s = + try ignore (int32_of_big_int (big_int_of_string s)); 0 + with Failure _ -> 1;; +test 5 eq_int + (should_fail "2147483648", 1);; +test 6 eq_int + (should_fail "-2147483649", 1);; +test 7 eq_int + (should_fail "4294967296", 1);; +test 8 eq_int + (should_fail "18446744073709551616", 1);; + +testing_function "big_int_of_int64";; + +test 1 eq_big_int + (big_int_of_int64 0L, zero_big_int);; +test 2 eq_big_int + (big_int_of_int64 9223372036854775807L, big_int_of_string "9223372036854775807");; +test 3 eq_big_int + (big_int_of_int64 (-9223372036854775808L), big_int_of_string "-9223372036854775808");; + +testing_function "int64_of_big_int";; + +test 1 eq_int64 + (int64_of_big_int zero_big_int, 0L);; +test 2 eq_int64 + (int64_of_big_int (big_int_of_string "9223372036854775807"), 9223372036854775807L);; +test 3 eq_int64 + (int64_of_big_int (big_int_of_string "-9223372036854775808"), -9223372036854775808L);; +test 4 eq_int64 + (int64_of_big_int (big_int_of_string "-9223372036854775"), -9223372036854775L);; +let should_fail s = + try ignore (int64_of_big_int (big_int_of_string s)); 0 + with Failure _ -> 1;; +test 4 eq_int + (should_fail "9223372036854775808", 1);; +test 5 eq_int + (should_fail "-9223372036854775809", 1);; +test 6 eq_int + (should_fail "18446744073709551616", 1);; diff --git a/otherlibs/num/test/test_nats.ml b/otherlibs/num/test/test_nats.ml index bfb26f10..923086ec 100644 --- a/otherlibs/num/test/test_nats.ml +++ b/otherlibs/num/test/test_nats.ml @@ -97,16 +97,20 @@ testing_function "string_of_nat && nat_of_string";; for i = 1 to 20 do let s = String.make i '0' in - String.set s 0 '1'; - test i eq_string (string_of_nat (nat_of_string s), s) + String.set s 0 '1'; + ignore (test i eq_string (string_of_nat (nat_of_string s), s)) done;; +let set_mult_digit_nat n1 d1 l1 n2 d2 l2 n3 d3 = + ignore (mult_digit_nat n1 d1 l1 n2 d2 l2 n3 d3) +;; + let s = "3333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333333" in test 21 equal_nat ( nat_of_string s, (let nat = make_nat 15 in set_digit_nat nat 0 3; - mult_digit_nat nat 0 15 + set_mult_digit_nat nat 0 15 (nat_of_string (String.sub s 0 135)) 0 14 (nat_of_int 10) 0; nat)) @@ -121,8 +125,8 @@ for i = 1 to 20 do and n2 = Random.int 100000 in let nat1 = nat_of_int n1 and nat2 = nat_of_int n2 in - gcd_nat nat1 0 1 nat2 0 1; - test i eq (int_of_nat nat1, Int_misc.gcd_int n1 n2) + ignore (gcd_nat nat1 0 1 nat2 0 1); + ignore (test i eq (int_of_nat nat1, Int_misc.gcd_int n1 n2)) done ;; diff --git a/otherlibs/num/test/test_ratios.ml b/otherlibs/num/test/test_ratios.ml index 45fdce8b..df2001f1 100644 --- a/otherlibs/num/test/test_ratios.ml +++ b/otherlibs/num/test/test_ratios.ml @@ -5,169 +5,211 @@ open Ratio;; open Int_misc;; open Arith_status;; -set_error_when_null_denominator false;; +set_error_when_null_denominator false +;; let infinite_failure = "infinite or undefined rational number";; -testing_function "create_ratio";; +testing_function "create_ratio" +;; let r = create_ratio (big_int_of_int 1) (big_int_of_int (-2)) in -test 1 eq_big_int (numerator_ratio r, big_int_of_int (-1)) && -test 2 eq_big_int (denominator_ratio r, big_int_of_int 2);; +test 1 eq_big_int (numerator_ratio r, big_int_of_int (-1)) && +test 2 eq_big_int (denominator_ratio r, big_int_of_int 2) +;; let r = create_ratio (big_int_of_int 2) (big_int_of_int 3) in -test 3 eq_big_int (numerator_ratio r, big_int_of_int 2) && -test 4 eq_big_int (denominator_ratio r, big_int_of_int 3);; +test 3 eq_big_int (numerator_ratio r, big_int_of_int 2) && +test 4 eq_big_int (denominator_ratio r, big_int_of_int 3) +;; -set_normalize_ratio true;; +set_normalize_ratio true +;; let r = create_ratio (big_int_of_int 12) (big_int_of_int (-16)) in -test 5 eq_big_int (numerator_ratio r, big_int_of_int (-3)) && -test 6 eq_big_int (denominator_ratio r, big_int_of_int 4);; +test 5 eq_big_int (numerator_ratio r, big_int_of_int (-3)) && +test 6 eq_big_int (denominator_ratio r, big_int_of_int 4) +;; -set_normalize_ratio false;; +set_normalize_ratio false +;; let r = create_ratio (big_int_of_int 0) (big_int_of_int 0) in -test 7 eq_big_int (numerator_ratio r, big_int_of_int 0) && -test 8 eq_big_int (denominator_ratio r, big_int_of_int 0);; +test 7 eq_big_int (numerator_ratio r, big_int_of_int 0) && +test 8 eq_big_int (denominator_ratio r, big_int_of_int 0) +;; -testing_function "create_normalized_ratio";; +testing_function "create_normalized_ratio" +;; let r = create_normalized_ratio (big_int_of_int 1) (big_int_of_int (-2)) in -test 1 eq_big_int (numerator_ratio r, big_int_of_int (-1)) && -test 2 eq_big_int (denominator_ratio r, big_int_of_int 2);; +test 1 eq_big_int (numerator_ratio r, big_int_of_int (-1)) && +test 2 eq_big_int (denominator_ratio r, big_int_of_int 2) +;; let r = create_normalized_ratio (big_int_of_int 2) (big_int_of_int 3) in -test 3 eq_big_int (numerator_ratio r, big_int_of_int 2) && -test 4 eq_big_int (denominator_ratio r, big_int_of_int 3);; +test 3 eq_big_int (numerator_ratio r, big_int_of_int 2) && +test 4 eq_big_int (denominator_ratio r, big_int_of_int 3) +;; -set_normalize_ratio true;; +set_normalize_ratio true +;; let r = create_normalized_ratio (big_int_of_int 12) (big_int_of_int (-16)) in -test 5 eq_big_int (numerator_ratio r, big_int_of_int (-12)) && -test 6 eq_big_int (denominator_ratio r, big_int_of_int 16);; +test 5 eq_big_int (numerator_ratio r, big_int_of_int (-12)) && +test 6 eq_big_int (denominator_ratio r, big_int_of_int 16) +;; -set_normalize_ratio false;; +set_normalize_ratio false +;; let r = create_normalized_ratio (big_int_of_int 1) (big_int_of_int 0) in -test 7 eq_big_int (numerator_ratio r, big_int_of_int 1) && -test 8 eq_big_int (denominator_ratio r, big_int_of_int 0);; +test 7 eq_big_int (numerator_ratio r, big_int_of_int 1) && +test 8 eq_big_int (denominator_ratio r, big_int_of_int 0) +;; let r = create_normalized_ratio (big_int_of_int 0) (big_int_of_int 0) in -test 9 eq_big_int (numerator_ratio r, big_int_of_int 0) && -test 10 eq_big_int (denominator_ratio r, big_int_of_int 0);; +test 9 eq_big_int (numerator_ratio r, big_int_of_int 0) && +test 10 eq_big_int (denominator_ratio r, big_int_of_int 0) +;; -testing_function "null_denominator";; +testing_function "null_denominator" +;; test 1 eq (null_denominator (create_ratio (big_int_of_int 1) (big_int_of_int (-2))), - false);; + false) +;; test 2 eq - (null_denominator (create_ratio (big_int_of_int 1) zero_big_int),true);; + (null_denominator (create_ratio (big_int_of_int 1) zero_big_int),true) +;; (***** -testing_function "verify_null_denominator";; +testing_function "verify_null_denominator" +;; test 1 - eq (verify_null_denominator (ratio_of_string "0/1"), false);; + eq (verify_null_denominator (ratio_of_string "0/1"), false) +;; test 2 - eq (verify_null_denominator (ratio_of_string "0/0"), true);; + eq (verify_null_denominator (ratio_of_string "0/0"), true) +;; *****) -testing_function "sign_ratio";; +testing_function "sign_ratio" +;; test 1 -eq_int (sign_ratio (create_ratio (big_int_of_int (-2)) (big_int_of_int (-3))), - 1);; +eq_int (sign_ratio (create_ratio (big_int_of_int (-2)) (big_int_of_int (-3))), + 1) +;; test 2 -eq_int (sign_ratio (create_ratio (big_int_of_int 2) (big_int_of_int (-3))), - (-1));; +eq_int (sign_ratio (create_ratio (big_int_of_int 2) (big_int_of_int (-3))), + (-1)) +;; test 3 -eq_int (sign_ratio (create_ratio zero_big_int (big_int_of_int (-3))), 0);; +eq_int (sign_ratio (create_ratio zero_big_int (big_int_of_int (-3))), 0) +;; -testing_function "normalize_ratio";; +testing_function "normalize_ratio" +;; let r = create_ratio (big_int_of_int 12) (big_int_of_int (-16)) in -normalize_ratio r; -test 1 eq_big_int (numerator_ratio r, big_int_of_int (-3)) && -test 2 eq_big_int (denominator_ratio r, big_int_of_int 4);; +ignore (normalize_ratio r); +test 1 eq_big_int (numerator_ratio r, big_int_of_int (-3)) && +test 2 eq_big_int (denominator_ratio r, big_int_of_int 4) +;; let r = create_ratio (big_int_of_int (-1)) zero_big_int in -normalize_ratio r; -test 3 eq_big_int (numerator_ratio r, big_int_of_int (-1)) && -test 4 eq_big_int (denominator_ratio r, zero_big_int);; +ignore (normalize_ratio r); +test 3 eq_big_int (numerator_ratio r, big_int_of_int (-1)) && +test 4 eq_big_int (denominator_ratio r, zero_big_int) +;; -testing_function "report_sign_ratio";; +testing_function "report_sign_ratio" +;; -test 1 -eq_big_int (report_sign_ratio - (create_ratio (big_int_of_int 2) (big_int_of_int (-3))) +test 1 +eq_big_int (report_sign_ratio + (create_ratio (big_int_of_int 2) (big_int_of_int (-3))) (big_int_of_int 1), - big_int_of_int (-1));; + big_int_of_int (-1)) +;; test 2 -eq_big_int (report_sign_ratio - (create_ratio (big_int_of_int 2) (big_int_of_int 3)) +eq_big_int (report_sign_ratio + (create_ratio (big_int_of_int 2) (big_int_of_int 3)) (big_int_of_int 1), - big_int_of_int 1);; + big_int_of_int 1) +;; -testing_function "is_integer_ratio";; +testing_function "is_integer_ratio" +;; test 1 eq (is_integer_ratio (create_ratio (big_int_of_int 2) (big_int_of_int (-1))), - true);; + true) +;; test 2 eq (is_integer_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)), - false);; + false) +;; -testing_function "add_ratio";; +testing_function "add_ratio" +;; -let r = add_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 2)) +let r = add_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 2)) (create_ratio (big_int_of_int 2) (big_int_of_int 3)) in -test 1 eq_big_int (numerator_ratio r, big_int_of_int 7) && -test 2 eq_big_int (denominator_ratio r, big_int_of_int 6);; +test 1 eq_big_int (numerator_ratio r, big_int_of_int 7) && +test 2 eq_big_int (denominator_ratio r, big_int_of_int 6) +;; -let r = add_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) +let r = add_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in -test 3 eq_big_int (numerator_ratio r, big_int_of_int 1) && -test 4 eq_big_int (denominator_ratio r, big_int_of_int 6);; +test 3 eq_big_int (numerator_ratio r, big_int_of_int 1) && +test 4 eq_big_int (denominator_ratio r, big_int_of_int 6) +;; -let r = add_ratio (create_ratio (big_int_of_int 2) zero_big_int) +let r = add_ratio (create_ratio (big_int_of_int 2) zero_big_int) (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in -test 5 eq_big_int (numerator_ratio r, big_int_of_int 4) && -test 6 eq_big_int (denominator_ratio r, zero_big_int);; +test 5 eq_big_int (numerator_ratio r, big_int_of_int 4) && +test 6 eq_big_int (denominator_ratio r, zero_big_int) +;; -let r = add_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) +let r = add_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) (create_ratio (big_int_of_int 1) zero_big_int) in -test 7 eq_big_int (numerator_ratio r, big_int_of_int 3) && -test 8 eq_big_int (denominator_ratio r, zero_big_int);; +test 7 eq_big_int (numerator_ratio r, big_int_of_int 3) && +test 8 eq_big_int (denominator_ratio r, zero_big_int) +;; -let r = add_ratio (create_ratio (big_int_of_int 2) zero_big_int) +let r = add_ratio (create_ratio (big_int_of_int 2) zero_big_int) (create_ratio (big_int_of_int 1) zero_big_int) in -test 9 eq_big_int (numerator_ratio r, zero_big_int) && -test 10 eq_big_int (denominator_ratio r, zero_big_int);; +test 9 eq_big_int (numerator_ratio r, zero_big_int) && +test 10 eq_big_int (denominator_ratio r, zero_big_int) +;; -let r = add_ratio (create_ratio (big_int_of_string "12724951") - (big_int_of_string "26542080")) - (create_ratio (big_int_of_string "-1") +let r = add_ratio (create_ratio (big_int_of_string "12724951") + (big_int_of_string "26542080")) + (create_ratio (big_int_of_string "-1") (big_int_of_string "81749606400")) in -test 11 eq_big_int (numerator_ratio r, - big_int_of_string "1040259735682744320") && -test 12 eq_big_int (denominator_ratio r, - big_int_of_string "2169804593037312000");; +test 11 eq_big_int (numerator_ratio r, + big_int_of_string "1040259735682744320") && +test 12 eq_big_int (denominator_ratio r, + big_int_of_string "2169804593037312000") +;; let r1,r2 = - (create_ratio (big_int_of_string "12724951") - (big_int_of_string "26542080"), - create_ratio (big_int_of_string "-1") + (create_ratio (big_int_of_string "12724951") + (big_int_of_string "26542080"), + create_ratio (big_int_of_string "-1") (big_int_of_string "81749606400")) in let bi1 = mult_big_int (numerator_ratio r1) (denominator_ratio r2) -and bi2 = mult_big_int (numerator_ratio r2) (denominator_ratio r1) +and bi2 = mult_big_int (numerator_ratio r2) (denominator_ratio r1) in test 1 eq_big_int (bi1, big_int_of_string "1040259735709286400") -&& +&& test 2 eq_big_int (bi2, big_int_of_string "-26542080") @@ -179,441 +221,550 @@ eq_big_int (add_big_int bi1 bi2, big_int_of_string "1040259735682744320") ;; -testing_function "sub_ratio";; +testing_function "sub_ratio" +;; -let r = sub_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) +let r = sub_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) (create_ratio (big_int_of_int 1) (big_int_of_int 2)) in -test 1 eq_big_int (numerator_ratio r, big_int_of_int 1) && -test 2 eq_big_int (denominator_ratio r, big_int_of_int 6);; +test 1 eq_big_int (numerator_ratio r, big_int_of_int 1) && +test 2 eq_big_int (denominator_ratio r, big_int_of_int 6) +;; -let r = sub_ratio (create_ratio (big_int_of_int 2) zero_big_int) +let r = sub_ratio (create_ratio (big_int_of_int 2) zero_big_int) (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in -test 3 eq_big_int (numerator_ratio r, big_int_of_int 4) && -test 4 eq_big_int (denominator_ratio r, zero_big_int);; +test 3 eq_big_int (numerator_ratio r, big_int_of_int 4) && +test 4 eq_big_int (denominator_ratio r, zero_big_int) +;; -let r = sub_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) +let r = sub_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) (create_ratio (big_int_of_int 1) zero_big_int) in -test 5 eq_big_int (numerator_ratio r, big_int_of_int (-3)) && -test 6 eq_big_int (denominator_ratio r, zero_big_int);; +test 5 eq_big_int (numerator_ratio r, big_int_of_int (-3)) && +test 6 eq_big_int (denominator_ratio r, zero_big_int) +;; -let r = sub_ratio (create_ratio (big_int_of_int 2) zero_big_int) +let r = sub_ratio (create_ratio (big_int_of_int 2) zero_big_int) (create_ratio (big_int_of_int 1) zero_big_int) in -test 7 eq_big_int (numerator_ratio r, zero_big_int) && -test 8 eq_big_int (denominator_ratio r, zero_big_int);; +test 7 eq_big_int (numerator_ratio r, zero_big_int) && +test 8 eq_big_int (denominator_ratio r, zero_big_int) +;; -testing_function "mult_ratio";; +testing_function "mult_ratio" +;; -let r = mult_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) +let r = mult_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) (create_ratio (big_int_of_int 7) (big_int_of_int 5)) in -test 1 eq_big_int (numerator_ratio r, big_int_of_int 14) && -test 2 eq_big_int (denominator_ratio r, big_int_of_int 15);; +test 1 eq_big_int (numerator_ratio r, big_int_of_int 14) && +test 2 eq_big_int (denominator_ratio r, big_int_of_int 15) +;; -let r = mult_ratio (create_ratio (big_int_of_int 2) zero_big_int) +let r = mult_ratio (create_ratio (big_int_of_int 2) zero_big_int) (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in test 3 eq_big_int (numerator_ratio r, big_int_of_int (-2)) && -test 4 eq_big_int (denominator_ratio r, zero_big_int);; +test 4 eq_big_int (denominator_ratio r, zero_big_int) +;; -let r = mult_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) +let r = mult_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) (create_ratio (big_int_of_int 1) zero_big_int) in -test 5 eq_big_int (numerator_ratio r, big_int_of_int 2) && -test 6 eq_big_int (denominator_ratio r, zero_big_int);; +test 5 eq_big_int (numerator_ratio r, big_int_of_int 2) && +test 6 eq_big_int (denominator_ratio r, zero_big_int) +;; -let r = mult_ratio (create_ratio (big_int_of_int 2) zero_big_int) +let r = mult_ratio (create_ratio (big_int_of_int 2) zero_big_int) (create_ratio (big_int_of_int 1) zero_big_int) in -test 7 eq_big_int (numerator_ratio r, big_int_of_int 2) && -test 8 eq_big_int (denominator_ratio r, zero_big_int);; +test 7 eq_big_int (numerator_ratio r, big_int_of_int 2) && +test 8 eq_big_int (denominator_ratio r, zero_big_int) +;; -testing_function "div_ratio";; +testing_function "div_ratio" +;; -let r = div_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) +let r = div_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) (create_ratio (big_int_of_int 5) (big_int_of_int 7)) in -test 1 eq_big_int (numerator_ratio r, big_int_of_int 14) && -test 2 eq_big_int (denominator_ratio r, big_int_of_int 15);; +test 1 eq_big_int (numerator_ratio r, big_int_of_int 14) && +test 2 eq_big_int (denominator_ratio r, big_int_of_int 15) +;; -let r = div_ratio (create_ratio (big_int_of_int 2) zero_big_int) +let r = div_ratio (create_ratio (big_int_of_int 2) zero_big_int) (create_ratio (big_int_of_int 1) (big_int_of_int (-2))) in -test 3 eq_big_int (numerator_ratio r, big_int_of_int (-4)) && -test 4 eq_big_int (denominator_ratio r, zero_big_int);; +test 3 eq_big_int (numerator_ratio r, big_int_of_int (-4)) && +test 4 eq_big_int (denominator_ratio r, zero_big_int) +;; -let r = div_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) +let r = div_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 3)) (create_ratio (big_int_of_int 1) zero_big_int) in -test 5 eq_big_int (numerator_ratio r, zero_big_int) && -test 6 eq_big_int (denominator_ratio r, big_int_of_int 3);; +test 5 eq_big_int (numerator_ratio r, zero_big_int) && +test 6 eq_big_int (denominator_ratio r, big_int_of_int 3) +;; -let r = div_ratio (create_ratio (big_int_of_int 2) zero_big_int) +let r = div_ratio (create_ratio (big_int_of_int 2) zero_big_int) (create_ratio (big_int_of_int 1) zero_big_int) in -test 7 eq_big_int (numerator_ratio r, zero_big_int) && -test 8 eq_big_int (denominator_ratio r, zero_big_int);; +test 7 eq_big_int (numerator_ratio r, zero_big_int) && +test 8 eq_big_int (denominator_ratio r, zero_big_int) +;; -testing_function "integer_ratio";; +testing_function "integer_ratio" +;; -test 1 -eq_big_int (integer_ratio - (create_ratio (big_int_of_int 5) (big_int_of_int 3)), - big_int_of_int 1);; +test 1 +eq_big_int (integer_ratio + (create_ratio (big_int_of_int 5) (big_int_of_int 3)), + big_int_of_int 1) +;; test 2 -eq_big_int (integer_ratio - (create_ratio (big_int_of_int 5) (big_int_of_int (-3))), - big_int_of_int (-1));; +eq_big_int (integer_ratio + (create_ratio (big_int_of_int 5) (big_int_of_int (-3))), + big_int_of_int (-1)) +;; test 3 -eq_big_int (integer_ratio - (create_ratio (big_int_of_int 3) (big_int_of_int 2)), - big_int_of_int 1);; +eq_big_int (integer_ratio + (create_ratio (big_int_of_int 3) (big_int_of_int 2)), + big_int_of_int 1) +;; test 4 -eq_big_int (integer_ratio - (create_ratio (big_int_of_int 3) (big_int_of_int (-2))), - big_int_of_int (-1));; +eq_big_int (integer_ratio + (create_ratio (big_int_of_int 3) (big_int_of_int (-2))), + big_int_of_int (-1)) +;; failwith_test 5 integer_ratio (create_ratio (big_int_of_int 3) zero_big_int) -(Failure("integer_ratio "^infinite_failure));; +(Failure("integer_ratio "^infinite_failure)) +;; -testing_function "floor_ratio";; +testing_function "floor_ratio" +;; test 1 -eq_big_int (floor_ratio - (create_ratio (big_int_of_int 5) (big_int_of_int 3)), - big_int_of_int 1);; +eq_big_int (floor_ratio + (create_ratio (big_int_of_int 5) (big_int_of_int 3)), + big_int_of_int 1) +;; test 2 -eq_big_int (floor_ratio - (create_ratio (big_int_of_int 5) (big_int_of_int (-3))), - big_int_of_int (-2));; +eq_big_int (floor_ratio + (create_ratio (big_int_of_int 5) (big_int_of_int (-3))), + big_int_of_int (-2)) +;; test 3 -eq_big_int (floor_ratio - (create_ratio (big_int_of_int 3) (big_int_of_int 2)), - big_int_of_int 1);; +eq_big_int (floor_ratio + (create_ratio (big_int_of_int 3) (big_int_of_int 2)), + big_int_of_int 1) +;; test 4 -eq_big_int (floor_ratio - (create_ratio (big_int_of_int 3) (big_int_of_int (-2))), - big_int_of_int (-2));; +eq_big_int (floor_ratio + (create_ratio (big_int_of_int 3) (big_int_of_int (-2))), + big_int_of_int (-2)) +;; failwith_test 5 floor_ratio (create_ratio (big_int_of_int 3) zero_big_int) -Division_by_zero;; +Division_by_zero +;; -testing_function "round_ratio";; +testing_function "round_ratio" +;; test 1 -eq_big_int (round_ratio - (create_ratio (big_int_of_int 5) (big_int_of_int 3)), - big_int_of_int 2);; +eq_big_int (round_ratio + (create_ratio (big_int_of_int 5) (big_int_of_int 3)), + big_int_of_int 2) +;; test 2 -eq_big_int (round_ratio - (create_ratio (big_int_of_int 5) (big_int_of_int (-3))), - big_int_of_int (-2));; +eq_big_int (round_ratio + (create_ratio (big_int_of_int 5) (big_int_of_int (-3))), + big_int_of_int (-2)) +;; test 3 -eq_big_int (round_ratio - (create_ratio (big_int_of_int 3) (big_int_of_int 2)), - big_int_of_int 2);; +eq_big_int (round_ratio + (create_ratio (big_int_of_int 3) (big_int_of_int 2)), + big_int_of_int 2) +;; test 4 -eq_big_int (round_ratio - (create_ratio (big_int_of_int 3) (big_int_of_int (-2))), - big_int_of_int (-2));; +eq_big_int (round_ratio + (create_ratio (big_int_of_int 3) (big_int_of_int (-2))), + big_int_of_int (-2)) +;; failwith_test 5 round_ratio (create_ratio (big_int_of_int 3) zero_big_int) -Division_by_zero;; +Division_by_zero +;; -testing_function "ceiling_ratio";; +testing_function "ceiling_ratio" +;; test 1 -eq_big_int (ceiling_ratio - (create_ratio (big_int_of_int 5) (big_int_of_int 3)), - big_int_of_int 2);; +eq_big_int (ceiling_ratio + (create_ratio (big_int_of_int 5) (big_int_of_int 3)), + big_int_of_int 2) +;; test 2 -eq_big_int (ceiling_ratio - (create_ratio (big_int_of_int 5) (big_int_of_int (-3))), - big_int_of_int (-1));; +eq_big_int (ceiling_ratio + (create_ratio (big_int_of_int 5) (big_int_of_int (-3))), + big_int_of_int (-1)) +;; test 3 -eq_big_int (ceiling_ratio - (create_ratio (big_int_of_int 3) (big_int_of_int 2)), - big_int_of_int 2);; +eq_big_int (ceiling_ratio + (create_ratio (big_int_of_int 3) (big_int_of_int 2)), + big_int_of_int 2) +;; test 4 -eq_big_int (ceiling_ratio - (create_ratio (big_int_of_int 3) (big_int_of_int (-2))), - big_int_of_int (-1));; +eq_big_int (ceiling_ratio + (create_ratio (big_int_of_int 3) (big_int_of_int (-2))), + big_int_of_int (-1)) +;; test 5 -eq_big_int (ceiling_ratio - (create_ratio (big_int_of_int 4) (big_int_of_int 2)), - big_int_of_int 2);; +eq_big_int (ceiling_ratio + (create_ratio (big_int_of_int 4) (big_int_of_int 2)), + big_int_of_int 2) +;; failwith_test 6 ceiling_ratio (create_ratio (big_int_of_int 3) zero_big_int) -Division_by_zero;; +Division_by_zero +;; -testing_function "eq_ratio";; +testing_function "eq_ratio" +;; test 1 eq_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3), - create_ratio (big_int_of_int (-20)) (big_int_of_int (-12)));; + create_ratio (big_int_of_int (-20)) (big_int_of_int (-12))) +;; test 2 -eq_ratio (create_ratio (big_int_of_int 1) zero_big_int, - create_ratio (big_int_of_int 2) zero_big_int);; +eq_ratio (create_ratio (big_int_of_int 1) zero_big_int, + create_ratio (big_int_of_int 2) zero_big_int) +;; let neq_ratio x y = not (eq_ratio x y);; test 3 neq_ratio (create_ratio (big_int_of_int 1) zero_big_int, - create_ratio (big_int_of_int (-1)) zero_big_int);; + create_ratio (big_int_of_int (-1)) zero_big_int) +;; test 4 -neq_ratio (create_ratio (big_int_of_int 1) zero_big_int, - create_ratio zero_big_int zero_big_int);; +neq_ratio (create_ratio (big_int_of_int 1) zero_big_int, + create_ratio zero_big_int zero_big_int) +;; test 5 -eq_ratio (create_ratio zero_big_int zero_big_int, - create_ratio zero_big_int zero_big_int);; +eq_ratio (create_ratio zero_big_int zero_big_int, + create_ratio zero_big_int zero_big_int) +;; -testing_function "compare_ratio";; +testing_function "compare_ratio" +;; test 1 -eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) +eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) (create_ratio (big_int_of_int 0) (big_int_of_int 0)), - 0);; + 0) +;; test 2 -eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) +eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) (create_ratio (big_int_of_int 1) (big_int_of_int 0)), - 0);; + 0) +;; test 3 -eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) +eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)), - 0);; + 0) +;; test 4 -eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) +eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) (create_ratio (big_int_of_int 0) (big_int_of_int 0)), - 0);; + 0) +;; test 5 -eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) +eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) (create_ratio (big_int_of_int 0) (big_int_of_int 0)), - 0);; + 0) +;; test 6 -eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) +eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) (create_ratio (big_int_of_int 5) (big_int_of_int 3)), - 0);; + 0) +;; test 7 -eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) +eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) (create_ratio (big_int_of_int 0) (big_int_of_int 0)), - 0);; + 0) +;; test 8 -eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) +eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)), - 0);; + 0) +;; test 9 -eq_int (compare_ratio (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)) +eq_int (compare_ratio (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)) (create_ratio (big_int_of_int 0) (big_int_of_int 0)), - 0);; + 0) +;; test 10 -eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) +eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) (create_ratio (big_int_of_int 0) (big_int_of_int 1)), - 0);; + 0) +;; test 11 -eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 1)) +eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 1)) (create_ratio (big_int_of_int 0) (big_int_of_int 0)), - 0);; + 0) +;; test 12 -eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) +eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) (create_ratio (big_int_of_int 1) (big_int_of_int 0)), - 0);; + 0) +;; test 13 -eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) +eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) (create_ratio (big_int_of_int 2) (big_int_of_int 0)), - 0);; + 0) +;; test 14 -eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) +eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)), - 1);; + 1) +;; test 15 -eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) +eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) (create_ratio (big_int_of_int 1) (big_int_of_int 0)), - (-1));; + (-1)) +;; test 16 -eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) - (create_ratio (big_int_of_int 1) (big_int_of_int 0)), - (-1));; +eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) + (create_ratio (big_int_of_int 1) (big_int_of_int 0)), + (-1)) +;; test 17 -eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) +eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) (create_ratio (big_int_of_int 5) (big_int_of_int 3)), - 1);; + 1) +;; test 18 -eq_int (compare_ratio (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)) - (create_ratio (big_int_of_int 1) (big_int_of_int 0)), - (-1));; +eq_int (compare_ratio (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)) + (create_ratio (big_int_of_int 1) (big_int_of_int 0)), + (-1)) +;; test 19 -eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) +eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)), - 1);; + 1) +;; test 20 -eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) +eq_int (compare_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) (create_ratio (big_int_of_int 0) (big_int_of_int 3)), - 1);; + 1) +;; test 21 -eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) +eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)), - 0);; + 0) +;; test 22 -eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) +eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) (create_ratio (big_int_of_int (-2)) (big_int_of_int 0)), - 0);; + 0) +;; test 23 -eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) - (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)), - 1);; +eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) + (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)), + 1) +;; test 24 -eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) +eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) (create_ratio (big_int_of_int 5) (big_int_of_int 3)), - (-1));; + (-1)) +;; test 25 -eq_int (compare_ratio (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)) - (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)), - 1);; +eq_int (compare_ratio (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)) + (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)), + 1) +;; test 26 -eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) +eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)), - (-1));; + (-1)) +;; test 27 -eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) +eq_int (compare_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) (create_ratio (big_int_of_int 0) (big_int_of_int 3)), - (-1));; + (-1)) +;; test 28 -eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) - (create_ratio (big_int_of_int 3) (big_int_of_int 2)), - 1);; +eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) + (create_ratio (big_int_of_int 3) (big_int_of_int 2)), + 1) +;; test 29 -eq_int (compare_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2)) - (create_ratio (big_int_of_int 5) (big_int_of_int 3)), - (-1));; +eq_int (compare_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2)) + (create_ratio (big_int_of_int 5) (big_int_of_int 3)), + (-1)) +;; test 30 -eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) - (create_ratio (big_int_of_int (-3)) (big_int_of_int 2)), - 1);; +eq_int (compare_ratio (create_ratio (big_int_of_int 5) (big_int_of_int 3)) + (create_ratio (big_int_of_int (-3)) (big_int_of_int 2)), + 1) +;; test 31 -eq_int (compare_ratio (create_ratio (big_int_of_int (-3)) (big_int_of_int 2)) - (create_ratio (big_int_of_int 5) (big_int_of_int 3)), - (-1));; +eq_int (compare_ratio (create_ratio (big_int_of_int (-3)) (big_int_of_int 2)) + (create_ratio (big_int_of_int 5) (big_int_of_int 3)), + (-1)) +;; test 32 -eq_int (compare_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2)) - (create_ratio (big_int_of_int 0) (big_int_of_int 3)), - 1);; +eq_int (compare_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2)) + (create_ratio (big_int_of_int 0) (big_int_of_int 3)), + 1) +;; test 33 -eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 2)) - (create_ratio (big_int_of_int 5) (big_int_of_int 3)), - (-1));; +eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 2)) + (create_ratio (big_int_of_int 5) (big_int_of_int 3)), + (-1)) +;; test 34 -eq_int (compare_ratio (create_ratio (big_int_of_int (-3)) (big_int_of_int 2)) - (create_ratio (big_int_of_int 0) (big_int_of_int 3)), - (-1));; +eq_int (compare_ratio (create_ratio (big_int_of_int (-3)) (big_int_of_int 2)) + (create_ratio (big_int_of_int 0) (big_int_of_int 3)), + (-1)) +;; test 35 -eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 2)) - (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)), - 1);; +eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 2)) + (create_ratio (big_int_of_int (-5)) (big_int_of_int 3)), + 1) +;; test 36 -eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 2)) - (create_ratio (big_int_of_int 0) (big_int_of_int 3)), - 0);; +eq_int (compare_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 2)) + (create_ratio (big_int_of_int 0) (big_int_of_int 3)), + 0) +;; -testing_function "eq_big_int_ratio";; +testing_function "eq_big_int_ratio" +;; test 1 -eq_big_int_ratio (big_int_of_int 3, - (create_ratio (big_int_of_int 3) (big_int_of_int 1)));; +eq_big_int_ratio (big_int_of_int 3, + (create_ratio (big_int_of_int 3) (big_int_of_int 1))) +;; test 2 eq -(not (eq_big_int_ratio (big_int_of_int 1) +(not (eq_big_int_ratio (big_int_of_int 1) (create_ratio (big_int_of_int 3) (big_int_of_int 1))), -true);; +true) +;; test 3 eq -(not (eq_big_int_ratio (big_int_of_int 1) +(not (eq_big_int_ratio (big_int_of_int 1) (create_ratio (big_int_of_int 3) (big_int_of_int 2))), - true);; + true) +;; test 4 eq -(not (eq_big_int_ratio (big_int_of_int 1) +(not (eq_big_int_ratio (big_int_of_int 1) (create_ratio (big_int_of_int 3) (big_int_of_int 0))), - true);; + true) +;; test 5 eq -(not (eq_big_int_ratio (big_int_of_int 1) +(not (eq_big_int_ratio (big_int_of_int 1) (create_ratio (big_int_of_int (-3)) (big_int_of_int 2))), - true);; + true) +;; -testing_function "compare_big_int_ratio";; +testing_function "compare_big_int_ratio" +;; test 1 -eq_int (compare_big_int_ratio - (big_int_of_int 1) - (create_ratio (big_int_of_int 3) (big_int_of_int 0)), (-1));; +eq_int (compare_big_int_ratio + (big_int_of_int 1) + (create_ratio (big_int_of_int 3) (big_int_of_int 0)), (-1)) +;; test 2 -eq_int (compare_big_int_ratio - (big_int_of_int 1) - (create_ratio (big_int_of_int 0) (big_int_of_int 0)), 0);; +eq_int (compare_big_int_ratio + (big_int_of_int 1) + (create_ratio (big_int_of_int 0) (big_int_of_int 0)), 0) +;; test 3 -eq_int (compare_big_int_ratio - (big_int_of_int 1) - (create_ratio (big_int_of_int (-3)) (big_int_of_int 0)), 1);; +eq_int (compare_big_int_ratio + (big_int_of_int 1) + (create_ratio (big_int_of_int (-3)) (big_int_of_int 0)), 1) +;; test 4 -eq_int (compare_big_int_ratio - (big_int_of_int (-1)) - (create_ratio (big_int_of_int 3) (big_int_of_int 0)), (-1));; +eq_int (compare_big_int_ratio + (big_int_of_int (-1)) + (create_ratio (big_int_of_int 3) (big_int_of_int 0)), (-1)) +;; test 5 -eq_int (compare_big_int_ratio - (big_int_of_int (-1)) - (create_ratio (big_int_of_int 0) (big_int_of_int 0)), 0);; +eq_int (compare_big_int_ratio + (big_int_of_int (-1)) + (create_ratio (big_int_of_int 0) (big_int_of_int 0)), 0) +;; test 6 -eq_int (compare_big_int_ratio - (big_int_of_int (-1)) - (create_ratio (big_int_of_int (-3)) (big_int_of_int 0)), 1);; +eq_int (compare_big_int_ratio + (big_int_of_int (-1)) + (create_ratio (big_int_of_int (-3)) (big_int_of_int 0)), 1) +;; test 7 -eq_int (compare_big_int_ratio - (big_int_of_int 1) - (create_ratio (big_int_of_int 1) (big_int_of_int 1)), 0);; +eq_int (compare_big_int_ratio + (big_int_of_int 1) + (create_ratio (big_int_of_int 1) (big_int_of_int 1)), 0) +;; test 8 -eq_int (compare_big_int_ratio - (big_int_of_int 1) - (create_ratio (big_int_of_int 3) (big_int_of_int 2)), (-1));; +eq_int (compare_big_int_ratio + (big_int_of_int 1) + (create_ratio (big_int_of_int 3) (big_int_of_int 2)), (-1)) +;; test 9 -eq_int (compare_big_int_ratio - (big_int_of_int 1) - (create_ratio (big_int_of_int 2) (big_int_of_int 3)), 1);; +eq_int (compare_big_int_ratio + (big_int_of_int 1) + (create_ratio (big_int_of_int 2) (big_int_of_int 3)), 1) +;; -testing_function "int_of_ratio";; +testing_function "int_of_ratio" +;; test 1 -eq_int (int_of_ratio (create_ratio (big_int_of_int 4) (big_int_of_int 2)), - 2);; +eq_int (int_of_ratio (create_ratio (big_int_of_int 4) (big_int_of_int 2)), + 2) +;; test 2 -eq_int (int_of_ratio - (create_ratio (big_int_of_int biggest_int) (big_int_of_int 1)), - biggest_int);; +eq_int (int_of_ratio + (create_ratio (big_int_of_int biggest_int) (big_int_of_int 1)), + biggest_int) +;; failwith_test 3 int_of_ratio (create_ratio (big_int_of_int 4) (big_int_of_int 0)) -(Failure "integer argument required");; +(Failure "integer argument required") +;; failwith_test 4 -int_of_ratio (create_ratio (succ_big_int (big_int_of_int biggest_int)) +int_of_ratio (create_ratio (succ_big_int (big_int_of_int biggest_int)) (big_int_of_int 1)) -(Failure "integer argument required");; +(Failure "integer argument required") +;; failwith_test 5 int_of_ratio (create_ratio (big_int_of_int 4) (big_int_of_int 3)) -(Failure "integer argument required");; +(Failure "integer argument required") +;; -testing_function "ratio_of_int";; +testing_function "ratio_of_int" +;; test 1 -eq_ratio (ratio_of_int 3, - create_ratio (big_int_of_int 3) (big_int_of_int 1));; - +eq_ratio (ratio_of_int 3, + create_ratio (big_int_of_int 3) (big_int_of_int 1)) +;; + test 2 -eq_ratio (ratio_of_nat (nat_of_int 2), - create_ratio (big_int_of_int 2) (big_int_of_int 1));; +eq_ratio (ratio_of_nat (nat_of_int 2), + create_ratio (big_int_of_int 2) (big_int_of_int 1)) +;; -testing_function "nat_of_ratio";; +testing_function "nat_of_ratio" +;; let nat1 = nat_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 1)) and nat2 = nat_of_int 3 in @@ -623,306 +774,404 @@ eq (eq_nat nat1 0 (length_nat nat1) nat2 0 (length_nat nat2), true) failwith_test 2 nat_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 0)) -(Failure "nat_of_ratio");; +(Failure "nat_of_ratio") +;; failwith_test 3 nat_of_ratio (create_ratio (big_int_of_int (-3)) (big_int_of_int 1)) -(Failure "nat_of_ratio");; +(Failure "nat_of_ratio") +;; failwith_test 4 nat_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 2)) -(Failure "nat_of_ratio");; +(Failure "nat_of_ratio") +;; -testing_function "ratio_of_big_int";; +testing_function "ratio_of_big_int" +;; test 1 -eq_ratio (ratio_of_big_int (big_int_of_int 3), - create_ratio (big_int_of_int 3) (big_int_of_int 1));; +eq_ratio (ratio_of_big_int (big_int_of_int 3), + create_ratio (big_int_of_int 3) (big_int_of_int 1)) +;; -testing_function "big_int_of_ratio";; +testing_function "big_int_of_ratio" +;; test 1 -eq_big_int (big_int_of_ratio - (create_ratio (big_int_of_int 3) (big_int_of_int 1)), - big_int_of_int 3);; +eq_big_int (big_int_of_ratio + (create_ratio (big_int_of_int 3) (big_int_of_int 1)), + big_int_of_int 3) +;; test 2 -eq_big_int (big_int_of_ratio +eq_big_int (big_int_of_ratio (create_ratio (big_int_of_int (-3)) (big_int_of_int 1)), - big_int_of_int (-3));; + big_int_of_int (-3)) +;; failwith_test 3 big_int_of_ratio (create_ratio (big_int_of_int 3) (big_int_of_int 0)) -(Failure "big_int_of_ratio");; +(Failure "big_int_of_ratio") +;; -testing_function "string_of_ratio";; +testing_function "string_of_ratio" +;; test 1 -eq_string (string_of_ratio - (create_ratio (big_int_of_int 43) (big_int_of_int 35)), - "43/35");; +eq_string (string_of_ratio + (create_ratio (big_int_of_int 43) (big_int_of_int 35)), + "43/35") +;; test 2 -eq_string (string_of_ratio - (create_ratio (big_int_of_int 42) (big_int_of_int 0)), - "1/0");; +eq_string (string_of_ratio + (create_ratio (big_int_of_int 42) (big_int_of_int 0)), + "1/0") +;; -set_normalize_ratio_when_printing false;; +set_normalize_ratio_when_printing false +;; test 3 -eq_string (string_of_ratio - (create_ratio (big_int_of_int 42) (big_int_of_int 35)), - "42/35");; +eq_string (string_of_ratio + (create_ratio (big_int_of_int 42) (big_int_of_int 35)), + "42/35") +;; -set_normalize_ratio_when_printing true;; +set_normalize_ratio_when_printing true +;; test 4 eq_string (string_of_ratio - (create_ratio (big_int_of_int 42) (big_int_of_int 35)), - "6/5");; + (create_ratio (big_int_of_int 42) (big_int_of_int 35)), + "6/5") +;; -testing_function "ratio_of_string";; +testing_function "ratio_of_string" +;; test 1 -eq_ratio (ratio_of_string ("123/3456"), - create_ratio (big_int_of_int 123) (big_int_of_int 3456));; +eq_ratio (ratio_of_string ("123/3456"), + create_ratio (big_int_of_int 123) (big_int_of_int 3456)) +;; (*********** test 2 -eq_ratio (ratio_of_string ("12.3/34.56"), - create_ratio (big_int_of_int 1230) (big_int_of_int 3456));; +eq_ratio (ratio_of_string ("12.3/34.56"), + create_ratio (big_int_of_int 1230) (big_int_of_int 3456)) +;; test 3 -eq_ratio (ratio_of_string ("1.23/325.6"), - create_ratio (big_int_of_int 123) (big_int_of_int 32560));; +eq_ratio (ratio_of_string ("1.23/325.6"), + create_ratio (big_int_of_int 123) (big_int_of_int 32560)) +;; test 4 -eq_ratio (ratio_of_string ("12.3/345.6"), - create_ratio (big_int_of_int 123) (big_int_of_int 3456));; +eq_ratio (ratio_of_string ("12.3/345.6"), + create_ratio (big_int_of_int 123) (big_int_of_int 3456)) +;; test 5 -eq_ratio (ratio_of_string ("12.3/0.0"), - create_ratio (big_int_of_int 123) (big_int_of_int 0));; +eq_ratio (ratio_of_string ("12.3/0.0"), + create_ratio (big_int_of_int 123) (big_int_of_int 0)) +;; ***********) test 6 -eq_ratio (ratio_of_string ("0/0"), - create_ratio (big_int_of_int 0) (big_int_of_int 0));; +eq_ratio (ratio_of_string ("0/0"), + create_ratio (big_int_of_int 0) (big_int_of_int 0)) +;; test 7 -eq_ratio (ratio_of_string "1234567890", - create_ratio (big_int_of_string "1234567890") unit_big_int);; +eq_ratio (ratio_of_string "1234567890", + create_ratio (big_int_of_string "1234567890") unit_big_int) +;; failwith_test 8 ratio_of_string "frlshjkurty" (Failure "invalid digit");; (*********** -testing_function "msd_ratio";; +testing_function "msd_ratio" +;; test 1 eq_int (msd_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 1)), - 0);; + 0) +;; test 2 eq_int (msd_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 12)), - (-2));; + (-2)) +;; test 3 eq_int (msd_ratio (create_ratio (big_int_of_int 12) (big_int_of_int 1)), - 1);; + 1) +;; test 4 eq_int (msd_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 2)), - (-1));; + (-1)) +;; test 5 eq_int (msd_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 1)), - 0);; + 0) +;; test 6 eq_int (msd_ratio (create_ratio (big_int_of_int 25) (big_int_of_int 21)), - 0);; + 0) +;; test 7 eq_int (msd_ratio (create_ratio (big_int_of_int 35) (big_int_of_int 21)), - 0);; + 0) +;; test 8 eq_int (msd_ratio (create_ratio (big_int_of_int 215) (big_int_of_int 31)), - 0);; + 0) +;; test 9 eq_int (msd_ratio (create_ratio (big_int_of_int 2) (big_int_of_int 30)), - (-2));; + (-2)) +;; test 10 -eq_int (msd_ratio (create_ratio (big_int_of_int 2345) +eq_int (msd_ratio (create_ratio (big_int_of_int 2345) (big_int_of_int 23456)), - (-2));; + (-2)) +;; test 11 -eq_int (msd_ratio (create_ratio (big_int_of_int 2345) +eq_int (msd_ratio (create_ratio (big_int_of_int 2345) (big_int_of_int 2346)), - (-1));; + (-1)) +;; test 12 -eq_int (msd_ratio (create_ratio (big_int_of_int 2345) +eq_int (msd_ratio (create_ratio (big_int_of_int 2345) (big_int_of_int 2344)), - 0);; + 0) +;; test 13 -eq_int (msd_ratio (create_ratio (big_int_of_int 23456) +eq_int (msd_ratio (create_ratio (big_int_of_int 23456) (big_int_of_int 2345)), - 1);; + 1) +;; test 14 -eq_int (msd_ratio (create_ratio (big_int_of_int 23467) +eq_int (msd_ratio (create_ratio (big_int_of_int 23467) (big_int_of_int 2345)), - 1);; + 1) +;; failwith_test 15 msd_ratio (create_ratio (big_int_of_int 1) (big_int_of_int 0)) -("msd_ratio "^infinite_failure);; +("msd_ratio "^infinite_failure) +;; failwith_test 16 msd_ratio (create_ratio (big_int_of_int (-1)) (big_int_of_int 0)) -("msd_ratio "^infinite_failure);; +("msd_ratio "^infinite_failure) +;; failwith_test 17 msd_ratio (create_ratio (big_int_of_int 0) (big_int_of_int 0)) -("msd_ratio "^infinite_failure);; +("msd_ratio "^infinite_failure) +;; *************************) -testing_function "round_futur_last_digit";; +testing_function "round_futur_last_digit" +;; let s = "+123456" in -test 1 eq (round_futur_last_digit s 1 (pred (String.length s)), +test 1 eq (round_futur_last_digit s 1 (pred (String.length s)), false) && -test 2 eq_string (s, "+123466");; +test 2 eq_string (s, "+123466") +;; let s = "123456" in test 3 eq (round_futur_last_digit s 0 (String.length s), false) && -test 4 eq_string (s, "123466");; +test 4 eq_string (s, "123466") +;; let s = "-123456" in test 5 eq (round_futur_last_digit s 1 (pred (String.length s)), false) && -test 6 eq_string (s, "-123466");; +test 6 eq_string (s, "-123466") +;; let s = "+123496" in test 7 eq (round_futur_last_digit s 1 (pred (String.length s)), false) && -test 8 eq_string (s, "+123506");; +test 8 eq_string (s, "+123506") +;; let s = "123496" in test 9 eq (round_futur_last_digit s 0 (String.length s), false) && -test 10 eq_string (s, "123506");; +test 10 eq_string (s, "123506") +;; let s = "-123496" in test 11 eq (round_futur_last_digit s 1 (pred (String.length s)), false) && -test 12 eq_string (s, "-123506");; +test 12 eq_string (s, "-123506") +;; let s = "+996" in -test 13 eq (round_futur_last_digit s 1 (pred (String.length s)), +test 13 eq (round_futur_last_digit s 1 (pred (String.length s)), true) && -test 14 eq_string (s, "+006");; +test 14 eq_string (s, "+006") +;; let s = "996" in test 15 eq (round_futur_last_digit s 0 (String.length s), true) && -test 16 eq_string (s, "006");; +test 16 eq_string (s, "006") +;; let s = "-996" in -test 17 eq (round_futur_last_digit s 1 (pred (String.length s)), +test 17 eq (round_futur_last_digit s 1 (pred (String.length s)), true) && -test 18 eq_string (s, "-006");; +test 18 eq_string (s, "-006") +;; let s = "+6666666" in -test 19 eq (round_futur_last_digit s 1 (pred (String.length s)), +test 19 eq (round_futur_last_digit s 1 (pred (String.length s)), false) && -test 20 eq_string (s, "+6666676") ;; +test 20 eq_string (s, "+6666676") +;; let s = "6666666" in test 21 eq (round_futur_last_digit s 0 (String.length s), false) && -test 22 eq_string (s, "6666676") ;; +test 22 eq_string (s, "6666676") +;; let s = "-6666666" in -test 23 eq (round_futur_last_digit s 1 (pred (String.length s)), +test 23 eq (round_futur_last_digit s 1 (pred (String.length s)), false) && -test 24 eq_string (s, "-6666676") ;; +test 24 eq_string (s, "-6666676") +;; -testing_function "approx_ratio_fix";; +testing_function "approx_ratio_fix" +;; -let s = approx_ratio_fix 5 - (create_ratio (big_int_of_int 2) +let s = approx_ratio_fix 5 + (create_ratio (big_int_of_int 2) (big_int_of_int 3)) in test 1 -eq_string (s, "+0.66667");; +eq_string (s, "+0.66667") +;; test 2 -eq_string (approx_ratio_fix 5 - (create_ratio (big_int_of_int 20) - (big_int_of_int 3)), - "+6.66667");; +eq_string (approx_ratio_fix 5 + (create_ratio (big_int_of_int 20) + (big_int_of_int 3)), + "+6.66667") +;; test 3 -eq_string (approx_ratio_fix 5 - (create_ratio (big_int_of_int 2) +eq_string (approx_ratio_fix 5 + (create_ratio (big_int_of_int 2) (big_int_of_int 30)), - "+0.06667");; + "+0.06667") +;; test 4 -eq_string (approx_ratio_fix 5 - (create_ratio (big_int_of_string "999996") - (big_int_of_string "1000000")), - "+1.00000");; +eq_string (approx_ratio_fix 5 + (create_ratio (big_int_of_string "999996") + (big_int_of_string "1000000")), + "+1.00000") +;; test 5 -eq_string (approx_ratio_fix 5 - (create_ratio (big_int_of_string "299996") - (big_int_of_string "100000")), - "+2.99996");; +eq_string (approx_ratio_fix 5 + (create_ratio (big_int_of_string "299996") + (big_int_of_string "100000")), + "+2.99996") +;; test 6 -eq_string (approx_ratio_fix 5 - (create_ratio (big_int_of_string "2999996") - (big_int_of_string "1000000")), - "+3.00000");; +eq_string (approx_ratio_fix 5 + (create_ratio (big_int_of_string "2999996") + (big_int_of_string "1000000")), + "+3.00000") +;; test 7 -eq_string (approx_ratio_fix 4 - (create_ratio (big_int_of_string "299996") - (big_int_of_string "100000")), - "+3.0000");; +eq_string (approx_ratio_fix 4 + (create_ratio (big_int_of_string "299996") + (big_int_of_string "100000")), + "+3.0000") +;; test 8 -eq_string (approx_ratio_fix 5 - (create_ratio (big_int_of_int 29996) - (big_int_of_string "100000")), - "+0.29996");; +eq_string (approx_ratio_fix 5 + (create_ratio (big_int_of_int 29996) + (big_int_of_string "100000")), + "+0.29996") +;; test 9 -eq_string (approx_ratio_fix 5 - (create_ratio (big_int_of_int 0) - (big_int_of_int 1)), - "+0");; +eq_string (approx_ratio_fix 5 + (create_ratio (big_int_of_int 0) + (big_int_of_int 1)), + "+0") +;; failwith_test 10 (approx_ratio_fix 5) (create_ratio (big_int_of_int 1) (big_int_of_int 0)) -(Failure "approx_ratio_fix infinite or undefined rational number");; +(Failure "approx_ratio_fix infinite or undefined rational number") +;; failwith_test 11 (approx_ratio_fix 5) (create_ratio (big_int_of_int 0) (big_int_of_int 0)) -(Failure "approx_ratio_fix infinite or undefined rational number");; +(Failure "approx_ratio_fix infinite or undefined rational number") +;; -testing_function "approx_ratio_exp";; +(* PR#4566 *) +test 12 +eq_string (approx_ratio_fix 8 + (create_ratio (big_int_of_int 9603) + (big_int_of_string "100000000000")), + + "+0.00000010") +;; +test 13 +eq_string (approx_ratio_fix 1 + (create_ratio (big_int_of_int 94) + (big_int_of_int 1000)), + "+0.1") +;; +test 14 +eq_string (approx_ratio_fix 1 + (create_ratio (big_int_of_int 49) + (big_int_of_int 1000)), + "+0.0") +;; + +testing_function "approx_ratio_exp" +;; test 1 -eq_string (approx_ratio_exp 5 - (create_ratio (big_int_of_int 2) - (big_int_of_int 3)), - "+0.66667e0");; +eq_string (approx_ratio_exp 5 + (create_ratio (big_int_of_int 2) + (big_int_of_int 3)), + "+0.66667e0") +;; test 2 -eq_string (approx_ratio_exp 5 - (create_ratio (big_int_of_int 20) - (big_int_of_int 3)), - "+0.66667e1");; +eq_string (approx_ratio_exp 5 + (create_ratio (big_int_of_int 20) + (big_int_of_int 3)), + "+0.66667e1") +;; test 3 -eq_string (approx_ratio_exp 5 - (create_ratio (big_int_of_int 2) - (big_int_of_int 30)), - "+0.66667e-1");; +eq_string (approx_ratio_exp 5 + (create_ratio (big_int_of_int 2) + (big_int_of_int 30)), + "+0.66667e-1") +;; test 4 -eq_string (approx_ratio_exp 5 - (create_ratio (big_int_of_string "999996") - (big_int_of_string "1000000")), - "+1.00000e0");; +eq_string (approx_ratio_exp 5 + (create_ratio (big_int_of_string "999996") + (big_int_of_string "1000000")), + "+1.00000e0") +;; test 5 -eq_string (approx_ratio_exp 5 - (create_ratio (big_int_of_string "299996") - (big_int_of_string "100000")), - "+0.30000e1");; +eq_string (approx_ratio_exp 5 + (create_ratio (big_int_of_string "299996") + (big_int_of_string "100000")), + "+0.30000e1") +;; test 6 -eq_string (approx_ratio_exp 5 - (create_ratio (big_int_of_int 29996) - (big_int_of_string "100000")), - "+0.29996e0");; +eq_string (approx_ratio_exp 5 + (create_ratio (big_int_of_int 29996) + (big_int_of_string "100000")), + "+0.29996e0") +;; test 7 -eq_string (approx_ratio_exp 5 - (create_ratio (big_int_of_int 0) - (big_int_of_int 1)), - "+0.00000e0");; +eq_string (approx_ratio_exp 5 + (create_ratio (big_int_of_int 0) + (big_int_of_int 1)), + "+0.00000e0") +;; failwith_test 8 (approx_ratio_exp 5) (create_ratio (big_int_of_int 1) (big_int_of_int 0)) -(Failure "approx_ratio_exp infinite or undefined rational number");; +(Failure "approx_ratio_exp infinite or undefined rational number") +;; failwith_test 9 (approx_ratio_exp 5) (create_ratio (big_int_of_int 0) (big_int_of_int 0)) -(Failure "approx_ratio_exp infinite or undefined rational number");; +(Failure "approx_ratio_exp infinite or undefined rational number") +;; diff --git a/otherlibs/str/.depend b/otherlibs/str/.depend index 43b299de..bafddbd7 100644 --- a/otherlibs/str/.depend +++ b/otherlibs/str/.depend @@ -12,5 +12,6 @@ strstubs.o: strstubs.c ../../byterun/mlvalues.h \ ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/fail.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ ../../byterun/mlvalues.h +str.cmi: str.cmo: str.cmi str.cmx: str.cmi diff --git a/otherlibs/str/Makefile b/otherlibs/str/Makefile index 06a59306..37388459 100644 --- a/otherlibs/str/Makefile +++ b/otherlibs/str/Makefile @@ -11,62 +11,21 @@ # # ######################################################################### -# $Id: Makefile,v 1.34 2007/01/29 12:11:16 xleroy Exp $ +# $Id: Makefile,v 1.35 2007/11/06 15:16:56 frisch Exp $ # Makefile for the str library -include ../../config/Makefile -# Compilation options -CC=$(BYTECC) -CFLAGS=-O -I../../byterun $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -CAMLC=../../ocamlcomp.sh -CAMLOPT=../../ocamlcompopt.sh -COMPFLAGS=-warn-error A -g -COBJS=strstubs.o -MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib +LIBNAME=str +COBJS=strstubs.$(O) +CAMLOBJS=str.cmo -all: libstr.a str.cmi str.cma +include ../Makefile -allopt: libstr.a str.cmi str.cmxa - -libstr.a: $(COBJS) - $(MKLIB) -o str $(COBJS) - -str.cma: str.cmo - $(MKLIB) -ocamlc '$(CAMLC)' -o str str.cmo - -str.cmxa: str.cmx - $(MKLIB) -ocamlopt '$(CAMLOPT)' -o str str.cmx - -str.cmx: ../../ocamlopt - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.a *.so *.o - -install: - if test -f dllstr.so; then cp dllstr.so $(STUBLIBDIR)/dllstr.so; fi - cp libstr.a $(LIBDIR)/libstr.a - cd $(LIBDIR); $(RANLIB) libstr.a - cp str.cma str.cmi str.mli $(LIBDIR) - -installopt: - cp str.cmx str.cmxa str.a $(LIBDIR) - cd $(LIBDIR); $(RANLIB) str.a - -.SUFFIXES: .ml .mli .cmo .cmi .cmx - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< +depend: -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< +str.cmo: str.cmi +str.cmx: str.cmi depend: gcc -MM $(CFLAGS) *.c > .depend diff --git a/otherlibs/str/Makefile.nt b/otherlibs/str/Makefile.nt index f3eec32d..d99abe21 100644 --- a/otherlibs/str/Makefile.nt +++ b/otherlibs/str/Makefile.nt @@ -11,72 +11,15 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.15.4.1 2008/01/18 15:27:36 doligez Exp $ +# $Id: Makefile.nt,v 1.16 2007/11/06 15:16:56 frisch Exp $ # Makefile for the str library -include ../../config/Makefile +LIBNAME=str +COBJS=strstubs.$(O) +CAMLOBJS=str.cmo -# Compilation options -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) - -all: dllstr.dll libstr.$(A) str.cmi str.cma - -allopt: libstr.$(A) str.cmi str.cmxa - -dllstr.dll: $(DCOBJS) - $(call MKDLL,dllstr.dll,tmp.$(A),$(DCOBJS) ../../byterun/ocamlrun.$(A)) - rm tmp.* - -libstr.$(A): $(SCOBJS) - $(call MKLIB,libstr.$(A),$(SCOBJS)) - -str.cma: str.cmo - $(CAMLC) -a -o str.cma str.cmo -dllib -lstr -cclib -lstr - -str.cmxa: str.cmx - $(CAMLOPT) -a -o str.cmxa str.cmx -cclib -lstr - -str.cmx: ../../ocamlopt - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.$(A) *.dll *.$(O) *.$(SO) - -install: - cp dllstr.dll $(STUBLIBDIR)/dllstr.dll - cp libstr.$(A) $(LIBDIR)/libstr.$(A) - cp str.cma str.cmi str.mli $(LIBDIR) - -installopt: - cp str.cmx str.cmxa str.$(A) $(LIBDIR) - -.SUFFIXES: .ml .mli .cmo .cmi .cmx .$(DO) .$(SO) - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.c.$(DO): - $(BYTECC) $(DLLCCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(DO) - -.c.$(SO): - $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(SO) +include ../Makefile.nt depend: diff --git a/otherlibs/str/str.ml b/otherlibs/str/str.ml index 7e81e42b..1e1fb51e 100644 --- a/otherlibs/str/str.ml +++ b/otherlibs/str/str.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: str.ml,v 1.20.6.1 2007/10/31 10:01:29 xleroy Exp $ *) +(* $Id: str.ml,v 1.22 2008/08/01 12:27:13 xleroy Exp $ *) (** String utilities *) @@ -645,20 +645,25 @@ let substitute_first expr repl_fun text = with Not_found -> text +let opt_search_forward re s pos = + try Some(search_forward re s pos) with Not_found -> None + let global_substitute expr repl_fun text = - let rec replace start last_was_empty = - try - let startpos = if last_was_empty then start + 1 else start in - if startpos > String.length text then raise Not_found; - let pos = search_forward expr text startpos in - let end_pos = match_end() in - let repl_text = repl_fun text in - String.sub text start (pos-start) :: - repl_text :: - replace end_pos (end_pos = pos) - with Not_found -> - [string_after text start] in - String.concat "" (replace 0 false) + let rec replace accu start last_was_empty = + let startpos = if last_was_empty then start + 1 else start in + if startpos > String.length text then + string_after text start :: accu + else + match opt_search_forward expr text startpos with + | None -> + string_after text start :: accu + | Some pos -> + let end_pos = match_end() in + let repl_text = repl_fun text in + replace (repl_text :: String.sub text start (pos-start) :: accu) + end_pos (end_pos = pos) + in + String.concat "" (List.rev (replace [] 0 false)) let global_replace expr repl text = global_substitute expr (replace_matched repl) text @@ -667,58 +672,66 @@ and replace_first expr repl text = (** Splitting *) -let search_forward_progress expr text start = - let pos = search_forward expr text start in - if match_end() > start then pos - else if start < String.length text then search_forward expr text (start + 1) - else raise Not_found +let opt_search_forward_progress expr text start = + match opt_search_forward expr text start with + | None -> None + | Some pos -> + if match_end() > start then + Some pos + else if start < String.length text then + opt_search_forward expr text (start + 1) + else None let bounded_split expr text num = let start = if string_match expr text 0 then match_end() else 0 in - let rec split start n = - if start >= String.length text then [] else - if n = 1 then [string_after text start] else - try - let pos = search_forward_progress expr text start in - String.sub text start (pos-start) :: split (match_end()) (n-1) - with Not_found -> - [string_after text start] in - split start num + let rec split accu start n = + if start >= String.length text then accu else + if n = 1 then string_after text start :: accu else + match opt_search_forward_progress expr text start with + | None -> + string_after text start :: accu + | Some pos -> + split (String.sub text start (pos-start) :: accu) + (match_end()) (n-1) + in + List.rev (split [] start num) let split expr text = bounded_split expr text 0 let bounded_split_delim expr text num = - let rec split start n = - if start > String.length text then [] else - if n = 1 then [string_after text start] else - try - let pos = search_forward_progress expr text start in - String.sub text start (pos-start) :: split (match_end()) (n-1) - with Not_found -> - [string_after text start] in - if text = "" then [] else split 0 num + let rec split accu start n = + if start > String.length text then accu else + if n = 1 then string_after text start :: accu else + match opt_search_forward_progress expr text start with + | None -> + string_after text start :: accu + | Some pos -> + split (String.sub text start (pos-start) :: accu) + (match_end()) (n-1) + in + if text = "" then [] else List.rev (split [] 0 num) let split_delim expr text = bounded_split_delim expr text 0 type split_result = Text of string | Delim of string let bounded_full_split expr text num = - let rec split start n = - if start >= String.length text then [] else - if n = 1 then [Text(string_after text start)] else - try - let pos = search_forward_progress expr text start in - let s = matched_string text in - if pos > start then - Text(String.sub text start (pos-start)) :: - Delim(s) :: - split (match_end()) (n-1) - else - Delim(s) :: - split (match_end()) (n-1) - with Not_found -> - [Text(string_after text start)] in - split 0 num + let rec split accu start n = + if start >= String.length text then accu else + if n = 1 then Text(string_after text start) :: accu else + match opt_search_forward_progress expr text start with + | None -> + Text(string_after text start) :: accu + | Some pos -> + let s = matched_string text in + if pos > start then + split (Delim(s) :: Text(String.sub text start (pos-start)) :: accu) + (match_end()) (n-1) + else + split (Delim(s) :: accu) + (match_end()) (n-1) + in + List.rev (split [] 0 num) let full_split expr text = bounded_full_split expr text 0 diff --git a/otherlibs/systhreads/.depend b/otherlibs/systhreads/.depend index 4f4e3162..fa6bbbda 100644 --- a/otherlibs/systhreads/.depend +++ b/otherlibs/systhreads/.depend @@ -23,6 +23,10 @@ posix.o: posix.c ../../byterun/alloc.h ../../byterun/compatibility.h \ ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/sys.h \ ../../byterun/misc.h condition.cmi: mutex.cmi +event.cmi: +mutex.cmi: +thread.cmi: +threadUnix.cmi: condition.cmo: mutex.cmi condition.cmi condition.cmx: mutex.cmx condition.cmi event.cmo: mutex.cmi condition.cmi event.cmi @@ -33,3 +37,7 @@ thread.cmo: thread.cmi thread.cmx: thread.cmi threadUnix.cmo: thread.cmi threadUnix.cmi threadUnix.cmx: thread.cmx threadUnix.cmi +thread_posix.cmo: +thread_posix.cmx: +thread_win32.cmo: +thread_win32.cmx: diff --git a/otherlibs/systhreads/Makefile b/otherlibs/systhreads/Makefile index fcb34deb..2a768573 100644 --- a/otherlibs/systhreads/Makefile +++ b/otherlibs/systhreads/Makefile @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.40.4.1 2007/03/06 16:02:09 xleroy Exp $ +# $Id: Makefile,v 1.44 2008/07/15 15:31:32 frisch Exp $ include ../../config/Makefile @@ -55,7 +55,13 @@ 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 $(PTHREAD_LINK) + -cclib -lthreadsnat $(PTHREAD_LINK) + +# Note: I removed "-cclib -lunix" from the line above. +# Indeed, if we link threads.cmxa, then we must also link unix.cmxa, +# which itself will pass -lunix to the C linker. It seems more +# modular to me this way. -- Alain + $(THREAD_OBJS:.cmo=.cmx): ../../ocamlopt diff --git a/otherlibs/systhreads/Makefile.nt b/otherlibs/systhreads/Makefile.nt index 69224b7d..b762ec9c 100644 --- a/otherlibs/systhreads/Makefile.nt +++ b/otherlibs/systhreads/Makefile.nt @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.30 2007/01/29 12:11:17 xleroy Exp $ +# $Id: Makefile.nt,v 1.31 2007/11/06 15:16:56 frisch Exp $ include ../../config/Makefile @@ -19,46 +19,50 @@ include ../../config/Makefile CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib -I ../win32unix CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -I ../win32unix COMPFLAGS=-warn-error A -g +MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib +CFLAGS=-I../../byterun $(EXTRACFLAGS) -THREAD_OBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo +CAMLOBJS=thread.cmo mutex.cmo condition.cmo event.cmo threadUnix.cmo +CMIFILES=$(CAMLOBJS:.cmo=.cmi) +COBJS=win32_b.$(O) +COBJS_NAT=win32_n.$(O) GENFILES=thread.ml -all: dllthreads.dll libthreads.$(A) threads.cma +LIBNAME=threads -allopt: libthreadsnat.$(A) threads.cmxa +all: lib$(LIBNAME).$(A) $(LIBNAME).cma $(CMIFILES) -dllthreads.dll: win32_b.$(DO) - $(call MKDLL,dllthreads.dll,tmp.$(A),win32_b.$(DO) ../../byterun/ocamlrun.$(A)) - rm tmp.* +allopt: lib$(LIBNAME).$(A) $(LIBNAME).cmxa $(LIBNAME).cmxs $(CMIFILES) -libthreads.$(A): win32_b.$(SO) - $(call MKLIB,libthreads.$(A),win32_b.$(SO)) +$(LIBNAME).cma: $(CAMLOBJS) + $(MKLIB) -o $(LIBNAME) -ocamlc "..\\..\\boot\\ocamlrun ..\\..\\ocamlc" -linkall $(CAMLOBJS) $(LINKOPTS) -win32_b.$(DO): win32.c - $(BYTECC) -I../../byterun $(DLLCCCOMPOPTS) -c win32.c - mv win32.$(O) win32_b.$(DO) +lib$(LIBNAME).$(A): $(COBJS) + $(MKLIB) -o $(LIBNAME) $(COBJS) $(LDOPTS) -win32_b.$(SO): win32.c - $(BYTECC) -I../../byterun $(BYTECCCOMPOPTS) -c win32.c - mv win32.$(O) win32_b.$(SO) +win32_b.$(O): win32.c + $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c win32.c + mv win32.$(O) win32_b.$(O) -libthreadsnat.$(A): win32_n.$(O) - $(call MKLIB,libthreadsnat.$(A),win32_n.$(O)) + + +$(LIBNAME).cmxa: $(CAMLOBJS:.cmo=.cmx) + $(MKLIB) -o $(LIBNAME)nat -ocamlopt "..\\..\\boot\\ocamlrun ..\\..\\ocamlopt" -linkall $(CAMLOBJS:.cmo=.cmx) $(LINKOPTS) + mv $(LIBNAME)nat.cmxa $(LIBNAME).cmxa + mv $(LIBNAME)nat.$(A) $(LIBNAME).$(A) + +$(LIBNAME).cmxs: $(LIBNAME).cmxa lib$(LIBNAME)nat.$(A) + $(CAMLOPT) -shared -o $(LIBNAME).cmxs -I . $(LIBNAME).cmxa -linkall + +lib$(LIBNAME)nat.$(A): $(COBJS_NAT) + $(MKLIB) -o $(LIBNAME)nat $(COBJS_NAT) $(LDOPTS) win32_n.$(O): win32.c $(NATIVECC) -DNATIVE_CODE -O -I../../asmrun -I../../byterun $(NATIVECCCOMPOPTS) -c win32.c mv win32.$(O) win32_n.$(O) -threads.cma: $(THREAD_OBJS) - $(CAMLC) -a -o threads.cma $(THREAD_OBJS) \ - -dllib -lthreads -cclib -lthreads - -threads.cmxa: $(THREAD_OBJS:.cmo=.cmx) - $(CAMLOPT) -a -o threads.cmxa $(THREAD_OBJS:.cmo=.cmx) \ - -cclib -lthreadsnat - -$(THREAD_OBJS:.cmo=.cmx): ../../ocamlopt +$(CAMLOBJS:.cmo=.cmx): ../../ocamlopt thread.ml: thread_win32.ml cp thread_win32.ml thread.ml @@ -74,12 +78,13 @@ install: cp dllthreads.dll $(STUBLIBDIR)/dllthreads.dll cp libthreads.$(A) $(LIBDIR)/libthreads.$(A) mkdir -p $(LIBDIR)/threads - cp $(THREAD_OBJS:.cmo=.cmi) threads.cma $(LIBDIR)/threads + cp $(CMIFILES) threads.cma $(LIBDIR)/threads rm -f $(LIBDIR)/threads/stdlib.cma installopt: cp libthreadsnat.$(A) $(LIBDIR)/libthreadsnat.$(A) cp $(THREAD_OBJS:.cmo=.cmx) threads.cmxa threads.$(A) $(LIBDIR)/threads + cp threads.cmxs $(LIBDIR)/threads .SUFFIXES: .ml .mli .cmo .cmi .cmx diff --git a/otherlibs/systhreads/posix.c b/otherlibs/systhreads/posix.c index d00e1fbe..4a94dc67 100644 --- a/otherlibs/systhreads/posix.c +++ b/otherlibs/systhreads/posix.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: posix.c,v 1.55.4.1 2007/11/01 16:42:29 xleroy Exp $ */ +/* $Id: posix.c,v 1.58 2008/09/27 10:46:55 xleroy Exp $ */ /* Thread interface for POSIX 1003.1c threads */ @@ -27,7 +27,6 @@ #include #ifdef __linux__ #include -#include #endif #include "alloc.h" #include "backtrace.h" @@ -122,15 +121,11 @@ static pthread_key_t last_channel_locked_key; /* Identifier for next thread creation */ static intnat thread_next_ident = 0; -/* Whether to use sched_yield() or not */ -static int broken_sched_yield = 0; - /* Forward declarations */ value caml_threadstatus_new (void); void caml_threadstatus_terminate (value); int caml_threadstatus_wait (value); static void caml_pthread_check (int, char *); -static void caml_thread_sysdeps_initialize(void); /* Imports for the native-code compiler */ extern struct longjmp_buffer caml_termination_jmpbuf; @@ -258,6 +253,12 @@ static void caml_io_mutex_lock(struct channel *chan) pthread_mutex_init(mutex, NULL); chan->mutex = (void *) mutex; } + /* PR#4351: first try to acquire mutex without releasing the master lock */ + if (pthread_mutex_trylock(chan->mutex) == 0) { + pthread_setspecific(last_channel_locked_key, (void *) chan); + return; + } + /* If unsuccessful, block on mutex */ enter_blocking_section(); pthread_mutex_lock(chan->mutex); /* Problem: if a signal occurs at this point, @@ -326,6 +327,44 @@ static void * caml_thread_tick(void * arg) return NULL; /* prevents compiler warning */ } +/* Reinitialize the thread machinery after a fork() (PR#4577) */ + +static void caml_thread_reinitialize(void) +{ + caml_thread_t thr, next; + pthread_t tick_pthread; + pthread_attr_t attr; + struct channel * chan; + + /* Remove all other threads (now nonexistent) + from the doubly-linked list of threads */ + thr = curr_thread->next; + while (thr != curr_thread) { + next = thr->next; + stat_free(thr); + thr = next; + } + curr_thread->next = curr_thread; + curr_thread->prev = curr_thread; + /* Reinitialize the master lock machinery, + just in case the fork happened while other threads were doing + leave_blocking_section */ + pthread_mutex_init(&caml_runtime_mutex, NULL); + pthread_cond_init(&caml_runtime_is_free, NULL); + caml_runtime_waiters = 0; /* no other thread is waiting for the RTS */ + caml_runtime_busy = 1; /* normally useless */ + /* Reinitialize all IO mutexes */ + for (chan = caml_all_opened_channels; + chan != NULL; + chan = chan->next) { + if (chan->mutex != NULL) pthread_mutex_init(chan->mutex, NULL); + } + /* Fork a new tick thread */ + pthread_attr_init(&attr); + pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); + pthread_create(&tick_pthread, &attr, caml_thread_tick, NULL); +} + /* Initialize the thread machinery */ value caml_thread_initialize(value unit) /* ML */ @@ -338,8 +377,6 @@ value caml_thread_initialize(value unit) /* ML */ /* Protect against repeated initialization (PR#1325) */ if (curr_thread != NULL) return Val_unit; Begin_root (mu); - /* OS-specific initialization */ - caml_thread_sysdeps_initialize(); /* Initialize the keys */ pthread_key_create(&thread_descriptor_key, NULL); pthread_key_create(&last_channel_locked_key, NULL); @@ -384,6 +421,9 @@ value caml_thread_initialize(value unit) /* ML */ caml_pthread_check( pthread_create(&tick_pthread, &attr, caml_thread_tick, NULL), "Thread.init"); + /* Set up fork() to reinitialize the thread machinery in the child + (PR#4577) */ + pthread_atfork(NULL, NULL, caml_thread_reinitialize); End_roots(); return Val_unit; } @@ -562,7 +602,10 @@ value caml_thread_yield(value unit) /* ML */ { if (caml_runtime_waiters == 0) return Val_unit; enter_blocking_section(); - if (! broken_sched_yield) sched_yield(); +#ifndef __linux__ + /* sched_yield() doesn't do what we want in Linux 2.6 and up (PR#2663) */ + sched_yield(); +#endif leave_blocking_section(); return Val_unit; } @@ -620,6 +663,10 @@ value caml_mutex_lock(value wrapper) /* ML */ { int retcode; pthread_mutex_t * mut = Mutex_val(wrapper); + /* PR#4351: first try to acquire mutex without releasing the master lock */ + retcode = pthread_mutex_trylock(mut); + if (retcode == 0) return Val_unit; + /* If unsuccessful, block on mutex */ Begin_root(wrapper) /* prevent the deallocation of mutex */ enter_blocking_section(); retcode = pthread_mutex_lock(mut); @@ -633,11 +680,8 @@ value caml_mutex_unlock(value wrapper) /* ML */ { int retcode; pthread_mutex_t * mut = Mutex_val(wrapper); - Begin_root(wrapper) /* prevent the deallocation of mutex */ - enter_blocking_section(); - retcode = pthread_mutex_unlock(mut); - leave_blocking_section(); - End_roots(); + /* PR#4351: no need to release and reacquire master lock */ + retcode = pthread_mutex_unlock(mut); caml_pthread_check(retcode, "Mutex.unlock"); return Val_unit; } @@ -703,11 +747,7 @@ value caml_condition_signal(value wrapper) /* ML */ { int retcode; pthread_cond_t * cond = Condition_val(wrapper); - Begin_root(wrapper) /* prevent deallocation of condition */ - enter_blocking_section(); - retcode = pthread_cond_signal(cond); - leave_blocking_section(); - End_roots(); + retcode = pthread_cond_signal(cond); caml_pthread_check(retcode, "Condition.signal"); return Val_unit; } @@ -716,11 +756,7 @@ value caml_condition_broadcast(value wrapper) /* ML */ { int retcode; pthread_cond_t * cond = Condition_val(wrapper); - Begin_root(wrapper) /* prevent deallocation of condition */ - enter_blocking_section(); - retcode = pthread_cond_broadcast(cond); - leave_blocking_section(); - End_roots(); + retcode = pthread_cond_broadcast(cond); caml_pthread_check(retcode, "Condition.broadcast"); return Val_unit; } @@ -888,20 +924,3 @@ static void caml_pthread_check(int retcode, char *msg) raise_sys_error(str); } -/* OS-specific initialization */ - -static void caml_thread_sysdeps_initialize(void) -{ -#ifdef __linux__ - /* sched_yield() doesn't do what we want in kernel 2.6 and up (PR#2663) */ - struct utsname un; - if (uname(&un) == -1) return; - broken_sched_yield = - un.release[1] != '.' || un.release[0] >= '3' /* version 3 and up */ - || (un.release[0] == '2' && - (un.release[3] != '.' || un.release[2] >= '6')); /* 2.6 and up */ - caml_gc_message(0x100, "POSIX threads. Avoid sched_yield: %d\n", - broken_sched_yield); -#endif -} - diff --git a/otherlibs/systhreads/thread.mli b/otherlibs/systhreads/thread.mli index 0ba4c0e8..85fb1606 100644 --- a/otherlibs/systhreads/thread.mli +++ b/otherlibs/systhreads/thread.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: thread.mli,v 1.20.10.1 2007/10/25 08:35:32 xleroy Exp $ *) +(* $Id: thread.mli,v 1.21 2008/01/11 16:13:16 doligez Exp $ *) (** Lightweight threads for Posix [1003.1c] and Win32. *) diff --git a/otherlibs/systhreads/win32.c b/otherlibs/systhreads/win32.c index 77d8af3c..a84122cf 100644 --- a/otherlibs/systhreads/win32.c +++ b/otherlibs/systhreads/win32.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: win32.c,v 1.44 2006/04/16 23:28:21 doligez Exp $ */ +/* $Id: win32.c,v 1.45 2007/10/31 09:12:29 xleroy Exp $ */ /* Thread interface for Win32 threads */ @@ -227,6 +227,11 @@ static void caml_io_mutex_lock(struct channel * chan) if (mutex == NULL) caml_wthread_error("Thread.iolock"); chan->mutex = (void *) mutex; } + /* PR#4351: first try to acquire mutex without releasing the master lock */ + if (WaitForSingleObject((HANDLE) chan->mutex, 0) == WAIT_OBJECT_0) { + TlsSetValue(last_channel_locked_key, (void *) chan); + return; + } enter_blocking_section(); WaitForSingleObject((HANDLE) chan->mutex, INFINITE); /* Problem: if a signal occurs at this point, @@ -518,6 +523,9 @@ CAMLprim value caml_mutex_new(value unit) CAMLprim value caml_mutex_lock(value mut) { int retcode; + /* PR#4351: first try to acquire mutex without releasing the master lock */ + retcode = WaitForSingleObject(Mutex_val(mut), 0); + if (retcode == WAIT_OBJECT_0) return Val_unit; Begin_root(mut) /* prevent deallocation of mutex */ enter_blocking_section(); retcode = WaitForSingleObject(Mutex_val(mut), INFINITE); @@ -530,11 +538,8 @@ CAMLprim value caml_mutex_lock(value mut) CAMLprim value caml_mutex_unlock(value mut) { BOOL retcode; - Begin_root(mut) /* prevent deallocation of mutex */ - enter_blocking_section(); - retcode = ReleaseMutex(Mutex_val(mut)); - leave_blocking_section(); - End_roots(); + /* PR#4351: no need to release and reacquire master lock */ + retcode = ReleaseMutex(Mutex_val(mut)); if (!retcode) caml_wthread_error("Mutex.unlock"); return Val_unit; } @@ -630,12 +635,8 @@ CAMLprim value caml_condition_signal(value cond) if (Condition_val(cond)->count > 0) { Condition_val(cond)->count --; - Begin_root(cond) /* prevent deallocation of cond */ - enter_blocking_section(); - /* Increment semaphore by 1, waking up one waiter */ - ReleaseSemaphore(s, 1, NULL); - leave_blocking_section(); - End_roots(); + /* Increment semaphore by 1, waking up one waiter */ + ReleaseSemaphore(s, 1, NULL); } return Val_unit; } @@ -647,12 +648,8 @@ CAMLprim value caml_condition_broadcast(value cond) if (c > 0) { Condition_val(cond)->count = 0; - Begin_root(cond) /* prevent deallocation of cond */ - enter_blocking_section(); - /* Increment semaphore by c, waking up all waiters */ - ReleaseSemaphore(s, c, NULL); - leave_blocking_section(); - End_roots(); + /* Increment semaphore by c, waking up all waiters */ + ReleaseSemaphore(s, c, NULL); } return Val_unit; } diff --git a/otherlibs/threads/.depend b/otherlibs/threads/.depend index e1a829fa..919e0922 100644 --- a/otherlibs/threads/.depend +++ b/otherlibs/threads/.depend @@ -22,6 +22,8 @@ scheduler.o: scheduler.c ../../byterun/alloc.h \ ../../byterun/mlvalues.h ../../byterun/memory.h ../../byterun/sys.h \ ../../byterun/misc.h condition.cmi: mutex.cmi +event.cmi: +mutex.cmi: thread.cmi: unix.cmo threadUnix.cmi: unix.cmo condition.cmo: thread.cmi mutex.cmi condition.cmi @@ -38,3 +40,5 @@ thread.cmo: unix.cmo thread.cmi thread.cmx: unix.cmx thread.cmi threadUnix.cmo: unix.cmo thread.cmi threadUnix.cmi threadUnix.cmx: unix.cmx thread.cmx threadUnix.cmi +unix.cmo: +unix.cmx: diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile index d6c8a76c..6453f02d 100644 --- a/otherlibs/threads/Makefile +++ b/otherlibs/threads/Makefile @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.59 2007/02/16 09:54:55 ertai Exp $ +# $Id: Makefile,v 1.61.2.1 2008/10/08 13:07:13 doligez Exp $ include ../../config/Makefile @@ -34,13 +34,14 @@ LIB_OBJS=pervasives.cmo \ $(LIB)/nativeint.cmo \ $(LIB)/lexing.cmo $(LIB)/parsing.cmo \ $(LIB)/set.cmo $(LIB)/map.cmo $(LIB)/stack.cmo $(LIB)/queue.cmo \ + $(LIB)/camlinternalLazy.cmo $(LIB)/lazy.cmo \ $(LIB)/stream.cmo $(LIB)/buffer.cmo \ $(LIB)/printf.cmo $(LIB)/format.cmo \ $(LIB)/scanf.cmo $(LIB)/arg.cmo \ $(LIB)/printexc.cmo $(LIB)/gc.cmo $(LIB)/digest.cmo $(LIB)/random.cmo \ $(LIB)/camlinternalOO.cmo $(LIB)/oo.cmo $(LIB)/camlinternalMod.cmo \ $(LIB)/genlex.cmo $(LIB)/callback.cmo $(LIB)/weak.cmo \ - $(LIB)/lazy.cmo $(LIB)/filename.cmo $(LIB)/complex.cmo \ + $(LIB)/filename.cmo $(LIB)/complex.cmo \ $(LIB)/arrayLabels.cmo $(LIB)/listLabels.cmo $(LIB)/stringLabels.cmo \ $(LIB)/stdLabels.cmo $(LIB)/moreLabels.cmo @@ -83,12 +84,12 @@ marshal.cmi: $(LIB)/marshal.cmi ln -s $(LIB)/marshal.cmi marshal.cmi unix.mli: $(UNIXLIB)/unix.mli - ln -sf $(UNIXLIB)/unix.mli unix.mli + ln -s -f $(UNIXLIB)/unix.mli unix.mli unix.cmi: $(UNIXLIB)/unix.cmi - ln -sf $(UNIXLIB)/unix.cmi unix.cmi + ln -s -f $(UNIXLIB)/unix.cmi unix.cmi -unix.cmo: unix.mli unix.cmi $(UNIXLIB)/unixLabels.cmo +unix.cmo: unix.mli unix.cmi $(UNIXLIB)/unixLabels.cmo $(CAMLC) ${COMPFLAGS} -c unix.ml partialclean: diff --git a/otherlibs/threads/unix.ml b/otherlibs/threads/unix.ml index ed0f34a3..247cb109 100644 --- a/otherlibs/threads/unix.ml +++ b/otherlibs/threads/unix.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: unix.ml,v 1.20 2006/09/21 13:54:26 xleroy Exp $ *) +(* $Id: unix.ml,v 1.22 2008/08/01 16:29:44 mauny Exp $ *) (* An alternate implementation of the Unix module from ../unix which is safe in conjunction with bytecode threads. *) @@ -541,29 +541,6 @@ type msg_flag = | MSG_DONTROUTE | MSG_PEEK -type socket_bool_option = - SO_DEBUG - | SO_BROADCAST - | SO_REUSEADDR - | SO_KEEPALIVE - | SO_DONTROUTE - | SO_OOBINLINE - | SO_ACCEPTCONN - -type socket_int_option = - SO_SNDBUF - | SO_RCVBUF - | SO_ERROR - | SO_TYPE - | SO_RCVLOWAT - | SO_SNDLOWAT - -type socket_optint_option = SO_LINGER - -type socket_float_option = - SO_RCVTIMEO - | SO_SNDTIMEO - external _socket : socket_domain -> socket_type -> int -> file_descr = "unix_socket" external _socketpair : @@ -595,23 +572,6 @@ external listen : file_descr -> int -> unit = "unix_listen" external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown" external getsockname : file_descr -> sockaddr = "unix_getsockname" external getpeername : file_descr -> sockaddr = "unix_getpeername" -external getsockopt : file_descr -> socket_bool_option -> bool - = "unix_getsockopt_bool" -external setsockopt : file_descr -> socket_bool_option -> bool -> unit - = "unix_setsockopt_bool" -external getsockopt_int : file_descr -> socket_int_option -> int - = "unix_getsockopt_int" -external setsockopt_int : file_descr -> socket_int_option -> int -> unit - = "unix_setsockopt_int" -external getsockopt_optint : file_descr -> socket_optint_option -> int option - = "unix_getsockopt_optint" -external setsockopt_optint - : file_descr -> socket_optint_option -> int option -> unit - = "unix_setsockopt_optint" -external getsockopt_float : file_descr -> socket_float_option -> float - = "unix_getsockopt_float" -external setsockopt_float : file_descr -> socket_float_option -> float -> unit - = "unix_setsockopt_float" external _connect : file_descr -> sockaddr -> unit = "unix_connect" @@ -671,6 +631,70 @@ let rec sendto fd buf ofs len flags addr = wait_write fd; sendto fd buf ofs len flags addr +type socket_bool_option = + SO_DEBUG + | SO_BROADCAST + | SO_REUSEADDR + | SO_KEEPALIVE + | SO_DONTROUTE + | SO_OOBINLINE + | SO_ACCEPTCONN + | TCP_NODELAY + | IPV6_ONLY + + +type socket_int_option = + SO_SNDBUF + | SO_RCVBUF + | SO_ERROR + | SO_TYPE + | SO_RCVLOWAT + | SO_SNDLOWAT + +type socket_optint_option = SO_LINGER + +type socket_float_option = + SO_RCVTIMEO + | SO_SNDTIMEO + +type socket_error_option = SO_ERROR + +module SO: sig + type ('opt, 'v) t + val bool: (socket_bool_option, bool) t + val int: (socket_int_option, int) t + val optint: (socket_optint_option, int option) t + val float: (socket_float_option, float) t + val error: (socket_error_option, error option) t + val get: ('opt, 'v) t -> file_descr -> 'opt -> 'v + val set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit +end = struct + type ('opt, 'v) t = int + let bool = 0 + let int = 1 + let optint = 2 + let float = 3 + let error = 4 + external get: ('opt, 'v) t -> file_descr -> 'opt -> 'v + = "unix_getsockopt" + external set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit + = "unix_setsockopt" +end + +let getsockopt fd opt = SO.get SO.bool fd opt +let setsockopt fd opt v = SO.set SO.bool fd opt v + +let getsockopt_int fd opt = SO.get SO.int fd opt +let setsockopt_int fd opt v = SO.set SO.int fd opt v + +let getsockopt_optint fd opt = SO.get SO.optint fd opt +let setsockopt_optint fd opt v = SO.set SO.optint fd opt v + +let getsockopt_float fd opt = SO.get SO.float fd opt +let setsockopt_float fd opt v = SO.set SO.float fd opt v + +let getsockopt_error fd = SO.get SO.error fd SO_ERROR + type host_entry = { h_name : string; h_aliases : string array; diff --git a/otherlibs/unix/.depend b/otherlibs/unix/.depend index b0ec6169..2c589e92 100644 --- a/otherlibs/unix/.depend +++ b/otherlibs/unix/.depend @@ -656,6 +656,11 @@ sockopt.o: sockopt.c ../../byterun/mlvalues.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 ../../byterun/fail.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ @@ -783,6 +788,7 @@ write.o: write.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ ../../byterun/misc.h ../../byterun/mlvalues.h ../../byterun/signals.h \ ../../byterun/compatibility.h ../../byterun/misc.h \ ../../byterun/mlvalues.h unixsupport.h +unix.cmi: unixLabels.cmi: unix.cmi unix.cmo: unix.cmi unix.cmx: unix.cmi diff --git a/otherlibs/unix/Makefile b/otherlibs/unix/Makefile index c293eacc..8b085196 100644 --- a/otherlibs/unix/Makefile +++ b/otherlibs/unix/Makefile @@ -11,21 +11,15 @@ # # ######################################################################### -# $Id: Makefile,v 1.45 2007/02/07 15:49:11 doligez Exp $ +# $Id: Makefile,v 1.46 2007/11/06 15:16:56 frisch Exp $ # Makefile for the Unix interface library -include ../../config/Makefile +LIBNAME=unix -# Compilation options -CC=$(BYTECC) -CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS) $(SHAREDCCCOMPOPTS) -CAMLC=../../ocamlcomp.sh -CAMLOPT=../../ocamlcompopt.sh -MKLIB=../../boot/ocamlrun ../../tools/ocamlmklib -COMPFLAGS=-warn-error A -g +EXTRACAMLFLAGS=-nolabels -OBJS=accept.o access.o addrofstr.o alarm.o bind.o chdir.o chmod.o \ +COBJS=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 \ @@ -42,50 +36,11 @@ OBJS=accept.o access.o addrofstr.o alarm.o bind.o chdir.o chmod.o \ time.o times.o truncate.o umask.o unixsupport.o unlink.o \ utimes.o wait.o write.o -MLOBJS=unix.cmo unixLabels.cmo +CAMLOBJS=unix.cmo unixLabels.cmo -all: libunix.a unix.cma +HEADERS=unixsupport.h -allopt: libunix.a unix.cmxa - -libunix.a: $(OBJS) - $(MKLIB) -o unix $(OBJS) - -unix.cma: $(MLOBJS) - $(MKLIB) -o unix -ocamlc '$(CAMLC)' -linkall $(MLOBJS) - -unix.cmxa: $(MLOBJS:.cmo=.cmx) - $(MKLIB) -o unix -ocamlopt '$(CAMLOPT)' -linkall $(MLOBJS:.cmo=.cmx) - -unix.cmx: ../../ocamlopt - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.a *.o *.so - -install: - if test -f dllunix.so; then cp dllunix.so $(STUBLIBDIR)/dllunix.so; fi - 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) - cd $(LIBDIR); $(RANLIB) unix.a - -.SUFFIXES: .ml .mli .cmo .cmi .cmx - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) -nolabels $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) -nolabels $< +include ../Makefile depend: gcc -MM $(CFLAGS) *.c > .depend diff --git a/otherlibs/unix/access.c b/otherlibs/unix/access.c index dd203ee7..52d3c7c0 100644 --- a/otherlibs/unix/access.c +++ b/otherlibs/unix/access.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: access.c,v 1.11.12.1 2007/10/09 14:30:29 xleroy Exp $ */ +/* $Id: access.c,v 1.12 2008/01/11 16:13:16 doligez Exp $ */ #include #include diff --git a/otherlibs/unix/nice.c b/otherlibs/unix/nice.c index 77d4096c..c784ce82 100644 --- a/otherlibs/unix/nice.c +++ b/otherlibs/unix/nice.c @@ -11,32 +11,14 @@ /* */ /***********************************************************************/ -/* $Id: nice.c,v 1.10 2001/12/07 13:40:32 xleroy Exp $ */ +/* $Id: nice.c,v 1.11 2008/08/01 13:14:36 xleroy Exp $ */ #include #include "unixsupport.h" #include - -#ifdef HAS_GETPRIORITY - -#include -#include -#include - -CAMLprim value unix_nice(value incr) -{ - int prio; - errno = 0; - prio = getpriority(PRIO_PROCESS, 0); - if (prio == -1 && errno != 0) - uerror("nice", Nothing); - prio += Int_val(incr); - if (setpriority(PRIO_PROCESS, 0, prio) == -1) - uerror("nice", Nothing); - return Val_int(prio); -} - -#else +#ifdef HAS_UNISTD +#include +#endif CAMLprim value unix_nice(value incr) { @@ -46,5 +28,3 @@ CAMLprim value unix_nice(value incr) if (ret == -1 && errno != 0) uerror("nice", Nothing); return Val_int(ret); } - -#endif diff --git a/otherlibs/unix/signals.c b/otherlibs/unix/signals.c index fcf70fd9..27c06499 100644 --- a/otherlibs/unix/signals.c +++ b/otherlibs/unix/signals.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: signals.c,v 1.10.12.1 2007/11/01 16:42:29 xleroy Exp $ */ +/* $Id: signals.c,v 1.11 2008/01/11 16:13:16 doligez Exp $ */ #include #include diff --git a/otherlibs/unix/sockopt.c b/otherlibs/unix/sockopt.c index cd811a14..78f5d3c4 100644 --- a/otherlibs/unix/sockopt.c +++ b/otherlibs/unix/sockopt.c @@ -11,18 +11,21 @@ /* */ /***********************************************************************/ -/* $Id: sockopt.c,v 1.19 2005/03/24 17:20:53 doligez Exp $ */ +/* $Id: sockopt.c,v 1.21 2008/08/01 13:46:08 xleroy Exp $ */ #include +#include #include #include #include "unixsupport.h" #ifdef HAS_SOCKETS +#include #include #include #include +#include #include "socketaddr.h" @@ -74,164 +77,224 @@ #ifndef SO_SNDTIMEO #define SO_SNDTIMEO (-1) #endif +#ifndef TCP_NODELAY +#define TCP_NODELAY (-1) +#endif +#ifndef SO_ERROR +#define SO_ERROR (-1) +#endif +#ifndef IPPROTO_IPV6 +#define IPPROTO_IPV6 (-1) +#endif +#ifndef IPV6_V6ONLY +#define IPV6_V6ONLY (-1) +#endif -static int sockopt_bool[] = { - SO_DEBUG, SO_BROADCAST, SO_REUSEADDR, SO_KEEPALIVE, - SO_DONTROUTE, SO_OOBINLINE, SO_ACCEPTCONN }; - -static int sockopt_int[] = { - SO_SNDBUF, SO_RCVBUF, SO_ERROR, SO_TYPE, SO_RCVLOWAT, SO_SNDLOWAT }; - -static int sockopt_optint[] = { SO_LINGER }; - -static int sockopt_float[] = { SO_RCVTIMEO, SO_SNDTIMEO }; +enum option_type { + TYPE_BOOL = 0, + TYPE_INT = 1, + TYPE_LINGER = 2, + TYPE_TIMEVAL = 3, + TYPE_UNIX_ERROR = 4 +}; + +struct socket_option { + int level; + int option; +}; + +/* Table of options, indexed by type */ + +static struct socket_option sockopt_bool[] = { + { SOL_SOCKET, SO_DEBUG }, + { SOL_SOCKET, SO_BROADCAST }, + { SOL_SOCKET, SO_REUSEADDR }, + { SOL_SOCKET, SO_KEEPALIVE }, + { SOL_SOCKET, SO_DONTROUTE }, + { SOL_SOCKET, SO_OOBINLINE }, + { SOL_SOCKET, SO_ACCEPTCONN }, + { IPPROTO_TCP, TCP_NODELAY }, + { IPPROTO_IPV6, IPV6_V6ONLY} +}; + +static struct socket_option sockopt_int[] = { + { SOL_SOCKET, SO_SNDBUF }, + { SOL_SOCKET, SO_RCVBUF }, + { SOL_SOCKET, SO_ERROR }, + { SOL_SOCKET, SO_TYPE }, + { SOL_SOCKET, SO_RCVLOWAT }, + { SOL_SOCKET, SO_SNDLOWAT } }; + +static struct socket_option sockopt_linger[] = { + { SOL_SOCKET, SO_LINGER } +}; + +static struct socket_option sockopt_timeval[] = { + { SOL_SOCKET, SO_RCVTIMEO }, + { SOL_SOCKET, SO_SNDTIMEO } +}; + +static struct socket_option sockopt_unix_error[] = { + { SOL_SOCKET, SO_ERROR } +}; + +static struct socket_option * sockopt_table[] = { + sockopt_bool, + sockopt_int, + sockopt_linger, + sockopt_timeval, + sockopt_unix_error +}; + +static char * getsockopt_fun_name[] = { + "getsockopt", + "getsockopt_int", + "getsockopt_optint", + "getsockopt_float", + "getsockopt_error" +}; + +static char * setsockopt_fun_name[] = { + "setsockopt", + "setsockopt_int", + "setsockopt_optint", + "setsockopt_float", + "setsockopt_error" +}; + +union option_value { + int i; + struct linger lg; + struct timeval tv; +}; -CAMLexport value getsockopt_int(int *sockopt, value socket, - int level, value option) +CAMLexport value +unix_getsockopt_aux(char * name, + enum option_type ty, int level, int option, + value socket) { - int optval; + union option_value optval; socklen_param_type optsize; - optsize = sizeof(optval); - if (getsockopt(Int_val(socket), level, sockopt[Int_val(option)], - (void *) &optval, &optsize) == -1) - uerror("getsockopt", Nothing); - return Val_int(optval); -} - -CAMLexport value setsockopt_int(int *sockopt, value socket, int level, - value option, value status) -{ - int optval = Int_val(status); - if (setsockopt(Int_val(socket), level, sockopt[Int_val(option)], - (void *) &optval, sizeof(optval)) == -1) - uerror("setsockopt", Nothing); - return Val_unit; -} - -CAMLprim value unix_getsockopt_bool(value socket, value option) { - value res = getsockopt_int(sockopt_bool, socket, SOL_SOCKET, option); - return Val_bool(Int_val(res)); -} - -CAMLprim value unix_setsockopt_bool(value socket, value option, value status) -{ - return setsockopt_int(sockopt_bool, socket, SOL_SOCKET, option, status); -} - -CAMLprim value unix_getsockopt_int(value socket, value option) { - return getsockopt_int(sockopt_int, socket, SOL_SOCKET, option); -} - -CAMLprim value unix_setsockopt_int(value socket, value option, value status) -{ - return setsockopt_int(sockopt_int, socket, SOL_SOCKET, option, status); -} -CAMLexport value getsockopt_optint(int *sockopt, value socket, - int level, value option) -{ - struct linger optval; - socklen_param_type optsize; - value res = Val_int(0); /* None */ + switch (ty) { + case TYPE_BOOL: + case TYPE_INT: + case TYPE_UNIX_ERROR: + optsize = sizeof(optval.i); break; + case TYPE_LINGER: + optsize = sizeof(optval.lg); break; + case TYPE_TIMEVAL: + optsize = sizeof(optval.tv); break; + default: + unix_error(EINVAL, name, Nothing); + } - optsize = sizeof(optval); - if (getsockopt(Int_val(socket), level, sockopt[Int_val(option)], + if (getsockopt(Int_val(socket), level, option, (void *) &optval, &optsize) == -1) - uerror("getsockopt_optint", Nothing); - if (optval.l_onoff != 0) { - res = alloc_small(1, 0); - Field(res, 0) = Val_int(optval.l_linger); + uerror(name, Nothing); + + switch (ty) { + case TYPE_BOOL: + case TYPE_INT: + return Val_int(optval.i); + case TYPE_LINGER: + if (optval.lg.l_onoff == 0) { + return Val_int(0); /* None */ + } else { + value res = alloc_small(1, 0); /* Some */ + Field(res, 0) = Val_int(optval.lg.l_linger); + return res; + } + case TYPE_TIMEVAL: + return copy_double((double) optval.tv.tv_sec + + (double) optval.tv.tv_usec / 1e6); + case TYPE_UNIX_ERROR: + if (optval.i == 0) { + return Val_int(0); /* None */ + } else { + value err, res; + err = unix_error_of_code(optval.i); + Begin_root(err); + res = alloc_small(1, 0); /* Some */ + Field(res, 0) = err; + End_roots(); + return res; + } + default: + unix_error(EINVAL, name, Nothing); } - return res; } -CAMLexport value setsockopt_optint(int *sockopt, value socket, int level, - value option, value status) +CAMLexport value +unix_setsockopt_aux(char * name, + enum option_type ty, int level, int option, + value socket, value val) { - struct linger optval; - - optval.l_onoff = Is_block (status); - if (optval.l_onoff) - optval.l_linger = Int_val (Field (status, 0)); - if (setsockopt(Int_val(socket), level, sockopt[Int_val(option)], - (void *) &optval, sizeof(optval)) == -1) - uerror("setsockopt_optint", Nothing); - return Val_unit; -} - -CAMLprim value unix_getsockopt_optint(value socket, value option) -{ - return getsockopt_optint(sockopt_optint, socket, SOL_SOCKET, option); -} - -CAMLprim value unix_setsockopt_optint(value socket, value option, value status) -{ - return setsockopt_optint(sockopt_optint, socket, SOL_SOCKET, option, status); -} - -CAMLexport value getsockopt_float(int *sockopt, value socket, - int level, value option) -{ - struct timeval tv; + union option_value optval; socklen_param_type optsize; + double f; + + switch (ty) { + case TYPE_BOOL: + case TYPE_INT: + optsize = sizeof(optval.i); + optval.i = Int_val(val); + break; + case TYPE_LINGER: + optsize = sizeof(optval.lg); + optval.lg.l_onoff = Is_block (val); + if (optval.lg.l_onoff) + optval.lg.l_linger = Int_val (Field (val, 0)); + break; + case TYPE_TIMEVAL: + f = Double_val(val); + optsize = sizeof(optval.tv); + optval.tv.tv_sec = (int) f; + optval.tv.tv_usec = (int) (1e6 * (f - optval.tv.tv_sec)); + break; + case TYPE_UNIX_ERROR: + default: + unix_error(EINVAL, name, Nothing); + } - optsize = sizeof(tv); - if (getsockopt(Int_val(socket), level, sockopt[Int_val(option)], - (void *) &tv, &optsize) == -1) - uerror("getsockopt_float", Nothing); - return copy_double((double) tv.tv_sec + (double) tv.tv_usec / 1e6); -} + if (setsockopt(Int_val(socket), level, option, + (void *) &optval, optsize) == -1) + uerror(name, Nothing); -CAMLexport value setsockopt_float(int *sockopt, value socket, int level, - value option, value status) -{ - struct timeval tv; - double tv_f; - - tv_f = Double_val(status); - tv.tv_sec = (int)tv_f; - tv.tv_usec = (int) (1e6 * (tv_f - tv.tv_sec)); - if (setsockopt(Int_val(socket), level, sockopt[Int_val(option)], - (void *) &tv, sizeof(tv)) == -1) - uerror("setsockopt_float", Nothing); return Val_unit; } -CAMLprim value unix_getsockopt_float(value socket, value option) +CAMLprim value unix_getsockopt(value vty, value vsocket, value voption) { - return getsockopt_float(sockopt_float, socket, SOL_SOCKET, option); + enum option_type ty = Int_val(vty); + struct socket_option * opt = &(sockopt_table[ty][Int_val(voption)]); + return unix_getsockopt_aux(getsockopt_fun_name[ty], + ty, + opt->level, + opt->option, + vsocket); } -CAMLprim value unix_setsockopt_float(value socket, value option, value status) +CAMLprim value unix_setsockopt(value vty, value vsocket, value voption, + value val) { - return setsockopt_float(sockopt_float, socket, SOL_SOCKET, option, status); + enum option_type ty = Int_val(vty); + struct socket_option * opt = &(sockopt_table[ty][Int_val(voption)]); + return unix_setsockopt_aux(setsockopt_fun_name[ty], + ty, + opt->level, + opt->option, + vsocket, + val); } #else -CAMLprim value unix_getsockopt_bool(value socket, value option) +CAMLprim value unix_getsockopt(value vty, value socket, value option) { invalid_argument("getsockopt not implemented"); } -CAMLprim value unix_setsockopt_bool(value socket, value option, value status) +CAMLprim value unix_setsockopt(value vty, value socket, value option, value val) { invalid_argument("setsockopt not implemented"); } -CAMLprim value unix_getsockopt_int(value socket, value option) -{ invalid_argument("getsockopt_int not implemented"); } - -CAMLprim value unix_setsockopt_int(value socket, value option, value status) -{ invalid_argument("setsockopt_int not implemented"); } - -CAMLprim value unix_getsockopt_optint(value socket, value option) -{ invalid_argument("getsockopt_optint not implemented"); } - -CAMLprim value unix_setsockopt_optint(value socket, value option, value status) -{ invalid_argument("setsockopt_optint not implemented"); } - -CAMLprim value unix_getsockopt_float(value socket, value option) -{ invalid_argument("getsockopt_float not implemented"); } - -CAMLprim value unix_setsockopt_float(value socket, value option, value status) -{ invalid_argument("setsockopt_float not implemented"); } - #endif diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml index d9be705a..6f03043f 100644 --- a/otherlibs/unix/unix.ml +++ b/otherlibs/unix/unix.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: unix.ml,v 1.66 2006/09/21 13:54:26 xleroy Exp $ *) +(* $Id: unix.ml,v 1.68 2008/08/01 13:46:08 xleroy Exp $ *) type error = E2BIG @@ -433,29 +433,6 @@ type msg_flag = | MSG_DONTROUTE | MSG_PEEK -type socket_bool_option = - SO_DEBUG - | SO_BROADCAST - | SO_REUSEADDR - | SO_KEEPALIVE - | SO_DONTROUTE - | SO_OOBINLINE - | SO_ACCEPTCONN - -type socket_int_option = - SO_SNDBUF - | SO_RCVBUF - | SO_ERROR - | SO_TYPE - | SO_RCVLOWAT - | SO_SNDLOWAT - -type socket_optint_option = SO_LINGER - -type socket_float_option = - SO_RCVTIMEO - | SO_SNDTIMEO - external socket : socket_domain -> socket_type -> int -> file_descr = "unix_socket" external socketpair : @@ -499,22 +476,68 @@ let sendto fd buf ofs len flags addr = then invalid_arg "Unix.sendto" else unsafe_sendto fd buf ofs len flags addr -external getsockopt : file_descr -> socket_bool_option -> bool - = "unix_getsockopt_bool" -external setsockopt : file_descr -> socket_bool_option -> bool -> unit - = "unix_setsockopt_bool" -external getsockopt_int : file_descr -> socket_int_option -> int - = "unix_getsockopt_int" -external setsockopt_int : file_descr -> socket_int_option -> int -> unit - = "unix_setsockopt_int" -external getsockopt_optint : file_descr -> socket_optint_option -> int option - = "unix_getsockopt_optint" -external setsockopt_optint : file_descr -> socket_optint_option -> int option -> unit - = "unix_setsockopt_optint" -external getsockopt_float : file_descr -> socket_float_option -> float - = "unix_getsockopt_float" -external setsockopt_float : file_descr -> socket_float_option -> float -> unit - = "unix_setsockopt_float" +type socket_bool_option = + SO_DEBUG + | SO_BROADCAST + | SO_REUSEADDR + | SO_KEEPALIVE + | SO_DONTROUTE + | SO_OOBINLINE + | SO_ACCEPTCONN + | TCP_NODELAY + | IPV6_ONLY + +type socket_int_option = + SO_SNDBUF + | SO_RCVBUF + | SO_ERROR + | SO_TYPE + | SO_RCVLOWAT + | SO_SNDLOWAT + +type socket_optint_option = SO_LINGER + +type socket_float_option = + SO_RCVTIMEO + | SO_SNDTIMEO + +type socket_error_option = SO_ERROR + +module SO: sig + type ('opt, 'v) t + val bool: (socket_bool_option, bool) t + val int: (socket_int_option, int) t + val optint: (socket_optint_option, int option) t + val float: (socket_float_option, float) t + val error: (socket_error_option, error option) t + val get: ('opt, 'v) t -> file_descr -> 'opt -> 'v + val set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit +end = struct + type ('opt, 'v) t = int + let bool = 0 + let int = 1 + let optint = 2 + let float = 3 + let error = 4 + external get: ('opt, 'v) t -> file_descr -> 'opt -> 'v + = "unix_getsockopt" + external set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit + = "unix_setsockopt" +end + +let getsockopt fd opt = SO.get SO.bool fd opt +let setsockopt fd opt v = SO.set SO.bool fd opt v + +let getsockopt_int fd opt = SO.get SO.int fd opt +let setsockopt_int fd opt v = SO.set SO.int fd opt v + +let getsockopt_optint fd opt = SO.get SO.optint fd opt +let setsockopt_optint fd opt v = SO.set SO.optint fd opt v + +let getsockopt_float fd opt = SO.get SO.float fd opt +let setsockopt_float fd opt v = SO.set SO.float fd opt v + +let getsockopt_error fd = SO.get SO.error fd SO_ERROR type host_entry = { h_name : string; diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli index 4f125d29..851c4f85 100644 --- a/otherlibs/unix/unix.mli +++ b/otherlibs/unix/unix.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: unix.mli,v 1.85.4.1 2007/11/10 12:43:13 xleroy Exp $ *) +(* $Id: unix.mli,v 1.89 2008/09/04 13:53:43 doligez Exp $ *) (** Interface to the Unix system *) @@ -144,7 +144,9 @@ type process_status = | WSTOPPED of int (** The process was stopped by a signal; the argument is the signal number. *) -(** The termination status of a process. *) +(** The termination status of a process. See module {!Sys} for the + definitions of the standard signal numbers. Note that they are + not the numbers used by the OS. *) type wait_flag = @@ -996,6 +998,8 @@ type socket_bool_option = | SO_DONTROUTE (** Bypass the standard routing algorithms *) | SO_OOBINLINE (** Leave out-of-band data in line *) | SO_ACCEPTCONN (** Report whether socket listening is enabled *) + | TCP_NODELAY (** Control the Nagle algorithm for TCP sockets *) + | IPV6_ONLY (** Forbid binding an IPv6 socket to an IPv4 address *) (** The socket options that can be consulted with {!Unix.getsockopt} and modified with {!Unix.setsockopt}. These options have a boolean ([true]/[false]) value. *) @@ -1003,7 +1007,7 @@ type socket_bool_option = 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_ERROR (** Deprecated. Use {!Unix.getsockopt_error} instead. *) | SO_TYPE (** Report the socket type *) | SO_RCVLOWAT (** Minimum number of bytes to process for input operations *) | SO_SNDLOWAT (** Minimum number of bytes to process for output operations *) @@ -1034,31 +1038,29 @@ val getsockopt : file_descr -> socket_bool_option -> bool val setsockopt : file_descr -> socket_bool_option -> bool -> unit (** Set or clear a boolean-valued option in the given socket. *) -external getsockopt_int : - file_descr -> socket_int_option -> int = "unix_getsockopt_int" +val getsockopt_int : file_descr -> socket_int_option -> int (** Same as {!Unix.getsockopt} for an integer-valued socket option. *) -external setsockopt_int : - file_descr -> socket_int_option -> int -> unit = "unix_setsockopt_int" +val setsockopt_int : file_descr -> socket_int_option -> int -> unit (** Same as {!Unix.setsockopt} for an integer-valued socket option. *) -external getsockopt_optint : - file_descr -> socket_optint_option -> int option = "unix_getsockopt_optint" +val getsockopt_optint : file_descr -> socket_optint_option -> int option (** Same as {!Unix.getsockopt} for a socket option whose value is an [int option]. *) -external setsockopt_optint : - file_descr -> socket_optint_option -> int option -> - unit = "unix_setsockopt_optint" +val setsockopt_optint : + file_descr -> socket_optint_option -> int option -> unit (** Same as {!Unix.setsockopt} for a socket option whose value is an [int option]. *) -external getsockopt_float : - file_descr -> socket_float_option -> float = "unix_getsockopt_float" +val getsockopt_float : file_descr -> socket_float_option -> float (** Same as {!Unix.getsockopt} for a socket option whose value is a floating-point number. *) -external setsockopt_float : - file_descr -> socket_float_option -> float -> unit = "unix_setsockopt_float" +val setsockopt_float : file_descr -> socket_float_option -> float -> unit (** Same as {!Unix.setsockopt} for a socket option whose value is a floating-point number. *) +val getsockopt_error : file_descr -> error option +(** Return the error condition associated with the given socket, + and clear it. *) + (** {6 High-level network connection functions} *) diff --git a/otherlibs/unix/unixLabels.mli b/otherlibs/unix/unixLabels.mli index 9c178269..9af5f2d9 100644 --- a/otherlibs/unix/unixLabels.mli +++ b/otherlibs/unix/unixLabels.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: unixLabels.mli,v 1.15.4.1 2007/11/19 21:27:56 doligez Exp $ *) +(* $Id: unixLabels.mli,v 1.19 2008/08/01 13:46:08 xleroy Exp $ *) (** Interface to the Unix system. To use as replacement to default {!Unix} module, @@ -153,7 +153,7 @@ 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}. *) +(** Flags for {!UnixLabels.waitpid}. *) val execv : prog:string -> args:string array -> 'a (** [execv prog args] execute the program in file [prog], with @@ -1009,6 +1009,8 @@ type socket_bool_option = | SO_DONTROUTE (** Bypass the standard routing algorithms *) | SO_OOBINLINE (** Leave out-of-band data in line *) | SO_ACCEPTCONN (** Report whether socket listening is enabled *) + | TCP_NODELAY (** Control the Nagle algorithm for TCP sockets *) + | IPV6_ONLY (** Forbid binding an IPv6 socket to an IPv4 address *) (** The socket options that can be consulted with {!UnixLabels.getsockopt} and modified with {!UnixLabels.setsockopt}. These options have a boolean ([true]/[false]) value. *) @@ -1016,7 +1018,7 @@ type socket_bool_option = 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_ERROR (** Deprecated. Use {!Unix.getsockopt_error} instead. *) | SO_TYPE (** Report the socket type *) | SO_RCVLOWAT (** Minimum number of bytes to process for input operations *) | SO_SNDLOWAT (** Minimum number of bytes to process for output operations *) @@ -1047,31 +1049,28 @@ val getsockopt : file_descr -> socket_bool_option -> bool val setsockopt : file_descr -> socket_bool_option -> bool -> unit (** Set or clear a boolean-valued option in the given socket. *) -external getsockopt_int : - file_descr -> socket_int_option -> int = "unix_getsockopt_int" -(** Same as {!UnixLabels.getsockopt} for an integer-valued socket option. *) +val getsockopt_int : file_descr -> socket_int_option -> int +(** Same as {!Unix.getsockopt} for an integer-valued socket option. *) -external setsockopt_int : - file_descr -> socket_int_option -> int -> unit = "unix_setsockopt_int" -(** Same as {!UnixLabels.setsockopt} for an integer-valued socket option. *) +val setsockopt_int : file_descr -> socket_int_option -> int -> unit +(** Same as {!Unix.setsockopt} for an integer-valued socket option. *) -external getsockopt_optint : - file_descr -> socket_optint_option -> int option = "unix_getsockopt_optint" -(** Same as {!UnixLabels.getsockopt} for a socket option whose value is an [int option]. *) +val getsockopt_optint : file_descr -> socket_optint_option -> int option +(** Same as {!Unix.getsockopt} for a socket option whose value is an [int option]. *) -external setsockopt_optint : - file_descr -> socket_optint_option -> int option -> - unit = "unix_setsockopt_optint" -(** Same as {!UnixLabels.setsockopt} for a socket option whose value is an [int option]. *) +val setsockopt_optint : + file_descr -> socket_optint_option -> int option -> unit +(** Same as {!Unix.setsockopt} for a socket option whose value is an [int option]. *) -external getsockopt_float : - file_descr -> socket_float_option -> float = "unix_getsockopt_float" -(** Same as {!UnixLabels.getsockopt} for a socket option whose value is a floating-point number. *) +val getsockopt_float : file_descr -> socket_float_option -> float +(** Same as {!Unix.getsockopt} for a socket option whose value is a floating-point number. *) -external setsockopt_float : - file_descr -> socket_float_option -> float -> unit = "unix_setsockopt_float" -(** Same as {!UnixLabels.setsockopt} for a socket option whose value is a floating-point number. *) +val setsockopt_float : file_descr -> socket_float_option -> float -> unit +(** Same as {!Unix.setsockopt} for a socket option whose value is a floating-point number. *) +val getsockopt_error : file_descr -> error option +(** Return the error condition associated with the given socket, + and clear it. *) (** {6 High-level network connection functions} *) diff --git a/otherlibs/win32graph/Makefile.nt b/otherlibs/win32graph/Makefile.nt index 9102d451..371507d5 100644 --- a/otherlibs/win32graph/Makefile.nt +++ b/otherlibs/win32graph/Makefile.nt @@ -11,84 +11,25 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.7 2007/01/29 12:11:18 xleroy Exp $ - -include ../../config/Makefile - -# Compilation options -CC=$(BYTECC) -CFLAGS=-I../../byterun -CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib -CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -COMPFLAGS=-warn-error A -g +# $Id: Makefile.nt,v 1.8 2007/11/06 15:16:56 frisch Exp $ +LIBNAME=graphics COBJS=open.$(O) draw.$(O) events.$(O) dib.$(O) CAMLOBJS=graphics.cmo WIN32LIBS=$(call SYSLIB,kernel32) $(call SYSLIB,gdi32) $(call SYSLIB,user32) +LINKOPTS=-cclib "\"$(WIN32LIBS)\"" +LDOPTS=-ldopt "$(WIN32LIBS)" -all: dllgraphics.dll libgraphics.$(A) graphics.cma - -allopt: libgraphics.$(A) graphics.cmxa - -dllgraphics.dll: $(COBJS:.$(O)=.$(DO)) - $(call MKDLL,dllgraphics.dll,tmp.$(A),\ - $(COBJS:.$(O)=.$(DO)) ../../byterun/ocamlrun.$(A) $(WIN32LIBS)) - rm tmp.* - -libgraphics.$(A): $(COBJS:.$(O)=.$(SO)) - $(call MKLIB,libgraphics.$(A),$(COBJS:.$(O)=.$(SO))) - -graphics.cma: $(CAMLOBJS) - $(CAMLC) -a -o graphics.cma $(CAMLOBJS) \ - -dllib -lgraphics -cclib -lgraphics -cclib "$(WIN32LIBS)" - -graphics.cmxa: $(CAMLOBJS:.cmo=.cmx) - $(CAMLOPT) -a -o graphics.cmxa $(CAMLOBJS:.cmo=.cmx) \ - -cclib -lgraphics -cclib "$(WIN32LIBS)" - -partialclean: - rm -f *.cm* - -clean: partialclean - rm -f *.$(A) *.dll *.exp *.$(O) - rm -f graphics.ml graphics.mli - rm -f io.h - -install: - cp dllgraphics.dll $(STUBLIBDIR)/dllgraphics.dll - cp libgraphics.$(A) $(LIBDIR)/libgraphics.$(A) - cp graphics.cmi graphics.cma $(LIBDIR) - -installopt: - cp graphics.cmxa graphics.cmx graphics.$(A) $(LIBDIR) +include ../Makefile.nt graphics.ml: ../graph/graphics.ml cp ../graph/graphics.ml graphics.ml graphics.mli: ../graph/graphics.mli cp ../graph/graphics.mli graphics.mli -.SUFFIXES: .ml .mli .cmo .cmi .cmx .$(DO) .$(SO) - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.c.$(DO): - $(BYTECC) $(DLLCCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(DO) - -.c.$(SO): - $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(SO) - depend: graphics.cmo: graphics.cmi graphics.cmx: graphics.cmi -draw.$(SO) draw.$(DO): libgraph.h -open.$(SO) open.$(DO): libgraph.h +draw.$(O): libgraph.h +open.$(O): libgraph.h diff --git a/otherlibs/win32graph/open.c b/otherlibs/win32graph/open.c index f38484ad..a57a1472 100644 --- a/otherlibs/win32graph/open.c +++ b/otherlibs/win32graph/open.c @@ -10,13 +10,14 @@ /* */ /***********************************************************************/ -/* $Id: open.c,v 1.11 2006/05/09 16:02:48 xleroy Exp $ */ +/* $Id: open.c,v 1.12 2007/11/06 15:16:56 frisch Exp $ */ #include #include #include "mlvalues.h" #include "fail.h" #include "libgraph.h" +#include "callback.h" #include static value gr_reset(void); @@ -343,7 +344,6 @@ CAMLprim value caml_gr_sigio_handler(void) /* Processing of graphic errors */ -value * caml_named_value (char * name); static value * graphic_failure_exn = NULL; void gr_fail(char *fmt, char *arg) { diff --git a/otherlibs/win32unix/Makefile.nt b/otherlibs/win32unix/Makefile.nt index 1e72a033..d404c684 100644 --- a/otherlibs/win32unix/Makefile.nt +++ b/otherlibs/win32unix/Makefile.nt @@ -11,16 +11,7 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.35 2007/02/07 15:49:11 doligez Exp $ - -include ../../config/Makefile - -# Compilation options -CC=$(BYTECC) -CFLAGS=-I../../byterun -I../unix -CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib -CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -COMPFLAGS=-warn-error A -g +# $Id: Makefile.nt,v 1.37 2008/07/29 08:31:41 xleroy Exp $ # Files in this directory WIN_FILES = accept.c bind.c channels.c close.c \ @@ -30,7 +21,8 @@ WIN_FILES = accept.c bind.c channels.c close.c \ mkdir.c open.c pipe.c read.c rename.c \ select.c sendrecv.c \ shutdown.c sleep.c socket.c sockopt.c startup.c stat.c \ - system.c unixsupport.c windir.c winwait.c write.c + system.c unixsupport.c windir.c winwait.c write.c \ + winlist.c winworker.c windbug.c # Files from the ../unix directory UNIX_FILES = access.c addrofstr.c chdir.c chmod.c cst2constr.c \ @@ -39,83 +31,31 @@ UNIX_FILES = access.c addrofstr.c chdir.c chmod.c cst2constr.c \ getserv.c gmtime.c putenv.c rmdir.c \ socketaddr.c strofaddr.c time.c unlink.c utimes.c -ALL_FILES=$(WIN_FILES) $(UNIX_FILES) - -DOBJS=$(ALL_FILES:.c=.$(DO)) -SOBJS=$(ALL_FILES:.c=.$(SO)) - -LIBS=$(call SYSLIB,wsock32) - -CAML_OBJS=unix.cmo unixLabels.cmo -CAMLOPT_OBJS=$(CAML_OBJS:.cmo=.cmx) - UNIX_CAML_FILES = unix.mli unixLabels.mli unixLabels.ml -all: dllunix.dll libunix.$(A) unix.cma - -allopt: libunix.$(A) unix.cmxa - -dllunix.dll: $(DOBJS) - $(call MKDLL,dllunix.dll,tmp.$(A),$(DOBJS) ../../byterun/ocamlrun.$(A) $(LIBS)) - rm tmp.* - -libunix.$(A): $(SOBJS) - $(call MKLIB,libunix.$(A),$(SOBJS)) - -$(DOBJS) $(SOBJS): unixsupport.h +ALL_FILES=$(WIN_FILES) $(UNIX_FILES) +WSOCKLIB=$(call SYSLIB,ws2_32) -unix.cma: $(CAML_OBJS) - $(CAMLC) -a -linkall -o unix.cma $(CAML_OBJS) \ - -dllib -lunix -cclib -lunix -cclib $(LIBS) +LIBNAME=unix +COBJS=$(ALL_FILES:.c=.$(O)) +CAMLOBJS=unix.cmo unixLabels.cmo +LINKOPTS=-cclib $(WSOCKLIB) +LDOPTS=-ldopt $(WSOCKLIB) +EXTRACAMLFLAGS=-nolabels +EXTRACFLAGS=-I../unix +HEADERS=unixsupport.h -unix.cmxa: $(CAMLOPT_OBJS) - $(CAMLOPT) -a -linkall -o unix.cmxa $(CAMLOPT_OBJS) \ - -cclib -lunix -cclib $(LIBS) -partialclean: - rm -f *.cm* +include ../Makefile.nt -clean: partialclean - rm -f *.$(A) *.dll *.$(O) +clean:: rm -f $(UNIX_FILES) $(UNIX_CAML_FILES) -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) - -unixLabels.cmo: unixLabels.ml - $(CAMLC) -c $(COMPFLAGS) -nolabels unixLabels.ml - -unixLabels.cmx: unixLabels.ml - $(CAMLOPT) -c $(COMPFLAGS) -nolabels unixLabels.ml - $(UNIX_FILES) $(UNIX_CAML_FILES): %: ../unix/% cp ../unix/$* $* -.SUFFIXES: .ml .mli .cmo .cmi .cmx .$(DO) .$(SO) - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) -c $(COMPFLAGS) $< - -.c.$(DO): - $(BYTECC) $(DLLCCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(DO) - -.c.$(SO): - $(BYTECC) $(BYTECCCOMPOPTS) $(CFLAGS) -c $< - mv $*.$(O) $*.$(SO) - depend: +$(COBJS): unixsupport.h + include .depend diff --git a/otherlibs/win32unix/createprocess.c b/otherlibs/win32unix/createprocess.c index 7f59f1ed..422c68ab 100644 --- a/otherlibs/win32unix/createprocess.c +++ b/otherlibs/win32unix/createprocess.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: createprocess.c,v 1.13.20.1 2007/10/25 08:32:42 xleroy Exp $ */ +/* $Id: createprocess.c,v 1.14 2008/01/11 16:13:16 doligez Exp $ */ #include #include diff --git a/otherlibs/win32unix/dllunix.dlib b/otherlibs/win32unix/dllunix.dlib index 01ffc59e..e3ebf34e 100644 --- a/otherlibs/win32unix/dllunix.dlib +++ b/otherlibs/win32unix/dllunix.dlib @@ -7,6 +7,7 @@ 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 +winlist.d.o winworker.d.o windbug.d.o # Files from the ../unix directory access.d.o addrofstr.d.o chdir.d.o chmod.d.o cst2constr.d.o diff --git a/otherlibs/win32unix/libunix.clib b/otherlibs/win32unix/libunix.clib index 29b8d6e6..043dcf76 100644 --- a/otherlibs/win32unix/libunix.clib +++ b/otherlibs/win32unix/libunix.clib @@ -7,6 +7,7 @@ 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 +winlist.o winworker.o windbug.o # Files from the ../unix directory access.o addrofstr.o chdir.o chmod.o cst2constr.o diff --git a/otherlibs/win32unix/lockf.c b/otherlibs/win32unix/lockf.c index be5af56e..821363ff 100644 --- a/otherlibs/win32unix/lockf.c +++ b/otherlibs/win32unix/lockf.c @@ -3,6 +3,7 @@ /* Objective Caml */ /* */ /* Contributed by Tracy Camp, PolyServe Inc., */ +/* Further improvements by Reed Wilson */ /* */ /* Copyright 2002 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ @@ -12,195 +13,148 @@ /* */ /***********************************************************************/ -/* $Id: lockf.c,v 1.4 2005/09/22 14:21:50 xleroy Exp $ */ +/* $Id: lockf.c,v 1.7.2.1 2008/10/08 13:05:42 xleroy Exp $ */ #include #include #include +#include #include #include "unixsupport.h" #include - -/* - -Commands for Unix.lockf: - -type 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 *) - - -val lockf : file_descr -> lock_command -> int -> unitlockf fd cmd size - -puts a lock on a region of the file opened as fd. The region starts at the current - read/write position for fd (as set by Unix.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 process from acquiring a read or write lock on - the region. A read lock (set with F_RLOCK or F_TRLOCK) prevents any other - process from acquiring a write lock on the region, but lets other processes - acquire read locks on it. -*/ +#include #ifndef INVALID_SET_FILE_POINTER #define INVALID_SET_FILE_POINTER (-1) #endif -static void set_file_pointer(HANDLE h, LARGE_INTEGER dest, - PLARGE_INTEGER cur, DWORD method) +/* Sets handle h to a position based on gohere */ +/* output, if set, is changed to the new location */ + +static void set_file_pointer(HANDLE h, LARGE_INTEGER gohere, + PLARGE_INTEGER output, DWORD method) { - LONG high = dest.HighPart; - DWORD ret = SetFilePointer(h, dest.LowPart, &high, method); - if (ret == INVALID_SET_FILE_POINTER) { + LONG high = gohere.HighPart; + DWORD ret = SetFilePointer(h, gohere.LowPart, &high, method); + if(ret == INVALID_SET_FILE_POINTER) { DWORD err = GetLastError(); - if (err != NO_ERROR) { win32_maperr(err); uerror("lockf", Nothing); } + if(err != NO_ERROR) { + win32_maperr(err); + uerror("lockf", Nothing); + } + } + if(output != NULL) { + output->LowPart = ret; + output->HighPart = high; } - if (cur != NULL) { cur->LowPart = ret; cur->HighPart = high; } } CAMLprim value unix_lockf(value fd, value cmd, value span) { - int ret; - OVERLAPPED overlap; - DWORD l_start; - DWORD l_len; - HANDLE h; - OSVERSIONINFO VersionInfo; - LARGE_INTEGER cur_position; - LARGE_INTEGER end_position; - LARGE_INTEGER offset_position; + CAMLparam3(fd, cmd, span); + OVERLAPPED overlap; + intnat l_len; + HANDLE h; + OSVERSIONINFO version; + LARGE_INTEGER cur_position; + LARGE_INTEGER beg_position; + LARGE_INTEGER lock_len; + LARGE_INTEGER zero; + DWORD err = NO_ERROR; + + version.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); + if(GetVersionEx(&version) == 0) { + invalid_argument("lockf only supported on WIN32_NT platforms: could not determine current platform."); + } + if(version.dwPlatformId != VER_PLATFORM_WIN32_NT) { + invalid_argument("lockf only supported on WIN32_NT platforms"); + } - VersionInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); - if(GetVersionEx(&VersionInfo) == 0) - { - invalid_argument("lockf only supported on WIN32_NT platforms: could not determine current platform."); - } -/* file locking only exists on NT versions */ - if(VersionInfo.dwPlatformId != VER_PLATFORM_WIN32_NT) - { - invalid_argument("lockf only supported on WIN32_NT platforms"); - } + h = Handle_val(fd); + + l_len = Long_val(span); - h = Handle_val(fd); + /* No matter what, we need the current position in the file */ + zero.HighPart = zero.LowPart = 0; + set_file_pointer(h, zero, &cur_position, FILE_CURRENT); - overlap.Offset = 0; - overlap.OffsetHigh = 0; - overlap.hEvent = 0; - l_len = Long_val(span); + /* All unused fields must be set to zero */ + memset(&overlap, 0, sizeof(overlap)); - offset_position.HighPart = 0; - cur_position.HighPart = 0; - end_position.HighPart = 0; - offset_position.LowPart = 0; - cur_position.LowPart = 0; - end_position.LowPart = 0; + if(l_len == 0) { + /* Lock from cur to infinity */ + lock_len.QuadPart = -1; + overlap.OffsetHigh = cur_position.HighPart; + overlap.Offset = cur_position.LowPart ; + } + else if(l_len > 0) { + /* Positive file offset */ + lock_len.QuadPart = l_len; + overlap.OffsetHigh = cur_position.HighPart; + overlap.Offset = cur_position.LowPart ; + } + else { + /* Negative file offset */ + lock_len.QuadPart = - l_len; + if (lock_len.QuadPart > cur_position.QuadPart) { + errno = EINVAL; + uerror("lockf", Nothing); + } + beg_position.QuadPart = cur_position.QuadPart - lock_len.QuadPart; + overlap.OffsetHigh = beg_position.HighPart; + overlap.Offset = beg_position.LowPart ; + } - if(l_len == 0) - { -/* save current pointer */ - set_file_pointer(h,offset_position,&cur_position,FILE_CURRENT); -/* set to end and query */ - set_file_pointer(h,offset_position,&end_position,FILE_END); - l_len = end_position.LowPart; -/* restore previous current pointer */ - set_file_pointer(h,cur_position,NULL,FILE_BEGIN); - } - else - { - if (l_len < 0) - { - set_file_pointer(h,offset_position,&cur_position,FILE_CURRENT); - l_len = abs(l_len); - if(l_len > cur_position.LowPart) - { - errno = EINVAL; - uerror("lockf", Nothing); - return Val_unit; - } - overlap.Offset = cur_position.LowPart - l_len; - } - } - switch (Int_val(cmd)) - { - case 0: /* F_ULOCK */ - if(UnlockFileEx(h, 0, l_len,0,&overlap) == 0) - { - errno = EACCES; - ret = -1; - } - break; - case 1: /* F_LOCK */ -/* this should block until write lock is obtained */ - if(LockFileEx(h,LOCKFILE_EXCLUSIVE_LOCK,0,l_len,0,&overlap) == 0) - { - errno = EACCES; - ret = -1; - } - break; - case 2: /* F_TLOCK */ -/* - * this should return immediately if write lock can-not - * be obtained. - */ - if(LockFileEx(h,LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK,0,l_len,0,&overlap) == 0) - { - errno = EACCES; - ret = -1; - } - break; - case 3: /* F_TEST */ -/* - * I'm doing this by aquiring an immediate write - * lock and then releasing it. It is not clear that - * this behavior matches anything in particular, but - * it is not clear the nature of the lock test performed - * by ocaml (unix) currently. - */ - if(LockFileEx(h,LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK,0,l_len,0,&overlap) == 0) - { - errno = EACCES; - ret = -1; - } - else - { - UnlockFileEx(h, 0, l_len,0,&overlap); - ret = 0; - } - break; - case 4: /* F_RLOCK */ -/* this should block until read lock is obtained */ - if(LockFileEx(h,0,0,l_len,0,&overlap) == 0) - { - errno = EACCES; - ret = -1; - } - break; - case 5: /* F_TRLOCK */ -/* - * this should return immediately if read lock can-not - * be obtained. - */ - if(LockFileEx(h,LOCKFILE_FAIL_IMMEDIATELY,0,l_len,0,&overlap) == 0) - { - errno = EACCES; - ret = -1; - } - break; - default: - errno = EINVAL; - ret = -1; - } - if (ret == -1) uerror("lockf", Nothing); - return Val_unit; + switch(Int_val(cmd)) { + case 0: /* F_ULOCK - unlock */ + if (! UnlockFileEx(h, 0, + lock_len.LowPart, lock_len.HighPart, &overlap)) + err = GetLastError(); + break; + case 1: /* F_LOCK - blocking write lock */ + enter_blocking_section(); + if (! LockFileEx(h, LOCKFILE_EXCLUSIVE_LOCK, 0, + lock_len.LowPart, lock_len.HighPart, &overlap)) + err = GetLastError(); + leave_blocking_section(); + break; + case 2: /* F_TLOCK - non-blocking write lock */ + if (! LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK, 0, + lock_len.LowPart, lock_len.HighPart, &overlap)) + err = GetLastError(); + break; + case 3: /* F_TEST - check whether a write lock can be obtained */ + /* I'm doing this by aquiring an immediate write + * lock and then releasing it. It is not clear that + * this behavior matches anything in particular, but + * it is not clear the nature of the lock test performed + * by ocaml (unix) currently. */ + if (LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY | LOCKFILE_EXCLUSIVE_LOCK, 0, + lock_len.LowPart, lock_len.HighPart, &overlap)) { + UnlockFileEx(h, 0, lock_len.LowPart, lock_len.HighPart, &overlap); + } else { + err = GetLastError(); + } + break; + case 4: /* F_RLOCK - blocking read lock */ + enter_blocking_section(); + if (! LockFileEx(h, 0, 0, + lock_len.LowPart, lock_len.HighPart, &overlap)) + err = GetLastError(); + leave_blocking_section(); + break; + case 5: /* F_TRLOCK - non-blocking read lock */ + if (! LockFileEx(h, LOCKFILE_FAIL_IMMEDIATELY, 0, + lock_len.LowPart, lock_len.HighPart, &overlap)) + err = GetLastError(); + break; + default: + errno = EINVAL; + uerror("lockf", Nothing); + } + if (err != NO_ERROR) { + win32_maperr(err); + uerror("lockf", Nothing); + } + CAMLreturn(Val_unit); } - diff --git a/otherlibs/win32unix/open.c b/otherlibs/win32unix/open.c index fd8a4b14..ebcc9c81 100644 --- a/otherlibs/win32unix/open.c +++ b/otherlibs/win32unix/open.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: open.c,v 1.9.20.1 2007/10/25 07:42:48 xleroy Exp $ */ +/* $Id: open.c,v 1.10 2008/01/11 16:13:16 doligez Exp $ */ #include #include diff --git a/otherlibs/win32unix/select.c b/otherlibs/win32unix/select.c index 41fb1e90..f30c898b 100644 --- a/otherlibs/win32unix/select.c +++ b/otherlibs/win32unix/select.c @@ -2,100 +2,1046 @@ /* */ /* Objective Caml */ /* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* Contributed by Sylvain Le Gall for Lexifi */ /* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* Copyright 2008 Institut National de Recherche en Informatique et */ /* en Automatique. All rights reserved. This file is distributed */ /* under the terms of the GNU Library General Public License, with */ /* the special exception on linking described in file ../../LICENSE. */ /* */ /***********************************************************************/ -/* $Id: select.c,v 1.12 2006/10/18 08:26:54 xleroy Exp $ */ +/* $Id: select.c,v 1.14 2008/07/31 12:09:18 xleroy Exp $ */ #include #include #include #include +#include +#include #include "unixsupport.h" +#include "windbug.h" +#include "winworker.h" +#include "winlist.h" -static void fdlist_to_fdset(value fdlist, fd_set *fdset) +/* This constant define the maximum number of objects that + * can be handle by a SELECTDATA. + * It takes the following parameters into account: + * - limitation on number of objects is mostly due to limitation + * a WaitForMultipleObjects + * - there is always an event "hStop" to watch + * + * This lead to pick the following value as the biggest possible + * value + */ +#define MAXIMUM_SELECT_OBJECTS (MAXIMUM_WAIT_OBJECTS - 1) + +/* Manage set of handle */ +typedef struct _SELECTHANDLESET { + LPHANDLE lpHdl; + DWORD nMax; + DWORD nLast; +} SELECTHANDLESET; + +typedef SELECTHANDLESET *LPSELECTHANDLESET; + +void handle_set_init (LPSELECTHANDLESET hds, LPHANDLE lpHdl, DWORD max) +{ + DWORD i; + + hds->lpHdl = lpHdl; + hds->nMax = max; + hds->nLast = 0; + + /* Set to invalid value every entry of the handle */ + for (i = 0; i < hds->nMax; i++) + { + hds->lpHdl[i] = INVALID_HANDLE_VALUE; + }; +} + +void handle_set_add (LPSELECTHANDLESET hds, HANDLE hdl) +{ + LPSELECTHANDLESET res; + + if (hds->nLast < hds->nMax) + { + hds->lpHdl[hds->nLast] = hdl; + hds->nLast++; + } + + DBUG_PRINT("Adding handle %x to set %x", hdl, hds); +} + +BOOL handle_set_mem (LPSELECTHANDLESET hds, HANDLE hdl) +{ + BOOL res; + DWORD i; + + res = FALSE; + for (i = 0; !res && i < hds->nLast; i++) + { + res = (hds->lpHdl[i] == hdl); + } + + return res; +} + +void handle_set_reset (LPSELECTHANDLESET hds) +{ + DWORD i; + + for (i = 0; i < hds->nMax; i++) + { + hds->lpHdl[i] = INVALID_HANDLE_VALUE; + } + hds->nMax = 0; + hds->nLast = 0; + hds->lpHdl = NULL; +} + +/* Data structure for handling select */ + +typedef enum _SELECTHANDLETYPE { + SELECT_HANDLE_NONE = 0, + SELECT_HANDLE_DISK, + SELECT_HANDLE_CONSOLE, + SELECT_HANDLE_PIPE, + SELECT_HANDLE_SOCKET, +} SELECTHANDLETYPE; + +typedef enum _SELECTMODE { + SELECT_MODE_NONE = 0, + SELECT_MODE_READ, + SELECT_MODE_WRITE, + SELECT_MODE_EXCEPT, +} SELECTMODE; + +typedef enum _SELECTSTATE { + SELECT_STATE_NONE = 0, + SELECT_STATE_INITFAILED, + SELECT_STATE_ERROR, + SELECT_STATE_SIGNALED +} SELECTSTATE; + +typedef enum _SELECTTYPE { + SELECT_TYPE_NONE = 0, + SELECT_TYPE_STATIC, /* Result is known without running anything */ + SELECT_TYPE_CONSOLE_READ, /* Reading data on console */ + SELECT_TYPE_PIPE_READ, /* Reading data on pipe */ + SELECT_TYPE_SOCKET /* Classic select */ +} SELECTTYPE; + +/* Data structure for results */ +typedef struct _SELECTRESULT { + LIST lst; + SELECTMODE EMode; + LPVOID lpOrig; +} SELECTRESULT; + +typedef SELECTRESULT *LPSELECTRESULT; + +/* Data structure for query */ +typedef struct _SELECTQUERY { + LIST lst; + SELECTMODE EMode; + HANDLE hFileDescr; + LPVOID lpOrig; +} SELECTQUERY; + +typedef SELECTQUERY *LPSELECTQUERY; + +typedef struct _SELECTDATA { + LIST lst; + SELECTTYPE EType; + SELECTRESULT aResults[MAXIMUM_SELECT_OBJECTS]; + DWORD nResultsCount; + /* Data following are dedicated to APC like call, they + will be initialized if required. + */ + WORKERFUNC funcWorker; + SELECTQUERY aQueries[MAXIMUM_SELECT_OBJECTS]; + DWORD nQueriesCount; + SELECTSTATE EState; + DWORD nError; + LPWORKER lpWorker; +} SELECTDATA; + +typedef SELECTDATA *LPSELECTDATA; + +/* Get error status if associated condition is false */ +static BOOL check_error(LPSELECTDATA lpSelectData, BOOL bFailed) +{ + if (bFailed && lpSelectData->nError == 0) + { + lpSelectData->EState = SELECT_STATE_ERROR; + lpSelectData->nError = GetLastError(); + } + return bFailed; +} + +/* Create data associated with a select operation */ +LPSELECTDATA select_data_new (LPSELECTDATA lpSelectData, SELECTTYPE EType) +{ + /* Allocate the data structure */ + LPSELECTDATA res; + DWORD i; + + if (!HeapLock(GetProcessHeap())) + { + win32_maperr(GetLastError()); + uerror("select", Nothing); + } + res = (LPSELECTDATA)HeapAlloc(GetProcessHeap(), 0, sizeof(SELECTDATA)); + HeapUnlock(GetProcessHeap()); + + /* Init common data */ + list_init((LPLIST)res); + list_next_set((LPLIST)res, (LPLIST)lpSelectData); + res->EType = EType; + res->nResultsCount = 0; + + + /* Data following are dedicated to APC like call, they + will be initialized if required. For now they are set to + invalid values. + */ + res->funcWorker = NULL; + res->nQueriesCount = 0; + res->EState = SELECT_STATE_NONE; + res->nError = 0; + res->lpWorker = NULL; + + return res; +} + +/* Free select data */ +void select_data_free (LPSELECTDATA lpSelectData) +{ + DWORD i; + + DBUG_PRINT("Freeing data of %x", lpSelectData); + + /* Free APC related data, if they exists */ + if (lpSelectData->lpWorker != NULL) + { + worker_job_finish(lpSelectData->lpWorker); + lpSelectData->lpWorker = NULL; + }; + + /* Make sure results/queries cannot be accessed */ + lpSelectData->nResultsCount = 0; + lpSelectData->nQueriesCount = 0; + + if (!HeapLock(GetProcessHeap())) + { + win32_maperr(GetLastError()); + uerror("select_data_free", Nothing); + }; + HeapFree(GetProcessHeap(), 0, lpSelectData); + HeapUnlock(GetProcessHeap()); +} + +/* Add a result to select data, return zero if something goes wrong. */ +DWORD select_data_result_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, LPVOID lpOrig) +{ + DWORD res; + DWORD i; + + res = 0; + if (lpSelectData->nResultsCount < MAXIMUM_SELECT_OBJECTS) + { + i = lpSelectData->nResultsCount; + lpSelectData->aResults[i].EMode = EMode; + lpSelectData->aResults[i].lpOrig = lpOrig; + lpSelectData->nResultsCount++; + res = 1; + } + + return res; +} + +/* Add a query to select data, return zero if something goes wrong */ +DWORD select_data_query_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, HANDLE hFileDescr, LPVOID lpOrig) { - value l; - FD_ZERO(fdset); - for (l = fdlist; l != Val_int(0); l = Field(l, 1)) { - FD_SET(Socket_val(Field(l, 0)), fdset); + DWORD res; + DWORD i; + + res = 0; + if (lpSelectData->nQueriesCount < MAXIMUM_SELECT_OBJECTS) + { + i = lpSelectData->nQueriesCount; + lpSelectData->aQueries[i].EMode = EMode; + lpSelectData->aQueries[i].hFileDescr = hFileDescr; + lpSelectData->aQueries[i].lpOrig = lpOrig; + lpSelectData->nQueriesCount++; + res = 1; } + + return res; } -static value fdset_to_fdlist(value fdlist, fd_set *fdset) +/* Search for a job that has available query slots and that match provided type. + * If none is found, create a new one. Return the corresponding SELECTDATA, and + * update provided SELECTDATA head, if required. + */ +LPSELECTDATA select_data_job_search (LPSELECTDATA *lppSelectData, SELECTTYPE EType) { - value res = Val_int(0); - Begin_roots2(fdlist, res) - for (/*nothing*/; fdlist != Val_int(0); fdlist = Field(fdlist, 1)) { - value s = Field(fdlist, 0); - if (FD_ISSET(Socket_val(s), fdset)) { - value newres = alloc_small(2, 0); - Field(newres, 0) = s; - Field(newres, 1) = res; - res = newres; + LPSELECTDATA res; + + res = NULL; + + /* Search for job */ + DBUG_PRINT("Searching an available job for type %d", EType); + res = *lppSelectData; + while ( + res != NULL + && !( + res->EType == EType + && res->nQueriesCount < MAXIMUM_SELECT_OBJECTS + ) + ) + { + res = LIST_NEXT(LPSELECTDATA, res); + } + + /* No matching job found, create one */ + if (res == NULL) + { + DBUG_PRINT("No job for type %d found, create one", EType); + res = select_data_new(*lppSelectData, EType); + *lppSelectData = res; + } + + return res; +} + +/***********************/ +/* Console */ +/***********************/ + +void read_console_poll(HANDLE hStop, void *_data) +{ + HANDLE events[2]; + INPUT_RECORD record; + DWORD waitRes; + DWORD n; + LPSELECTDATA lpSelectData; + LPSELECTQUERY lpQuery; + + DBUG_PRINT("Waiting for data on console"); + + record; + waitRes = 0; + n = 0; + lpSelectData = (LPSELECTDATA)_data; + lpQuery = &(lpSelectData->aQueries[0]); + + events[0] = hStop; + events[1] = lpQuery->hFileDescr; + while (lpSelectData->EState == SELECT_STATE_NONE) + { + waitRes = WaitForMultipleObjects(2, events, FALSE, INFINITE); + if (waitRes == WAIT_OBJECT_0 || check_error(lpSelectData, waitRes == WAIT_FAILED)) + { + /* stop worker event or error */ + break; + } + /* console event */ + if (check_error(lpSelectData, PeekConsoleInput(lpQuery->hFileDescr, &record, 1, &n) == 0)) + { + break; + } + /* check for ASCII keypress only */ + if (record.EventType == KEY_EVENT && + record.Event.KeyEvent.bKeyDown && + record.Event.KeyEvent.uChar.AsciiChar != 0) + { + select_data_result_add(lpSelectData, lpQuery->EMode, lpQuery->lpOrig); + lpSelectData->EState = SELECT_STATE_SIGNALED; + break; + } + else + { + /* discard everything else and try again */ + if (check_error(lpSelectData, ReadConsoleInput(lpQuery->hFileDescr, &record, 1, &n) == 0)) + { + break; } } - End_roots(); + }; +} + +/* Add a function to monitor console input */ +LPSELECTDATA read_console_poll_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, HANDLE hFileDescr, LPVOID lpOrig) +{ + LPSELECTDATA res; + + res = select_data_new(lpSelectData, SELECT_TYPE_CONSOLE_READ); + res->funcWorker = read_console_poll; + select_data_query_add(res, SELECT_MODE_READ, hFileDescr, lpOrig); + return res; } -CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value timeout) +/***********************/ +/* Pipe */ +/***********************/ + +/* Monitor a pipe for input */ +void read_pipe_poll (HANDLE hStop, void *_data) +{ + DWORD event; + DWORD n; + LPSELECTQUERY iterQuery; + LPSELECTDATA lpSelectData; + DWORD i; + + /* Poll pipe */ + event = 0; + n = 0; + lpSelectData = (LPSELECTDATA)_data; + + DBUG_PRINT("Checking data pipe"); + while (lpSelectData->EState == SELECT_STATE_NONE) + { + for (i = 0; i < lpSelectData->nQueriesCount; i++) + { + iterQuery = &(lpSelectData->aQueries[i]); + if (check_error( + lpSelectData, + PeekNamedPipe( + iterQuery->hFileDescr, + NULL, + 0, + NULL, + &n, + NULL) == 0)) + { + break; + }; + + if (n > 0) + { + lpSelectData->EState = SELECT_STATE_SIGNALED; + select_data_result_add(lpSelectData, iterQuery->EMode, iterQuery->lpOrig); + }; + }; + + /* Alas, nothing except polling seems to work for pipes. + Check the state & stop_worker_event every 10 ms + */ + if (lpSelectData->EState == SELECT_STATE_NONE) + { + event = WaitForSingleObject(hStop, 10); + if (event == WAIT_OBJECT_0 || check_error(lpSelectData, event == WAIT_FAILED)) + { + break; + } + } + } + DBUG_PRINT("Finish checking data on pipe"); +} + +/* Add a function to monitor pipe input */ +LPSELECTDATA read_pipe_poll_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, HANDLE hFileDescr, LPVOID lpOrig) +{ + LPSELECTDATA res; + LPSELECTDATA hd; + + hd = lpSelectData; + /* Polling pipe is a non blocking operation by default. This means that each + worker can handle many pipe. We begin to try to find a worker that is + polling pipe, but for which there is under the limit of pipe per worker. + */ + DBUG_PRINT("Searching an available worker handling pipe"); + res = select_data_job_search(&hd, SELECT_TYPE_PIPE_READ); + + /* Add a new pipe to poll */ + res->funcWorker = read_pipe_poll; + select_data_query_add(res, EMode, hFileDescr, lpOrig); + + return hd; +} + +/***********************/ +/* Socket */ +/***********************/ + +/* Monitor socket */ +void socket_poll (HANDLE hStop, void *_data) +{ + LPSELECTDATA lpSelectData; + LPSELECTQUERY iterQuery; + HANDLE aEvents[MAXIMUM_SELECT_OBJECTS]; + DWORD nEvents; + long maskEvents; + DWORD i; + u_long iMode; + + lpSelectData = (LPSELECTDATA)_data; + + for (nEvents = 0; nEvents < lpSelectData->nQueriesCount; nEvents++) + { + iterQuery = &(lpSelectData->aQueries[nEvents]); + aEvents[nEvents] = CreateEvent(NULL, TRUE, FALSE, NULL); + maskEvents = 0; + switch (iterQuery->EMode) + { + case SELECT_MODE_READ: + maskEvents = FD_READ | FD_ACCEPT | FD_CLOSE; + break; + case SELECT_MODE_WRITE: + maskEvents = FD_WRITE | FD_CONNECT | FD_CLOSE; + break; + case SELECT_MODE_EXCEPT: + maskEvents = FD_OOB; + break; + } + check_error(lpSelectData, + WSAEventSelect( + (SOCKET)(iterQuery->hFileDescr), + aEvents[nEvents], + maskEvents) == SOCKET_ERROR); + } + + /* Add stop event */ + aEvents[nEvents] = hStop; + nEvents++; + + if (lpSelectData->nError == 0) + { + check_error(lpSelectData, + WaitForMultipleObjects( + nEvents, + aEvents, + FALSE, + INFINITE) == WAIT_FAILED); + }; + + if (lpSelectData->nError == 0) + { + for (i = 0; i < lpSelectData->nQueriesCount; i++) + { + iterQuery = &(lpSelectData->aQueries[i]); + if (WaitForSingleObject(aEvents[i], 0) == WAIT_OBJECT_0) + { + DBUG_PRINT("Socket %d has pending events", (i - 1)); + if (iterQuery != NULL) + { + select_data_result_add(lpSelectData, iterQuery->EMode, iterQuery->lpOrig); + } + } + /* WSAEventSelect() automatically sets socket to nonblocking mode. + Restore the blocking one. */ + iMode = 0; + check_error(lpSelectData, + WSAEventSelect((SOCKET)(iterQuery->hFileDescr), aEvents[i], 0) != 0 || + ioctlsocket((SOCKET)(iterQuery->hFileDescr), FIONBIO, &iMode) != 0); + + CloseHandle(aEvents[i]); + aEvents[i] = INVALID_HANDLE_VALUE; + } + } +} + +/* Add a function to monitor socket */ +LPSELECTDATA socket_poll_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, HANDLE hFileDescr, LPVOID lpOrig) +{ + LPSELECTDATA res; + LPSELECTDATA hd; + + hd = lpSelectData; + /* Polling socket can be done mulitple handle at the same time. You just + need one worker to use it. Try to find if there is already a worker + handling this kind of request. + */ + DBUG_PRINT("Scanning list of worker to find one that already handle socket"); + res = select_data_job_search(&hd, SELECT_TYPE_SOCKET); + + /* Add a new socket to poll */ + res->funcWorker = socket_poll; + DBUG_PRINT("Add socket %x to worker", hFileDescr); + select_data_query_add(res, EMode, hFileDescr, lpOrig); + DBUG_PRINT("Socket %x added", hFileDescr); + + return hd; +} + +/***********************/ +/* Static */ +/***********************/ + +/* Add a static result */ +LPSELECTDATA static_poll_add (LPSELECTDATA lpSelectData, SELECTMODE EMode, HANDLE hFileDescr, LPVOID lpOrig) { - fd_set read, write, except; - double tm; - struct timeval tv; - struct timeval * tvp; - 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) - tm = Double_val(timeout); - if (readfds == Val_int(0) - && writefds == Val_int(0) - && exceptfds == Val_int(0)) { - if ( tm > 0.0 ) { - enter_blocking_section(); - Sleep( (int)(tm * 1000)); - leave_blocking_section(); + LPSELECTDATA res; + LPSELECTDATA hd; + + /* Look for an already initialized static element */ + hd = lpSelectData; + res = select_data_job_search(&hd, SELECT_TYPE_STATIC); + + /* Add a new query/result */ + select_data_query_add(res, EMode, hFileDescr, lpOrig); + select_data_result_add(res, EMode, lpOrig); + + return hd; +} + +/********************************/ +/* Generic select data handling */ +/********************************/ + +/* Guess handle type */ +static SELECTHANDLETYPE get_handle_type(value fd) +{ + DWORD mode; + SELECTHANDLETYPE res; + + CAMLparam1(fd); + + mode = 0; + res = SELECT_HANDLE_NONE; + + if (Descr_kind_val(fd) == KIND_SOCKET) + { + res = SELECT_HANDLE_SOCKET; + } + else + { + switch(GetFileType(Handle_val(fd))) + { + case FILE_TYPE_DISK: + res = SELECT_HANDLE_DISK; + break; + + case FILE_TYPE_CHAR: /* character file or a console */ + if (GetConsoleMode(Handle_val(fd), &mode) != 0) + { + res = SELECT_HANDLE_CONSOLE; + } + else + { + res = SELECT_HANDLE_NONE; + }; + break; + + case FILE_TYPE_PIPE: /* a named or an anonymous pipe (socket already handled) */ + res = SELECT_HANDLE_PIPE; + break; + }; + }; + + CAMLreturnT(SELECTHANDLETYPE, res); +} + +/* Choose what to do with given data */ +LPSELECTDATA select_data_dispatch (LPSELECTDATA lpSelectData, SELECTMODE EMode, value fd) +{ + LPSELECTDATA res; + HANDLE hFileDescr; + void *lpOrig; + struct sockaddr sa; + int sa_len; + BOOL alreadyAdded; + + CAMLparam1(fd); + + res = lpSelectData; + hFileDescr = Handle_val(fd); + lpOrig = (void *)fd; + sa_len = sizeof(sa); + alreadyAdded = FALSE; + + DBUG_PRINT("Begin dispatching handle %x", hFileDescr); + + DBUG_PRINT("Waiting for %d on handle %x", EMode, hFileDescr); + + /* There is only 2 way to have except mode: transmission of OOB data through + a socket TCP/IP and through a strange interaction with a TTY. + With windows, we only consider the TCP/IP except condition + */ + switch(get_handle_type(fd)) + { + case SELECT_HANDLE_DISK: + DBUG_PRINT("Handle %x is a disk handle", hFileDescr); + /* Disk is always ready in read/write operation */ + if (EMode == SELECT_MODE_READ || EMode == SELECT_MODE_WRITE) + { + res = static_poll_add(res, EMode, hFileDescr, lpOrig); + }; + break; + + case SELECT_HANDLE_CONSOLE: + DBUG_PRINT("Handle %x is a console handle", hFileDescr); + /* Console is always ready in write operation, need to check for read. */ + if (EMode == SELECT_MODE_READ) + { + res = read_console_poll_add(res, EMode, hFileDescr, lpOrig); } - read_list = write_list = except_list = Val_int(0); - } else { - fdlist_to_fdset(readfds, &read); - fdlist_to_fdset(writefds, &write); - fdlist_to_fdset(exceptfds, &except); - if (tm < 0.0) - tvp = (struct timeval *) NULL; - else { - tv.tv_sec = (int) tm; - tv.tv_usec = (int) (1e6 * (tm - (int) tm)); - tvp = &tv; + else if (EMode == SELECT_MODE_WRITE) + { + res = static_poll_add(res, EMode, hFileDescr, lpOrig); + }; + break; + + case SELECT_HANDLE_PIPE: + DBUG_PRINT("Handle %x is a pipe handle", hFileDescr); + /* Console is always ready in write operation, need to check for read. */ + if (EMode == SELECT_MODE_READ) + { + DBUG_PRINT("Need to check availability of data on pipe"); + res = read_pipe_poll_add(res, EMode, hFileDescr, lpOrig); } - enter_blocking_section(); - if (select(FD_SETSIZE, &read, &write, &except, tvp) == -1) - err = WSAGetLastError(); - leave_blocking_section(); - if (err) { - win32_maperr(err); - uerror("select", Nothing); + else if (EMode == SELECT_MODE_WRITE) + { + DBUG_PRINT("No need to check availability of data on pipe, write operation always possible"); + res = static_poll_add(res, EMode, hFileDescr, lpOrig); + }; + break; + + case SELECT_HANDLE_SOCKET: + DBUG_PRINT("Handle %x is a socket handle", hFileDescr); + if (getsockname((SOCKET)hFileDescr, &sa, &sa_len) == SOCKET_ERROR) + { + if (WSAGetLastError() == WSAEINVAL) + { + /* Socket is not bound */ + DBUG_PRINT("Socket is not connected"); + if (EMode == SELECT_MODE_WRITE || EMode == SELECT_MODE_READ) + { + res = static_poll_add(res, EMode, hFileDescr, lpOrig); + alreadyAdded = TRUE; + } + } } - read_list = fdset_to_fdlist(readfds, &read); - write_list = fdset_to_fdlist(writefds, &write); - except_list = fdset_to_fdlist(exceptfds, &except); - } - res = alloc_small(3, 0); - Field(res, 0) = read_list; - Field(res, 1) = write_list; - Field(res, 2) = except_list; - End_roots(); - End_roots(); - return res; + if (!alreadyAdded) + { + res = socket_poll_add(res, EMode, hFileDescr, lpOrig); + } + break; + + default: + DBUG_PRINT("Handle %x is unknown", hFileDescr); + caml_failwith("Unknown handle"); + break; + }; + + DBUG_PRINT("Finish dispatching handle %x", hFileDescr); + + CAMLreturnT(LPSELECTDATA, res); +} + +static DWORD caml_list_length (value lst) +{ + DWORD res; + + CAMLparam1 (lst); + CAMLlocal1 (l); + + for (res = 0, l = lst; l != Val_int(0); l = Field(l, 1), res++) + { } + + CAMLreturnT(DWORD, res); +} + +#define MAX(a, b) ((a) > (b) ? (a) : (b)) + +CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value timeout) +{ + /* Event associated to handle */ + DWORD nEventsCount; + DWORD nEventsMax; + HANDLE *lpEventsDone; + + /* Data for all handles */ + LPSELECTDATA lpSelectData; + LPSELECTDATA iterSelectData; + + /* Iterator for results */ + LPSELECTRESULT iterResult; + + /* Iterator */ + DWORD i; + + /* Error status */ + DWORD err; + + /* Time to wait */ + DWORD milliseconds; + + /* Wait return */ + DWORD waitRet; + + /* Set of handle */ + SELECTHANDLESET hds; + DWORD hdsMax; + LPHANDLE hdsData; + + /* Length of each list */ + DWORD readfds_len; + DWORD writefds_len; + DWORD exceptfds_len; + + CAMLparam4 (readfds, writefds, exceptfds, timeout); + CAMLlocal5 (read_list, write_list, except_list, res, l); + CAMLlocal1 (fd); + + DBUG_PRINT("in select"); + + nEventsCount = 0; + nEventsMax = 0; + lpEventsDone = NULL; + lpSelectData = NULL; + iterSelectData = NULL; + iterResult = NULL; + err = 0; + waitRet = 0; + readfds_len = caml_list_length(readfds); + writefds_len = caml_list_length(writefds); + exceptfds_len = caml_list_length(exceptfds); + hdsMax = MAX(readfds_len, MAX(writefds_len, exceptfds_len)); + + if (!HeapLock(GetProcessHeap())) + { + win32_maperr(GetLastError()); + uerror("select", Nothing); + } + hdsData = (HANDLE *)HeapAlloc( + GetProcessHeap(), + 0, + sizeof(HANDLE) * hdsMax); + HeapUnlock(GetProcessHeap()); + + if (Double_val(timeout) >= 0.0) + { + milliseconds = 1000 * Double_val(timeout); + DBUG_PRINT("Will wait %d ms", milliseconds); + } + else + { + milliseconds = INFINITE; + } + + + /* Create list of select data, based on the different list of fd to watch */ + DBUG_PRINT("Dispatch read fd"); + handle_set_init(&hds, hdsData, hdsMax); + for (l = readfds; l != Val_int(0); l = Field(l, 1)) + { + fd = Field(l, 0); + if (!handle_set_mem(&hds, Handle_val(fd))) + { + handle_set_add(&hds, Handle_val(fd)); + lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_READ, fd); + } + else + { + DBUG_PRINT("Discarding handle %x which is already monitor for read", Handle_val(fd)); + } + } + handle_set_reset(&hds); + + DBUG_PRINT("Dispatch write fd"); + handle_set_init(&hds, hdsData, hdsMax); + for (l = writefds; l != Val_int(0); l = Field(l, 1)) + { + fd = Field(l, 0); + if (!handle_set_mem(&hds, Handle_val(fd))) + { + handle_set_add(&hds, Handle_val(fd)); + lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_WRITE, fd); + } + else + { + DBUG_PRINT("Discarding handle %x which is already monitor for write", Handle_val(fd)); + } + } + handle_set_reset(&hds); + + DBUG_PRINT("Dispatch exceptional fd"); + handle_set_init(&hds, hdsData, hdsMax); + for (l = exceptfds; l != Val_int(0); l = Field(l, 1)) + { + fd = Field(l, 0); + if (!handle_set_mem(&hds, Handle_val(fd))) + { + handle_set_add(&hds, Handle_val(fd)); + lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_EXCEPT, fd); + } + else + { + DBUG_PRINT("Discarding handle %x which is already monitor for exceptional", Handle_val(fd)); + } + } + handle_set_reset(&hds); + + /* Building the list of handle to wait for */ + DBUG_PRINT("Building events done array"); + nEventsMax = list_length((LPLIST)lpSelectData); + nEventsCount = 0; + if (!HeapLock(GetProcessHeap())) + { + win32_maperr(GetLastError()); + uerror("select", Nothing); + } + lpEventsDone = (HANDLE *)HeapAlloc(GetProcessHeap(), 0, sizeof(HANDLE) * nEventsMax); + HeapUnlock(GetProcessHeap()); + + iterSelectData = lpSelectData; + while (iterSelectData != NULL) + { + /* Execute APC */ + if (iterSelectData->funcWorker != NULL) + { + iterSelectData->lpWorker = + worker_job_submit( + iterSelectData->funcWorker, + (void *)iterSelectData); + DBUG_PRINT("Job submitted to worker %x", iterSelectData->lpWorker); + lpEventsDone[nEventsCount] = worker_job_event_done(iterSelectData->lpWorker); + nEventsCount++; + }; + iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); + }; + + DBUG_PRINT("Need to watch %d workers", nEventsCount); + + /* Processing select itself */ + enter_blocking_section(); + /* There are worker started, waiting to be monitored */ + if (nEventsCount > 0) + { + /* Waiting for event */ + if (err == 0) + { + DBUG_PRINT("Waiting for one select worker to be done"); + switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, FALSE, milliseconds)) + { + case WAIT_FAILED: + err = GetLastError(); + break; + + case WAIT_TIMEOUT: + DBUG_PRINT("Select timeout"); + break; + + default: + DBUG_PRINT("One worker is done"); + break; + }; + } + + /* Ordering stop to every worker */ + DBUG_PRINT("Sending stop signal to every select workers"); + iterSelectData = lpSelectData; + while (iterSelectData != NULL) + { + if (iterSelectData->lpWorker != NULL) + { + worker_job_stop(iterSelectData->lpWorker); + }; + iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); + }; + + DBUG_PRINT("Waiting for every select worker to be done"); + switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, TRUE, INFINITE)) + { + case WAIT_FAILED: + err = GetLastError(); + break; + + default: + DBUG_PRINT("Every worker is done"); + break; + } + } + /* Nothing to monitor but some time to wait. */ + else + { + Sleep(milliseconds); + } + leave_blocking_section(); + + DBUG_PRINT("Error status: %d (0 is ok)", err); + /* Build results */ + if (err == 0) + { + DBUG_PRINT("Building result"); + read_list = Val_unit; + write_list = Val_unit; + except_list = Val_unit; + + iterSelectData = lpSelectData; + while (iterSelectData != NULL) + { + for (i = 0; i < iterSelectData->nResultsCount; i++) + { + iterResult = &(iterSelectData->aResults[i]); + l = alloc_small(2, 0); + Store_field(l, 0, (value)iterResult->lpOrig); + switch (iterResult->EMode) + { + case SELECT_MODE_READ: + Store_field(l, 1, read_list); + read_list = l; + break; + case SELECT_MODE_WRITE: + Store_field(l, 1, write_list); + write_list = l; + break; + case SELECT_MODE_EXCEPT: + Store_field(l, 1, except_list); + except_list = l; + break; + } + } + /* We try to only process the first error, bypass other errors */ + if (err == 0 && iterSelectData->EState == SELECT_STATE_ERROR) + { + err = iterSelectData->nError; + } + iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); + } + } + + /* Free resources */ + DBUG_PRINT("Free selectdata resources"); + iterSelectData = lpSelectData; + while (iterSelectData != NULL) + { + lpSelectData = iterSelectData; + iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); + select_data_free(lpSelectData); + } + lpSelectData = NULL; + + /* Free allocated events/handle set array */ + DBUG_PRINT("Free local allocated resources"); + if (!HeapLock(GetProcessHeap())) + { + win32_maperr(GetLastError()); + uerror("select", Nothing); + } + HeapFree(GetProcessHeap(), 0, lpEventsDone); + HeapFree(GetProcessHeap(), 0, hdsData); + HeapUnlock(GetProcessHeap()); + + DBUG_PRINT("Raise error if required"); + if (err != 0) + { + win32_maperr(err); + uerror("select", Nothing); + } + + DBUG_PRINT("Build final result"); + res = alloc_small(3, 0); + Store_field(res, 0, read_list); + Store_field(res, 1, write_list); + Store_field(res, 2, except_list); + + DBUG_PRINT("out select"); + + CAMLreturn(res); } diff --git a/otherlibs/win32unix/sockopt.c b/otherlibs/win32unix/sockopt.c index c9717322..2af9b002 100644 --- a/otherlibs/win32unix/sockopt.c +++ b/otherlibs/win32unix/sockopt.c @@ -11,147 +11,219 @@ /* */ /***********************************************************************/ -/* $Id: sockopt.c,v 1.15 2002/07/23 14:12:01 doligez Exp $ */ +/* $Id: sockopt.c,v 1.19 2008/08/01 13:46:08 xleroy Exp $ */ +#include #include +#include #include +#include #include "unixsupport.h" +#include "socketaddr.h" + +#ifndef IPPROTO_IPV6 +#define IPPROTO_IPV6 (-1) +#endif +#ifndef IPV6_V6ONLY +#define IPV6_V6ONLY (-1) +#endif + +enum option_type { + TYPE_BOOL = 0, + TYPE_INT = 1, + TYPE_LINGER = 2, + TYPE_TIMEVAL = 3, + TYPE_UNIX_ERROR = 4 +}; + +struct socket_option { + int level; + int option; +}; + +/* Table of options, indexed by type */ + +static struct socket_option sockopt_bool[] = { + { SOL_SOCKET, SO_DEBUG }, + { SOL_SOCKET, SO_BROADCAST }, + { SOL_SOCKET, SO_REUSEADDR }, + { SOL_SOCKET, SO_KEEPALIVE }, + { SOL_SOCKET, SO_DONTROUTE }, + { SOL_SOCKET, SO_OOBINLINE }, + { SOL_SOCKET, SO_ACCEPTCONN }, + { IPPROTO_TCP, TCP_NODELAY }, + { IPPROTO_IPV6, IPV6_V6ONLY} +}; + +static struct socket_option sockopt_int[] = { + { SOL_SOCKET, SO_SNDBUF }, + { SOL_SOCKET, SO_RCVBUF }, + { SOL_SOCKET, SO_ERROR }, + { SOL_SOCKET, SO_TYPE }, + { SOL_SOCKET, SO_RCVLOWAT }, + { SOL_SOCKET, SO_SNDLOWAT } }; + +static struct socket_option sockopt_linger[] = { + { SOL_SOCKET, SO_LINGER } +}; + +static struct socket_option sockopt_timeval[] = { + { SOL_SOCKET, SO_RCVTIMEO }, + { SOL_SOCKET, SO_SNDTIMEO } +}; + +static struct socket_option sockopt_unix_error[] = { + { SOL_SOCKET, SO_ERROR } +}; + +static struct socket_option * sockopt_table[] = { + sockopt_bool, + sockopt_int, + sockopt_linger, + sockopt_timeval, + sockopt_unix_error +}; + +static char * getsockopt_fun_name[] = { + "getsockopt", + "getsockopt_int", + "getsockopt_optint", + "getsockopt_float", + "getsockopt_error" +}; + +static char * setsockopt_fun_name[] = { + "setsockopt", + "setsockopt_int", + "setsockopt_optint", + "setsockopt_float", + "setsockopt_error" +}; + +union option_value { + int i; + struct linger lg; + struct timeval tv; +}; -static int sockopt_bool[] = { - SO_DEBUG, SO_BROADCAST, SO_REUSEADDR, SO_KEEPALIVE, - SO_DONTROUTE, SO_OOBINLINE, SO_ACCEPTCONN }; - -static int sockopt_int[] = { - SO_SNDBUF, SO_RCVBUF, SO_ERROR, SO_TYPE, SO_RCVLOWAT, SO_SNDLOWAT }; - -static int sockopt_optint[] = { SO_LINGER }; - -static int sockopt_float[] = { SO_RCVTIMEO, SO_SNDTIMEO }; - -CAMLprim value getsockopt_int(int *sockopt, value socket, - int level, value option) -{ - int optval; - int optsize; - - optsize = sizeof(optval); - if (getsockopt(Socket_val(socket), - level, sockopt[Int_val(option)], - (void *) &optval, &optsize) == -1) - uerror("getsockopt", Nothing); - return Val_int(optval); -} - -CAMLprim value setsockopt_int(int *sockopt, value socket, int level, - value option, value status) -{ - int optval = Int_val(status); - if (setsockopt(Socket_val(socket), - level, sockopt[Int_val(option)], - (void *) &optval, sizeof(optval)) == -1) - uerror("setsockopt", Nothing); - return Val_unit; -} - -CAMLprim value unix_getsockopt_bool(value socket, value option) { - return getsockopt_int(sockopt_bool, socket, SOL_SOCKET, option); -} - -CAMLprim value unix_setsockopt_bool(value socket, value option, value status) -{ - return setsockopt_int(sockopt_bool, socket, SOL_SOCKET, option, status); -} - -CAMLprim value unix_getsockopt_int(value socket, value option) { - return getsockopt_int(sockopt_int, socket, SOL_SOCKET, option); -} - -CAMLprim value unix_setsockopt_int(value socket, value option, value status) -{ - return setsockopt_int(sockopt_int, socket, SOL_SOCKET, option, status); -} - -CAMLprim value getsockopt_optint(int *sockopt, value socket, - int level, value option) +CAMLexport value +unix_getsockopt_aux(char * name, + enum option_type ty, int level, int option, + value socket) { - struct linger optval; - int optsize; - value res = Val_int(0); /* None */ + union option_value optval; + socklen_param_type optsize; + + + switch (ty) { + case TYPE_BOOL: + case TYPE_INT: + case TYPE_UNIX_ERROR: + optsize = sizeof(optval.i); break; + case TYPE_LINGER: + optsize = sizeof(optval.lg); break; + case TYPE_TIMEVAL: + optsize = sizeof(optval.tv); break; + default: + unix_error(EINVAL, name, Nothing); + } - optsize = sizeof(optval); - if (getsockopt(Socket_val(socket), - level, sockopt[Int_val(option)], + if (getsockopt(Socket_val(socket), level, option, (void *) &optval, &optsize) == -1) - uerror("getsockopt_optint", Nothing); - if (optval.l_onoff != 0) { - res = alloc_small(1, 0); - Field(res, 0) = Val_int(optval.l_linger); + uerror(name, Nothing); + + switch (ty) { + case TYPE_BOOL: + case TYPE_INT: + return Val_int(optval.i); + case TYPE_LINGER: + if (optval.lg.l_onoff == 0) { + return Val_int(0); /* None */ + } else { + value res = alloc_small(1, 0); /* Some */ + Field(res, 0) = Val_int(optval.lg.l_linger); + return res; + } + case TYPE_TIMEVAL: + return copy_double((double) optval.tv.tv_sec + + (double) optval.tv.tv_usec / 1e6); + case TYPE_UNIX_ERROR: + if (optval.i == 0) { + return Val_int(0); /* None */ + } else { + value err, res; + err = unix_error_of_code(optval.i); + Begin_root(err); + res = alloc_small(1, 0); /* Some */ + Field(res, 0) = err; + End_roots(); + return res; + } + default: + unix_error(EINVAL, name, Nothing); + return Val_unit; /* Avoid warning */ } - return res; -} - -CAMLprim value setsockopt_optint(int *sockopt, value socket, int level, - value option, value status) -{ - struct linger optval; - - optval.l_onoff = Is_block (status); - if (optval.l_onoff) - optval.l_linger = Int_val (Field (status, 0)); - if (setsockopt(Socket_val(socket), - level, sockopt[Int_val(option)], - (void *) &optval, sizeof(optval)) == -1) - uerror("setsockopt_optint", Nothing); - return Val_unit; -} - -CAMLprim value unix_getsockopt_optint(value socket, value option) -{ - return getsockopt_optint(sockopt_optint, socket, SOL_SOCKET, option); } -CAMLprim value unix_setsockopt_optint(value socket, value option, value status) +CAMLexport value +unix_setsockopt_aux(char * name, + enum option_type ty, int level, int option, + value socket, value val) { - return setsockopt_optint(sockopt_optint, socket, SOL_SOCKET, option, status); -} + union option_value optval; + socklen_param_type optsize; + double f; + + switch (ty) { + case TYPE_BOOL: + case TYPE_INT: + optsize = sizeof(optval.i); + optval.i = Int_val(val); + break; + case TYPE_LINGER: + optsize = sizeof(optval.lg); + optval.lg.l_onoff = Is_block (val); + if (optval.lg.l_onoff) + optval.lg.l_linger = Int_val (Field (val, 0)); + break; + case TYPE_TIMEVAL: + f = Double_val(val); + optsize = sizeof(optval.tv); + optval.tv.tv_sec = (int) f; + optval.tv.tv_usec = (int) (1e6 * (f - optval.tv.tv_sec)); + break; + case TYPE_UNIX_ERROR: + default: + unix_error(EINVAL, name, Nothing); + } -CAMLprim value getsockopt_float(int *sockopt, value socket, - int level, value option) -{ - struct timeval tv; - int optsize; - - optsize = sizeof(tv); - if (getsockopt(Socket_val(socket), - level, sockopt[Int_val(option)], - (void *) &tv, &optsize) == -1) - uerror("getsockopt_float", Nothing); - return copy_double((double) tv.tv_sec + (double) tv.tv_usec / 1e6); -} + if (setsockopt(Socket_val(socket), level, option, + (void *) &optval, optsize) == -1) + uerror(name, Nothing); -CAMLprim value setsockopt_float(int *sockopt, value socket, int level, - value option, value status) -{ - struct timeval tv; - double tv_f; - - tv_f = Double_val(status); - tv.tv_sec = (int)tv_f; - tv.tv_usec = (int) (1e6 * (tv_f - tv.tv_sec)); - if (setsockopt(Socket_val(socket), - level, sockopt[Int_val(option)], - (void *) &tv, sizeof(tv)) == -1) - uerror("setsockopt_float", Nothing); return Val_unit; } -CAMLprim value unix_getsockopt_float(value socket, value option) +CAMLprim value unix_getsockopt(value vty, value vsocket, value voption) { - return getsockopt_float(sockopt_float, socket, SOL_SOCKET, option); + enum option_type ty = Int_val(vty); + struct socket_option * opt = &(sockopt_table[ty][Int_val(voption)]); + return unix_getsockopt_aux(getsockopt_fun_name[ty], + ty, + opt->level, + opt->option, + vsocket); } -CAMLprim value unix_setsockopt_float(value socket, value option, value status) +CAMLprim value unix_setsockopt(value vty, value vsocket, value voption, + value val) { - return setsockopt_float(sockopt_float, socket, SOL_SOCKET, option, status); + enum option_type ty = Int_val(vty); + struct socket_option * opt = &(sockopt_table[ty][Int_val(voption)]); + return unix_setsockopt_aux(setsockopt_fun_name[ty], + ty, + opt->level, + opt->option, + vsocket, + val); } - diff --git a/otherlibs/win32unix/startup.c b/otherlibs/win32unix/startup.c index ae584e56..bbf5fe1f 100644 --- a/otherlibs/win32unix/startup.c +++ b/otherlibs/win32unix/startup.c @@ -16,6 +16,8 @@ #include #include #include "unixsupport.h" +#include "winworker.h" +#include "windbug.h" value val_process_id; @@ -26,18 +28,27 @@ CAMLprim value win_startup(unit) int i; HANDLE h; + DBUG_INIT; + (void) WSAStartup(MAKEWORD(2, 0), &wsaData); DuplicateHandle(GetCurrentProcess(), GetCurrentProcess(), GetCurrentProcess(), &h, 0, TRUE, DUPLICATE_SAME_ACCESS); val_process_id = Val_int(h); + worker_init(); + return Val_unit; } CAMLprim value win_cleanup(unit) value unit; { + worker_cleanup(); + (void) WSACleanup(); + + DBUG_CLEANUP; + return Val_unit; } diff --git a/otherlibs/win32unix/unix.ml b/otherlibs/win32unix/unix.ml index 2feb2e4f..0d4b190e 100644 --- a/otherlibs/win32unix/unix.ml +++ b/otherlibs/win32unix/unix.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: unix.ml,v 1.46 2007/02/25 14:38:11 xleroy Exp $ *) +(* $Id: unix.ml,v 1.48 2008/08/01 13:46:08 xleroy Exp $ *) (* Initialization *) @@ -506,29 +506,6 @@ type msg_flag = | MSG_DONTROUTE | MSG_PEEK -type socket_bool_option = - SO_DEBUG - | SO_BROADCAST - | SO_REUSEADDR - | SO_KEEPALIVE - | SO_DONTROUTE - | SO_OOBINLINE - | SO_ACCEPTCONN - -type socket_int_option = - SO_SNDBUF - | SO_RCVBUF - | SO_ERROR - | SO_TYPE - | SO_RCVLOWAT - | SO_SNDLOWAT - -type socket_optint_option = SO_LINGER - -type socket_float_option = - SO_RCVTIMEO - | SO_SNDTIMEO - external socket : socket_domain -> socket_type -> int -> file_descr = "unix_socket" let socketpair dom ty proto = invalid_arg "Unix.socketpair not implemented" @@ -570,22 +547,68 @@ let sendto fd buf ofs len flags addr = then invalid_arg "Unix.sendto" else unsafe_sendto fd buf ofs len flags addr -external getsockopt : file_descr -> socket_bool_option -> bool - = "unix_getsockopt_bool" -external setsockopt : file_descr -> socket_bool_option -> bool -> unit - = "unix_setsockopt_bool" -external getsockopt_int : file_descr -> socket_int_option -> int - = "unix_getsockopt_int" -external setsockopt_int : file_descr -> socket_int_option -> int -> unit - = "unix_setsockopt_int" -external getsockopt_optint : file_descr -> socket_optint_option -> int option - = "unix_getsockopt_optint" -external setsockopt_optint : file_descr -> socket_optint_option -> int option -> unit - = "unix_setsockopt_optint" -external getsockopt_float : file_descr -> socket_float_option -> float - = "unix_getsockopt_float" -external setsockopt_float : file_descr -> socket_float_option -> float -> unit - = "unix_setsockopt_float" +type socket_bool_option = + SO_DEBUG + | SO_BROADCAST + | SO_REUSEADDR + | SO_KEEPALIVE + | SO_DONTROUTE + | SO_OOBINLINE + | SO_ACCEPTCONN + | TCP_NODELAY + | IPV6_ONLY + +type socket_int_option = + SO_SNDBUF + | SO_RCVBUF + | SO_ERROR + | SO_TYPE + | SO_RCVLOWAT + | SO_SNDLOWAT + +type socket_optint_option = SO_LINGER + +type socket_float_option = + SO_RCVTIMEO + | SO_SNDTIMEO + +type socket_error_option = SO_ERROR + +module SO: sig + type ('opt, 'v) t + val bool: (socket_bool_option, bool) t + val int: (socket_int_option, int) t + val optint: (socket_optint_option, int option) t + val float: (socket_float_option, float) t + val error: (socket_error_option, error option) t + val get: ('opt, 'v) t -> file_descr -> 'opt -> 'v + val set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit +end = struct + type ('opt, 'v) t = int + let bool = 0 + let int = 1 + let optint = 2 + let float = 3 + let error = 4 + external get: ('opt, 'v) t -> file_descr -> 'opt -> 'v + = "unix_getsockopt" + external set: ('opt, 'v) t -> file_descr -> 'opt -> 'v -> unit + = "unix_setsockopt" +end + +let getsockopt fd opt = SO.get SO.bool fd opt +let setsockopt fd opt v = SO.set SO.bool fd opt v + +let getsockopt_int fd opt = SO.get SO.int fd opt +let setsockopt_int fd opt v = SO.set SO.int fd opt v + +let getsockopt_optint fd opt = SO.get SO.optint fd opt +let setsockopt_optint fd opt v = SO.set SO.optint fd opt v + +let getsockopt_float fd opt = SO.get SO.float fd opt +let setsockopt_float fd opt v = SO.set SO.float fd opt v + +let getsockopt_error fd = SO.get SO.error fd SO_ERROR (* Host and protocol databases *) diff --git a/otherlibs/win32unix/windbug.c b/otherlibs/win32unix/windbug.c new file mode 100644 index 00000000..b6cba54d --- /dev/null +++ b/otherlibs/win32unix/windbug.c @@ -0,0 +1,32 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Contributed by Sylvain Le Gall for Lexifi */ +/* */ +/* Copyright 2008 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id: windbug.c,v 1.2 2008/07/31 12:09:18 xleroy Exp $ */ + +#include + +int dbug = 0; + +void dbug_init (void) +{ + dbug = (getenv("OCAMLDBUG") != NULL); +} + +void dbug_cleanup (void) +{ +} + +int dbug_test (void) +{ + return dbug; +} diff --git a/otherlibs/win32unix/windbug.h b/otherlibs/win32unix/windbug.h new file mode 100644 index 00000000..4c65aa51 --- /dev/null +++ b/otherlibs/win32unix/windbug.h @@ -0,0 +1,50 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Contributed by Sylvain Le Gall for Lexifi */ +/* */ +/* Copyright 2008 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id: windbug.h,v 1.2 2008/07/31 12:09:18 xleroy Exp $ */ + +/*#define DBUG*/ + +#ifdef DBUG + +#include +#include + +#define DBUG_PRINT(fmt, ...) \ + do \ + { \ + if (dbug_test()) \ + { \ + fprintf(stderr, "DBUG (pid:%d, tid: %d): ", GetCurrentProcessId(), GetCurrentThreadId()); \ + fprintf(stderr, fmt, __VA_ARGS__); \ + fprintf(stderr, "\n"); \ + fflush(stderr); \ + }; \ + } while(0) + +/* Initialize and cleanup dbug variable */ +void dbug_init (void); +void dbug_cleanup (void); + +/* Test if we are in dbug mode */ +int dbug_test (void); + +#define DBUG_INIT dbug_init() +#define DBUG_CLEANUP dbug_cleanup() + +#else +#define DBUG_PRINT(fmt, ...) +#define DBUG_INIT +#define DBUG_CLEANUP +#endif + diff --git a/otherlibs/win32unix/winlist.c b/otherlibs/win32unix/winlist.c new file mode 100644 index 00000000..af5000df --- /dev/null +++ b/otherlibs/win32unix/winlist.c @@ -0,0 +1,80 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Contributed by Sylvain Le Gall for Lexifi */ +/* */ +/* Copyright 2008 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id: winlist.c,v 1.2 2008/07/31 12:09:18 xleroy Exp $ */ + +/* Basic list function in C. */ + +#include "winlist.h" +#include + +void list_init (LPLIST lst) +{ + lst->lpNext = NULL; +} + +void list_cleanup (LPLIST lst) +{ + lst->lpNext = NULL; +} + +void list_next_set (LPLIST lst, LPLIST next) +{ + lst->lpNext = next; +} + +LPLIST list_next (LPLIST lst) +{ + return lst->lpNext; +} + +int list_length (LPLIST lst) +{ + int length = 0; + LPLIST iter = lst; + while (iter != NULL) + { + length++; + iter = list_next(iter); + }; + return length; +} + +LPLIST list_concat (LPLIST lsta, LPLIST lstb) +{ + LPLIST res = NULL; + LPLIST iter = NULL; + LPLIST iterPrev = NULL; + + if (lsta == NULL) + { + res = lstb; + } + else if (lstb == NULL) + { + res = lsta; + } + else + { + res = lsta; + iter = lsta; + while (iter != NULL) + { + iterPrev = iter; + iter = list_next(iter); + }; + iterPrev->lpNext = lstb; + }; + + return res; +} diff --git a/otherlibs/win32unix/winlist.h b/otherlibs/win32unix/winlist.h new file mode 100644 index 00000000..aa838756 --- /dev/null +++ b/otherlibs/win32unix/winlist.h @@ -0,0 +1,54 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Contributed by Sylvain Le Gall for Lexifi */ +/* */ +/* Copyright 2008 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id: winlist.h,v 1.2 2008/07/31 12:09:18 xleroy Exp $ */ +#ifndef _WINLIST_H +#define _WINLIST_H + +/* Basic list function in C. */ + +/* Singly-linked list data structure. + * To transform a C struct into a list structure, you must include + * at first position of your C struct a "LIST lst" and call list_init + * on this data structure. + * + * See winworker.c for example. + */ +typedef struct _LIST LIST; +typedef LIST *LPLIST; + +struct _LIST { + LPLIST lpNext; +}; + +/* Initialize list data structure */ +void list_init (LPLIST lst); + +/* Cleanup list data structure */ +void list_cleanup (LPLIST lst); + +/* Set next element */ +void list_next_set (LPLIST lst, LPLIST next); + +/* Return next element */ +LPLIST list_next (LPLIST); + +#define LIST_NEXT(T, e) ((T)(list_next((LPLIST)(e)))) + +/* Get number of element */ +int list_length (LPLIST); + +/* Concat two list. */ +LPLIST list_concat (LPLIST, LPLIST); + +#endif /* _WINLIST_H */ diff --git a/otherlibs/win32unix/winwait.c b/otherlibs/win32unix/winwait.c index 318d7f2a..fa5cbe36 100644 --- a/otherlibs/win32unix/winwait.c +++ b/otherlibs/win32unix/winwait.c @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: winwait.c,v 1.18.6.1 2007/10/25 08:31:58 xleroy Exp $ */ +/* $Id: winwait.c,v 1.20 2008/01/11 16:13:16 doligez Exp $ */ #include #include @@ -19,6 +19,7 @@ #include #include "unixsupport.h" #include +#include static value alloc_process_status(HANDLE pid, int status) { diff --git a/otherlibs/win32unix/winworker.c b/otherlibs/win32unix/winworker.c new file mode 100644 index 00000000..695f4251 --- /dev/null +++ b/otherlibs/win32unix/winworker.c @@ -0,0 +1,338 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Contributed by Sylvain Le Gall for Lexifi */ +/* */ +/* Copyright 2008 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id: winworker.c,v 1.2 2008/07/31 12:09:18 xleroy Exp $ */ + +#include "winworker.h" +#include "winlist.h" +#include "windbug.h" +#include +#include +#include "unixsupport.h" + +typedef enum { + WORKER_CMD_NONE = 0, + WORKER_CMD_EXEC, + WORKER_CMD_STOP +} WORKERCMD; + +struct _WORKER { + LIST lst; /* This structure is used as a list. */ + HANDLE hJobStarted; /* Event representing that the function has begun. */ + HANDLE hJobStop; /* Event that can be used to notify the function that it + should stop processing. */ + HANDLE hJobDone; /* Event representing that the function has finished. */ + void *lpJobUserData; /* User data for the job. */ + WORKERFUNC hJobFunc; /* Function to be called during APC */ + HANDLE hWorkerReady; /* Worker is ready. */ + HANDLE hCommandReady; /* Worker should execute command. */ + WORKERCMD ECommand; /* Command to execute */ + HANDLE hThread; /* Thread handle of the worker. */ +}; + +#define THREAD_WORKERS_MAX 16 +#define THREAD_WORKERS_MEM 4000 + +LPWORKER lpWorkers = NULL; +DWORD nWorkersCurrent = 0; +DWORD nWorkersMax = 0; +HANDLE hWorkersMutex = INVALID_HANDLE_VALUE; +HANDLE hWorkerHeap = INVALID_HANDLE_VALUE; + +DWORD WINAPI worker_wait (LPVOID _data) +{ + BOOL bExit; + LPWORKER lpWorker; + + lpWorker = (LPWORKER )_data; + bExit = FALSE; + + DBUG_PRINT("Worker %x starting", lpWorker); + while ( + !bExit + && SignalObjectAndWait( + lpWorker->hWorkerReady, + lpWorker->hCommandReady, + INFINITE, + TRUE) == WAIT_OBJECT_0) + { + DBUG_PRINT("Worker %x running", lpWorker); + switch (lpWorker->ECommand) + { + case WORKER_CMD_NONE: + break; + + case WORKER_CMD_EXEC: + if (lpWorker->hJobFunc != NULL) + { + SetEvent(lpWorker->hJobStarted); + lpWorker->hJobFunc(lpWorker->hJobStop, lpWorker->lpJobUserData); + SetEvent(lpWorker->hJobDone); + }; + break; + + case WORKER_CMD_STOP: + bExit = TRUE; + break; + } + }; + DBUG_PRINT("Worker %x exiting", lpWorker); + + return 0; +} + +LPWORKER worker_new (void) +{ + LPWORKER lpWorker = NULL; + + if (!HeapLock(hWorkerHeap)) + { + win32_maperr(GetLastError()); + uerror("worker_new", Nothing); + }; + lpWorker = (LPWORKER)HeapAlloc(hWorkerHeap, 0, sizeof(WORKER)); + HeapUnlock(hWorkerHeap); + list_init((LPLIST)lpWorker); + lpWorker->hJobStarted = CreateEvent(NULL, TRUE, FALSE, NULL); + lpWorker->hJobStop = CreateEvent(NULL, TRUE, FALSE, NULL); + lpWorker->hJobDone = CreateEvent(NULL, TRUE, FALSE, NULL); + lpWorker->lpJobUserData = NULL; + lpWorker->hWorkerReady = CreateEvent(NULL, FALSE, FALSE, NULL); + lpWorker->hCommandReady = CreateEvent(NULL, FALSE, FALSE, NULL); + lpWorker->ECommand = WORKER_CMD_NONE; + lpWorker->hThread = CreateThread( + NULL, + THREAD_WORKERS_MEM, + worker_wait, + (LPVOID)lpWorker, + 0, + NULL); + + return lpWorker; +}; + +void worker_free (LPWORKER lpWorker) +{ + /* Wait for termination of the worker */ + DBUG_PRINT("Shutting down worker %x", lpWorker); + WaitForSingleObject(lpWorker->hWorkerReady, INFINITE); + lpWorker->ECommand = WORKER_CMD_STOP; + SetEvent(lpWorker->hCommandReady); + WaitForSingleObject(lpWorker->hThread, INFINITE); + + /* Free resources */ + DBUG_PRINT("Freeing resources of worker %x", lpWorker); + if (lpWorker->hThread != INVALID_HANDLE_VALUE) + { + CloseHandle(lpWorker->hThread); + lpWorker->hThread = INVALID_HANDLE_VALUE; + } + + if (lpWorker->hJobStarted != INVALID_HANDLE_VALUE) + { + CloseHandle(lpWorker->hJobStarted); + lpWorker->hJobStarted = INVALID_HANDLE_VALUE; + } + + if (lpWorker->hJobStop != INVALID_HANDLE_VALUE) + { + CloseHandle(lpWorker->hJobStop); + lpWorker->hJobStop = INVALID_HANDLE_VALUE; + } + + if (lpWorker->hJobDone != INVALID_HANDLE_VALUE) + { + CloseHandle(lpWorker->hJobDone); + lpWorker->hJobDone = INVALID_HANDLE_VALUE; + } + + lpWorker->lpJobUserData = NULL; + lpWorker->hJobFunc = NULL; + + if (lpWorker->hWorkerReady != INVALID_HANDLE_VALUE) + { + CloseHandle(lpWorker->hWorkerReady); + lpWorker->hWorkerReady = INVALID_HANDLE_VALUE; + } + + if (lpWorker->hCommandReady != INVALID_HANDLE_VALUE) + { + CloseHandle(lpWorker->hCommandReady); + lpWorker->hCommandReady = INVALID_HANDLE_VALUE; + } + + if (!HeapLock(hWorkerHeap)) + { + win32_maperr(GetLastError()); + uerror("worker_new", Nothing); + }; + HeapFree(hWorkerHeap, 0, lpWorker); + HeapUnlock(hWorkerHeap); +}; + +LPWORKER worker_pop (void) +{ + LPWORKER lpWorkerFree = NULL; + + WaitForSingleObject(hWorkersMutex, INFINITE); + /* Get the first worker of the list */ + if (lpWorkers != NULL) + { + lpWorkerFree = lpWorkers; + lpWorkers = LIST_NEXT(LPWORKER, lpWorkers); + } + nWorkersCurrent++; + nWorkersMax = (nWorkersCurrent > nWorkersMax ? nWorkersCurrent : nWorkersMax); + DBUG_PRINT("Workers running current/runnning max/waiting: %d/%d/%d", + nWorkersCurrent, + nWorkersMax, + list_length((LPLIST)lpWorkers)); + ReleaseMutex(hWorkersMutex); + + if (lpWorkerFree == NULL) + { + /* We cannot find a free worker, create one. */ + lpWorkerFree = worker_new(); + } + + /* Ensure that we don't get dangling pointer to old data. */ + list_init((LPLIST)lpWorkerFree); + lpWorkerFree->lpJobUserData = NULL; + + /* Reset events */ + ResetEvent(lpWorkerFree->hJobStarted); + ResetEvent(lpWorkerFree->hJobStop); + ResetEvent(lpWorkerFree->hJobDone); + + return lpWorkerFree; +} + +void worker_push(LPWORKER lpWorker) +{ + BOOL bFreeWorker; + + bFreeWorker = TRUE; + + WaitForSingleObject(hWorkersMutex, INFINITE); + DBUG_PRINT("Testing if we are under the maximum number of running workers"); + if (list_length((LPLIST)lpWorkers) < THREAD_WORKERS_MAX) + { + DBUG_PRINT("Saving this worker for future use"); + DBUG_PRINT("Next: %x", ((LPLIST)lpWorker)->lpNext); + lpWorkers = (LPWORKER)list_concat((LPLIST)lpWorker, (LPLIST)lpWorkers); + bFreeWorker = FALSE; + }; + nWorkersCurrent--; + DBUG_PRINT("Workers running current/runnning max/waiting: %d/%d/%d", + nWorkersCurrent, + nWorkersMax, + list_length((LPLIST)lpWorkers)); + ReleaseMutex(hWorkersMutex); + + if (bFreeWorker) + { + DBUG_PRINT("Freeing worker %x", lpWorker); + worker_free(lpWorker); + } +} + +void worker_init (void) +{ + int i = 0; + + /* Init a shared variable. The only way to ensure that no other + worker will be at the same point is to use a critical section. + */ + DBUG_PRINT("Allocating mutex for workers"); + if (hWorkersMutex == INVALID_HANDLE_VALUE) + { + hWorkersMutex = CreateMutex(NULL, FALSE, NULL); + } + + if (hWorkerHeap == INVALID_HANDLE_VALUE) + { + hWorkerHeap = HeapCreate(0, sizeof(WORKER) * THREAD_WORKERS_MAX * 4, 0); + } +} + +void worker_cleanup(void) +{ + LPWORKER lpWorker = NULL; + + /* WARNING: we can have a race condition here, if while this code + is executed another worker is waiting to access hWorkersMutex, + he will never be able to get it... + */ + if (hWorkersMutex != INVALID_HANDLE_VALUE) + { + WaitForSingleObject(hWorkersMutex, INFINITE); + DBUG_PRINT("Freeing global resource of workers"); + /* Empty the queue of worker worker */ + while (lpWorkers != NULL) + { + ReleaseMutex(hWorkersMutex); + lpWorker = worker_pop(); + DBUG_PRINT("Freeing worker %x", lpWorker); + WaitForSingleObject(hWorkersMutex, INFINITE); + worker_free(lpWorker); + }; + ReleaseMutex(hWorkersMutex); + + /* Destroy associated mutex */ + CloseHandle(hWorkersMutex); + hWorkersMutex = INVALID_HANDLE_VALUE; + }; +} + +LPWORKER worker_job_submit (WORKERFUNC f, void *user_data) +{ + LPWORKER lpWorker = worker_pop(); + + DBUG_PRINT("Waiting for worker to be ready"); + enter_blocking_section(); + WaitForSingleObject(lpWorker->hWorkerReady, INFINITE); + ResetEvent(lpWorker->hWorkerReady); + leave_blocking_section(); + DBUG_PRINT("Worker is ready"); + + lpWorker->hJobFunc = f; + lpWorker->lpJobUserData = user_data; + lpWorker->ECommand = WORKER_CMD_EXEC; + + DBUG_PRINT("Call worker (func: %x, worker: %x)", f, lpWorker); + SetEvent(lpWorker->hCommandReady); + + return (LPWORKER)lpWorker; +} + +HANDLE worker_job_event_done (LPWORKER lpWorker) +{ + return lpWorker->hJobDone; +} + +void worker_job_stop (LPWORKER lpWorker) +{ + DBUG_PRINT("Sending stop signal to worker %x", lpWorker); + SetEvent(lpWorker->hJobStop); + DBUG_PRINT("Signal sent to worker %x", lpWorker); +} + +void worker_job_finish (LPWORKER lpWorker) +{ + DBUG_PRINT("Finishing call of worker %x", lpWorker); + enter_blocking_section(); + WaitForSingleObject(lpWorker->hJobDone, INFINITE); + leave_blocking_section(); + + worker_push(lpWorker); +} diff --git a/otherlibs/win32unix/winworker.h b/otherlibs/win32unix/winworker.h new file mode 100644 index 00000000..2f841c02 --- /dev/null +++ b/otherlibs/win32unix/winworker.h @@ -0,0 +1,70 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Contributed by Sylvain Le Gall for Lexifi */ +/* */ +/* Copyright 2008 Institut National de Recherche en Informatique et */ +/* en Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU Library General Public License, with */ +/* the special exception on linking described in file ../../LICENSE. */ +/* */ +/***********************************************************************/ + +/* $Id: winworker.h,v 1.2 2008/07/31 12:09:18 xleroy Exp $ */ +#ifndef _WINWORKER_H +#define _WINWORKER_H + +#define _WIN32_WINNT 0x0400 +#include + +/* Pool of worker threads. + * + * These functions help to manage a pool of worker thread and submit task to + * the pool. It helps to reduce the number of thread creation. + * + * Each worker are started in alertable wait state and jobs are submitted as + * APC (asynchronous procedure call). + */ + +/* Data associated with submitted job */ +typedef struct _WORKER WORKER; +typedef WORKER *LPWORKER; + +/* Function type of submitted job: + * void worker_call (HANDLE hStop, void *data) + * + * This function will be called using the data following: + * - hStop must be watched for change, since it represents an external command + * to stop the call. This event is shared through the WORKER structure, which + * can be access throuhg worker_job_event_done. + * - data is user provided data for the function. + */ +typedef void (*WORKERFUNC) (HANDLE, void *); + +/* Initialize global data structure for worker + */ +void worker_init (void); + +/* Free global data structure for worker + */ +void worker_cleanup (void); + +/* Submit a job to worker. Use returned data to synchronize with the procedure + * submitted. + */ +LPWORKER worker_job_submit (WORKERFUNC f, void *data); + +/* Get event to know when a job is done. + */ +HANDLE worker_job_event_done (LPWORKER); + +/* Ask a job to stop processing. + */ +void worker_job_stop (LPWORKER); + +/* End a job submitted to worker. + */ +void worker_job_finish (LPWORKER); + +#endif /* _WINWORKER_H */ diff --git a/parsing/lexer.mll b/parsing/lexer.mll index 04d94799..6ddbb5ce 100644 --- a/parsing/lexer.mll +++ b/parsing/lexer.mll @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: lexer.mll,v 1.73 2005/04/11 16:44:26 doligez Exp $ *) +(* $Id: lexer.mll,v 1.73.24.1 2008/10/08 13:07:13 doligez Exp $ *) (* The lexer definition *) @@ -136,9 +136,11 @@ let char_for_decimal_code lexbuf i = let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in - if (c < 0 || c > 255) && not (in_comment ()) - then raise (Error(Illegal_escape (Lexing.lexeme lexbuf), - Location.curr lexbuf)) + if (c < 0 || c > 255) then + if in_comment () + then 'x' + else raise (Error(Illegal_escape (Lexing.lexeme lexbuf), + Location.curr lexbuf)) else Char.chr c let char_for_hexadecimal_code lexbuf i = diff --git a/parsing/location.ml b/parsing/location.ml index 561c3950..2cbe917c 100644 --- a/parsing/location.ml +++ b/parsing/location.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: location.ml,v 1.48.16.1 2007/12/06 13:36:03 doligez Exp $ *) +(* $Id: location.ml,v 1.50 2008/01/11 16:13:16 doligez Exp $ *) open Lexing @@ -61,7 +61,7 @@ let rhs_loc n = { loc_ghost = false; };; -let input_name = ref "" +let input_name = ref "_none_" let input_lexbuf = ref (None : lexbuf option) (* Terminal info *) @@ -230,6 +230,14 @@ let print ppf loc = fprintf ppf "%s%i" msg_chars startchar; fprintf ppf "%s%i%s@.%s" msg_to endchar msg_colon msg_head; end +;; + +let print_error ppf loc = + print ppf loc; + fprintf ppf "Error: "; +;; + +let print_error_cur_file ppf = print_error ppf (in_file !input_name);; let print_warning loc ppf w = if Warnings.is_active w then begin diff --git a/parsing/location.mli b/parsing/location.mli index 2db3c63d..8218946a 100644 --- a/parsing/location.mli +++ b/parsing/location.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: location.mli,v 1.16 2005/03/24 17:20:54 doligez Exp $ *) +(* $Id: location.mli,v 1.17 2007/12/04 13:38:58 doligez Exp $ *) (* Source code locations (ranges of positions), used in parsetree. *) @@ -47,7 +47,8 @@ val input_name: string ref val input_lexbuf: Lexing.lexbuf option ref val get_pos_info : Lexing.position -> string * int * int (* file, line, char *) -val print: formatter -> t -> unit +val print_error: formatter -> t -> unit +val print_error_cur_file: formatter -> unit val print_warning: t -> formatter -> Warnings.t -> unit val prerr_warning: t -> Warnings.t -> unit val echo_eof: unit -> unit diff --git a/parsing/parser.mly b/parsing/parser.mly index d8392cdc..9971af7e 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -10,7 +10,7 @@ /* */ /***********************************************************************/ -/* $Id: parser.mly,v 1.126.6.1 2007/11/30 00:53:19 garrigue Exp $ */ +/* $Id: parser.mly,v 1.131 2008/07/14 09:09:53 xleroy Exp $ */ /* The parser definition */ @@ -153,30 +153,32 @@ let bigarray_untuplify = function | exp -> [exp] let bigarray_get arr arg = + let get = if !Clflags.fast then "unsafe_get" else "get" in match bigarray_untuplify arg with [c1] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" "get")), + mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" get)), ["", arr; "", c1])) | [c1;c2] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" "get")), + mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" get)), ["", arr; "", c1; "", c2])) | [c1;c2;c3] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" "get")), + mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" get)), ["", arr; "", c1; "", c2; "", c3])) | coords -> mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "get")), ["", arr; "", ghexp(Pexp_array coords)])) let bigarray_set arr arg newval = + let set = if !Clflags.fast then "unsafe_set" else "set" in match bigarray_untuplify arg with [c1] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" "set")), + mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" set)), ["", arr; "", c1; "", newval])) | [c1;c2] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" "set")), + mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array2" set)), ["", arr; "", c1; "", c2; "", newval])) | [c1;c2;c3] -> - mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" "set")), + mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array3" set)), ["", arr; "", c1; "", c2; "", c3; "", newval])) | coords -> mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Genarray" "set")), @@ -675,12 +677,12 @@ class_type: { $1 } | QUESTION LIDENT COLON simple_core_type_or_tuple MINUSGREATER class_type { mkcty(Pcty_fun("?" ^ $2 , - {ptyp_desc = Ptyp_constr(Lident "option", [$4]); + {ptyp_desc = Ptyp_constr(Ldot (Lident "*predef*", "option"), [$4]); ptyp_loc = $4.ptyp_loc}, $6)) } | OPTLABEL simple_core_type_or_tuple MINUSGREATER class_type { mkcty(Pcty_fun("?" ^ $1 , - {ptyp_desc = Ptyp_constr(Lident "option", [$2]); + {ptyp_desc = Ptyp_constr(Ldot (Lident "*predef*", "option"), [$2]); ptyp_loc = $2.ptyp_loc}, $4)) } | LIDENT COLON simple_core_type_or_tuple MINUSGREATER class_type @@ -1077,6 +1079,8 @@ pattern: false)) } | pattern BAR pattern { mkpat(Ppat_or($1, $3)) } + | LAZY simple_pattern + { mkpat(Ppat_lazy $2) } ; simple_pattern: val_ident %prec below_EQUAL @@ -1147,10 +1151,11 @@ type_declarations: type_declaration: type_parameters LIDENT type_kind constraints { let (params, variance) = List.split $1 in - let (kind, manifest) = $3 in + let (kind, private_flag, manifest) = $3 in ($2, {ptype_params = params; ptype_cstrs = List.rev $4; ptype_kind = kind; + ptype_private = private_flag; ptype_manifest = manifest; ptype_variance = variance; ptype_loc = symbol_rloc()}) } @@ -1161,23 +1166,23 @@ constraints: ; type_kind: /*empty*/ - { (Ptype_abstract, None) } + { (Ptype_abstract, Public, None) } | EQUAL core_type - { (Ptype_abstract, Some $2) } + { (Ptype_abstract, Public, Some $2) } | EQUAL constructor_declarations - { (Ptype_variant(List.rev $2, Public), None) } + { (Ptype_variant(List.rev $2), Public, None) } | EQUAL PRIVATE constructor_declarations - { (Ptype_variant(List.rev $3, Private), None) } + { (Ptype_variant(List.rev $3), Private, None) } | EQUAL private_flag BAR constructor_declarations - { (Ptype_variant(List.rev $4, $2), None) } + { (Ptype_variant(List.rev $4), $2, None) } | EQUAL private_flag LBRACE label_declarations opt_semi RBRACE - { (Ptype_record(List.rev $4, $2), None) } + { (Ptype_record(List.rev $4), $2, None) } | EQUAL core_type EQUAL private_flag opt_bar constructor_declarations - { (Ptype_variant(List.rev $6, $4), Some $2) } + { (Ptype_variant(List.rev $6), $4, Some $2) } | EQUAL core_type EQUAL private_flag LBRACE label_declarations opt_semi RBRACE - { (Ptype_record(List.rev $6, $4), Some $2) } + { (Ptype_record(List.rev $6), $4, Some $2) } | EQUAL PRIVATE core_type - { (Ptype_private, Some $3) } + { (Ptype_abstract, Private, Some $3) } ; type_parameters: /*empty*/ { [] } @@ -1226,8 +1231,9 @@ with_constraint: { let params, variance = List.split $2 in ($3, Pwith_type {ptype_params = params; ptype_cstrs = List.rev $6; - ptype_kind = $4; + ptype_kind = Ptype_abstract; ptype_manifest = Some $5; + ptype_private = $4; ptype_variance = variance; ptype_loc = symbol_rloc()}) } /* used label_longident instead of type_longident to disallow @@ -1236,8 +1242,8 @@ with_constraint: { ($2, Pwith_module $4) } ; with_type_binder: - EQUAL { Ptype_abstract } - | EQUAL PRIVATE { Ptype_private } + EQUAL { Public } + | EQUAL PRIVATE { Private } ; /* Polymorphic types */ @@ -1266,11 +1272,11 @@ core_type2: { $1 } | QUESTION LIDENT COLON core_type2 MINUSGREATER core_type2 { mktyp(Ptyp_arrow("?" ^ $2 , - {ptyp_desc = Ptyp_constr(Lident "option", [$4]); + {ptyp_desc = Ptyp_constr(Ldot (Lident "*predef*", "option"), [$4]); ptyp_loc = $4.ptyp_loc}, $6)) } | OPTLABEL core_type2 MINUSGREATER core_type2 { mktyp(Ptyp_arrow("?" ^ $1 , - {ptyp_desc = Ptyp_constr(Lident "option", [$2]); + {ptyp_desc = Ptyp_constr(Ldot (Lident "*predef*", "option"), [$2]); ptyp_loc = $2.ptyp_loc}, $4)) } | LIDENT COLON core_type2 MINUSGREATER core_type2 { mktyp(Ptyp_arrow($1, $3, $5)) } diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 3d6c0c52..cad68268 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: parsetree.mli,v 1.43 2006/04/05 02:28:13 garrigue Exp $ *) +(* $Id: parsetree.mli,v 1.45 2008/07/09 13:03:37 mauny Exp $ *) (* Abstract syntax tree produced by parsing *) @@ -75,6 +75,7 @@ and pattern_desc = | Ppat_or of pattern * pattern | Ppat_constraint of pattern * core_type | Ppat_type of Longident.t + | Ppat_lazy of pattern type expression = { pexp_desc: expression_desc; @@ -124,16 +125,16 @@ and type_declaration = { ptype_params: string list; ptype_cstrs: (core_type * core_type * Location.t) list; ptype_kind: type_kind; + ptype_private: private_flag; ptype_manifest: core_type option; ptype_variance: (bool * bool) list; ptype_loc: Location.t } and type_kind = Ptype_abstract - | Ptype_variant of (string * core_type list * Location.t) list * private_flag + | Ptype_variant of (string * core_type list * Location.t) list | Ptype_record of - (string * mutable_flag * core_type * Location.t) list * private_flag - | Ptype_private + (string * mutable_flag * core_type * Location.t) list and exception_declaration = core_type list diff --git a/parsing/printast.ml b/parsing/printast.ml index 754e65df..181f91e1 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: printast.ml,v 1.30.8.1 2007/04/25 19:59:29 doligez Exp $ *) +(* $Id: printast.ml,v 1.34 2008/07/09 13:03:37 mauny Exp $ *) open Asttypes;; open Format;; @@ -186,12 +186,15 @@ and pattern i ppf x = line i ppf "Ppat_or\n"; pattern i ppf p1; pattern i ppf p2; + | Ppat_lazy p -> + line i ppf "Ppat_lazy\n"; + pattern i ppf p; | Ppat_constraint (p, ct) -> line i ppf "Ppat_constraint"; pattern i ppf p; core_type i ppf ct; | Ppat_type li -> - line i ppf "PPat_type"; + line i ppf "Ppat_type"; longident i ppf li and expression i ppf x = @@ -317,6 +320,7 @@ and type_declaration i ppf x = list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs; line i ppf "ptype_kind =\n"; type_kind (i+1) ppf x.ptype_kind; + line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private; line i ppf "ptype_manifest =\n"; option (i+1) core_type ppf x.ptype_manifest; @@ -324,14 +328,12 @@ and type_kind i ppf x = match x with | Ptype_abstract -> line i ppf "Ptype_abstract\n" - | Ptype_variant (l, priv) -> - line i ppf "Ptype_variant %a\n" fmt_private_flag priv; + | Ptype_variant l -> + line i ppf "Ptype_variant\n"; list (i+1) string_x_core_type_list_x_location ppf l; - | Ptype_record (l, priv) -> - line i ppf "Ptype_record %a\n" fmt_private_flag priv; + | Ptype_record l -> + line i ppf "Ptype_record\n"; list (i+1) string_x_mutable_flag_x_core_type_x_location ppf l; - | Ptype_private -> - line i ppf "Ptype_private\n" and exception_declaration i ppf x = list i core_type ppf x diff --git a/parsing/syntaxerr.ml b/parsing/syntaxerr.ml index 0a6f7173..c5617357 100644 --- a/parsing/syntaxerr.ml +++ b/parsing/syntaxerr.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: syntaxerr.ml,v 1.8 2002/04/18 08:50:43 garrigue Exp $ *) +(* $Id: syntaxerr.ml,v 1.9 2007/12/04 13:38:58 doligez Exp $ *) (* Auxiliary type for reporting syntax errors *) @@ -31,11 +31,9 @@ let report_error ppf = function the highlighted '%s' might be unmatched" closing opening else begin fprintf ppf "%aSyntax error: '%s' expected@." - Location.print closing_loc closing; + Location.print_error closing_loc closing; fprintf ppf "%aThis '%s' might be unmatched" - Location.print opening_loc opening + Location.print_error opening_loc opening end | Other loc -> - fprintf ppf "%aSyntax error" Location.print loc - - + fprintf ppf "%aSyntax error" Location.print_error loc diff --git a/stdlib/.depend b/stdlib/.depend index fe9f5ad1..faa33821 100644 --- a/stdlib/.depend +++ b/stdlib/.depend @@ -1,12 +1,46 @@ +arg.cmi: +array.cmi: +arrayLabels.cmi: +buffer.cmi: +callback.cmi: +camlinternalLazy.cmi: camlinternalMod.cmi: obj.cmi camlinternalOO.cmi: obj.cmi +char.cmi: +complex.cmi: +digest.cmi: +filename.cmi: format.cmi: buffer.cmi +gc.cmi: genlex.cmi: stream.cmi +hashtbl.cmi: +int32.cmi: +int64.cmi: +lazy.cmi: +lexing.cmi: +list.cmi: +listLabels.cmi: +map.cmi: +marshal.cmi: moreLabels.cmi: set.cmi map.cmi hashtbl.cmi +nativeint.cmi: +obj.cmi: oo.cmi: camlinternalOO.cmi parsing.cmi: obj.cmi lexing.cmi +pervasives.cmi: +printexc.cmi: printf.cmi: obj.cmi buffer.cmi +queue.cmi: random.cmi: nativeint.cmi int64.cmi int32.cmi +scanf.cmi: +set.cmi: +sort.cmi: +stack.cmi: +stdLabels.cmi: +stream.cmi: +string.cmi: +stringLabels.cmi: +sys.cmi: weak.cmi: hashtbl.cmi arg.cmo: sys.cmi string.cmi printf.cmi list.cmi buffer.cmi array.cmi arg.cmi arg.cmx: sys.cmx string.cmx printf.cmx list.cmx buffer.cmx array.cmx arg.cmi @@ -18,6 +52,8 @@ buffer.cmo: sys.cmi string.cmi buffer.cmi buffer.cmx: sys.cmx string.cmx buffer.cmi callback.cmo: obj.cmi callback.cmi callback.cmx: obj.cmx callback.cmi +camlinternalLazy.cmo: obj.cmi camlinternalLazy.cmi +camlinternalLazy.cmx: obj.cmx camlinternalLazy.cmi camlinternalMod.cmo: obj.cmi camlinternalOO.cmi array.cmi camlinternalMod.cmi camlinternalMod.cmx: obj.cmx camlinternalOO.cmx array.cmx camlinternalMod.cmi camlinternalOO.cmo: sys.cmi string.cmi obj.cmi map.cmi list.cmi char.cmi \ @@ -46,8 +82,8 @@ int32.cmo: pervasives.cmi int32.cmi int32.cmx: pervasives.cmx int32.cmi int64.cmo: pervasives.cmi int64.cmi int64.cmx: pervasives.cmx int64.cmi -lazy.cmo: obj.cmi lazy.cmi -lazy.cmx: obj.cmx lazy.cmi +lazy.cmo: obj.cmi camlinternalLazy.cmi lazy.cmi +lazy.cmx: obj.cmx camlinternalLazy.cmx lazy.cmi lexing.cmo: sys.cmi string.cmi array.cmi lexing.cmi lexing.cmx: sys.cmx string.cmx array.cmx lexing.cmi list.cmo: list.cmi @@ -70,8 +106,8 @@ parsing.cmo: obj.cmi lexing.cmi array.cmi parsing.cmi parsing.cmx: obj.cmx lexing.cmx array.cmx parsing.cmi pervasives.cmo: pervasives.cmi pervasives.cmx: pervasives.cmi -printexc.cmo: printf.cmi obj.cmi printexc.cmi -printexc.cmx: printf.cmx obj.cmx printexc.cmi +printexc.cmo: printf.cmi obj.cmi buffer.cmi array.cmi printexc.cmi +printexc.cmx: printf.cmx obj.cmx buffer.cmx array.cmx printexc.cmi printf.cmo: string.cmi 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 \ @@ -94,8 +130,10 @@ stack.cmo: list.cmi stack.cmi stack.cmx: list.cmx stack.cmi stdLabels.cmo: stringLabels.cmi listLabels.cmi arrayLabels.cmi stdLabels.cmi stdLabels.cmx: stringLabels.cmx listLabels.cmx arrayLabels.cmx stdLabels.cmi -stream.cmo: string.cmi obj.cmi list.cmi stream.cmi -stream.cmx: string.cmx obj.cmx list.cmx stream.cmi +std_exit.cmo: +std_exit.cmx: +stream.cmo: string.cmi obj.cmi list.cmi lazy.cmi stream.cmi +stream.cmx: string.cmx obj.cmx list.cmx lazy.cmx stream.cmi string.cmo: pervasives.cmi list.cmi char.cmi string.cmi string.cmx: pervasives.cmx list.cmx char.cmx string.cmi stringLabels.cmo: string.cmi stringLabels.cmi diff --git a/stdlib/Makefile b/stdlib/Makefile index 905df33e..502905c6 100644 --- a/stdlib/Makefile +++ b/stdlib/Makefile @@ -11,34 +11,9 @@ # # ######################################################################### -# $Id: Makefile,v 1.88 2007/02/09 13:24:20 doligez Exp $ +# $Id: Makefile,v 1.91 2008/07/24 05:18:31 frisch Exp $ -include ../config/Makefile - -RUNTIME=../boot/ocamlrun -COMPILER=../ocamlc -CAMLC=$(RUNTIME) $(COMPILER) -COMPFLAGS=-g -warn-error A -nostdlib -OPTCOMPILER=../ocamlopt -CAMLOPT=$(RUNTIME) $(OPTCOMPILER) -OPTCOMPFLAGS=-warn-error A -nostdlib -g -CAMLDEP=../boot/ocamlrun ../tools/ocamldep - -OBJS=pervasives.cmo $(OTHERS) -OTHERS=array.cmo list.cmo char.cmo string.cmo sys.cmo \ - hashtbl.cmo sort.cmo marshal.cmo obj.cmo \ - int32.cmo int64.cmo nativeint.cmo \ - lexing.cmo parsing.cmo \ - set.cmo map.cmo stack.cmo queue.cmo stream.cmo buffer.cmo \ - printf.cmo format.cmo scanf.cmo \ - arg.cmo printexc.cmo gc.cmo \ - digest.cmo random.cmo callback.cmo \ - camlinternalOO.cmo oo.cmo camlinternalMod.cmo \ - genlex.cmo weak.cmo \ - lazy.cmo filename.cmo complex.cmo \ - arrayLabels.cmo listLabels.cmo stringLabels.cmo moreLabels.cmo stdLabels.cmo - -all: stdlib.cma std_exit.cmo camlheader camlheader_ur +include Makefile.shared allopt: stdlib.cmxa std_exit.cmx allopt-$(PROFILING) @@ -47,10 +22,6 @@ allopt-noprof: allopt-prof: stdlib.p.cmxa std_exit.p.cmx rm -f std_exit.p.cmi -install: - cp stdlib.cma std_exit.cmo *.cmi *.mli *.ml camlheader camlheader_ur \ - $(LIBDIR) - installopt: installopt-default installopt-$(PROFILING) installopt-default: @@ -68,12 +39,6 @@ installopt-prof: cp stdlib.p.cmxa stdlib.p.a std_exit.p.cmx std_exit.p.o $(LIBDIR) cd $(LIBDIR); $(RANLIB) stdlib.p.a -stdlib.cma: $(OBJS) - $(CAMLC) -a -o stdlib.cma $(OBJS) - -stdlib.cmxa: $(OBJS:.cmo=.cmx) - $(CAMLOPT) -a -o stdlib.cmxa $(OBJS:.cmo=.cmx) - stdlib.p.cmxa: $(OBJS:.cmo=.p.cmx) $(CAMLOPT) -a -o stdlib.p.cmxa $(OBJS:.cmo=.p.cmx) @@ -90,48 +55,5 @@ 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 - -.SUFFIXES: .mli .ml .cmi .cmo .cmx .p.cmx - -.mli.cmi: - $(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $< - -.ml.cmo: - $(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $< - -.ml.cmx: - $(CAMLOPT) $(OPTCOMPFLAGS) `./Compflags $@` -c $< - -.ml.p.cmx: - $(CAMLOPT) $(OPTCOMPFLAGS) `./Compflags $@` -p -c -o $*.p.cmx $< - -# Dependencies on the compiler -$(OBJS) std_exit.cmo: $(COMPILER) -$(OBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER) -$(OBJS:.cmo=.cmx) std_exit.cmx: $(OPTCOMPILER) -$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: $(OPTCOMPILER) - -# Dependencies on Pervasives (not tracked by ocamldep) -$(OBJS) std_exit.cmo: pervasives.cmi -$(OTHERS:.cmo=.cmi) std_exit.cmi: pervasives.cmi -$(OBJS:.cmo=.cmx) std_exit.cmx: pervasives.cmi -$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmi -$(OTHERS:.cmo=.cmx) std_exit.cmx: pervasives.cmx -$(OTHERS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmx - -clean:: - rm -f *.cm* *.o *.a - rm -f *~ - -include .depend - -depend: - $(CAMLDEP) *.mli *.ml > .depend +.PHONY: all allopt allopt-noprof allopt-prof install installopt +.PHONY: installopt-default installopt-noprof installopt-prof clean depend diff --git a/stdlib/Makefile.nt b/stdlib/Makefile.nt index 0022f050..a586e770 100644 --- a/stdlib/Makefile.nt +++ b/stdlib/Makefile.nt @@ -11,94 +11,22 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.43 2007/02/23 12:42:42 doligez Exp $ +# $Id: Makefile.nt,v 1.46 2008/07/24 05:18:31 frisch Exp $ -include ../config/Makefile - -RUNTIME=../boot/ocamlrun -COMPILER=../ocamlc -CAMLC=$(RUNTIME) $(COMPILER) -COMPFLAGS=-warn-error A -nostdlib -OPTCOMPILER=../ocamlopt -CAMLOPT=$(RUNTIME) $(OPTCOMPILER) -OPTCOMPFLAGS=-warn-error A -nostdlib -g -CAMLDEP=../boot/ocamlrun ../tools/ocamldep - -OBJS=pervasives.cmo $(OTHERS) -OTHERS=array.cmo list.cmo char.cmo string.cmo sys.cmo \ - hashtbl.cmo sort.cmo marshal.cmo obj.cmo \ - int32.cmo int64.cmo nativeint.cmo \ - lexing.cmo parsing.cmo \ - set.cmo map.cmo stack.cmo queue.cmo stream.cmo buffer.cmo \ - printf.cmo format.cmo scanf.cmo \ - arg.cmo printexc.cmo gc.cmo \ - digest.cmo random.cmo callback.cmo \ - camlinternalOO.cmo oo.cmo camlinternalMod.cmo \ - genlex.cmo weak.cmo \ - lazy.cmo filename.cmo complex.cmo \ - arrayLabels.cmo listLabels.cmo stringLabels.cmo moreLabels.cmo stdLabels.cmo - -all: stdlib.cma std_exit.cmo camlheader camlheader_ur +include Makefile.shared allopt: stdlib.cmxa std_exit.cmx -install: - cp stdlib.cma std_exit.cmo *.cmi *.mli *.ml camlheader camlheader_ur $(LIBDIR) - installopt: cp stdlib.cmxa stdlib.$(A) std_exit.$(O) *.cmx $(LIBDIR) -stdlib.cma: $(OBJS) - $(CAMLC) -a -o stdlib.cma $(OBJS) - -stdlib.cmxa: $(OBJS:.cmo=.cmx) - $(CAMLOPT) -a -o stdlib.cmxa $(OBJS:.cmo=.cmx) - camlheader camlheader_ur: headernt.c ../config/Makefile - $(call MKEXE,tmpheader.exe,-I../byterun $(BYTECCCOMPOPTS) $(BYTECCLINKOPTS) headernt.c $(EXTRALIBS)) + $(BYTECC) $(BYTECCCOMPOPTS) -c -I../byterun headernt.c + $(MKEXE) -o tmpheader.exe headernt.$(O) $(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 - -.SUFFIXES: .mli .ml .cmi .cmo .cmx - -.mli.cmi: - $(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $< - -.ml.cmo: - $(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $< - -.ml.cmx: - $(CAMLOPT) $(OPTCOMPFLAGS) `./Compflags $@` -c $< - -# Dependencies on the compiler -$(OBJS) std_exit.cmo: $(COMPILER) -$(OBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER) -$(OBJS:.cmo=.cmx) std_exit.cmx: $(OPTCOMPILER) -$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: $(OPTCOMPILER) - -# Dependencies on Pervasives (not tracked by ocamldep) -$(OBJS) std_exit.cmo: pervasives.cmi -$(OTHERS:.cmo=.cmi) std_exit.cmi: pervasives.cmi -$(OBJS:.cmo=.cmx) std_exit.cmx: pervasives.cmi -$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmi -$(OTHERS:.cmo=.cmx) std_exit.cmx: pervasives.cmx -$(OTHERS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmx - -clean:: - rm -f *.cm* *.$(O) *.$(A) - rm -f *~ - -include .depend +# TODO: do not call flexlink to build tmpheader.exe (we don't need +# the export table) -depend: beforedepend - $(CAMLDEP) *.mli *.ml > .depend diff --git a/stdlib/Makefile.shared b/stdlib/Makefile.shared new file mode 100755 index 00000000..d214c49a --- /dev/null +++ b/stdlib/Makefile.shared @@ -0,0 +1,96 @@ +######################################################################### +# # +# 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.shared,v 1.2 2008/08/01 16:57:10 mauny Exp $ + +include ../config/Makefile +RUNTIME=../boot/ocamlrun +COMPILER=../ocamlc +CAMLC=$(RUNTIME) $(COMPILER) +COMPFLAGS=-g -warn-error A -nostdlib +OPTCOMPILER=../ocamlopt +CAMLOPT=$(RUNTIME) $(OPTCOMPILER) +OPTCOMPFLAGS=-warn-error A -nostdlib -g +CAMLDEP=../boot/ocamlrun ../tools/ocamldep + +OBJS=pervasives.cmo $(OTHERS) +OTHERS=array.cmo list.cmo char.cmo string.cmo sys.cmo \ + hashtbl.cmo sort.cmo marshal.cmo obj.cmo \ + int32.cmo int64.cmo nativeint.cmo \ + lexing.cmo parsing.cmo \ + set.cmo map.cmo stack.cmo queue.cmo \ + camlinternalLazy.cmo lazy.cmo stream.cmo \ + buffer.cmo printf.cmo format.cmo scanf.cmo \ + arg.cmo printexc.cmo gc.cmo \ + digest.cmo random.cmo callback.cmo \ + camlinternalOO.cmo oo.cmo camlinternalMod.cmo \ + genlex.cmo weak.cmo \ + filename.cmo complex.cmo \ + arrayLabels.cmo listLabels.cmo stringLabels.cmo moreLabels.cmo stdLabels.cmo + +all: stdlib.cma std_exit.cmo camlheader camlheader_ur + +install: + cp stdlib.cma std_exit.cmo *.cmi *.mli *.ml camlheader camlheader_ur $(LIBDIR) + +stdlib.cma: $(OBJS) + $(CAMLC) -a -o stdlib.cma $(OBJS) + +stdlib.cmxa: $(OBJS:.cmo=.cmx) + $(CAMLOPT) -a -o stdlib.cmxa $(OBJS:.cmo=.cmx) + +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 + +.SUFFIXES: .mli .ml .cmi .cmo .cmx .p.cmx + +.mli.cmi: + $(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $< + +.ml.cmo: + $(CAMLC) $(COMPFLAGS) `./Compflags $@` -c $< + +.ml.cmx: + $(CAMLOPT) $(OPTCOMPFLAGS) `./Compflags $@` -c $< + +.ml.p.cmx: + $(CAMLOPT) $(OPTCOMPFLAGS) `./Compflags $@` -p -c -o $*.p.cmx $< + +# Dependencies on the compiler +$(OBJS) std_exit.cmo: $(COMPILER) +$(OBJS:.cmo=.cmi) std_exit.cmi: $(COMPILER) +$(OBJS:.cmo=.cmx) std_exit.cmx: $(OPTCOMPILER) +$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: $(OPTCOMPILER) + +# Dependencies on Pervasives (not tracked by ocamldep) +$(OBJS) std_exit.cmo: pervasives.cmi +$(OTHERS:.cmo=.cmi) std_exit.cmi: pervasives.cmi +$(OBJS:.cmo=.cmx) std_exit.cmx: pervasives.cmi +$(OBJS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmi +$(OTHERS:.cmo=.cmx) std_exit.cmx: pervasives.cmx +$(OTHERS:.cmo=.p.cmx) std_exit.p.cmx: pervasives.cmx + +clean:: + rm -f *.cm* *.$(O) *.$(A) + rm -f *~ + +include .depend + +depend: + $(CAMLDEP) *.mli *.ml > .depend diff --git a/stdlib/StdlibModules b/stdlib/StdlibModules index c6cd6813..498dcc28 100644 --- a/stdlib/StdlibModules +++ b/stdlib/StdlibModules @@ -1,6 +1,6 @@ # This file lists all standard library modules. -*- Makefile -*- # It is used in particular to know what to expunge in toplevels. -# $Id: StdlibModules,v 1.3 2004/08/12 12:57:00 xleroy Exp $ +# $Id: StdlibModules,v 1.4 2008/08/01 16:57:10 mauny Exp $ STDLIB_MODULES=\ arg \ @@ -8,6 +8,7 @@ STDLIB_MODULES=\ arrayLabels \ buffer \ callback \ + camlinternalLazy \ camlinternalMod \ camlinternalOO \ char \ diff --git a/stdlib/arg.ml b/stdlib/arg.ml index 3b74ab31..71706281 100644 --- a/stdlib/arg.ml +++ b/stdlib/arg.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: arg.ml,v 1.35.12.2 2007/11/26 16:12:31 doligez Exp $ *) +(* $Id: arg.ml,v 1.36 2008/01/11 16:13:16 doligez Exp $ *) type key = string type doc = string diff --git a/stdlib/arg.mli b/stdlib/arg.mli index 2e798540..f4687e74 100644 --- a/stdlib/arg.mli +++ b/stdlib/arg.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: arg.mli,v 1.36.10.1 2007/11/20 18:24:24 doligez Exp $ *) +(* $Id: arg.mli,v 1.37 2008/01/11 16:13:16 doligez Exp $ *) (** Parsing of command line arguments. diff --git a/stdlib/buffer.ml b/stdlib/buffer.ml index 59eb4273..666f563e 100644 --- a/stdlib/buffer.ml +++ b/stdlib/buffer.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: buffer.ml,v 1.18 2005/10/25 18:34:07 doligez Exp $ *) +(* $Id: buffer.ml,v 1.19 2008/09/09 08:50:39 weis Exp $ *) (* Extensible buffers *) @@ -126,12 +126,13 @@ let advance_to_non_alpha s start = 'î'|'ô'|'û'|'ë'|'ï'|'ü'|'ç'| 'É'|'À'|'Á'|'È'|'Ù'|'Â'|'Ê'| 'Î'|'Ô'|'Û'|'Ë'|'Ï'|'Ü'|'Ç' -> - advance (i + 1) lim + advance (i + 1) lim | _ -> i in advance start (String.length s);; (* We are just at the beginning of an ident in s, starting at start. *) -let find_ident s start = +let find_ident s start lim = + if start >= lim then raise Not_found else match s.[start] with (* Parenthesized ident ? *) | '(' | '{' as c -> @@ -152,19 +153,21 @@ let add_substitute b f s = match s.[i] with | '$' as current when previous = '\\' -> add_char b current; - subst current (i + 1) + subst ' ' (i + 1) | '$' -> - let ident, next_i = find_ident s (i + 1) in + let j = i + 1 in + let ident, next_i = find_ident s j lim in add_string b (f ident); subst ' ' next_i | current when previous == '\\' -> add_char b '\\'; add_char b current; - subst current (i + 1) + subst ' ' (i + 1) | '\\' as current -> subst current (i + 1) | current -> add_char b current; subst current (i + 1) - end in + end else + if previous = '\\' then add_char b previous in subst ' ' 0;; diff --git a/stdlib/camlinternalLazy.ml b/stdlib/camlinternalLazy.ml new file mode 100644 index 00000000..2cd2ff64 --- /dev/null +++ b/stdlib/camlinternalLazy.ml @@ -0,0 +1,64 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Damien Doligez, projet Para, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id: camlinternalLazy.ml,v 1.1 2008/08/01 16:57:10 mauny Exp $ *) + +(* Internals of forcing lazy values. *) + +exception Undefined;; + +let raise_undefined = Obj.repr (fun () -> raise Undefined);; + +(* Assume [blk] is a block with tag lazy *) +let force_lazy_block (blk : 'arg lazy_t) = + let closure = (Obj.obj (Obj.field (Obj.repr blk) 0) : unit -> 'arg) in + Obj.set_field (Obj.repr blk) 0 raise_undefined; + try + let result = closure () in + Obj.set_field (Obj.repr blk) 0 (Obj.repr result); (* do set_field BEFORE set_tag *) + Obj.set_tag (Obj.repr blk) Obj.forward_tag; + result + with e -> + Obj.set_field (Obj.repr blk) 0 (Obj.repr (fun () -> raise e)); + raise e +;; + +(* Assume [blk] is a block with tag lazy *) +let force_val_lazy_block (blk : 'arg lazy_t) = + let closure = (Obj.obj (Obj.field (Obj.repr blk) 0) : unit -> 'arg) in + Obj.set_field (Obj.repr blk) 0 raise_undefined; + let result = closure () in + Obj.set_field (Obj.repr blk) 0 (Obj.repr result); (* do set_field BEFORE set_tag *) + Obj.set_tag (Obj.repr blk) (Obj.forward_tag); + result +;; + +(* [force] is not used, since [Lazy.force] is declared as a primitive + whose code inlines the tag tests of its argument. This function is + here for the sake of completeness, and for debugging purpose. *) + +let force (lzv : 'arg lazy_t) = + let x = Obj.repr lzv in + let t = Obj.tag x in + if t = Obj.forward_tag then (Obj.obj (Obj.field x 0) : 'arg) else + if t <> Obj.lazy_tag then (Obj.obj x : 'arg) + else force_lazy_block lzv +;; + +let force_val (lzv : 'arg lazy_t) = + let x = Obj.repr lzv in + let t = Obj.tag x in + if t = Obj.forward_tag then (Obj.obj (Obj.field x 0) : 'arg) else + if t <> Obj.lazy_tag then (Obj.obj x : 'arg) + else force_val_lazy_block lzv +;; diff --git a/stdlib/camlinternalLazy.mli b/stdlib/camlinternalLazy.mli new file mode 100644 index 00000000..31c260fa --- /dev/null +++ b/stdlib/camlinternalLazy.mli @@ -0,0 +1,25 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Damien Doligez, projet Para, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id: camlinternalLazy.mli,v 1.1 2008/08/01 16:57:10 mauny Exp $ *) + +(* Internals of forcing lazy values *) + +exception Undefined;; + +val force_lazy_block : 'a lazy_t -> 'a ;; + +val force_val_lazy_block : 'a lazy_t -> 'a ;; + +val force : 'a lazy_t -> 'a ;; +val force_val : 'a lazy_t -> 'a ;; diff --git a/stdlib/camlinternalMod.ml b/stdlib/camlinternalMod.ml index 6d8e0f3e..f9ba7c8e 100644 --- a/stdlib/camlinternalMod.ml +++ b/stdlib/camlinternalMod.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: camlinternalMod.ml,v 1.5.6.2 2007/10/26 15:39:04 xleroy Exp $ *) +(* $Id: camlinternalMod.ml,v 1.6 2008/01/11 16:13:16 doligez Exp $ *) type shape = | Function diff --git a/stdlib/camlinternalOO.ml b/stdlib/camlinternalOO.ml index 0fc77626..b48b59ed 100644 --- a/stdlib/camlinternalOO.ml +++ b/stdlib/camlinternalOO.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: camlinternalOO.ml,v 1.15.6.1 2007/10/29 03:11:03 garrigue Exp $ *) +(* $Id: camlinternalOO.ml,v 1.16 2008/01/11 16:13:16 doligez Exp $ *) open Obj diff --git a/stdlib/char.ml b/stdlib/char.ml index 1826d3f6..91e8cac3 100644 --- a/stdlib/char.ml +++ b/stdlib/char.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: char.ml,v 1.13 2005/05/19 15:30:35 habouzit Exp $ *) +(* $Id: char.ml,v 1.14 2007/04/16 11:06:51 weis Exp $ *) (* Character operations *) @@ -29,23 +29,26 @@ external string_unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" let escaped = function - '\'' -> "\\'" + | '\'' -> "\\'" | '\\' -> "\\\\" | '\n' -> "\\n" | '\t' -> "\\t" - | c -> if is_printable c then begin - let s = string_create 1 in - string_unsafe_set s 0 c; - s - end else begin - let n = code c in - let s = string_create 4 in - string_unsafe_set s 0 '\\'; - string_unsafe_set s 1 (unsafe_chr (48 + n / 100)); - string_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10)); - string_unsafe_set s 3 (unsafe_chr (48 + n mod 10)); - s - end + | '\r' -> "\\r" + | '\b' -> "\\b" + | c -> + if is_printable c then begin + let s = string_create 1 in + string_unsafe_set s 0 c; + s + end else begin + let n = code c in + let s = string_create 4 in + string_unsafe_set s 0 '\\'; + string_unsafe_set s 1 (unsafe_chr (48 + n / 100)); + string_unsafe_set s 2 (unsafe_chr (48 + (n / 10) mod 10)); + string_unsafe_set s 3 (unsafe_chr (48 + n mod 10)); + s + end let lowercase c = if (c >= 'A' && c <= 'Z') diff --git a/stdlib/format.ml b/stdlib/format.ml index b424c03f..6f4128c5 100644 --- a/stdlib/format.ml +++ b/stdlib/format.ml @@ -11,7 +11,10 @@ (* *) (***********************************************************************) -(* $Id: format.ml,v 1.70.6.1 2007/12/18 09:19:52 weis Exp $ *) +(* $Id: format.ml,v 1.74 2008/09/08 12:30:19 weis Exp $ *) + +(* A pretty-printing facility and definition of formatters for ``parallel'' + (i.e. unrelated or independent) pretty-printing on multiple out channels. *) (************************************************************** @@ -21,8 +24,10 @@ type size;; -external size_of_int : int -> size = "%identity";; -external int_of_size : size -> int = "%identity";; +external size_of_int : int -> size = "%identity" +;; +external int_of_size : size -> int = "%identity" +;; (* Tokens are one of the following : *) @@ -67,7 +72,8 @@ type pp_queue_elem = { mutable elem_size : size; token : pp_token; length : int; -};; +} +;; (* Scan stack: each element is (left_total, queue element) where left_total @@ -88,12 +94,14 @@ type 'a queue_elem = and 'a queue_cell = { mutable head : 'a; mutable tail : 'a queue_elem; -};; +} +;; type 'a queue = { mutable insert : 'a queue_elem; mutable body : 'a queue_elem; -};; +} +;; (* The formatter specific tag handling functions. *) type formatter_tag_functions = { @@ -101,7 +109,8 @@ type formatter_tag_functions = { mark_close_tag : tag -> string; print_open_tag : tag -> unit; print_close_tag : tag -> unit; -};; +} +;; (* A formatter with all its machinery. *) type formatter = { @@ -155,7 +164,8 @@ type formatter = { mutable pp_print_close_tag : tag -> unit; (* The pretty-printer queue. *) mutable pp_queue : pp_queue_elem queue; -};; +} +;; (************************************************************** @@ -181,23 +191,27 @@ exception Empty_queue;; let peek_queue = function | { body = Cons { head = x; }; } -> x - | _ -> raise Empty_queue;; + | _ -> raise Empty_queue +;; let take_queue = function | { body = Cons { head = x; tail = tl; }; } as q -> q.body <- tl; if tl = Nil then q.insert <- Nil; (* Maintain the invariant. *) x - | _ -> raise Empty_queue;; + | _ -> raise Empty_queue +;; (* Enter a token in the pretty-printer queue. *) let pp_enqueue state ({length = len} as token) = state.pp_right_total <- state.pp_right_total + len; - add_queue token state.pp_queue;; + add_queue token state.pp_queue +;; let pp_clear_queue state = state.pp_left_total <- 1; state.pp_right_total <- 1; - clear_queue state.pp_queue;; + clear_queue state.pp_queue +;; (* Pp_infinity: large value for default tokens size. @@ -217,7 +231,7 @@ let pp_clear_queue state = pretty-printing algorithm's invariants. Given that this arithmetic correctness check is difficult and error prone and given that 1e10 + 1 is in practice large enough, there is no need to attempt to set - pp_infinity to the theoretically maximum limit. Is it not worth the + pp_infinity to the theoretically maximum limit. It is not worth the burden ! *) let pp_infinity = 1000000010;; @@ -237,7 +251,8 @@ let break_new_line state offset width = let real_indent = min state.pp_max_indent indent in state.pp_current_indent <- real_indent; state.pp_space_left <- state.pp_margin - state.pp_current_indent; - pp_display_blanks state state.pp_current_indent;; + pp_display_blanks state state.pp_current_indent +;; (* To force a line break inside a block: no offset is added. *) let break_line state width = break_new_line state 0 width;; @@ -245,7 +260,8 @@ let break_line state width = break_new_line state 0 width;; (* To format a break that fits on the current line. *) let break_same_line state width = state.pp_space_left <- state.pp_space_left - width; - pp_display_blanks state width;; + pp_display_blanks state width +;; (* To indent no more than pp_max_indent, if one tries to open a block beyond pp_max_indent, then the block is rejected on the left @@ -257,7 +273,8 @@ let pp_force_break_line state = (match bl_ty with | Pp_fits -> () | Pp_hbox -> () | _ -> break_line state width) - | _ -> pp_output_newline state;; + | _ -> pp_output_newline state +;; (* To skip a token, if the previous line has been broken. *) let pp_skip_token state = @@ -265,11 +282,12 @@ let pp_skip_token state = match take_queue state.pp_queue with | { elem_size = size; length = len; } -> state.pp_left_total <- state.pp_left_total - len; - state.pp_space_left <- state.pp_space_left + int_of_size size;; + state.pp_space_left <- state.pp_space_left + int_of_size size +;; (************************************************************** - The main pretting printing functions. + The main pretty printing functions. **************************************************************) @@ -395,23 +413,28 @@ let format_pp_token state size = function (* Print if token size is known or printing is delayed. Size is known when not negative. Printing is delayed when the text waiting in the queue requires - more room to format than exists on the current line. *) -let rec advance_left state = - try - match peek_queue state.pp_queue with - | { elem_size = size; token = tok; length = len; } -> - let size = int_of_size size in - if not - (size < 0 && - (state.pp_right_total - state.pp_left_total < - state.pp_space_left)) then - begin - ignore(take_queue state.pp_queue); - format_pp_token state (if size < 0 then pp_infinity else size) tok; - state.pp_left_total <- len + state.pp_left_total; - advance_left state - end with - | Empty_queue -> ();; + more room to format than exists on the current line. + + Note: [advance_loop] must be tail recursive to prevent stack overflows. *) +let rec advance_loop state = + match peek_queue state.pp_queue with + | {elem_size = size; token = tok; length = len} -> + let size = int_of_size size in + if not + (size < 0 && + (state.pp_right_total - state.pp_left_total < state.pp_space_left)) + then begin + ignore (take_queue state.pp_queue); + format_pp_token state (if size < 0 then pp_infinity else size) tok; + state.pp_left_total <- len + state.pp_left_total; + advance_loop state + end +;; + +let advance_left state = + try advance_loop state with + | Empty_queue -> () +;; let enqueue_advance state tok = pp_enqueue state tok; advance_left state;; @@ -421,11 +444,13 @@ let make_queue_elem size tok len = let enqueue_string_as state size s = let len = int_of_size size in - enqueue_advance state (make_queue_elem size (Pp_text s) len);; + enqueue_advance state (make_queue_elem size (Pp_text s) len) +;; let enqueue_string state s = let len = String.length s in - enqueue_string_as state (size_of_int len) s;; + enqueue_string_as state (size_of_int len) s +;; (* Routines for scan stack determine sizes of blocks. *) @@ -433,7 +458,8 @@ let enqueue_string state s = (* The scan_stack is never empty. *) let scan_stack_bottom = let q_elem = make_queue_elem (size_of_int (-1)) (Pp_text "") 0 in - [Scan_elem (-1, q_elem)];; + [Scan_elem (-1, q_elem)] +;; (* Set size of blocks on scan stack: if ty = true then size of break is set else size of block is set; @@ -467,14 +493,16 @@ let set_size state ty = end | _ -> () (* scan_push is only used for breaks and boxes. *) end - | _ -> () (* scan_stack is never empty. *);; + | _ -> () (* scan_stack is never empty. *) +;; (* Push a token on scan stack. If b is true set_size is called. *) let scan_push state b tok = pp_enqueue state tok; if b then set_size state true; state.pp_scan_stack <- - Scan_elem (state.pp_right_total, tok) :: state.pp_scan_stack;; + Scan_elem (state.pp_right_total, tok) :: state.pp_scan_stack +;; (* To open a new block : the user may set the depth bound pp_max_boxes @@ -489,12 +517,13 @@ let pp_open_box_gen state indent br_ty = 0 in scan_push state false elem else if state.pp_curr_depth = state.pp_max_boxes - then enqueue_string state state.pp_ellipsis;; + then enqueue_string state state.pp_ellipsis +;; (* The box which is always opened. *) let pp_open_sys_box state = pp_open_box_gen state 0 Pp_hovbox;; -(* Close a block, setting sizes of its subblocks. *) +(* Close a block, setting sizes of its sub blocks. *) let pp_close_box state () = if state.pp_curr_depth > 1 then begin @@ -505,7 +534,8 @@ let pp_close_box state () = set_size state true; set_size state false end; state.pp_curr_depth <- state.pp_curr_depth - 1; - end;; + end +;; (* Open a tag, pushing it on the tag stack. *) let pp_open_tag state tag_name = @@ -537,7 +567,8 @@ let pp_close_tag state () = state.pp_print_close_tag tag_name; state.pp_tag_stack <- tags | _ -> () (* No more tag to close. *) - end;; + end +;; let pp_set_print_tags state b = state.pp_print_tags <- b;; let pp_set_mark_tags state b = state.pp_mark_tags <- b;; @@ -550,7 +581,8 @@ let pp_get_formatter_tag_functions state () = { mark_close_tag = state.pp_mark_close_tag; print_open_tag = state.pp_print_open_tag; print_close_tag = state.pp_print_close_tag; -};; +} +;; let pp_set_formatter_tag_functions state { mark_open_tag = mot; @@ -561,7 +593,8 @@ let pp_set_formatter_tag_functions state { state.pp_mark_open_tag <- mot; state.pp_mark_close_tag <- mct; state.pp_print_open_tag <- pot; - state.pp_print_close_tag <- pct;; + state.pp_print_close_tag <- pct +;; (* Initialize pretty-printer. *) let pp_rinit state = @@ -584,7 +617,8 @@ let pp_flush_queue state b = state.pp_right_total <- pp_infinity; advance_left state; if b then pp_output_newline state; - pp_rinit state;; + pp_rinit state +;; (************************************************************** @@ -595,13 +629,16 @@ let pp_flush_queue state b = (* To format a string. *) let pp_print_as_size state size s = if state.pp_curr_depth < state.pp_max_boxes - then enqueue_string_as state size s;; + then enqueue_string_as state size s +;; let pp_print_as state isize s = - pp_print_as_size state (size_of_int isize) s;; + pp_print_as_size state (size_of_int isize) s +;; let pp_print_string state s = - pp_print_as state (String.length s) s;; + pp_print_as state (String.length s) s +;; (* To format an integer. *) let pp_print_int state i = pp_print_string state (string_of_int i);; @@ -616,7 +653,8 @@ let pp_print_bool state b = pp_print_string state (string_of_bool b);; let pp_print_char state c = let s = String.create 1 in s.[0] <- c; - pp_print_as state 1 s;; + pp_print_as state 1 s +;; (* Opening boxes. *) let pp_open_hbox state () = pp_open_box_gen state 0 Pp_hbox @@ -636,12 +674,14 @@ and pp_print_flush state () = (* To get a newline when one does not want to close the current block. *) let pp_force_newline state () = if state.pp_curr_depth < state.pp_max_boxes then - enqueue_advance state (make_queue_elem (size_of_int 0) Pp_newline 0);; + enqueue_advance state (make_queue_elem (size_of_int 0) Pp_newline 0) +;; (* To format something if the line has just been broken. *) let pp_print_if_newline state () = if state.pp_curr_depth < state.pp_max_boxes then - enqueue_advance state (make_queue_elem (size_of_int 0) Pp_if_newline 0);; + enqueue_advance state (make_queue_elem (size_of_int 0) Pp_if_newline 0) +;; (* Breaks: indicate where a block may be broken. If line is broken then offset is added to the indentation of the current @@ -654,10 +694,12 @@ let pp_print_break state width offset = (size_of_int (- state.pp_right_total)) (Pp_break (width, offset)) width in - scan_push state true elem;; + scan_push state true elem +;; let pp_print_space state () = pp_print_break state 1 0 -and pp_print_cut state () = pp_print_break state 0 0;; +and pp_print_cut state () = pp_print_break state 0 0 +;; (* Tabulation boxes. *) let pp_open_tbox state () = @@ -665,7 +707,8 @@ let pp_open_tbox state () = if state.pp_curr_depth < state.pp_max_boxes then let elem = make_queue_elem (size_of_int 0) (Pp_tbegin (Pp_tbox (ref []))) 0 in - enqueue_advance state elem;; + enqueue_advance state elem +;; (* Close a tabulation block. *) let pp_close_tbox state () = @@ -675,7 +718,8 @@ let pp_close_tbox state () = let elem = make_queue_elem (size_of_int 0) Pp_tend 0 in enqueue_advance state elem; state.pp_curr_depth <- state.pp_curr_depth - 1 - end;; + end +;; (* Print a tabulation break. *) let pp_print_tbreak state width offset = @@ -685,7 +729,8 @@ let pp_print_tbreak state width offset = (size_of_int (- state.pp_right_total)) (Pp_tbreak (width, offset)) width in - scan_push state true elem;; + scan_push state true elem +;; let pp_print_tab state () = pp_print_tbreak state 0 0;; @@ -693,7 +738,8 @@ let pp_set_tab state () = if state.pp_curr_depth < state.pp_max_boxes then let elem = make_queue_elem (size_of_int 0) Pp_stab 0 in - enqueue_advance state elem;; + enqueue_advance state elem +;; (************************************************************** @@ -711,24 +757,28 @@ let pp_over_max_boxes state () = state.pp_curr_depth = state.pp_max_boxes;; (* Ellipsis. *) let pp_set_ellipsis_text state s = state.pp_ellipsis <- s -and pp_get_ellipsis_text state () = state.pp_ellipsis;; +and pp_get_ellipsis_text state () = state.pp_ellipsis +;; (* To set the margin of pretty-printer. *) let pp_limit n = - if n < pp_infinity then n else pred pp_infinity;; + if n < pp_infinity then n else pred pp_infinity +;; let pp_set_min_space_left state n = if n >= 1 then let n = pp_limit n in state.pp_min_space_left <- n; state.pp_max_indent <- state.pp_margin - state.pp_min_space_left; - pp_rinit state;; + pp_rinit state +;; (* Initially, we have : pp_max_indent = pp_margin - pp_min_space_left, and pp_space_left = pp_margin. *) let pp_set_max_indent state n = - pp_set_min_space_left state (state.pp_margin - n);; + pp_set_min_space_left state (state.pp_margin - n) +;; let pp_get_max_indent state () = state.pp_max_indent;; let pp_set_margin state n = @@ -745,27 +795,32 @@ let pp_set_margin state n = max (max (state.pp_margin - state.pp_min_space_left) (state.pp_margin / 2)) 1 in (* Rebuild invariants. *) - pp_set_max_indent state new_max_indent;; + pp_set_max_indent state new_max_indent +;; let pp_get_margin state () = state.pp_margin;; let pp_set_formatter_output_functions state f g = state.pp_output_function <- f; state.pp_flush_function <- g;; let pp_get_formatter_output_functions state () = - (state.pp_output_function, state.pp_flush_function);; + (state.pp_output_function, state.pp_flush_function) +;; let pp_set_all_formatter_output_functions state ~out:f ~flush:g ~newline:h ~spaces:i = pp_set_formatter_output_functions state f g; state.pp_output_newline <- (function () -> h ()); - state.pp_output_spaces <- (function n -> i n);; + state.pp_output_spaces <- (function n -> i n) +;; let pp_get_all_formatter_output_functions state () = (state.pp_output_function, state.pp_flush_function, - state.pp_output_newline, state.pp_output_spaces);; + state.pp_output_newline, state.pp_output_spaces) +;; let pp_set_formatter_out_channel state os = state.pp_output_function <- output os; - state.pp_flush_function <- (fun () -> flush os);; + state.pp_flush_function <- (fun () -> flush os) +;; (************************************************************** @@ -814,7 +869,8 @@ let pp_make_formatter f g h i = pp_print_open_tag = default_pp_print_open_tag; pp_print_close_tag = default_pp_print_close_tag; pp_queue = pp_q; - };; + } +;; (* Default function to output spaces. *) let blank_line = String.make 80 ' ';; @@ -824,34 +880,42 @@ let rec display_blanks state n = begin state.pp_output_function blank_line 0 80; display_blanks state (n - 80) - end;; + end +;; (* Default function to output new lines. *) let display_newline state () = state.pp_output_function "\n" 0 1;; -let make_formatter f g = - let ff = pp_make_formatter f g ignore ignore in - ff.pp_output_newline <- display_newline ff; - ff.pp_output_spaces <- display_blanks ff; - ff;; +(* Make a formatter with default functions to output spaces and new lines. *) +let make_formatter output flush = + let ppf = pp_make_formatter output flush ignore ignore in + ppf.pp_output_newline <- display_newline ppf; + ppf.pp_output_spaces <- display_blanks ppf; + ppf +;; let formatter_of_out_channel oc = - make_formatter (output oc) (fun () -> flush oc);; + make_formatter (output oc) (fun () -> flush oc) +;; let formatter_of_buffer b = - make_formatter (Buffer.add_substring b) ignore;; + make_formatter (Buffer.add_substring b) ignore +;; let stdbuf = Buffer.create 512;; +(* Predefined formatters. *) let str_formatter = formatter_of_buffer stdbuf and std_formatter = formatter_of_out_channel stdout -and err_formatter = formatter_of_out_channel stderr;; +and err_formatter = formatter_of_out_channel stderr +;; let flush_str_formatter () = pp_flush_queue str_formatter false; let s = Buffer.contents stdbuf in Buffer.reset stdbuf; - s;; + s +;; (************************************************************** @@ -948,7 +1012,8 @@ let giving_up mess fmt i = giving up at character number " ^ string_of_int i ^ (if i < Sformat.length fmt then " (" ^ String.make 1 (Sformat.get fmt i) ^ ")." - else String.make 1 '.');; + else String.make 1 '.') +;; (* When an invalid format deserves a special error explanation. *) let format_invalid_arg mess fmt i = invalid_arg (giving_up mess fmt i);; @@ -965,20 +1030,23 @@ let format_int_of_string fmt i s = let sz = try int_of_string s with | Failure s -> invalid_integer fmt i in - size_of_int sz;; + size_of_int sz +;; (* Getting strings out of buffers. *) let get_buffer_out b = let s = Buffer.contents b in Buffer.reset b; - s;; + s +;; (* [ppf] is supposed to be a pretty-printer that outputs in buffer [b]: to extract contents of [ppf] as a string we flush [ppf] and get the string out of [b]. *) let string_out b ppf = pp_flush_queue ppf false; - get_buffer_out b;; + get_buffer_out b +;; (* Applies [printer] to a formatter that outputs on a fresh buffer, then returns the resulting material. *) @@ -986,12 +1054,14 @@ let exstring printer arg = let b = Buffer.create 512 in let ppf = formatter_of_buffer b in printer ppf arg; - string_out b ppf;; + string_out b ppf +;; (* To turn out a character accumulator into the proper string result. *) let implode_rev s0 = function | [] -> s0 - | l -> String.concat "" (List.rev (s0 :: l));; + | l -> String.concat "" (List.rev (s0 :: l)) +;; (* [mkprintf] is the printf-like function generator: given the - [to_s] flag that tells if we are printing into a string, @@ -1221,7 +1291,8 @@ let mkprintf to_s get_out = Tformat.kapr kpr fmt in - kprintf;; + kprintf +;; (************************************************************** @@ -1237,17 +1308,20 @@ let printf fmt = fprintf std_formatter fmt;; let eprintf fmt = fprintf err_formatter fmt;; let kbprintf k b = - mkprintf false (fun _ -> formatter_of_buffer b) k;; + mkprintf false (fun _ -> formatter_of_buffer b) k +;; let bprintf b = kbprintf ignore b;; let ksprintf k = let b = Buffer.create 512 in let k ppf = k (string_out b ppf) in - mkprintf true (fun _ -> formatter_of_buffer b) k;; + mkprintf true (fun _ -> formatter_of_buffer b) k +;; let kprintf = ksprintf;; let sprintf fmt = ksprintf (fun s -> s) fmt;; -at_exit print_flush;; +at_exit print_flush +;; diff --git a/stdlib/gc.mli b/stdlib/gc.mli index 7dfbac1f..6a60a967 100644 --- a/stdlib/gc.mli +++ b/stdlib/gc.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: gc.mli,v 1.42.10.1 2008/02/12 13:30:16 doligez Exp $ *) +(* $Id: gc.mli,v 1.44 2008/02/29 14:21:22 doligez Exp $ *) (** Memory management control and statistics; finalised values. *) @@ -86,7 +86,7 @@ type control = mutable major_heap_increment : int; (** The minimum number of words to add to the - major heap when increasing it. Default: 60k. *) + major heap when increasing it. Default: 124k. *) mutable space_overhead : int; (** The major GC speed is computed from this parameter. @@ -125,7 +125,7 @@ type control = mutable stack_limit : int; (** The maximum size of the stack (in words). This is only relevant to the byte-code runtime, as the native code runtime - uses the operating system's stack. Default: 256k. *) + uses the operating system's stack. Default: 256k. *) } (** The GC parameters are given as a [control] record. Note that these parameters can also be initialised by setting the diff --git a/stdlib/int32.mli b/stdlib/int32.mli index befe8d86..63c2ffd3 100644 --- a/stdlib/int32.mli +++ b/stdlib/int32.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: int32.mli,v 1.18.10.1 2007/10/25 08:18:08 xleroy Exp $ *) +(* $Id: int32.mli,v 1.19 2008/01/11 16:13:16 doligez Exp $ *) (** 32-bit integers. diff --git a/stdlib/int64.mli b/stdlib/int64.mli index 81ab00e5..c50dd746 100644 --- a/stdlib/int64.mli +++ b/stdlib/int64.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: int64.mli,v 1.19.10.1 2007/10/25 08:18:08 xleroy Exp $ *) +(* $Id: int64.mli,v 1.20 2008/01/11 16:13:16 doligez Exp $ *) (** 64-bit integers. diff --git a/stdlib/lazy.ml b/stdlib/lazy.ml index 96566771..57c41fd9 100644 --- a/stdlib/lazy.ml +++ b/stdlib/lazy.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: lazy.ml,v 1.11.20.2 2008/01/29 13:14:57 doligez Exp $ *) +(* $Id: lazy.ml,v 1.13 2008/08/01 16:57:10 mauny Exp $ *) (* Module [Lazy]: deferred computations *) @@ -46,46 +46,16 @@ *) type 'a t = 'a lazy_t;; -exception Undefined;; -let raise_undefined = Obj.repr (fun () -> raise Undefined);; +exception Undefined = CamlinternalLazy.Undefined;; -external follow_forward : Obj.t -> 'a = "caml_lazy_follow_forward";; external make_forward : 'a -> 'a lazy_t = "caml_lazy_make_forward";; -let force (l : 'arg t) = - let x = Obj.repr l in - let t = Obj.tag x in - if t = Obj.forward_tag then (follow_forward x : 'arg) - else if t <> Obj.lazy_tag then (Obj.obj x : 'arg) - else begin - let closure = (Obj.obj (Obj.field x 0) : unit -> 'arg) in - Obj.set_field x 0 raise_undefined; - try - let result = closure () in - Obj.set_field x 0 (Obj.repr result); (* do set_field BEFORE set_tag *) - Obj.set_tag x Obj.forward_tag; - result - with e -> - Obj.set_field x 0 (Obj.repr (fun () -> raise e)); - raise e - end -;; +external force : 'a t -> 'a = "%lazy_force";; -let force_val (l : 'arg t) = - let x = Obj.repr l in - let t = Obj.tag x in - if t = Obj.forward_tag then (follow_forward x : 'arg) - else if t <> Obj.lazy_tag then (Obj.obj x : 'arg) - else begin - let closure = (Obj.obj (Obj.field x 0) : unit -> 'arg) in - Obj.set_field x 0 raise_undefined; - let result = closure () in - Obj.set_field x 0 (Obj.repr result); (* do set_field BEFORE set_tag *) - Obj.set_tag x (Obj.forward_tag); - result - end -;; +(* let force = force;; *) + +let force_val = CamlinternalLazy.force_val;; let lazy_from_fun (f : unit -> 'arg) = let x = Obj.new_block Obj.lazy_tag 1 in diff --git a/stdlib/lazy.mli b/stdlib/lazy.mli index f26ad5e5..cb613e0d 100644 --- a/stdlib/lazy.mli +++ b/stdlib/lazy.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: lazy.mli,v 1.10 2002/07/30 13:02:56 xleroy Exp $ *) +(* $Id: lazy.mli,v 1.11 2008/08/01 16:57:10 mauny Exp $ *) (** Deferred computations. *) @@ -39,7 +39,8 @@ type 'a t = 'a lazy_t;; exception Undefined;; -val force : 'a t -> 'a;; +external force : 'a t -> 'a = "%lazy_force";; +(* val force : 'a t -> 'a ;; *) (** [force x] forces the suspension [x] and returns its result. If [x] has already been forced, [Lazy.force x] returns the same value again without recomputing it. If it raised an exception, diff --git a/stdlib/lexing.ml b/stdlib/lexing.ml index 0a508714..a82ae352 100644 --- a/stdlib/lexing.ml +++ b/stdlib/lexing.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: lexing.ml,v 1.24 2005/10/25 18:34:07 doligez Exp $ *) +(* $Id: lexing.ml,v 1.25 2008/01/22 16:27:53 doligez Exp $ *) (* The run-time library for lexers generated by camllex *) @@ -220,6 +220,14 @@ let lexeme_end lexbuf = lexbuf.lex_curr_p.pos_cnum;; let lexeme_start_p lexbuf = lexbuf.lex_start_p;; let lexeme_end_p lexbuf = lexbuf.lex_curr_p;; +let new_line lexbuf = + let lcp = lexbuf.lex_curr_p in + lexbuf.lex_curr_p <- { lcp with + pos_lnum = lcp.pos_lnum + 1; + pos_bol = lcp.pos_cnum; + } +;; + (* Discard data left in lexer buffer. *) diff --git a/stdlib/lexing.mli b/stdlib/lexing.mli index d7c95bcf..482d2cc8 100644 --- a/stdlib/lexing.mli +++ b/stdlib/lexing.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: lexing.mli,v 1.32 2006/09/12 10:38:18 doligez Exp $ *) +(* $Id: lexing.mli,v 1.33.4.1 2008/10/08 13:07:13 doligez Exp $ *) (** The run-time library for lexers generated by [ocamllex]. *) @@ -62,13 +62,14 @@ 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 change the [pos_cnum] field + At each token, the lexing engine will copy [lex_curr_p] to + [lex_start_p], then change the [pos_cnum] field of [lex_curr_p] by updating it with the number of characters read - since the start of the [lexbuf]. The other fields are copied - without change by the lexing engine. In order to keep them + since the start of the [lexbuf]. The other fields are left + unchanged 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 relevant lexer actions (i.e. at each - end of line). + end of line -- see also [new_line]). *) val from_channel : in_channel -> lexbuf @@ -129,6 +130,11 @@ val lexeme_end_p : lexbuf -> position (** Like [lexeme_end], but return a complete [position] instead of an offset. *) +val new_line : lexbuf -> unit +(** Update the [lex_curr_p] field of the lexbuf to reflect the start + of a new line. You can call this function in the semantic action + of the rule that matches the end-of-line character. *) + (** {6 Miscellaneous functions} *) val flush_input : lexbuf -> unit diff --git a/stdlib/obj.ml b/stdlib/obj.ml index c654c197..86d06258 100644 --- a/stdlib/obj.ml +++ b/stdlib/obj.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: obj.ml,v 1.23.20.2 2008/01/29 13:14:57 doligez Exp $ *) +(* $Id: obj.ml,v 1.24 2008/01/29 13:11:15 doligez Exp $ *) (* Operations on internal representations of values *) @@ -54,3 +54,4 @@ let final_tag = custom_tag let int_tag = 1000 let out_of_heap_tag = 1001 +let unaligned_tag = 1002 diff --git a/stdlib/obj.mli b/stdlib/obj.mli index d372c97d..1d693081 100644 --- a/stdlib/obj.mli +++ b/stdlib/obj.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: obj.mli,v 1.29.10.2 2008/01/29 13:14:57 doligez Exp $ *) +(* $Id: obj.mli,v 1.30 2008/01/29 13:11:15 doligez Exp $ *) (** Operations on internal representations of values. @@ -49,6 +49,7 @@ val final_tag : int (* DEPRECATED *) val int_tag : int val out_of_heap_tag : int +val unaligned_tag : int (* should never happen *) (** The following two functions are deprecated. Use module {!Marshal} instead. *) diff --git a/stdlib/parsing.ml b/stdlib/parsing.ml index 4365d72d..1f048c76 100644 --- a/stdlib/parsing.ml +++ b/stdlib/parsing.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: parsing.ml,v 1.18 2004/01/01 16:42:40 doligez Exp $ *) +(* $Id: parsing.ml,v 1.19 2008/08/06 09:38:21 xleroy Exp $ *) (* The parsing engine *) @@ -78,6 +78,9 @@ external parse_engine : parse_tables -> parser_env -> parser_input -> Obj.t -> parser_output = "caml_parse_engine" +external set_trace: bool -> bool + = "caml_set_parser_trace" + let env = { s_stack = Array.create 100 0; v_stack = Array.create 100 (Obj.repr ()); diff --git a/stdlib/parsing.mli b/stdlib/parsing.mli index 08e6ca66..a546a092 100644 --- a/stdlib/parsing.mli +++ b/stdlib/parsing.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: parsing.mli,v 1.18 2004/04/14 15:37:30 doligez Exp $ *) +(* $Id: parsing.mli,v 1.19 2008/08/06 09:38:21 xleroy Exp $ *) (** The run-time library for parsers generated by [ocamlyacc]. *) @@ -59,6 +59,13 @@ exception Parse_error Can also be raised from the action part of a grammar rule, to initiate error recovery. *) +val set_trace: bool -> bool +(** Control debugging support for [ocamlyacc]-generated parsers. + After [Parsing.set_trace true], the pushdown automaton that + executes the parsers prints a trace of its actions (reading a token, + shifting a state, reducing by a rule) on standard output. + [Parsing.set_trace false] turns this debugging trace off. + The boolean returned is the previous state of the trace flag. *) (**/**) diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli index aa85e4da..e2699a75 100644 --- a/stdlib/pervasives.mli +++ b/stdlib/pervasives.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: pervasives.mli,v 1.108 2007/02/21 14:15:19 xleroy Exp $ *) +(* $Id: pervasives.mli,v 1.113 2008/10/06 13:33:21 doligez Exp $ *) (** The initially opened module. @@ -49,7 +49,7 @@ external ( = ) : 'a -> 'a -> bool = "%equal" if and only if their current contents are structurally equal, even if the two mutable objects are not the same physical object. Equality between functional values raises [Invalid_argument]. - Equality between cyclic data structures does not terminate. *) + Equality between cyclic data structures may not terminate. *) external ( <> ) : 'a -> 'a -> bool = "%notequal" (** Negation of {!Pervasives.(=)}. *) @@ -361,7 +361,8 @@ val min_float : float (** The smallest positive, non-zero, non-denormalized value of type [float]. *) val epsilon_float : float -(** The smallest positive float [x] such that [1.0 +. x <> 1.0]. *) +(** The difference between [1.0] and the smallest exactly representable + floating-point number greater than [1.0]. *) type fpclass = FP_normal (** Normal number, none of the below *) @@ -674,7 +675,7 @@ val open_in_bin : string -> in_channel mode, this function behaves like {!Pervasives.open_in}. *) val open_in_gen : open_flag list -> int -> string -> in_channel -(** [open_in mode perm filename] opens the named file for reading, +(** [open_in_gen mode perm filename] opens the named file for reading, as described above. The extra arguments [mode] and [perm] specify the opening mode and file permissions. {!Pervasives.open_in} and {!Pervasives.open_in_bin} are special @@ -816,17 +817,22 @@ external decr : int ref -> unit = "%decr" (** {6 Operations on format strings} *) -(** See modules {!Printf} and {!Scanf} for more operations on - format strings. *) -type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 +(** Format strings are used to read and print data using formatted input + functions in module {!Scanf} and formatted output in modules {!Printf} and + {!Format}. *) -type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 -(** Simplified type for format strings, included for backward compatibility - with earlier releases of Objective Caml. +(** Format strings have a general and highly polymorphic type + [('a, 'b, 'c, 'd, 'e, 'f) format6]. Type [format6] is built in. + The two simplified types, [format] and [format4] below are + included for backward compatibility with earlier releases of Objective + Caml. ['a] is the type of the parameters of the format, ['c] is the result type for the "printf"-style function, and ['b] is the type of the first argument given to [%a] and [%t] printing functions. *) +type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 + +type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 val string_of_format : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string (** Converts a format string into a string. *) @@ -851,7 +857,7 @@ val ( ^^ ) : val exit : int -> 'a (** Terminate the process, returning the given status code to the operating system: usually 0 to indicate no errors, - and a small positive integer to indicate failure. + and a small positive integer to indicate failure. All open output channels are flushed with flush_all. An implicit [exit 0] is performed each time a program terminates normally. An implicit [exit 2] is performed if the program diff --git a/stdlib/printexc.ml b/stdlib/printexc.ml index 77bf127d..4cd0eeca 100644 --- a/stdlib/printexc.ml +++ b/stdlib/printexc.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: printexc.ml,v 1.18 2004/01/16 15:24:02 doligez Exp $ *) +(* $Id: printexc.ml,v 1.19 2008/03/14 13:47:24 xleroy Exp $ *) open Printf;; @@ -68,3 +68,60 @@ let catch fct arg = flush stdout; eprintf "Uncaught exception: %s\n" (to_string x); exit 2 + +type loc_info = + | Known_location of bool (* is_raise *) + * string (* filename *) + * int (* line number *) + * int (* start char *) + * int (* end char *) + | Unknown_location of bool (*is_raise*) + +external get_exception_backtrace: + unit -> loc_info array option = "caml_get_exception_backtrace" + +let format_loc_info pos li = + let is_raise = + match li with + | Known_location(is_raise, _, _, _, _) -> is_raise + | Unknown_location(is_raise) -> is_raise in + let info = + if is_raise then + if pos = 0 then "Raised at" else "Re-raised at" + else + if pos = 0 then "Raised by primitive operation at" else "Called from" + in + match li with + | Known_location(is_raise, filename, lineno, startchar, endchar) -> + sprintf "%s file \"%s\", line %d, characters %d-%d" + info filename lineno startchar endchar + | Unknown_location(is_raise) -> + sprintf "%s unknown location" + info + +let print_backtrace outchan = + match get_exception_backtrace() with + | None -> + fprintf outchan + "(Program not linked with -g, cannot print stack backtrace)\n" + | Some a -> + for i = 0 to Array.length a - 1 do + if a.(i) <> Unknown_location true then + fprintf outchan "%s\n" (format_loc_info i a.(i)) + done + +let get_backtrace () = + match get_exception_backtrace() with + | None -> + "(Program not linked with -g, cannot print stack backtrace)\n" + | Some a -> + let b = Buffer.create 1024 in + for i = 0 to Array.length a - 1 do + if a.(i) <> Unknown_location true then + bprintf b "%s\n" (format_loc_info i a.(i)) + done; + Buffer.contents b + +external record_backtrace: bool -> unit = "caml_record_backtrace" +external backtrace_status: unit -> bool = "caml_backtrace_status" + diff --git a/stdlib/printexc.mli b/stdlib/printexc.mli index 434f2402..32cdc67f 100644 --- a/stdlib/printexc.mli +++ b/stdlib/printexc.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: printexc.mli,v 1.12 2005/10/25 18:34:07 doligez Exp $ *) +(* $Id: printexc.mli,v 1.13 2008/03/14 13:47:24 xleroy Exp $ *) (** Facilities for printing exceptions. *) @@ -36,3 +36,24 @@ val catch : ('a -> 'b) -> 'a -> 'b makes it harder to track the location of the exception using the debugger or the stack backtrace facility. So, do not use [Printexc.catch] in new code. *) + +val print_backtrace: out_channel -> unit +(** [Printexc.print_backtrace oc] prints an exception backtrace + on the output channel [oc]. The backtrace lists the program + locations where the most-recently raised exception was raised + and where it was propagated through function calls. *) + +val get_backtrace: unit -> string +(** [Printexc.get_backtrace ()] returns a string containing the + same exception backtrace that [Printexc.print_backtrace] would + print. *) + +val record_backtrace: bool -> unit +(** [Printexc.record_backtrace b] turns recording of exception backtraces + on (if [b = true]) or off (if [b = false]). Initially, backtraces + are not recorded, unless the [b] flag is given to the program + through the [OCAMLRUNPARAM] variable. *) + +val backtrace_status: unit -> bool +(** [Printexc.backtrace_status()] returns [true] if exception + backtraces are currently recorded, [false] if not. *) diff --git a/stdlib/printf.ml b/stdlib/printf.ml index 5c160964..b6e4c2dd 100644 --- a/stdlib/printf.ml +++ b/stdlib/printf.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: printf.ml,v 1.53.6.2 2007/12/18 12:40:29 weis Exp $ *) +(* $Id: printf.ml,v 1.58 2008/09/27 20:50:01 weis Exp $ *) external format_float: string -> float -> string = "caml_format_float" @@ -28,41 +28,56 @@ module Sformat = struct type index;; - external unsafe_index_of_int : int -> index = "%identity";; + 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";; + else failwith ("Sformat.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";; + = "%string_length" + ;; external get : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char - = "%string_safe_get";; + = "%string_safe_get" + ;; external unsafe_get : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> int -> char - = "%string_unsafe_get";; + = "%string_unsafe_get" + ;; external unsafe_to_string : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string - = "%identity";; + = "%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);; + 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;; +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 ``" ^ sfmt ^ "''");; + ("Printf: bad conversion %" ^ String.make 1 c ^ ", at char number " ^ + string_of_int i ^ " in format string ``" ^ sfmt ^ "''") +;; let bad_conversion_format fmt i c = - bad_conversion (Sformat.to_string fmt) i c;; + bad_conversion (Sformat.to_string fmt) i c +;; let incomplete_format fmt = invalid_arg - ("printf: premature end of format string ``" ^ - Sformat.to_string fmt ^ "''");; + ("Printf: premature end of format string ``" ^ + Sformat.to_string fmt ^ "''") +;; (* Parses a string conversion to return the specified length and the padding direction. *) let parse_string_conversion sfmt = @@ -77,7 +92,9 @@ let parse_string_conversion sfmt = parse true (succ i) | _ -> parse neg (succ i) in - try parse false 1 with Failure _ -> bad_conversion sfmt 0 's' + 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. *) @@ -91,16 +108,28 @@ let pad_string pad_char p neg s i len = res (* Format a string given a %s format, e.g. %40s or %-20s. - To do: ignore other flags (#, +, etc)? *) + To do ?: ignore other flags (#, +, etc). *) let format_string sfmt s = let (p, neg) = parse_string_conversion sfmt in - pad_string ' ' p neg s 0 (String.length s);; + pad_string ' ' p neg s 0 (String.length s) +;; (* 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. *) + ['*'] in the format are replaced by integers taken from the [widths] list. + [extract_format] returns a string which is the string representation of + the resulting format string. *) let extract_format fmt start stop widths = - let start = succ start in + let skip_positional_spec start = + match Sformat.unsafe_get fmt start with + | '0'..'9' -> + let rec skip_int_litteral i = + match Sformat.unsafe_get fmt i with + | '0'..'9' -> skip_int_litteral (succ i) + | '$' -> succ i + | _ -> start in + skip_int_litteral (succ start) + | _ -> start in + let start = skip_positional_spec (succ start) in let b = Buffer.create (stop - start + 10) in Buffer.add_char b '%'; let rec fill_format i widths = @@ -108,14 +137,15 @@ let extract_format fmt start stop widths = match (Sformat.unsafe_get fmt i, widths) with | ('*', h :: t) -> Buffer.add_string b (string_of_int h); - let i = succ i in + let i = skip_positional_spec (succ i) in fill_format i t | ('*', []) -> assert false (* should not happen *) | (c, _) -> Buffer.add_char b c; fill_format (succ i) widths in fill_format start (List.rev widths); - Buffer.contents b;; + Buffer.contents b +;; let extract_format_int conv fmt start stop widths = let sfmt = extract_format fmt start stop widths in @@ -123,7 +153,8 @@ let extract_format_int conv fmt start stop widths = | 'n' | 'N' -> sfmt.[String.length sfmt - 1] <- 'u'; sfmt - | _ -> sfmt;; + | _ -> sfmt +;; (* Returns the position of the next character following the meta format string, starting from position [i], inside a given format [fmt]. @@ -145,12 +176,14 @@ let sub_format incomplete_format bad_conversion_format conv fmt i = if j >= len then incomplete_format fmt else match Sformat.get fmt j with | '(' | '{' as c -> - let j = sub_fmt c (succ j) in sub (succ j) + let j = sub_fmt c (succ j) in + sub (succ j) | '}' | ')' as 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;; + sub_fmt conv i +;; let sub_format_for_printf conv = sub_format incomplete_format bad_conversion_format conv;; @@ -163,6 +196,7 @@ let iter_on_format_args fmt add_conv add_char = if i > lim then incomplete_format fmt else match Sformat.unsafe_get fmt i with | '*' -> scan_flags skip (add_conv skip i 'i') + (* | '$' -> scan_flags skip (succ i) *** PR#4321 *) | '#' | '-' | ' ' | '+' -> scan_flags skip (succ i) | '_' -> scan_flags true (succ i) | '0'..'9' @@ -212,7 +246,8 @@ let iter_on_format_args fmt add_conv add_char = else scan_fmt (succ i) else i in - ignore (scan_fmt 0);; + ignore (scan_fmt 0) +;; (* Returns a string that summarizes the typing information that a given format string contains. @@ -226,7 +261,8 @@ let summarize_format_type fmt = if skip then Buffer.add_string b "%_" else Buffer.add_char b '%'; add_char i c in iter_on_format_args fmt add_conv add_char; - Buffer.contents b;; + Buffer.contents b +;; module Ac = struct type ac = { @@ -234,11 +270,12 @@ module Ac = struct mutable ac_skip : int; mutable ac_rdrs : int; } -end;; +end +;; open Ac;; -(* Computes the number of arguments of a format (including flag +(* Computes the number of arguments of a format (including the flag arguments if any). *) let ac_of_format fmt = let ac = { ac_rglr = 0; ac_skip = 0; ac_rdrs = 0; } in @@ -255,23 +292,26 @@ let ac_of_format fmt = and add_char i c = succ i in iter_on_format_args fmt add_conv add_char; - ac;; + ac +;; let count_arguments_of_format fmt = let ac = ac_of_format fmt in - ac.ac_rglr + ac.ac_skip + ac.ac_rdrs;; + 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;; + loop 0 l +;; (* ``Abstracting'' version of kprintf: returns a (curried) function that will print when totally applied. Note: in the following, we are careful not to be badly caught - by the compiler optimizations on the representation of arrays. *) + by the compiler optimizations for the representation of arrays. *) let kapr kpr fmt = match count_arguments_of_format fmt with | 0 -> kpr fmt [||] @@ -309,22 +349,87 @@ let kapr kpr fmt = list_iter_i (fun i arg -> a.(nargs - i - 1) <- arg) args; kpr fmt a else Obj.magic (fun x -> loop (succ i) (x :: args)) in - loop 0 [];; - -(* Get the index of the next argument to printf. *) -let next_index n = Sformat.succ_index n;; + loop 0 [] +;; + +type positional_specification = + | Spec_none | Spec_index of Sformat.index +;; + +(* To scan an optional positional parameter specification, + i.e. an integer followed by a [$]. + + Calling [got_spec] with appropriate arguments, we ``return'' a positional + specification and an index to go on scanning the [fmt] format at hand. + + Note that this is optimized for the regular case, i.e. no positional + parameter, since in this case we juste ``return'' the constant + [Spec_none]; in case we have a positional parameter, we ``return'' a + [Spec_index] [positional_specification] which a bit more costly. + + Note also that we do not support [*$] specifications, since this would + lead to type checking problems: a [*$] positional specification means + ``take the next argument to [printf] (which must be an integer value)'', + name this integer value $n$; [*$] now designates parameter $n$. + + Unfortunately, the type of a parameter specified via a [*$] positional + specification should be the type of the corresponding argument to + [printf], hence this sould be the type of the $n$-th argument to [printf] + with $n$ being the {\em value} of the integer argument defining [*]; we + clearly cannot statically guess the value of this parameter in the general + case. Put it another way: this means type dependency, which is completely + out of scope of the Caml type algebra. *) + +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 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_spec (Spec_index (Sformat.index_of_litteral_position accu)) (succ j) + (* Not a positional specification: tell so the caller, and go back to + scanning the format from the original [i] position we were called at + first. *) + | _ -> got_spec Spec_none i in + get_int_litteral (int_of_char d - 48) (succ i) + (* No positional specification: tell so the caller, and go back to scanning + the format from the original [i] position. *) + | _ -> got_spec Spec_none i +;; + +(* Get the index of the next argument to printf, according to the given + positional specification. *) +let next_index spec n = + match spec with + | Spec_none -> Sformat.succ_index n + | Spec_index _ -> n +;; + +(* Get the index of the actual argument to printf, according to its + optional positional specification. *) +let get_index spec n = + match spec with + | Spec_none -> n + | Spec_index p -> p +;; (* Decode a format string and act on it. - [fmt] is the printf format string, and [pos] points to a [%] character. + [fmt] is the [printf] format string, and [pos] points to a [%] character in + the format string. After consuming the appropriate number of arguments and formatting - them, one of the five continuations is called: - [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. + them, one of the following five continuations described below is called: + + - [cont_s] for outputting a string (arguments: arg num, string, next pos) + - [cont_a] for performing a %a action (arguments: arg num, fn, arg, next pos) + - [cont_t] for performing a %t action (arguments: arg num, fn, next pos) + - [cont_f] for performing a flush action (arguments: arg num, next pos) + - [cont_m] for performing a %( action (arguments: 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 %conversion specification in [fmt]. *) @@ -336,58 +441,67 @@ let next_index n = Sformat.succ_index n;; 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 n = - Obj.magic (args.(Sformat.int_of_index 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_spec spec i = scan_flags spec n widths i in + scan_positional_spec fmt got_spec n i - let rec scan_flags n widths i = + and scan_flags spec n widths i = match Sformat.unsafe_get fmt i with | '*' -> - let (width : int) = get_arg n in - scan_flags (next_index n) (width :: widths) (succ 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_spec n (succ i) | '0'..'9' - | '.' | '#' | '-' | ' ' | '+' -> scan_flags n widths (succ i) - | _ -> scan_conv n widths i + | '.' | '#' | '-' | ' ' | '+' -> scan_flags spec n widths (succ i) + | _ -> scan_conv spec n widths i - and scan_conv n widths i = + and scan_conv spec n widths i = match Sformat.unsafe_get fmt i with | '%' -> cont_s n "%" (succ i) | 's' | 'S' as conv -> - let (x : string) = get_arg n in + let (x : string) = get_arg spec n in let x = if conv = 's' then x else "\"" ^ String.escaped x ^ "\"" in let s = (* optimize for common case %s *) if i = succ pos then x else format_string (extract_format fmt pos i widths) x in - cont_s (next_index n) s (succ i) + cont_s (next_index spec n) s (succ i) | 'c' | 'C' as conv -> - let (x : char) = get_arg n in + let (x : char) = get_arg spec n in let s = if conv = 'c' then String.make 1 x else "'" ^ Char.escaped x ^ "'" in - cont_s (next_index n) s (succ i) + cont_s (next_index spec n) s (succ i) | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' | 'N' as conv -> - let (x : int) = get_arg n in + let (x : int) = get_arg spec n in let s = format_int (extract_format_int conv fmt pos i widths) x in - cont_s (next_index n) s (succ i) + cont_s (next_index spec n) s (succ i) | 'f' | 'e' | 'E' | 'g' | 'G' -> - let (x : float) = get_arg n in + let (x : float) = get_arg spec n in let s = format_float (extract_format fmt pos i widths) x in - cont_s (next_index n) s (succ i) + cont_s (next_index spec n) s (succ i) | 'F' -> - let (x : float) = get_arg n in - cont_s (next_index n) (string_of_float x) (succ i) + 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 n in - cont_s (next_index n) (string_of_bool x) (succ i) + let (x : bool) = get_arg spec n in + cont_s (next_index spec n) (string_of_bool x) (succ i) | 'a' -> - let printer = get_arg n in - let n = Sformat.succ_index n in - let arg = get_arg n in - cont_a (next_index n) printer arg (succ i) + let printer = get_arg spec n in + (* 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 = 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 n in - cont_t (next_index n) printer (succ i) + let printer = get_arg spec n in + cont_t (next_index spec n) printer (succ i) | 'l' | 'n' | 'L' as conv -> begin match Sformat.unsafe_get fmt (succ i) with | 'd' | 'i' | 'o' | 'u' | 'x' | 'X' -> @@ -395,43 +509,44 @@ let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m = let s = match conv with | 'l' -> - let (x : int32) = get_arg n in + let (x : int32) = get_arg spec n in format_int32 (extract_format fmt pos i widths) x | 'n' -> - let (x : nativeint) = get_arg n in + let (x : nativeint) = get_arg spec n in format_nativeint (extract_format fmt pos i widths) x | _ -> - let (x : int64) = get_arg n in + let (x : int64) = get_arg spec n in format_int64 (extract_format fmt pos i widths) x in - cont_s (next_index n) s (succ i) + cont_s (next_index spec n) s (succ i) | _ -> - let (x : int) = get_arg n in + let (x : int) = get_arg spec n in let s = format_int (extract_format_int 'n' fmt pos i widths) x in - cont_s (next_index n) s (succ i) + cont_s (next_index spec n) s (succ i) end | '!' -> cont_f n (succ i) | '{' | '(' as conv (* ')' '}' *) -> - let (xf : ('a, 'b, 'c, 'd, 'e, 'f) format6) = get_arg 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 in if conv = '{' (* '}' *) then (* Just print the format argument as a specification. *) cont_s - (next_index n) + (next_index spec n) (summarize_format_type xf) j else (* Use the format argument instead of the format specification. *) - cont_m (next_index n) xf j + cont_m (next_index spec n) xf j | (* '(' *) ')' -> cont_s n "" (succ i) | conv -> bad_conversion_format fmt i conv in - scan_flags n [] (succ pos);; + scan_positional n [] (succ pos) +;; let mkprintf to_s get_out outc outs flush k fmt = - (* out is global to this invocation of pr, and must be shared by all its + (* [out] is global to this definition of [pr], and must be shared by all its recursive calls (if any). *) let out = get_out fmt in @@ -468,10 +583,12 @@ let mkprintf to_s get_out outc outs flush k fmt = let kpr = pr k (Sformat.index_of_int 0) in - kapr kpr fmt;; + kapr kpr fmt +;; let kfprintf k oc = - mkprintf false (fun _ -> oc) output_char output_string flush k;; + mkprintf false (fun _ -> oc) output_char output_string flush k +;; let ifprintf oc = kapr (fun _ -> Obj.magic ignore);; let fprintf oc = kfprintf ignore oc;; @@ -479,22 +596,26 @@ 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;; + 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 * Sformat.length fmt in - Buffer.create len;; + Buffer.create len +;; let get_contents b = let s = Buffer.contents b in Buffer.clear b; - s;; + s +;; let get_cont k b = k (get_contents b);; let ksprintf k = - mkprintf true get_buff Buffer.add_char Buffer.add_string ignore (get_cont k);; + mkprintf true get_buff Buffer.add_char Buffer.add_string ignore (get_cont k) +;; let kprintf = ksprintf;; @@ -511,7 +632,8 @@ module CamlinternalPr = struct mutable ac_rglr : int; mutable ac_skip : int; mutable ac_rdrs : int; - };; + } + ;; let ac_of_format = ac_of_format;; @@ -523,6 +645,8 @@ module CamlinternalPr = struct let kapr = kapr;; - end;; + end + ;; -end;; +end +;; diff --git a/stdlib/printf.mli b/stdlib/printf.mli index 8e9692d9..6249bcc0 100644 --- a/stdlib/printf.mli +++ b/stdlib/printf.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: printf.mli,v 1.54.6.2 2008/01/11 10:50:06 doligez Exp $ *) +(* $Id: printf.mli,v 1.57 2008/09/27 20:50:01 weis Exp $ *) (** Formatted output functions. *) @@ -122,6 +122,7 @@ val bprintf : Buffer.t -> ('a, Buffer.t, unit) format -> 'a (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, @@ -180,7 +181,10 @@ module CamlinternalPr : sig 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 + char -> + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + int -> + int val summarize_format_type : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> string @@ -192,12 +196,14 @@ module CamlinternalPr : sig (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 + (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 + ('a, 'b, 'c, 'd, 'e, 'f) format6 -> + 'g + end;; end;; - diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml index eb4dc51a..0d6b637a 100644 --- a/stdlib/scanf.ml +++ b/stdlib/scanf.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: scanf.ml,v 1.73 2006/11/17 08:34:05 weis Exp $ *) +(* $Id: scanf.ml,v 1.80 2008/09/27 20:45:05 weis Exp $ *) (* The run-time library for scanners. *) @@ -36,7 +36,7 @@ val invalidate_current_char : scanbuf -> unit;; val peek_char : scanbuf -> char;; (* [Scanning.peek_char ib] returns the current char available in - the buffer or read one if necessary (when the current character is + the buffer or reads one if necessary (when the current character is already scanned). If no character can be read, sets an end of file condition and returns '\000'. *) @@ -104,7 +104,8 @@ val from_file : string -> scanbuf;; val from_file_bin : string -> scanbuf;; val from_function : (unit -> char) -> scanbuf;; -end;; +end +;; module Scanning : SCANNING = struct @@ -121,7 +122,8 @@ type scanbuf = { mutable get_next_char : unit -> char; tokbuf : Buffer.t; file_name : file_name; -};; +} +;; let null_char = '\000';; @@ -134,14 +136,15 @@ let next_char ib = ib.current_char <- c; ib.current_char_is_valid <- true; ib.char_count <- succ ib.char_count; - if c == '\n' then ib.line_count <- succ ib.line_count; + if c = '\n' then ib.line_count <- succ ib.line_count; c with | End_of_file -> let c = null_char in ib.current_char <- c; ib.current_char_is_valid <- false; ib.eof <- true; - c;; + c +;; let peek_char ib = if ib.current_char_is_valid then ib.current_char else next_char ib;; @@ -154,17 +157,21 @@ let peek_char ib = let checked_peek_char ib = let c = peek_char ib in if ib.eof then raise End_of_file; - c;; + c +;; let end_of_input ib = ignore (peek_char ib); - ib.eof;; + ib.eof +;; let eof ib = ib.eof;; let beginning_of_input ib = ib.char_count = 0;; let name_of_input ib = ib.file_name;; -let char_count ib = ib.char_count;; +let char_count ib = + if ib.current_char_is_valid then ib.char_count - 1 else ib.char_count +;; let line_count ib = ib.line_count;; let reset_token ib = Buffer.reset ib.tokbuf;; let invalidate_current_char ib = ib.current_char_is_valid <- false;; @@ -174,19 +181,22 @@ let token ib = let tok = Buffer.contents tokbuf in Buffer.clear tokbuf; ib.token_count <- succ ib.token_count; - tok;; + tok +;; let token_count ib = ib.token_count;; let skip_char ib max = invalidate_current_char ib; - max;; + max +;; let ignore_char ib max = skip_char ib (max - 1);; let store_char ib c max = Buffer.add_char ib.tokbuf c; - ignore_char ib max;; + ignore_char ib max +;; let default_token_buffer_size = 1024;; @@ -200,7 +210,8 @@ let create fname next = { get_next_char = next; tokbuf = Buffer.create default_token_buffer_size; file_name = fname; -};; +} +;; let from_string s = let i = ref 0 in @@ -210,57 +221,75 @@ let from_string s = let c = s.[!i] in incr i; c in - create "string input" next;; + create "string input" next +;; 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 +(* Scanning from an input channel. *) + +(* Position of the problem: + + We cannot prevent the scanning mechanism to use one lookahead character, + if needed by the semantics of the format string specifications (e.g. a + trailing ``skip space'' specification in the format string); in this case, + the mandatory lookahead character is indeed read from the input and not + used to return the token read. It is thus mandatory to be able to store + an unused lookahead character somewhere to get it as the first character + of the next scan. + + To circumvent this problem, all the scanning functions get a low level + input buffer argument where they store the lookahead character when + needed; additionnaly, the input buffer is the only source of character of + a scanner. The [scanbuf] input buffers are defined in module {!Scanning}. + + Now we understand that it is extremely important that related successive + calls to scanners inded read from the same input buffer. In effect, if a + scanner [scan1] is reading from [ib1] and stores an unused lookahead + character [c1] into its input buffer [ib1], then another scanner [scan2] + not reading from the same buffer [ib1] will miss the character [c], + seemingly vanished in the air from the point of view of [scan2]. + + This mechanism works perfectly to read from strings, from files, and from + functions, since in those cases, allocating two buffers reading from the + same source is unnatural. + + Still, there is a difficulty in the case of scanning from an input + channel. In effect, when scanning from an input channel [ic], this channel + may not have been allocated from within 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]. + [ic]). This is highly error prone since, one of the function may seek the + input channel, while the other function has still an unused lookahead + character in its input buffer. In conclusion, you should never mixt direct + low level reading and high level scanning from the same input channel. + + This phenomenon of reading mess is even worse when one defines more than + one scanning buffer reading from the same input channel + [ic]. Unfortunately, we have no simple way to get rid of this problem + (unless the basic input channel API is modified to offer a ``consider this + char as unread'' procedure to keep back the unused lookahead character as + available in the input channel for further reading). + + To prevent some of the confusion the scanning buffer allocation function + is a memo function that never allocates two different scanning buffers for + the same input channel. This way, the user can naively perform successive + call to [fscanf] below, without allocating a new scanning buffer at each + invocation and hence preserving the expected semantics. 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. *) + channel API to allow arbitrary mixing of direct and formatted reading from + input channels. *) (* Perform bufferized input to improve efficiency. *) let file_buffer_size = ref 1024;; -(* To close a channel at end of input. *) +(* The scanner closes the input channel at end of input. *) let scan_close_at_end ic = close_in ic; raise End_of_file;; +(* The scanner does not close the input channel at end of input: + it just raises [End_of_file]. *) +let scan_raise_at_end _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 @@ -276,41 +305,53 @@ let from_ic scan_close_ic fname ic = buf.[0] end end in - create fname next;; + create fname next +;; let from_ic_close_at_end = from_ic scan_close_at_end;; 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 scan_raise_at_end ic = raise End_of_file;; - -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 + 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 + 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 + 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;; +let memo_from_ic = + let memo = ref [] in + (fun scan_close_ic fname ic -> + try List.assq ic !memo with + | Not_found -> + let ib = from_ic scan_close_ic fname ic in + memo := (ic, ib) :: !memo; + ib) +;; + +let from_channel = memo_from_ic scan_raise_at_end "input channel";; + +end +;; (* Formatted input functions. *) type ('a, 'b, 'c, 'd) scanner = - ('a, Scanning.scanbuf, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c;; + ('a, Scanning.scanbuf, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c +;; external string_to_format : - string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity";; + string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" +;; (* Reporting errors. *) exception Scan_failure of string;; @@ -319,13 +360,8 @@ let bad_input s = raise (Scan_failure s);; let bad_input_char c = bad_input (String.make 1 c);; let bad_input_escape c = - bad_input (Printf.sprintf "illegal escape character %C" 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) - | x -> raise x;; + bad_input (Printf.sprintf "illegal escape character %C" c) +;; module Sformat = Printf.CamlinternalPr.Sformat;; module Tformat = Printf.CamlinternalPr.Tformat;; @@ -334,23 +370,35 @@ let bad_conversion fmt i c = invalid_arg (Printf.sprintf "scanf: bad conversion %%%c, at char number %i \ - in format string ``%s''" c i (Sformat.to_string 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''" - (Sformat.to_string fmt));; + (Sformat.to_string fmt)) +;; + +let bad_float () = bad_input "no dot or exponent part found in +float token" +;; + +let character_mismatch_err c ci = + Printf.sprintf "looking for %C, found %C" c ci +;; -let bad_float () = bad_input "no dot or exponent part found in float token";; +let character_mismatch c ci = + bad_input (character_mismatch_err c ci) +;; let format_mismatch_err fmt1 fmt2 = Printf.sprintf - "format read ``%s'' does not match specification ``%s''" fmt1 fmt2;; + "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));; +let format_mismatch fmt1 fmt2 = bad_input (format_mismatch_err fmt1 fmt2);; -(* Checking that 2 format string are type compatible. *) +(* Checking that 2 format strings are type compatible. *) let compatible_format_type fmt1 fmt2 = Tformat.summarize_format_type (string_to_format fmt1) = Tformat.summarize_format_type (string_to_format fmt2);; @@ -362,9 +410,9 @@ let compatible_format_type fmt1 fmt2 = That's why we use checked_peek_char here. *) let check_char ib c = let ci = Scanning.checked_peek_char ib in - if ci != c then - bad_input (Printf.sprintf "looking for %C, found %C" c ci) else - Scanning.invalidate_current_char ib;; + if ci = c then Scanning.invalidate_current_char ib else + character_mismatch c ci +;; (* Checks that the current char is indeed one of the stopper characters, then skips it. @@ -377,7 +425,8 @@ let ignore_stoppers stps ib = if List.memq ci stps then Scanning.invalidate_current_char ib else let sr = String.concat "" (List.map (String.make 1) stps) in bad_input - (Printf.sprintf "looking for one of range %S, found %C" sr ci);; + (Printf.sprintf "looking for one of range %S, found %C" sr ci) +;; (* Extracting tokens from ouput token buffer. *) @@ -403,26 +452,31 @@ let token_int_literal conv ib = | 'b' -> "0b" ^ Scanning.token ib | _ -> assert false in let l = String.length tok in - if l = 0 || tok.[0] <> '+' then tok else String.sub tok 1 (l - 1);; + if l = 0 || tok.[0] <> '+' then tok else String.sub tok 1 (l - 1) +;; (* All the functions that convert a string to a number raise the exception Failure when the conversion is not possible. - This exception is then trapped in kscanf. *) + This exception is then trapped in [kscanf]. *) let token_int conv ib = int_of_string (token_int_literal conv ib);; + let token_float ib = float_of_string (Scanning.token ib);; (* To scan native ints, int32 and int64 integers. We cannot access to conversions to/from strings for those types, Nativeint.of_string, Int32.of_string, and Int64.of_string, - since those modules are not available to Scanf. + 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";; + = "caml_nativeint_of_string" +;; external int32_of_string : string -> int32 - = "caml_int32_of_string";; + = "caml_int32_of_string" +;; external int64_of_string : string -> int64 - = "caml_int64_of_string";; + = "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);; @@ -451,7 +505,8 @@ let rec scan_decimal_digits max ib = | '_' -> let max = Scanning.ignore_char ib max in scan_decimal_digits max ib - | _ -> max;; + | _ -> max +;; let scan_decimal_digits_plus max ib = let c = Scanning.checked_peek_char ib in @@ -459,7 +514,8 @@ let scan_decimal_digits_plus max ib = | '0' .. '9' -> let max = Scanning.store_char ib c max in scan_decimal_digits max ib - | c -> bad_input_char c;; + | c -> bad_input_char c +;; let scan_digits_plus digitp max ib = (* To scan numbers from other bases, we use a predicate argument to @@ -481,23 +537,27 @@ let scan_digits_plus digitp max ib = if digitp c then let max = Scanning.store_char ib c max in scan_digits max - else bad_input_char c;; + else bad_input_char c +;; let is_binary_digit = function | '0' .. '1' -> true - | _ -> false;; + | _ -> false +;; let scan_binary_int = scan_digits_plus is_binary_digit;; let is_octal_digit = function | '0' .. '7' -> true - | _ -> false;; + | _ -> false +;; let scan_octal_int = scan_digits_plus is_octal_digit;; let is_hexa_digit = function | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true - | _ -> false;; + | _ -> false +;; let scan_hexadecimal_int = scan_digits_plus is_hexa_digit;; @@ -509,11 +569,13 @@ let scan_sign max ib = match c with | '+' -> Scanning.store_char ib c max | '-' -> Scanning.store_char ib c max - | c -> max;; + | c -> max +;; let scan_optionally_signed_decimal_int max ib = let max = scan_sign max ib in - scan_unsigned_decimal_int max ib;; + scan_unsigned_decimal_int max ib +;; (* Scan an unsigned integer that could be given in any (common) basis. If digits are prefixed by one of 0x, 0X, 0o, or 0b, the number is @@ -531,11 +593,13 @@ let scan_unsigned_int 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;; + | c -> scan_unsigned_decimal_int max ib +;; let scan_optionally_signed_int max ib = let max = scan_sign max ib in - scan_unsigned_int max ib;; + scan_unsigned_int max ib +;; let scan_int_conv conv max ib = match conv with @@ -545,7 +609,8 @@ let scan_int_conv conv max ib = | 'o' -> scan_octal_int max ib | 'u' -> scan_unsigned_decimal_int max ib | 'x' | 'X' -> scan_hexadecimal_int max ib - | c -> assert false;; + | c -> assert false +;; (* Scanning floating point numbers. *) (* Fractional part is optional and can be reduced to 0 digits. *) @@ -556,7 +621,8 @@ let scan_frac_part max ib = match c with | '0' .. '9' as c -> scan_decimal_digits (Scanning.store_char ib c max) ib - | _ -> max;; + | _ -> max +;; (* Exp part is optional and can be reduced to 0 digits. *) let scan_exp_part max ib = @@ -566,7 +632,8 @@ let scan_exp_part max ib = match c with | 'e' | 'E' as c -> scan_optionally_signed_decimal_int (Scanning.store_char ib c max) ib - | _ -> max;; + | _ -> max +;; (* Scan the integer part of a floating point number, (not using the Caml lexical convention since the integer part can be empty): @@ -574,7 +641,8 @@ let scan_exp_part max ib = digits (e.g. -.1). *) let scan_int_part max ib = let max = scan_sign max ib in - scan_decimal_digits max ib;; + scan_decimal_digits max ib +;; let scan_float max ib = let max = scan_int_part max ib in @@ -586,7 +654,8 @@ let scan_float 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;; + | c -> scan_exp_part max ib +;; let scan_Float max ib = let max = scan_optionally_signed_decimal_int max ib in @@ -600,7 +669,8 @@ let scan_Float max ib = scan_exp_part max ib | 'e' | 'E' -> scan_exp_part max ib - | c -> bad_float ();; + | c -> bad_float () +;; (* Scan a regular string: stops when encountering a space or one of the characters in stp. It also stops when the maximum number of @@ -610,24 +680,27 @@ let scan_string stp max ib = if max = 0 then max else let c = Scanning.peek_char ib in if Scanning.eof ib then max else - if stp == [] then + if stp = [] then match c with | ' ' | '\t' | '\n' | '\r' -> max | c -> loop (Scanning.store_char ib c max) else if List.memq c stp then Scanning.skip_char ib max else loop (Scanning.store_char ib c max) in - loop max;; + loop max +;; (* Scan a char: peek strictly one character in the input, whatsoever. *) let scan_char max ib = - Scanning.store_char ib (Scanning.checked_peek_char ib) max;; + Scanning.store_char ib (Scanning.checked_peek_char ib) max +;; let char_for_backslash = function | 'n' -> '\010' | 'r' -> '\013' | 'b' -> '\008' | 't' -> '\009' - | c -> c;; + | c -> c +;; (* The integer value corresponding to the facial value of a valid decimal digit character. *) @@ -640,7 +713,8 @@ let char_for_decimal_code c0 c1 c2 = int_value_of_char c2 in if c < 0 || c > 255 then bad_input (Printf.sprintf "bad char \\%c%c%c" c0 c1 c2) - else char_of_int c;; + else char_of_int c +;; (* Called when encountering '\\' as starter of a char. Stops before the corresponding '\''. *) @@ -661,7 +735,8 @@ let scan_backslash_char max ib = 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;; + | c -> bad_input_char c +;; let scan_Char max ib = let rec loop s max = @@ -669,12 +744,21 @@ let scan_Char max ib = let c = Scanning.checked_peek_char ib in if Scanning.eof ib then bad_input "a char" else match c, s with + (* Looking for the '\'' at the beginning of the delimited char. *) | '\'', 3 -> loop 2 (Scanning.ignore_char ib max) + (* Looking for the '\'' at the end of the delimited char. *) | '\'', 1 -> Scanning.ignore_char ib max + (* Any other char at the beginning or end of the delimited char should be + '\''. *) + | c, (3 | 1) -> character_mismatch '\'' c + (* Found a '\\': check and read this escape char. *) | '\\', 2 -> loop 1 (scan_backslash_char (Scanning.ignore_char ib max) ib) + (* The regular case, remember the char, then look for the terminal '\\'. *) | c, 2 -> loop 1 (Scanning.store_char ib c max) - | c, _ -> bad_input_escape c in - loop 3 max;; + (* Any other case is an error, *) + | c, _ -> bad_input_char c in + loop 3 max +;; let scan_String max ib = let rec loop s max = @@ -701,7 +785,8 @@ let scan_String max ib = | '\\', false -> loop false max | c, false -> loop false (Scanning.store_char ib c max) | _, _ -> loop false (scan_backslash_char (max - 1) ib) in - loop true max;; + loop true max +;; let scan_bool max ib = if max < 4 then bad_input "a boolean" else @@ -712,12 +797,14 @@ let scan_bool max ib = | 't' -> 4 | 'f' -> 5 | _ -> bad_input "a boolean" in - scan_string [] (min max m) ib;; + scan_string [] (min max m) ib +;; (* Reading char sets in %[...] conversions. *) type char_set = | Pos_set of string (* Positive (regular) set. *) - | Neg_set of string (* Negative (complementary) set. *);; + | Neg_set of string (* Negative (complementary) set. *) +;; (* Char sets are read as sub-strings in the format string. *) let read_char_set fmt i = @@ -743,14 +830,16 @@ let read_char_set fmt i = j, Neg_set (Sformat.sub fmt (Sformat.index_of_int i) (j - i)) | _ -> let j = find_set i in - j, Pos_set (Sformat.sub fmt (Sformat.index_of_int i) (j - i));; + j, 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. *) (* Bit manipulations into bytes. *) let set_bit_of_byte byte idx b = - (b lsl idx) lor (byte land (* mask idx *) (lnot (1 lsl idx)));; + (b lsl idx) lor (byte land (* mask idx *) (lnot (1 lsl idx))) +;; let get_bit_of_byte byte idx = (byte lsr idx) land 1;; @@ -759,29 +848,32 @@ let set_bit_of_range r c b = let idx = c land 0x7 in let ydx = c lsr 3 in let byte = r.[ydx] in - r.[ydx] <- char_of_int (set_bit_of_byte (int_of_char byte) idx b);; + r.[ydx] <- char_of_int (set_bit_of_byte (int_of_char byte) idx b) +;; let get_bit_of_range r c = let idx = c land 0x7 in let ydx = c lsr 3 in let byte = r.[ydx] in - get_bit_of_byte (int_of_char byte) idx;; + get_bit_of_byte (int_of_char byte) idx +;; (* Char sets represented as bitvects represented as fixed length byte strings. *) (* Create a full or empty set of chars. *) let make_range bit = let c = char_of_int (if bit = 0 then 0 else 0xFF) in - String.make 32 c;; + String.make 32 c +;; -(* Test is a char belongs to a set of chars. *) +(* Test if a char belongs to a set of chars. *) let get_char_in_range r c = get_bit_of_range r (int_of_char c);; let bit_not b = (lnot b) land 1;; (* Build the bit vector corresponding to the set of characters that belongs to the string argument [set]. - (In the Scanf module [set] is always a sub-string of the format). *) + (In the [Scanf] module [set] is always a sub-string of the format.) *) let make_char_bit_vect bit set = let r = make_range (bit_not bit) in let lim = String.length set - 1 in @@ -802,14 +894,16 @@ let make_char_bit_vect bit set = set_bit_of_range r (int_of_char set.[i]) bit; loop bit true (succ i) in loop bit false 0; - r;; + r +;; (* Compute the predicate on chars corresponding to a char set. *) let make_pred bit set stp = let r = make_char_bit_vect bit set in List.iter (fun c -> set_bit_of_range r (int_of_char c) (bit_not bit)) stp; - (fun c -> get_char_in_range r c);; + (fun c -> get_char_in_range r c) +;; let make_setp stp char_set = match char_set with @@ -842,7 +936,8 @@ let make_setp stp char_set = 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;; + end +;; let setp_table = Hashtbl.create 7;; @@ -853,14 +948,16 @@ let add_setp stp char_set setp = 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;; + 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;; + setp +;; let scan_chars_in_char_set stp char_set max ib = let rec loop_pos1 cp1 max = @@ -930,13 +1027,15 @@ let scan_chars_in_char_set stp char_set max ib = | 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;; + max +;; let get_count t ib = match t with | 'l' -> Scanning.line_count ib | 'n' -> Scanning.char_count ib - | _ -> Scanning.token_count ib;; + | _ -> Scanning.token_count ib +;; let rec skip_whites ib = let c = Scanning.peek_char ib in @@ -945,188 +1044,221 @@ let rec skip_whites ib = | ' ' | '\t' | '\n' | '\r' -> Scanning.invalidate_current_char ib; skip_whites ib | _ -> () - end;; + end +;; 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;; + loop 0 l +;; + +(* The global error report function for [Scanf]. *) +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) + | x -> raise x +;; -(* The [kscanf] main scanning function. +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 [] +;; + +(* The [scan_format] main scanning function. It takes as arguments: - an input buffer [ib] from which to read characters, - an error handling function [ef], - a format [fmt] that specifies what to read in the input, + - a vector of user's defined readers rv, - and a function [f] to pass the tokens read to. - Then [kscanf] scans the format and the buffer in parallel to find - out tokens as specified by the format; when it founds one token, it + Then [scan_format] scans the format and the input buffer in parallel to + find out tokens as specified by the format; when it founds one token, it converts it as specified, remembers the converted value as a future argument to the function [f], and continues scanning. If the entire scanning succeeds (i.e. the format string has been exhausted and the buffer has provided tokens according to the - format string), the tokens are applied to [f]. + format string), [f] is applied to the tokens. 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 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 scan_format ib ef fmt rv f = let lim = Sformat.length fmt - 1 in - let limr = Array.length v - 1 in + let limr = Array.length rv - 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 ir f i = - if i > lim then f else - 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 ir f (succ i) - | '@' -> - let i = succ i in - if i > lim then incomplete_format fmt else begin - check_char ib (Sformat.get fmt i); - scan_fmt ir f (succ i) end - | c -> check_char ib c; scan_fmt ir f (succ i) + let rec scan fmt = - and scan_conversion skip max ir f i = - let stack = if skip then no_stack else stack in - match Sformat.get fmt i with - | '%' as conv -> - 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 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 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 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 ir (stack f (token_float ib)) (succ i) - | 'B' | 'b' -> - 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 + let rec scan_fmt ir f i = + if i > lim then ir, f else + match Sformat.get fmt i with + | ' ' -> skip_whites ib; scan_fmt ir f (succ i) + | '%' -> + if i > lim then incomplete_format fmt else + scan_conversion false max_int ir f (succ i) + | '@' -> + let i = succ i in + if i > lim then incomplete_format fmt else begin + check_char ib (Sformat.get fmt i); + scan_fmt ir f (succ i) end + | c -> check_char ib c; scan_fmt ir f (succ i) + + and scan_conversion skip max ir f i = + let stack = if skip then no_stack else stack in match Sformat.get fmt i with - (* This is in fact an integer conversion (e.g. %ld, %ni, or %Lo). *) + | '%' as conv -> + 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 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 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 - (* 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 ir f (succ i) - else bad_input "end of input not found" - | '_' -> - 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 + 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 ir (stack f (token_float ib)) (succ i) + | 'B' | 'b' -> + 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 rv.(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 ir f (succ i) + else bad_input "end of input not found" + | '_' -> + 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 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 - | '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 + | '.' -> + 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 + (* Find the static specification for the format to read. *) + 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 + (* Read the specified format string in the input buffer, + and check its correctness. *) + 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 else + (* For conversion %{%}, just return this format string as the token + read. *) + if conv = '{' (* '}' *) then scan_fmt ir (stack f rf) j else + (* Or else, read according to the format string just read. *) + let ir, nf = scan (Obj.magic rf) ir (stack f rf) 0 in + (* Return the format string read and the value just read, + then go on with the rest of the format. *) + scan_fmt ir nf j + + | c -> bad_conversion fmt i c + + and scan_fmt_stoppers i = + if i > lim then i - 1, [] else 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 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 + | '@' when i < lim -> let i = succ i in i, [Sformat.get fmt i] + | '@' when i = lim -> incomplete_format fmt + | _ -> i - 1, [] in + + scan_fmt in + Scanning.reset_token ib; let v = - try scan_fmt 0 (fun () -> f) 0 with + try snd (scan fmt 0 (fun () -> f) 0) with | (Scan_failure _ | Failure _ | End_of_file) as exc -> stack (delay ef ib) exc in - return v;; + return v +;; let mkscanf ib ef fmt = let sc = scan_format ib ef in - ascanf sc fmt;; + ascanf sc fmt +;; let kscanf ib ef fmt = mkscanf ib ef fmt;; @@ -1142,8 +1274,9 @@ let bscanf_format ib fmt f = 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 - f (string_to_format fmt1);; + format_mismatch fmt1 fmt else + f (string_to_format fmt1) +;; let sscanf_format s fmt f = bscanf_format (Scanning.from_string s) fmt f;; @@ -1152,7 +1285,9 @@ let quote_string s = Buffer.add_char b '\"'; Buffer.add_string b s; Buffer.add_char b '\"'; - Buffer.contents b;; + Buffer.contents b +;; let format_from_string s fmt = - sscanf_format (quote_string s) fmt (fun x -> x);; + sscanf_format (quote_string s) fmt (fun x -> x) +;; diff --git a/stdlib/scanf.mli b/stdlib/scanf.mli index 1c393481..ca4c0668 100644 --- a/stdlib/scanf.mli +++ b/stdlib/scanf.mli @@ -11,44 +11,71 @@ (* *) (***********************************************************************) -(* $Id: scanf.mli,v 1.69.4.1 2007/04/26 16:57:37 doligez Exp $ *) +(* $Id: scanf.mli,v 1.79 2008/09/27 20:45:05 weis Exp $ *) (** Formatted input functions. *) -(** {6 Functional input with format strings.} *) - -(** The formatted input functions provided by module [Scanf] are functionals - that apply their function argument to the values they read in the input. - 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 read 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 Introduction} *) + +(** {7 Functional input with format strings} *) + +(** The module [Scanf] provides formatted input functions or {e scanners}. + + The formatted input functions can read from any kind of input, including + strings, files, or anything that can return characters. The more general + source of characters is named a {e scanning buffer} and has type + {!Scanning.scanbuf}. The more general formatted input function reads from + any scanning buffer and is named [bscanf]. + + Generally speaking, the formatted input functions have 3 arguments: + - the first argument is a source of characters for the input, + - the second argument is a format string that specifies the values to + read, + - the third argument is a {e receiver function} that is applied to the + values read. + + Hence, a typical call to the formatted input function {!Scanf.bscanf} is + [bscanf ib fmt f], where: + + - [ib] is a source of characters (typically a {e + scanning buffer} with type {!Scanning.scanbuf}), + + - [fmt] is a format string (the same format strings as those used to print + material with module {!Printf} or {!Format}), + + - [f] is a function that has as many arguments as the number of values to + read in the input. *) + +(** {7 A simple example} *) + +(** As suggested above, the expression [bscanf ib "%d" f] reads a decimal + integer [n] from the source of characters [ib] and returns [f n]. + + For instance, + + - if we use [stdib] as the source of characters ({!Scanning.stdib} is + the predefined input buffer that reads from standard input), + + - if we define the receiver [f] as [let f x = x + 1], + + then [bscanf stdib "%d" f] reads an integer [n] from the standard input + and returns [f n] (that is [n + 1]). Thus, if we evaluate [bscanf stdib + "%d" f], and then enter [41] at the keyboard, we get [42] as the final + result. *) + +(** {7 Formatted input as a functional feature} *) + +(** The Caml scanning facility is reminiscent of the corresponding C feature. + However, it is also largely different, simpler, and yet more powerful: + the formatted input functions are higher-order functionals and the + parameter passing mechanism is just the regular function application not + the variable assigment based mechanism which is typical for formatted + input in imperative languages; the Caml format strings also feature + useful additions to easily define complex tokens; as expected within a + functional programming language, the formatted input functions also + support polymorphism, in particular arbitrary interaction with + polymorphic user-defined scanners. Furthermore, the Caml formatted input + facility is fully type-checked at compile time. *) (** {6 Scanning buffers} *) module Scanning : sig @@ -100,9 +127,8 @@ val from_function : (unit -> char) -> scanbuf;; 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 - one character at a time from the input channel [ic], starting at the - current reading position. *) +(** [Scanning.from_channel ic] returns a scanning buffer which reads from the + input channel [ic], starting at the current reading position. *) val end_of_input : scanbuf -> bool;; (** [Scanning.end_of_input ib] tests the end-of-input condition of the given @@ -118,9 +144,7 @@ val name_of_input : scanbuf -> string;; end;; -exception Scan_failure of string;; -(** The exception raised by formatted input functions when the input cannot be - read according to the given format. *) +(** {6 Type of formatted input functions} *) type ('a, 'b, 'c, 'd) scanner = ('a, Scanning.scanbuf, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c;; @@ -129,7 +153,7 @@ type ('a, 'b, 'c, 'd) scanner = 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]. + from the scanning input 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]: @@ -137,185 +161,220 @@ type ('a, 'b, 'c, 'd) scanner = 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. *) + functions must be provided before the receiver [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 [v] of type [t] followed + by a [';'] character, and returns [f v]. *) -(** {6 Formatted input functions} *) +exception Scan_failure of string;; +(** The exception that formatted input functions raise when the input cannot be + read according to the given format. *) + +(** {6 The general formatted input function} *) 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. - The result of this call to [f] is returned as the result of [bscanf]. - 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], - - scanning indications to specify boundaries of tokens. - - Among plain characters the space character (ASCII code 32) has a - special meaning: it matches ``whitespace'', that is any number of tab, - space, line feed and carriage return characters. Hence, a space in the format - matches any amount of whitespace in the input. - - Conversion specifications consist in the [%] character, followed by - an optional flag, an optional field width, and followed by one or - two conversion characters. The conversion characters and their - meanings are: - - - [d]: reads an optionally signed decimal integer. - - [i]: reads an optionally signed integer - (usual input formats for hexadecimal ([0x[d]+] and [0X[d]+]), - octal ([0o[d]+]), and binary [0b[d]+] notations are understood). - - [u]: reads an unsigned decimal integer. - - [x] or [X]: reads an unsigned hexadecimal integer. - - [o]: reads an unsigned octal integer. - - [s]: reads a string argument that spreads as much as possible, - until the next white space, the next scanning indication, or the - end-of-input is reached. Hence, this conversion always succeeds: - it returns an empty string if the bounding condition holds - when the scan begins. - - [S]: reads a delimited string argument (delimiters and special - escaped characters follow the lexical conventions of Caml). - - [c]: reads a single character. To test the current input character - without reading it, specify a null field width, i.e. use - specification [%0c]. Raise [Invalid_argument], if the field width - specification is greater than 1. - - [C]: reads a single delimited character (delimiters and special - escaped characters follow the lexical conventions of Caml). - - [f], [e], [E], [g], [G]: reads an optionally signed - floating-point number in decimal notation, in the style [dddd.ddd - e/E+-dd]. - - [F]: reads a floating point number according to the lexical - conventions of Caml (hence the decimal point is mandatory if the - exponent part is not mentioned). - - [B]: reads a boolean argument ([true] or [false]). - - [b]: reads a boolean argument (for backward compatibility; do not use - in new programs). - - [ld], [li], [lu], [lx], [lX], [lo]: reads an [int32] argument to - the format specified by the second letter (decimal, hexadecimal, etc). - - [nd], [ni], [nu], [nx], [nX], [no]: reads a [nativeint] argument to - the format specified by the second letter. - - [Ld], [Li], [Lu], [Lx], [LX], [Lo]: reads an [int64] argument to - the format specified by the second letter. - - [\[ range \]]: reads characters that matches one of the characters - mentioned in the range of characters [range] (or not mentioned in - it, if the range starts with [^]). Reads a [string] that can be - empty, if the next input character does not match the range. The set of - characters from [c1] to [c2] (inclusively) is denoted by [c1-c2]. - Hence, [%\[0-9\]] returns a string representing a decimal number - or an empty string if no decimal digit is found; similarly, - [%\[\\048-\\057\\065-\\070\]] returns a string of hexadecimal digits. - If a closing bracket appears in a range, it must occur as the - 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]. - For instance, "%\{%i%\}" reads any format string that can read a value of - type [int]; hence [Scanf.sscanf "fmt:\\\"number is %u\\\"" "fmt:%\{%i%\}"] - succeeds and returns the format string ["number is %u"]. - - [\( fmt %\)]: scanning format substitution. - Reads a format string to replace [fmt]. The format string read - must have the same type as [fmt]. - - [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 that introduces 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 width is composed of an optional integer literal - indicating the maximal width of the token to read. - For instance, [%6d] reads an integer, having at most 6 decimal digits; - [%4f] reads a float with at most 4 characters; and [%8\[\\000-\\255\]] - returns the next 8 characters (or all the characters still available, - if fewer 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 - 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] - character is encountered, the string token spreads as much as - possible. For instance, ["%s@\t"] reads a string up to the next - tab character or to the end of input. If a scanning - indication [\@c] does not follow a string conversion, it is treated - as a plain [c] character. - - 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. - 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: - - - the scanning indications introduce slight differences in the - syntax of [Scanf] format strings compared to those used by the - [Printf] module. However, scanning indications are similar to those - of the [Format] module; hence, when producing formatted text to be - scanned by [!Scanf.bscanf], it is wise to use printing functions - from [Format] (or, if you need to use functions from [Printf], - banish or carefully double check the format strings that contain - ['\@'] characters). - - - in addition to relevant digits, ['_'] characters may appear - 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. - - - the [scanf] facility is not intended for heavy duty lexical - analysis and parsing. If it appears not expressive enough for your - needs, several alternative exists: regular expressions (module - [Str]), stream parsers, [ocamllex]-generated lexers, - [ocamlyacc]-generated parsers. -*) +(** [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. + The result of this call to [f] is returned as the result of the entire + [bscanf] call. + 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. *) + +(** {6 Format string description} *) + +(** 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 the function [f], + - scanning indications to specify boundaries of tokens. *) + +(** {7 The space character in format strings} *) + +(** As mentioned above, a plain character in the format string is just + matched with the characters of the input; however, one character is a + special exception to this simple rule: the space character (ASCII code + 32) does not match a single space character, but any amount of + ``whitespace'' in the input. More precisely, a space inside the format + string matches {e any number} of tab, space, line feed and carriage + return characters. + + Matching {e any} amount of whitespace, a space in the format string + also matches no amount of whitespace at all; hence, the call [bscanf ib + "Price = %d $" (fun p -> p)] succeds and returns [1] when reading an + input with various whitespace in it, such as [Price = 1 $], + [Price = 1 $], or even [Price=1$]. *) + +(** {7 Conversion specifications in format strings} *) + +(** Conversion specifications consist in the [%] character, followed by + an optional flag, an optional field width, and followed by one or + two conversion characters. The conversion characters and their + meanings are: + + - [d]: reads an optionally signed decimal integer. + - [i]: reads an optionally signed integer + (usual input formats for hexadecimal ([0x[d]+] and [0X[d]+]), + octal ([0o[d]+]), and binary [0b[d]+] notations are understood). + - [u]: reads an unsigned decimal integer. + - [x] or [X]: reads an unsigned hexadecimal integer. + - [o]: reads an unsigned octal integer. + - [s]: reads a string argument that spreads as much as possible, until the + following bounding condition holds: a whitespace has been found, a + scanning indication has been encountered, or the end-of-input has been + reached. + Hence, this conversion always succeeds: it returns an empty + string, if the bounding condition holds when the scan begins. + - [S]: reads a delimited string argument (delimiters and special + escaped characters follow the lexical conventions of Caml). + - [c]: reads a single character. To test the current input character + without reading it, specify a null field width, i.e. use + specification [%0c]. Raise [Invalid_argument], if the field width + specification is greater than 1. + - [C]: reads a single delimited character (delimiters and special + escaped characters follow the lexical conventions of Caml). + - [f], [e], [E], [g], [G]: reads an optionally signed + floating-point number in decimal notation, in the style [dddd.ddd + e/E+-dd]. + - [F]: reads a floating point number according to the lexical + conventions of Caml (hence the decimal point is mandatory if the + exponent part is not mentioned). + - [B]: reads a boolean argument ([true] or [false]). + - [b]: reads a boolean argument (for backward compatibility; do not use + in new programs). + - [ld], [li], [lu], [lx], [lX], [lo]: reads an [int32] argument to + the format specified by the second letter (decimal, hexadecimal, etc). + - [nd], [ni], [nu], [nx], [nX], [no]: reads a [nativeint] argument to + the format specified by the second letter. + - [Ld], [Li], [Lu], [Lx], [LX], [Lo]: reads an [int64] argument to + the format specified by the second letter. + - [\[ range \]]: reads characters that matches one of the characters + mentioned in the range of characters [range] (or not mentioned in + it, if the range starts with [^]). Reads a [string] that can be + empty, if the next input character does not match the range. The set of + characters from [c1] to [c2] (inclusively) is denoted by [c1-c2]. + Hence, [%\[0-9\]] returns a string representing a decimal number + or an empty string if no decimal digit is found; similarly, + [%\[\\048-\\057\\065-\\070\]] returns a string of hexadecimal digits. + If a closing bracket appears in a range, it must occur as the + 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. + The format string read must have the same type as the format string + specification [fmt]. + For instance, ["%\{%i%\}"] reads any format string that can read a value of + type [int]; hence [Scanf.sscanf "fmt:\\\"number is %u\\\"" "fmt:%\{%i%\}"] + succeeds and returns the format string ["number is %u"]. + - [\( fmt %\)]: scanning format substitution. + Reads a format string to replace [fmt]. + The format string read must have the same type as the format string + specification [fmt]. + For instance, ["%\( %i% \)"] reads any format string that can read a value + of type [int]; hence [Scanf.sscanf "\\\"%4d\\\"1234.00" "%\(%i%\)"] + is equivalent to [Scanf.sscanf "1234.00" "%4d"]. + - [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 that introduces 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 width is composed of an optional integer literal + indicating the maximal width of the token to read. + For instance, [%6d] reads an integer, having at most 6 decimal digits; + [%4f] reads a float with at most 4 characters; and [%8\[\\000-\\255\]] + returns the next 8 characters (or all the characters still available, + if fewer than 8 characters are available in the input). + + Notes: + + - as mentioned above, a [%s] convertion always succeeds, even if there is + nothing to read in the input: it simply returns [""]. + + - in addition to the relevant digits, ['_'] characters may appear + 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. + + - the [scanf] facility is not intended for heavy duty lexical + analysis and parsing. If it appears not expressive enough for your + needs, several alternative exists: regular expressions (module + [Str]), stream parsers, [ocamllex]-generated lexers, + [ocamlyacc]-generated parsers. *) + +(** {7 Scanning indications in format strings} *) + +(** Scanning indications appear just after the string conversions [%s] + and [%\[ range \]] to delimit the end of the token. A scanning + indication is introduced by a [@] character, followed by some + constant character [c]. It means that the string token should end + just before the next matching [c] (which is skipped). If no [c] + character is encountered, the string token spreads as much as + possible. For instance, ["%s@\t"] reads a string up to the next + tab character or to the end of input. If a scanning + indication [\@c] does not follow a string conversion, it is treated + as a plain [c] character. + + Note: + + - the scanning indications introduce slight differences in the syntax of + [Scanf] format strings, compared to those used for the [Printf] + module. However, the scanning indications are similar to those used in + the [Format] module; hence, when producing formatted text to be scanned + by [!Scanf.bscanf], it is wise to use printing functions from the + [Format] module (or, if you need to use functions from [Printf], banish + or carefully double check the format strings that contain ['\@'] + characters). *) + +(** {7 Exceptions during scanning} *) + +(** Scanners may raise the following exceptions when the input cannot be read + according to the format string: + + - 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. + + - Raise [Invalid_argument] if the format string is invalid. + + Note: + + - 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. *) + +(** {6 Specialized formatted input functions} *) val fscanf : in_channel -> ('a, 'b, 'c, 'd) scanner;; (** Same as {!Scanf.bscanf}, but reads from the given channel. 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 you make careful use of partial - application). Hence, there are chances that some characters seem - to be skipped (in fact they are pending in the previously used - 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). + buffer, be aware that each [fscanf] invocation will operate with a + scanning buffer reading from the given channel. This extra level of + bufferization can lead to strange scanning behaviour if you use low level + primitives on the channel (reading characters, seeking the reading + position, and so on). - To avoid confusion, consider using [bscanf] with an explicitly - created scanning buffer. Use for instance [Scanning.from_file f] - to allocate the scanning buffer reading from file [f]. - - This method is not only clearer it is also faster, since scanning - buffers to files are optimized for fast buffered reading. *) + As a consequence, never mixt direct low level reading and high level + scanning from the same input channel. *) val sscanf : string -> ('a, 'b, 'c, 'd) scanner;; (** Same as {!Scanf.bscanf}, but reads from the given string. *) @@ -328,19 +387,21 @@ val kscanf : 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 calls the - error handling function [ef] with the scanning buffer and the - exception that aborted the scanning process. *) + [ef] that is called in case of error: if the scanning process or + some conversion fails, the scanning function aborts and calls the + error handling function [ef] with the scanning buffer and the + exception that aborted the scanning process. *) + +(** {6 Reading format strings from input} *) val bscanf_format : 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. - Raise [Scan_failure] if the format string value read doesn't have the - same type as [fmt]. *) + buffer [ib], according to the given format string [fmt], and applies [f] to + the resulting format string value. + Raise [Scan_failure] if the format string value read does not have the + same type as [fmt]. *) val sscanf_format : string -> ('a, 'b, 'c, 'd, 'e, 'f) format6 -> @@ -351,6 +412,6 @@ 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]. - Raise [Scan_failure] if [s], considered as a format string, doesn't - have the same type as [fmt]. *) + according to the given format string [fmt]. + Raise [Scan_failure] if [s], considered as a format string, does not + have the same type as [fmt]. *) diff --git a/stdlib/stdlib.mllib b/stdlib/stdlib.mllib index 58947c9b..c23f5045 100644 --- a/stdlib/stdlib.mllib +++ b/stdlib/stdlib.mllib @@ -1,6 +1,6 @@ # 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 $ +# $Id: stdlib.mllib,v 1.2 2008/08/01 16:57:10 mauny Exp $ Pervasives Arg @@ -8,6 +8,7 @@ Array ArrayLabels Buffer Callback +CamlinternalLazy CamlinternalMod CamlinternalOO Char diff --git a/stdlib/stream.ml b/stdlib/stream.ml index 192430ea..755e7434 100644 --- a/stdlib/stream.ml +++ b/stdlib/stream.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: stream.ml,v 1.13 2001/12/07 13:40:59 xleroy Exp $ *) +(* $Id: stream.ml,v 1.14 2008/06/18 15:35:02 mauny Exp $ *) (* The fields of type t are not mutable to preserve polymorphism of the empty stream. This is type safe because the empty stream is never @@ -22,7 +22,7 @@ and 'a data = Sempty | Scons of 'a * 'a data | Sapp of 'a data * 'a data - | Slazy of (unit -> 'a data) + | Slazy of 'a data Lazy.t | Sgen of 'a gen | Sbuffio of buffio and 'a gen = { mutable curr : 'a option option; func : int -> 'a option } @@ -42,44 +42,54 @@ let fill_buff b = b.len <- input b.ic b.buff 0 (String.length b.buff); b.ind <- 0 ;; -let rec get_data = - function - Sempty -> None - | Scons (a, d) -> Some (a, d) - | Sapp (d1, d2) -> - begin match get_data d1 with - Some (a, d1) -> Some (a, Sapp (d1, d2)) - | None -> get_data d2 - end - | Slazy f -> - begin match f () with - Sgen _ | Sbuffio _ -> failwith "illegal stream concatenation" - | x -> get_data x - end - | Sgen _ | Sbuffio _ -> - failwith "illegal stream concatenation" +let rec get_data count d = match d with + (* Returns either Sempty or Scons(a, _) even when d is a generator + or a buffer. In those cases, the item a is seen as extracted from + the generator/buffer. + The count parameter is used for calling `Sgen-functions'. *) + Sempty | Scons (_, _) -> d + | Sapp (d1, d2) -> + begin match get_data count d1 with + Scons (a, d11) -> Scons (a, Sapp (d11, d2)) + | Sempty -> get_data count d2 + | _ -> assert false + end + | Sgen {curr = Some None; func = _ } -> Sempty + | Sgen ({curr = Some(Some a); func = f} as g) -> + g.curr <- None; Scons(a, d) + | Sgen g -> + begin match g.func count with + None -> g.curr <- Some(None); Sempty + | Some a -> Scons(a, d) + (* Warning: anyone using g thinks that an item has been read *) + end + | Sbuffio b -> + if b.ind >= b.len then fill_buff b; + if b.len == 0 then Sempty else + let r = Obj.magic (String.unsafe_get b.buff b.ind) in + (* Warning: anyone using g thinks that an item has been read *) + b.ind <- succ b.ind; Scons(r, d) + | Slazy f -> get_data count (Lazy.force f) ;; let rec peek s = - match s.data with - Sempty -> None - | Scons (a, _) -> Some a - | Sapp (_, _) -> - begin match get_data s.data with - Some (a, d) -> set_data s (Scons (a, d)); Some a - | None -> None - end - | Slazy f -> - begin match f () with - Sgen _ | Sbuffio _ -> failwith "illegal stream concatenation" - | d -> set_data s d; peek s - end - | Sgen {curr = Some a} -> a - | Sgen g -> let x = g.func s.count in g.curr <- Some x; x - | Sbuffio b -> - if b.ind >= b.len then fill_buff b; - if b.len == 0 then begin set_data s Sempty; None end - else Some (Obj.magic (String.unsafe_get b.buff b.ind)) + (* consult the first item of s *) + match s.data with + Sempty -> None + | Scons (a, _) -> Some a + | Sapp (_, _) -> + begin match get_data s.count s.data with + Scons(a, _) as d -> set_data s d; Some a + | Sempty -> None + | _ -> assert false + end + | Slazy f -> set_data s (Lazy.force f); peek s + | Sgen {curr = Some a} -> a + | Sgen g -> let x = g.func s.count in g.curr <- Some x; x + | Sbuffio b -> + if b.ind >= b.len then fill_buff b; + if b.len == 0 then begin set_data s Sempty; None end + else Some (Obj.magic (String.unsafe_get b.buff b.ind)) ;; let rec junk s = @@ -152,13 +162,13 @@ let icons i s = {count = 0; data = Scons (i, s.data)};; let ising i = {count = 0; data = Scons (i, Sempty)};; let lapp f s = - {count = 0; data = Slazy (fun _ -> Sapp ((f ()).data, s.data))} + {count = 0; data = Slazy (lazy(Sapp ((f ()).data, s.data)))} ;; -let lcons f s = {count = 0; data = Slazy (fun _ -> Scons (f (), s.data))};; -let lsing f = {count = 0; data = Slazy (fun _ -> Scons (f (), Sempty))};; +let lcons f s = {count = 0; data = Slazy (lazy(Scons (f (), s.data)))};; +let lsing f = {count = 0; data = Slazy (lazy(Scons (f (), Sempty)))};; let sempty = {count = 0; data = Sempty};; -let slazy f = {count = 0; data = Slazy (fun _ -> (f ()).data)};; +let slazy f = {count = 0; data = Slazy (lazy(f ()).data)};; (* For debugging use *) @@ -184,7 +194,7 @@ and dump_data f = print_string ", "; dump_data f d2; print_string ")" - | Slazy f -> print_string "Slazy" + | Slazy _ -> print_string "Slazy" | Sgen _ -> print_string "Sgen" | Sbuffio b -> print_string "Sbuffio" ;; diff --git a/stdlib/string.ml b/stdlib/string.ml index 043dad96..292b8ba4 100644 --- a/stdlib/string.ml +++ b/stdlib/string.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: string.ml,v 1.26 2007/01/30 09:34:36 xleroy Exp $ *) +(* $Id: string.ml,v 1.28 2008/07/22 11:29:00 weis Exp $ *) (* String operations *) @@ -87,8 +87,8 @@ let escaped s = for i = 0 to length s - 1 do n := !n + (match unsafe_get s i with - '"' | '\\' | '\n' | '\t' -> 2 - | c -> if is_printable c then 1 else 4) + | '"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2 + | c -> if is_printable c then 1 else 4) done; if !n = length s then s else begin let s' = create !n in @@ -96,12 +96,16 @@ let escaped s = for i = 0 to length s - 1 do begin match unsafe_get s i with - ('"' | '\\') as c -> + | ('"' | '\\') as c -> unsafe_set s' !n '\\'; incr n; unsafe_set s' !n c | '\n' -> unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'n' | '\t' -> unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 't' + | '\r' -> + unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'r' + | '\b' -> + unsafe_set s' !n '\\'; incr n; unsafe_set s' !n 'b' | c -> if is_printable c then unsafe_set s' !n c @@ -144,34 +148,40 @@ let uncapitalize s = apply1 Char.lowercase s let rec index_rec s lim i c = if i >= lim then raise Not_found else - if unsafe_get s i = c then i else index_rec s lim (i+1) c;; + if unsafe_get s i = c then i else index_rec s lim (i + 1) c;; let index s c = index_rec s (length s) 0 c;; let index_from s i c = - if i < 0 || i > length s then invalid_arg "String.index_from" else - index_rec s (length s) i c;; + let l = length s in + if i < 0 || i >= l then invalid_arg "String.index_from" else + index_rec s l i c;; let rec rindex_rec s i c = if i < 0 then raise Not_found else - if unsafe_get s i = c then i else rindex_rec s (i-1) c;; + if unsafe_get s i = c then i else rindex_rec s (i - 1) c;; let rindex s c = rindex_rec s (length s - 1) c;; let rindex_from s i c = - if i < -1 || i >= length s then invalid_arg "String.rindex_from" else + let l = length s in + if i < 0 || i >= l then invalid_arg "String.rindex_from" else rindex_rec s i c;; let contains_from s i c = - if i < 0 || i > length s then invalid_arg "String.contains_from" else - try ignore(index_rec s (length s) i c); true with Not_found -> false;; + let l = length s in + if i < 0 || i >= l then invalid_arg "String.contains_from" else + try ignore (index_rec s l i c); true with Not_found -> false;; -let rcontains_from s i c = - if i < 0 || i >= length s then invalid_arg "String.rcontains_from" else - try ignore(rindex_rec s i c); true with Not_found -> false;; +let contains s c = + let l = length s in + l <> 0 && contains_from s 0 c;; -let contains s c = contains_from s 0 c;; +let rcontains_from s i c = + let l = length s in + if i < 0 || i >= l then invalid_arg "String.rcontains_from" else + try ignore (rindex_rec s i c); true with Not_found -> false;; type t = string -let compare (x: t) (y: t) = Pervasives.compare x y +let compare = Pervasives.compare diff --git a/stdlib/string.mli b/stdlib/string.mli index 09cfb93c..57ba2524 100644 --- a/stdlib/string.mli +++ b/stdlib/string.mli @@ -11,39 +11,49 @@ (* *) (***********************************************************************) -(* $Id: string.mli,v 1.37 2004/11/25 00:04:15 doligez Exp $ *) - -(** String operations. *) +(* $Id: string.mli,v 1.37.20.1 2008/10/08 13:07:13 doligez Exp $ *) + +(** String operations. + Given a string [s] of length [l], we call character number in [s] + the index of a character in [s]. Indexes start at [0], and we will + call a character number valid in [s] if it falls within the range + [[0...l-1]]. A position is the point between two characters or at + the beginning or end of the string. We call a position valid + in [s] if it falls within the range [[0...l]]. Note that character + number [n] is between positions [n] and [n+1]. + + Two parameters [start] and [len] are said to designate a valid + substring of [s] if [len >= 0] and [start] and [start+len] are + valid positions in [s]. + *) external length : string -> int = "%string_length" (** Return the length (number of characters) of the given string. *) 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]. 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)]. *) + Raise [Invalid_argument] if [n] not a valid character number in [s]. *) 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]. 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)]. *) + + Raise [Invalid_argument] if [n] is not a valid character number in [s]. *) external create : int -> string = "caml_create_string" (** [String.create n] returns a fresh string of length [n]. The string initially contains arbitrary characters. - Raise [Invalid_argument] if [n < 0] or [n > Sys.max_string_length]. -*) + + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) val make : int -> char -> string (** [String.make n c] returns a fresh string of length [n], filled with the character [c]. + Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}.*) val copy : string -> string @@ -51,16 +61,16 @@ val copy : string -> string val sub : string -> int -> int -> string (** [String.sub s start len] returns a fresh string of length [len], - containing the characters number [start] to [start + len - 1] - of string [s]. + containing the substring of [s] that starts at position [start] and + has length [len]. + Raise [Invalid_argument] if [start] and [len] do not - designate a valid substring of [s]; that is, if [start < 0], - or [len < 0], or [start + len > ]{!String.length}[ s]. *) + designate a valid substring of [s]. *) val fill : string -> int -> int -> char -> unit (** [String.fill s start len c] modifies string [s] in place, - replacing the characters number [start] to [start + len - 1] - by [c]. + replacing [len] characters by [c], starting at [start]. + Raise [Invalid_argument] if [start] and [len] do not designate a valid substring of [s]. *) @@ -69,7 +79,8 @@ val blit : string -> int -> string -> int -> int -> unit from string [src], starting at character number [srcoff], to string [dst], starting at character number [dstoff]. It works correctly even if [src] and [dst] are the same string, - and the source and destination chunks overlap. + and the source and destination intervals overlap. + Raise [Invalid_argument] if [srcoff] and [len] do not designate a valid substring of [src], or if [dstoff] and [len] do not designate a valid substring of [dst]. *) @@ -91,25 +102,33 @@ val escaped : string -> string not a copy. *) val index : string -> char -> int -(** [String.index s c] returns the position of the leftmost +(** [String.index s c] returns the character number of the first occurrence of character [c] in string [s]. + Raise [Not_found] if [c] does not occur in [s]. *) val rindex : string -> char -> int -(** [String.rindex s c] returns the position of the rightmost +(** [String.rindex s c] returns the character number of the last occurrence of character [c] in string [s]. + Raise [Not_found] if [c] does not occur in [s]. *) val index_from : string -> int -> char -> int -(** Same as {!String.index}, but start - searching at the character position given as second argument. - [String.index s c] is equivalent to [String.index_from s 0 c].*) +(** [String.index_from s i c] returns the character number of the + first occurrence of character [c] in string [s] after position [i]. + [String.index s c] is equivalent to [String.index_from s 0 c]. + + Raise [Invalid_argument] if [i] is not a valid position in [s]. + Raise [Not_found] if [c] does not occur in [s] after position [i]. *) val rindex_from : string -> int -> char -> int -(** Same as {!String.rindex}, but start - searching at the character position given as second argument. +(** [String.rindex_from s i c] returns the character number of the + last occurrence of character [c] in string [s] before position [i+1]. [String.rindex s c] is equivalent to - [String.rindex_from s (String.length s - 1) c]. *) + [String.rindex_from s (String.length s - 1) c]. + + Raise [Invalid_argument] if [i+1] is not a valid position in [s]. + Raise [Not_found] if [c] does not occur in [s] before position [i+1]. *) val contains : string -> char -> bool (** [String.contains s c] tests if character [c] @@ -117,15 +136,18 @@ val contains : string -> char -> bool val contains_from : string -> int -> char -> bool (** [String.contains_from s start c] tests if character [c] - appears in the substring of [s] starting from [start] to the end - of [s]. - Raise [Invalid_argument] if [start] is not a valid index of [s]. *) + appears in [s] after position [start]. + [String.contains s c] is equivalent to + [String.contains_from s 0 c]. + + Raise [Invalid_argument] if [start] is not a valid position in [s]. *) val rcontains_from : string -> int -> char -> bool (** [String.rcontains_from s stop c] tests if character [c] - appears in the substring of [s] starting from the beginning - of [s] to index [stop]. - Raise [Invalid_argument] if [stop] is not a valid index of [s]. *) + appears in [s] before position [stop+1]. + + Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid + position in [s]. *) val uppercase : string -> string (** Return a copy of the argument, with all lowercase letters diff --git a/stdlib/weak.ml b/stdlib/weak.ml index 1661fe62..8358d6e3 100644 --- a/stdlib/weak.ml +++ b/stdlib/weak.ml @@ -11,8 +11,7 @@ (* *) (***********************************************************************) -(* $Id: weak.ml,v 1.14.2.2 2008/01/29 13:14:33 doligez Exp $ *) - +(* $Id: weak.ml,v 1.17 2008/02/29 14:21:22 doligez Exp $ *) (** Weak array operations *) diff --git a/stdlib/weak.mli b/stdlib/weak.mli index 9789d075..437bab24 100644 --- a/stdlib/weak.mli +++ b/stdlib/weak.mli @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: weak.mli,v 1.15 2004/02/02 14:43:12 doligez Exp $ *) +(* $Id: weak.mli,v 1.16 2008/09/17 14:55:30 doligez Exp $ *) (** Arrays of weak pointers and hash tables of weak pointers. *) @@ -24,9 +24,11 @@ type 'a t any time. A weak pointer is said to be full if it points to a value, empty if the value was erased by the GC. - Note that weak arrays cannot be marshaled using - {!Pervasives.output_value} or the functions of the {!Marshal} - module. + + Notes: + - Integers are not allocated and cannot be stored in weak arrays. + - Weak arrays cannot be marshaled using {!Pervasives.output_value} + nor the functions of the {!Marshal} module. *) diff --git a/tools/.depend b/tools/.depend index 3ce73f53..b51459b6 100644 --- a/tools/.depend +++ b/tools/.depend @@ -1,8 +1,11 @@ depend.cmi: ../parsing/parsetree.cmi +profiling.cmi: addlabels.cmo: ../parsing/parsetree.cmi ../parsing/parse.cmi \ ../parsing/longident.cmi ../parsing/location.cmi ../parsing/asttypes.cmi addlabels.cmx: ../parsing/parsetree.cmi ../parsing/parse.cmx \ ../parsing/longident.cmx ../parsing/location.cmx ../parsing/asttypes.cmi +cvt_emit.cmo: +cvt_emit.cmx: depend.cmo: ../parsing/parsetree.cmi ../parsing/longident.cmi \ ../parsing/location.cmi depend.cmi depend.cmx: ../parsing/parsetree.cmi ../parsing/longident.cmx \ @@ -23,8 +26,12 @@ dumpobj.cmx: ../utils/tbl.cmx opnames.cmx ../bytecomp/opcodes.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 +myocamlbuild_config.cmo: +myocamlbuild_config.cmx: objinfo.cmo: ../utils/config.cmi ../bytecomp/cmo_format.cmi objinfo.cmx: ../utils/config.cmx ../bytecomp/cmo_format.cmi +ocaml299to3.cmo: +ocaml299to3.cmx: ocamlcp.cmo: ../driver/main_args.cmi ocamlcp.cmx: ../driver/main_args.cmx ocamldep.cmo: ../parsing/syntaxerr.cmi ../parsing/parsetree.cmi \ @@ -47,6 +54,8 @@ ocamlprof.cmx: ../utils/warnings.cmx ../parsing/syntaxerr.cmx \ ../parsing/parsetree.cmi ../parsing/parse.cmx ../utils/misc.cmx \ ../parsing/location.cmx ../parsing/lexer.cmx ../utils/config.cmx \ ../utils/clflags.cmx +opnames.cmo: +opnames.cmx: primreq.cmo: ../utils/config.cmi ../bytecomp/cmo_format.cmi primreq.cmx: ../utils/config.cmx ../bytecomp/cmo_format.cmi profiling.cmo: profiling.cmi diff --git a/tools/Makefile b/tools/Makefile index 557a3caa..6d80e35c 100644 --- a/tools/Makefile +++ b/tools/Makefile @@ -10,256 +10,12 @@ # # ######################################################################### -# $Id: Makefile,v 1.64 2007/02/07 10:31:36 ertai Exp $ +# $Id: Makefile,v 1.66 2007/11/22 22:14:43 doligez Exp $ -include ../config/Makefile - -CAMLRUN=../boot/ocamlrun -CAMLC=$(CAMLRUN) ../boot/ocamlc -nostdlib -I ../boot -CAMLOPT=$(CAMLRUN) ../ocamlopt -nostdlib -I ../stdlib -CAMLLEX=$(CAMLRUN) ../boot/ocamllex -INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \ - -I ../driver -COMPFLAGS= -warn-error A $(INCLUDES) -LINKFLAGS=$(INCLUDES) - -all: ocamldep ocamlprof ocamlcp ocamlmktop ocamlmklib scrapelabels addlabels \ - dumpobj - -opt.opt: ocamldep.opt - -# The dependency generator - -CAMLDEP_OBJ=depend.cmo ocamldep.cmo -CAMLDEP_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ - linenum.cmo warnings.cmo location.cmo longident.cmo \ - syntaxerr.cmo parser.cmo lexer.cmo parse.cmo - -ocamldep: depend.cmi $(CAMLDEP_OBJ) - $(CAMLC) $(LINKFLAGS) -o ocamldep $(CAMLDEP_IMPORTS) $(CAMLDEP_OBJ) - -ocamldep.opt: depend.cmi $(CAMLDEP_OBJ:.cmo=.cmx) - $(CAMLOPT) $(LINKFLAGS) -o ocamldep.opt $(CAMLDEP_IMPORTS:.cmo=.cmx) \ - $(CAMLDEP_OBJ:.cmo=.cmx) - -# ocamldep is precious: sometimes we are stuck in the middle of a -# bootstrap and we need to remake the dependencies -clean:: - if test -f ocamldep; then mv -f ocamldep ocamldep.bak; else :; fi - rm -f ocamldep.opt - -install:: - cp ocamldep $(BINDIR)/ocamldep$(EXE) - if test -f ocamldep.opt; \ - then cp ocamldep.opt $(BINDIR)/ocamldep.opt$(EXE); else :; fi - -# The profiler - -CSLPROF=ocamlprof.cmo -CSLPROF_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ - linenum.cmo warnings.cmo location.cmo longident.cmo \ - syntaxerr.cmo parser.cmo lexer.cmo parse.cmo - -ocamlprof: $(CSLPROF) profiling.cmo - $(CAMLC) $(LINKFLAGS) -o ocamlprof $(CSLPROF_IMPORTS) $(CSLPROF) - -ocamlcp: ocamlcp.cmo - $(CAMLC) $(LINKFLAGS) -o ocamlcp main_args.cmo ocamlcp.cmo - -install:: - cp ocamlprof $(BINDIR)/ocamlprof$(EXE) - cp ocamlcp $(BINDIR)/ocamlcp$(EXE) - cp profiling.cmi profiling.cmo $(LIBDIR) - -clean:: - rm -f ocamlprof ocamlcp +include Makefile.shared # To make custom toplevels ocamlmktop: ocamlmktop.tpl ../config/Makefile sed -e 's|%%BINDIR%%|$(BINDIR)|' ocamlmktop.tpl > ocamlmktop chmod +x ocamlmktop - -install:: - cp ocamlmktop $(BINDIR)/ocamlmktop - -clean:: - rm -f ocamlmktop - -# To help building mixed-mode libraries (Caml + C) - -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 - -clean:: - rm -f ocamlmklib - -ocamlmklib.ml: ocamlmklib.mlp ../config/Makefile - echo '(* THIS FILE IS GENERATED FROM ocamlmklib.mlp *)' >ocamlmklib.ml - sed -e "s|%%BINDIR%%|$(BINDIR)|" \ - -e "s|%%SUPPORTS_SHARED_LIBRARIES%%|$(SUPPORTS_SHARED_LIBRARIES)|" \ - -e "s|%%MKSHAREDLIB%%|$(MKSHAREDLIB)|" \ - -e "s|%%BYTECCRPATH%%|$(BYTECCRPATH)|" \ - -e "s|%%NATIVECCRPATH%%|$(NATIVECCRPATH)|" \ - -e "s|%%MKSHAREDLIBRPATH%%|$(MKSHAREDLIBRPATH)|" \ - -e "s|%%RANLIB%%|$(RANLIB)|" \ - ocamlmklib.mlp >> ocamlmklib.ml - -beforedepend:: ocamlmklib.ml - -clean:: - rm -f ocamlmklib.ml - -# Converter olabl/ocaml 2.99 to ocaml 3 - -OCAML299TO3= lexer299.cmo ocaml299to3.cmo -LIBRARY3= misc.cmo warnings.cmo linenum.cmo location.cmo - -ocaml299to3: $(OCAML299TO3) - $(CAMLC) $(LINKFLAGS) -o ocaml299to3 $(LIBRARY3) $(OCAML299TO3) - -lexer299.ml: lexer299.mll - $(CAMLLEX) lexer299.mll - -#install:: -# cp ocaml299to3 $(BINDIR)/ocaml299to3$(EXE) - -clean:: - rm -f ocaml299to3 lexer299.ml - -# Label remover for interface files (upgrade 3.02 to 3.03) - -SCRAPELABELS= lexer301.cmo scrapelabels.cmo - -scrapelabels: $(SCRAPELABELS) - $(CAMLC) $(LINKFLAGS) -o scrapelabels $(LIBRARY3) $(SCRAPELABELS) - -lexer301.ml: lexer301.mll - $(CAMLLEX) lexer301.mll - -install:: - cp scrapelabels $(LIBDIR) - -clean:: - rm -f scrapelabels lexer301.ml - -# Insert labels following an interface file (upgrade 3.02 to 3.03) - -ADDLABELS_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ - linenum.cmo warnings.cmo location.cmo longident.cmo \ - syntaxerr.cmo parser.cmo lexer.cmo parse.cmo - -addlabels: addlabels.ml - $(CAMLC) $(LINKFLAGS) -w sl -o addlabels \ - $(ADDLABELS_IMPORTS) addlabels.ml - -install:: - cp addlabels $(LIBDIR) - -clean:: - rm -f addlabels - -# The preprocessor for asm generators - -CVT_EMIT=cvt_emit.cmo - -cvt_emit: $(CVT_EMIT) - $(CAMLC) $(LINKFLAGS) -o cvt_emit $(CVT_EMIT) - -# cvt_emit is precious: sometimes we are stuck in the middle of a -# bootstrap and we need to remake the dependencies -clean:: - if test -f cvt_emit; then mv -f cvt_emit cvt_emit.bak; else :; fi - -cvt_emit.ml: cvt_emit.mll - $(CAMLLEX) cvt_emit.mll - -clean:: - rm -f cvt_emit.ml - -beforedepend:: cvt_emit.ml - -# The bytecode disassembler - -DUMPOBJ=opnames.cmo dumpobj.cmo - -dumpobj: $(DUMPOBJ) - $(CAMLC) $(LINKFLAGS) -o dumpobj \ - misc.cmo tbl.cmo config.cmo ident.cmo \ - opcodes.cmo bytesections.cmo $(DUMPOBJ) - -clean:: - rm -f dumpobj - -opnames.ml: ../byterun/instruct.h - 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 > opnames.ml - -clean:: - rm -f opnames.ml - -beforedepend:: opnames.ml - -# Dump .cmx files - -dumpapprox: dumpapprox.cmo - $(CAMLC) $(LINKFLAGS) -o dumpapprox config.cmo dumpapprox.cmo - -clean:: - rm -f dumpapprox - -# Print imported interfaces for .cmo files - -objinfo: objinfo.cmo - $(CAMLC) $(LINKFLAGS) -o objinfo config.cmo objinfo.cmo - -clean:: - rm -f objinfo - -# Scan object files for required primitives - -PRIMREQ=primreq.cmo - -primreq: $(PRIMREQ) - $(CAMLC) $(LINKFLAGS) -o primreq config.cmo $(PRIMREQ) - -clean:: - rm -f primreq - -# Common stuff - -.SUFFIXES: -.SUFFIXES: .ml .cmo .mli .cmi .cmx - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -.ml.cmx: - $(CAMLOPT) $(COMPFLAGS) -c $< - -clean:: - rm -f *.cmo *.cmi - -depend: beforedepend - $(CAMLRUN) ./ocamldep $(INCLUDES) *.mli *.ml > .depend - -include .depend diff --git a/tools/Makefile.nt b/tools/Makefile.nt index 14e82384..0fc67a6a 100644 --- a/tools/Makefile.nt +++ b/tools/Makefile.nt @@ -10,163 +10,14 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.24 2003/03/24 15:23:30 xleroy Exp $ +# $Id: Makefile.nt,v 1.26 2007/11/07 10:14:21 frisch Exp $ -include ../config/Makefile - -CAMLRUN=../boot/ocamlrun -CAMLC=$(CAMLRUN) ../boot/ocamlc -I ../boot -CAMLOPT=$(CAMLRUN) ../ocamlopt -CAMLLEX=$(CAMLRUN) ../boot/ocamllex -INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \ - -I ../driver -COMPFLAGS=$(INCLUDES) -LINKFLAGS=$(INCLUDES) - -all: ocamldep ocamlprof ocamlcp.exe ocamlmktop.exe primreq - -opt.opt: depend.cmx - -# The dependency generator - -CAMLDEP=depend.cmo ocamldep.cmo -CAMLDEP_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ - linenum.cmo warnings.cmo location.cmo longident.cmo \ - syntaxerr.cmo parser.cmo lexer.cmo parse.cmo - -ocamldep: depend.cmi $(CAMLDEP) - $(CAMLC) $(LINKFLAGS) -o ocamldep $(CAMLDEP_IMPORTS) $(CAMLDEP) - -depend.cmx: depend.ml - $(CAMLOPT) $(INCLUDES) -I ../stdlib depend.ml - -clean:: - rm -f ocamldep - -install:: - cp ocamldep $(BINDIR)/ocamldep.exe - -beforedepend:: ocamldep.ml - -# The profiler - -CSLPROF=ocamlprof.cmo -CSLPROF_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ - linenum.cmo warnings.cmo location.cmo longident.cmo \ - syntaxerr.cmo parser.cmo lexer.cmo parse.cmo - -ocamlprof: $(CSLPROF) profiling.cmo - $(CAMLC) $(LINKFLAGS) -o ocamlprof $(CSLPROF_IMPORTS) $(CSLPROF) - -ocamlcp.exe: ocamlcp.cmo - $(CAMLC) $(LINKFLAGS) -o ocamlcp.exe main_args.cmo ocamlcp.cmo - -install:: - cp ocamlprof $(BINDIR)/ocamlprof.exe - cp ocamlcp.exe $(BINDIR)/ocamlcp.exe - cp profiling.cmi profiling.cmo $(LIBDIR) - -clean:: - rm -f ocamlprof ocamlcp.exe +include Makefile.shared # To make custom toplevels OCAMLMKTOP=ocamlmktop.cmo OCAMLMKTOP_IMPORTS=misc.cmo config.cmo clflags.cmo ccomp.cmo -ocamlmktop.exe: $(OCAMLMKTOP) - $(CAMLC) $(LINKFLAGS) -o ocamlmktop.exe $(OCAMLMKTOP_IMPORTS) $(OCAMLMKTOP) - -install:: - cp ocamlmktop.exe $(BINDIR)/ocamlmktop.exe - -clean:: - rm -f ocamlmktop.exe - -# The preprocessor for asm generators - -CVT_EMIT=cvt_emit.cmo - -cvt_emit: $(CVT_EMIT) - $(CAMLC) $(LINKFLAGS) -o cvt_emit $(CVT_EMIT) - -clean:: - rm -f cvt_emit - -cvt_emit.ml: cvt_emit.mll - $(CAMLLEX) cvt_emit.mll - -clean:: - rm -f cvt_emit.ml - -beforedepend:: cvt_emit.ml - -# The bytecode disassembler - -DUMPOBJ=opnames.cmo dumpobj.cmo - -dumpobj: $(DUMPOBJ) - $(CAMLC) $(LINKFLAGS) -o dumpobj \ - misc.cmo tbl.cmo config.cmo ident.cmo \ - opcodes.cmo bytesections.cmo $(DUMPOBJ) - -clean:: - rm -f dumpobj - -opnames.ml: ../byterun/instruct.h - sed -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 > opnames.ml - -clean:: - rm -f opnames.ml - -beforedepend:: opnames.ml - -# Dump .cmx files - -dumpapprox: dumpapprox.cmo - $(CAMLC) $(LINKFLAGS) -o dumpapprox config.cmo dumpapprox.cmo - -clean:: - rm -f dumpapprox - -# Print imported interfaces for .cmo files - -objinfo: objinfo.cmo - $(CAMLC) $(LINKFLAGS) -o objinfo config.cmo objinfo.cmo - -clean:: - rm -f objinfo - -# Scan object files for required primitives - -PRIMREQ=primreq.cmo - -primreq: $(PRIMREQ) - $(CAMLC) $(LINKFLAGS) -o primreq config.cmo $(PRIMREQ) - -clean:: - rm -f primreq - -# Common stuff - -.SUFFIXES: -.SUFFIXES: .ml .cmo .mli .cmi - -.ml.cmo: - $(CAMLC) -c $(COMPFLAGS) $< - -.mli.cmi: - $(CAMLC) -c $(COMPFLAGS) $< - -clean:: - rm -f *.cmo *.cmi - -depend: beforedepend - $(CAMLRUN) ./ocamldep $(INCLUDES) *.mli *.ml > .depend - -include .depend +ocamlmktop: $(OCAMLMKTOP) + $(CAMLC) $(LINKFLAGS) -o ocamlmktop $(OCAMLMKTOP_IMPORTS) $(OCAMLMKTOP) diff --git a/tools/Makefile.shared b/tools/Makefile.shared new file mode 100644 index 00000000..9e847456 --- /dev/null +++ b/tools/Makefile.shared @@ -0,0 +1,276 @@ +######################################################################### +# # +# 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 Q Public License version 1.0. # +# # +######################################################################### + +# $Id: Makefile.shared,v 1.5 2007/11/22 22:14:43 doligez Exp $ + +include ../config/Makefile + +CAMLRUN=../boot/ocamlrun +CAMLC=$(CAMLRUN) ../boot/ocamlc -nostdlib -I ../boot +CAMLOPT=$(CAMLRUN) ../ocamlopt -nostdlib -I ../stdlib +CAMLLEX=$(CAMLRUN) ../boot/ocamllex +INCLUDES=-I ../utils -I ../parsing -I ../typing -I ../bytecomp -I ../asmcomp \ + -I ../driver +COMPFLAGS= -warn-error A $(INCLUDES) +LINKFLAGS=$(INCLUDES) + +all: ocamldep ocamlprof ocamlcp ocamlmktop ocamlmklib scrapelabels addlabels \ + dumpobj +.PHONY: all + +opt.opt: ocamldep.opt +.PHONY: opt.opt + +# The dependency generator + +CAMLDEP_OBJ=depend.cmo ocamldep.cmo +CAMLDEP_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ + linenum.cmo warnings.cmo location.cmo longident.cmo \ + syntaxerr.cmo parser.cmo lexer.cmo parse.cmo + +ocamldep: depend.cmi $(CAMLDEP_OBJ) + $(CAMLC) $(LINKFLAGS) -o ocamldep $(CAMLDEP_IMPORTS) $(CAMLDEP_OBJ) + +ocamldep.opt: depend.cmi $(CAMLDEP_OBJ:.cmo=.cmx) + $(CAMLOPT) $(LINKFLAGS) -o ocamldep.opt $(CAMLDEP_IMPORTS:.cmo=.cmx) \ + $(CAMLDEP_OBJ:.cmo=.cmx) + +# ocamldep is precious: sometimes we are stuck in the middle of a +# bootstrap and we need to remake the dependencies +clean:: + if test -f ocamldep; then mv -f ocamldep ocamldep.bak; else :; fi + rm -f ocamldep.opt + +install:: + cp ocamldep $(BINDIR)/ocamldep$(EXE) + if test -f ocamldep.opt; \ + then cp ocamldep.opt $(BINDIR)/ocamldep.opt$(EXE); else :; fi + +# The profiler + +CSLPROF=ocamlprof.cmo +CSLPROF_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ + linenum.cmo warnings.cmo location.cmo longident.cmo \ + syntaxerr.cmo parser.cmo lexer.cmo parse.cmo + +ocamlprof: $(CSLPROF) profiling.cmo + $(CAMLC) $(LINKFLAGS) -o ocamlprof $(CSLPROF_IMPORTS) $(CSLPROF) + +ocamlcp: ocamlcp.cmo + $(CAMLC) $(LINKFLAGS) -o ocamlcp main_args.cmo ocamlcp.cmo + +install:: + cp ocamlprof $(BINDIR)/ocamlprof$(EXE) + cp ocamlcp $(BINDIR)/ocamlcp$(EXE) + cp profiling.cmi profiling.cmo $(LIBDIR) + +clean:: + rm -f ocamlprof ocamlcp + +install:: + cp ocamlmktop $(BINDIR)/ocamlmktop$(EXE) + +clean:: + rm -f ocamlmktop + +# To help building mixed-mode libraries (Caml + C) + +ocamlmklib: myocamlbuild_config.cmo ocamlmklib.cmo + $(CAMLC) $(LINKFLAGS) -o ocamlmklib myocamlbuild_config.cmo \ + ocamlmklib.cmo + +ocamlmklib.cmo: myocamlbuild_config.cmi + +myocamlbuild_config.cmi: myocamlbuild_config.cmo + +myocamlbuild_config.ml: ../config/Makefile ../build/mkmyocamlbuild_config.sh + ../build/mkmyocamlbuild_config.sh + cp ../myocamlbuild_config.ml . + +install:: + cp ocamlmklib $(BINDIR)/ocamlmklib$(EXE) + +clean:: + rm -f ocamlmklib + +ocamlmklib.ml: ocamlmklib.mlp ../config/Makefile + echo '(* THIS FILE IS GENERATED FROM ocamlmklib.mlp *)' >ocamlmklib.ml + sed -e "s|%%BINDIR%%|$(BINDIR)|" \ + -e "s|%%SUPPORTS_SHARED_LIBRARIES%%|$(SUPPORTS_SHARED_LIBRARIES)|" \ + -e "s|%%MKSHAREDLIB%%|$(MKSHAREDLIB)|" \ + -e "s|%%BYTECCRPATH%%|$(BYTECCRPATH)|" \ + -e "s|%%NATIVECCRPATH%%|$(NATIVECCRPATH)|" \ + -e "s|%%MKSHAREDLIBRPATH%%|$(MKSHAREDLIBRPATH)|" \ + -e "s|%%RANLIB%%|$(RANLIB)|" \ + ocamlmklib.mlp >> ocamlmklib.ml + +beforedepend:: ocamlmklib.ml + +clean:: + rm -f ocamlmklib.ml + +# To make custom toplevels (see Makefile/Makefile.nt) + +install:: + cp ocamlmktop $(BINDIR)/ocamlmktop$(EXE) + +clean:: + rm -f ocamlmktop + + +# Converter olabl/ocaml 2.99 to ocaml 3 + +OCAML299TO3= lexer299.cmo ocaml299to3.cmo +LIBRARY3= misc.cmo warnings.cmo linenum.cmo location.cmo + +ocaml299to3: $(OCAML299TO3) + $(CAMLC) $(LINKFLAGS) -o ocaml299to3 $(LIBRARY3) $(OCAML299TO3) + +lexer299.ml: lexer299.mll + $(CAMLLEX) lexer299.mll + +#install:: +# cp ocaml299to3 $(BINDIR)/ocaml299to3$(EXE) + +clean:: + rm -f ocaml299to3 lexer299.ml + +# Label remover for interface files (upgrade 3.02 to 3.03) + +SCRAPELABELS= lexer301.cmo scrapelabels.cmo + +scrapelabels: $(SCRAPELABELS) + $(CAMLC) $(LINKFLAGS) -o scrapelabels $(LIBRARY3) $(SCRAPELABELS) + +lexer301.ml: lexer301.mll + $(CAMLLEX) lexer301.mll + +install:: + cp scrapelabels $(LIBDIR) + +clean:: + rm -f scrapelabels lexer301.ml + +# Insert labels following an interface file (upgrade 3.02 to 3.03) + +ADDLABELS_IMPORTS=misc.cmo config.cmo clflags.cmo terminfo.cmo \ + linenum.cmo warnings.cmo location.cmo longident.cmo \ + syntaxerr.cmo parser.cmo lexer.cmo parse.cmo + +addlabels: addlabels.ml + $(CAMLC) $(LINKFLAGS) -w sl -o addlabels \ + $(ADDLABELS_IMPORTS) addlabels.ml + +install:: + cp addlabels $(LIBDIR) + +clean:: + rm -f addlabels + +# The preprocessor for asm generators + +CVT_EMIT=cvt_emit.cmo + +cvt_emit: $(CVT_EMIT) + $(CAMLC) $(LINKFLAGS) -o cvt_emit $(CVT_EMIT) + +# cvt_emit is precious: sometimes we are stuck in the middle of a +# bootstrap and we need to remake the dependencies +clean:: + if test -f cvt_emit; then mv -f cvt_emit cvt_emit.bak; else :; fi + +cvt_emit.ml: cvt_emit.mll + $(CAMLLEX) cvt_emit.mll + +clean:: + rm -f cvt_emit.ml + +beforedepend:: cvt_emit.ml + +# The bytecode disassembler + +DUMPOBJ=opnames.cmo dumpobj.cmo + +dumpobj: $(DUMPOBJ) + $(CAMLC) $(LINKFLAGS) -o dumpobj \ + misc.cmo tbl.cmo config.cmo ident.cmo \ + opcodes.cmo bytesections.cmo $(DUMPOBJ) + +clean:: + rm -f dumpobj + +opnames.ml: ../byterun/instruct.h + 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 > opnames.ml + +clean:: + rm -f opnames.ml + +beforedepend:: opnames.ml + +# Dump .cmx files + +dumpapprox: dumpapprox.cmo + $(CAMLC) $(LINKFLAGS) -o dumpapprox config.cmo dumpapprox.cmo + +clean:: + rm -f dumpapprox + +# Print imported interfaces for .cmo files + +objinfo: objinfo.cmo + $(CAMLC) $(LINKFLAGS) -o objinfo config.cmo objinfo.cmo + +clean:: + rm -f objinfo + +# Scan object files for required primitives + +PRIMREQ=primreq.cmo + +primreq: $(PRIMREQ) + $(CAMLC) $(LINKFLAGS) -o primreq config.cmo $(PRIMREQ) + +clean:: + rm -f primreq + +# Common stuff + +.SUFFIXES: +.SUFFIXES: .ml .cmo .mli .cmi .cmx + +.ml.cmo: + $(CAMLC) -c $(COMPFLAGS) $< + +.mli.cmi: + $(CAMLC) -c $(COMPFLAGS) $< + +.ml.cmx: + $(CAMLOPT) $(COMPFLAGS) -c $< + +clean:: + rm -f *.cmo *.cmi + +depend: beforedepend + $(CAMLRUN) ./ocamldep $(INCLUDES) *.mli *.ml > .depend + +.PHONY: clean install beforedepend depend + +include .depend diff --git a/tools/addlabels.ml b/tools/addlabels.ml index 79afef0e..a89fbe51 100644 --- a/tools/addlabels.ml +++ b/tools/addlabels.ml @@ -1,4 +1,4 @@ -(* $Id: addlabels.ml,v 1.11 2006/05/29 03:55:36 garrigue Exp $ *) +(* $Id: addlabels.ml,v 1.12 2008/07/09 13:03:37 mauny Exp $ *) open StdLabels open Asttypes @@ -62,6 +62,7 @@ let rec pattern_vars pat = List.concat (List.map l ~f:(fun (_,p) -> pattern_vars p)) | Ppat_or (pat1, pat2) -> pattern_vars pat1 @ pattern_vars pat2 + | Ppat_lazy pat -> pattern_vars pat | Ppat_any | Ppat_constant _ | Ppat_construct _ | Ppat_variant _ | Ppat_type _ -> [] diff --git a/tools/depend.ml b/tools/depend.ml index 586e189b..0f33d18b 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: depend.ml,v 1.10.6.1 2007/11/10 13:47:09 xleroy Exp $ *) +(* $Id: depend.ml,v 1.13 2008/07/09 13:03:37 mauny Exp $ *) open Format open Location @@ -68,10 +68,10 @@ let add_type_declaration bv td = td.ptype_cstrs; add_opt add_type bv td.ptype_manifest; let rec add_tkind = function - Ptype_abstract | Ptype_private -> () - | Ptype_variant (cstrs, _) -> + Ptype_abstract -> () + | Ptype_variant cstrs -> List.iter (fun (c, args, _) -> List.iter (add_type bv) args) cstrs - | Ptype_record (lbls, _) -> + | Ptype_record lbls -> List.iter (fun (l, mut, ty, _) -> add_type bv ty) lbls in add_tkind td.ptype_kind @@ -112,6 +112,7 @@ let rec add_pattern bv pat = | Ppat_constraint(p, ty) -> add_pattern bv p; add_type bv ty | Ppat_variant(_, op) -> add_opt add_pattern bv op | Ppat_type (li) -> add bv li + | Ppat_lazy p -> add_pattern bv p let rec add_expr bv exp = match exp.pexp_desc with diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml index 838a507d..6132de6b 100644 --- a/tools/dumpobj.ml +++ b/tools/dumpobj.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: dumpobj.ml,v 1.37 2006/05/15 09:00:48 weis Exp $ *) +(* $Id: dumpobj.ml,v 1.38 2008/09/10 12:53:05 doligez Exp $ *) (* Disassembler for executable and .cmo object files *) @@ -451,7 +451,7 @@ let print_instr ic = print_int nvars; for i = 0 to nfuncs - 1 do print_string ", "; - print_int (orig + inputu ic); + print_int (orig + inputs ic); done; | Pubmet -> let tag = inputs ic in diff --git a/tools/make-package-macosx b/tools/make-package-macosx index 80a0bb89..fa2cf436 100755 --- a/tools/make-package-macosx +++ b/tools/make-package-macosx @@ -12,7 +12,7 @@ # # ######################################################################### -# $Id: make-package-macosx,v 1.13.4.3 2008/01/25 14:00:21 doligez Exp $ +# $Id: make-package-macosx,v 1.16 2008/02/29 14:21:22 doligez Exp $ cd package-macosx rm -rf ocaml.pkg ocaml-rw.dmg @@ -21,21 +21,6 @@ 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: - -# cat >ocaml.info <Description.plist < | cat >resources/ReadMe.txt < () - | _ -> - print_filename target_file; print_string depends_on; - let rec print_items pos = function - [] -> print_string "\n" - | dep :: rem -> - if pos + String.length dep <= 77 then begin - print_filename dep; print_string " "; - print_items (pos + String.length dep + 1) rem - end else begin - print_string escaped_eol; print_filename dep; print_string " "; - print_items (String.length dep + 5) rem - end in - print_items (String.length target_file + 2) deps + print_filename target_file; print_string depends_on; + let rec print_items pos = function + [] -> print_string "\n" + | dep :: rem -> + if pos + String.length dep <= 77 then begin + print_filename dep; print_string " "; + print_items (pos + String.length dep + 1) rem + end else begin + print_string escaped_eol; print_filename dep; print_string " "; + print_items (String.length dep + 5) rem + end in + print_items (String.length target_file + 2) deps let print_raw_dependencies source_file deps = print_filename source_file; print_string ":"; @@ -204,7 +201,7 @@ let ml_file_dependencies source_file = 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 basename = Filename.chop_extension source_file in let init_deps = if Sys.file_exists (basename ^ ".mli") then let cmi_name = basename ^ ".cmi" in ([cmi_name], [cmi_name]) @@ -229,7 +226,7 @@ let mli_file_dependencies source_file = 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 basename = Filename.chop_extension source_file in let (byt_deps, opt_deps) = Depend.StringSet.fold find_dependency !Depend.free_structure_names ([], []) in @@ -239,21 +236,21 @@ let mli_file_dependencies source_file = with x -> close_in ic; remove_preprocessed input_file; raise x -let file_dependencies source_file = +type file_kind = ML | MLI;; + +let file_dependencies_as kind source_file = Location.input_name := source_file; 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 () + match kind with + | ML -> ml_file_dependencies source_file + | MLI -> mli_file_dependencies source_file end with x -> let report_err = function | Lexer.Error(err, range) -> fprintf Format.err_formatter "@[%a%a@]@." - Location.print range Lexer.report_error err + Location.print_error range Lexer.report_error err | Syntaxerr.Error err -> fprintf Format.err_formatter "@[%a@]@." Syntaxerr.report_error err @@ -266,6 +263,13 @@ let file_dependencies source_file = error_occurred := true; report_err x +let file_dependencies source_file = + if Filename.check_suffix source_file ".ml" then + file_dependencies_as ML source_file + else if Filename.check_suffix source_file ".mli" then + file_dependencies_as MLI source_file + else () + (* Entry point *) let usage = "Usage: ocamldep [options] \nOptions are:" @@ -281,15 +285,18 @@ let _ = Arg.parse [ "-I", Arg.String add_to_load_path, " Add to the list of include directories"; + "-impl", Arg.String (file_dependencies_as ML), + " Process as a .ml file"; + "-intf", Arg.String (file_dependencies_as MLI), + " Process as a .mli file"; "-modules", Arg.Set raw_dependencies, - " Print module dependencies in raw form (output is not suitable for make)"; + " Print module dependencies in raw form (not suitable for make)"; "-native", Arg.Set native_only, - " Generate dependencies for a pure native-code project \ - (no .cmo files)"; + " Generate dependencies for a pure native-code project (no .cmo files)"; "-pp", Arg.String(fun s -> preprocessor := Some s), - " Pipe sources through preprocessor "; + " Pipe sources through preprocessor "; "-slash", Arg.Set force_slash, - " (for Windows) Use forward slash / instead of backslash \\ in file paths"; + " (Windows) Use forward slash / instead of backslash \\ in file paths"; "-version", Arg.Unit print_version, " Print version and exit"; ] file_dependencies usage; diff --git a/tools/ocamlmklib.mlp b/tools/ocamlmklib.mlp index e65f3cc6..cec48773 100644 --- a/tools/ocamlmklib.mlp +++ b/tools/ocamlmklib.mlp @@ -10,14 +10,14 @@ (* *) (***********************************************************************) -(* $Id: ocamlmklib.mlp,v 1.13 2007/02/07 10:31:36 ertai Exp $ *) +(* $Id: ocamlmklib.mlp,v 1.16 2008/01/08 15:39:47 doligez Exp $ *) open Printf 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, .obj, .lib files to pass to mksharedlib and ar *) +and c_objs = ref [] (* .o, .a, .obj, .lib, .dll 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 @@ -30,7 +30,6 @@ 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 = @@ -63,7 +62,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 List.exists (ends_with s) [".o"; ".a"; ".obj"; ".lib"] then + else if List.exists (ends_with s) [".o"; ".a"; ".obj"; ".lib"; ".dll"] then c_objs := s :: !c_objs else if s = "-cclib" then caml_libs := next_arg () :: "-cclib" :: !caml_libs @@ -71,13 +70,11 @@ 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 failsafe := true - else if s = "-h" || s = "-help" then + else if s = "-h" || s = "-help" || s = "--help" then raise (Bad_argument "") else if s = "-ldopt" then ld_opts := next_arg () :: !ld_opts @@ -128,15 +125,22 @@ let parse_arguments argv = (fun r -> r := List.rev !r) [ bytecode_objs; native_objs; c_objs; caml_libs; caml_opts; c_libs; c_objs; c_opts; ld_opts; rpath ]; + (* On retourne deux fois c_objs ?? -- AF *) + if !output_c = "" then output_c := !output let usage = "\ -Usage: ocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a|.obj|.lib files> +Usage: ocamlmklib [options] <.cmo|.cma|.cmx|.cmxa|.ml|.mli|.o|.a|.obj|.lib|.dll 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 -custom disable dynamic loading -dllpath Add to the run-time search path for DLLs + -F Specify a framework directory (MacOSX) + -framework Use framework (MacOSX) + -help Print this help message and exit + --help Same as -help + -h Same as -help -I Add to the path searched for Caml object files -failsafe fall back to static linking if DLL construction failed -ldopt C option passed to the shared linker only @@ -150,12 +154,11 @@ Options are: -rpath Same as -dllpath -R Same as -rpath -verbose Print commands before executing them + -v same as -verbose + -version Print version and exit -Wl,-rpath, Same as -dllpath -Wl,-rpath -Wl, Same as -dllpath -Wl,-R Same as -dllpath - -F Specify a framework directory (MacOSX) - -framework Use framework (MacOSX) - -version Print version and exit " let command cmd = @@ -194,18 +197,29 @@ let prepostfix pre name post = Filename.concat dir (pre ^ base ^ post) ;; +let transl_path s = + match Sys.os_type with + | "Win32" -> + let rec aux i = + if i = String.length s || s.[i] = ' ' then s + else (if s.[i] = '/' then s.[i] <- '\\'; aux (i + 1)) + in aux 0 + | _ -> s + let build_libs () = if !c_objs <> [] then begin if !dynlink then begin let retcode = command - (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 mksharedlibrpath) - (String.concat " " !c_libs)) "") in + (Printf.sprintf "%s -o %s %s %s %s %s %s" + mkdll + (prepostfix "dll" !output_c ext_dll) + (String.concat " " !c_objs) + (String.concat " " !c_opts) + (String.concat " " !ld_opts) + (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 ext_lib); @@ -216,7 +230,7 @@ let build_libs () = if !bytecode_objs <> [] then scommand (sprintf "%s -a %s -o %s.cma %s %s -dllib -l%s -cclib -l%s %s %s %s %s" - !ocamlc + (transl_path !ocamlc) (if !dynlink then "" else "-custom") !output (String.concat " " !caml_opts) @@ -230,7 +244,7 @@ let build_libs () = if !native_objs <> [] then scommand (sprintf "%s -a -o %s.cmxa %s %s -cclib -l%s %s %s %s %s" - !ocamlopt + (transl_path !ocamlopt) !output (String.concat " " !caml_opts) (String.concat " " !native_objs) diff --git a/tools/ocamlprof.ml b/tools/ocamlprof.ml index 7218a0ea..7eeca94d 100644 --- a/tools/ocamlprof.ml +++ b/tools/ocamlprof.ml @@ -11,7 +11,7 @@ (* *) (***********************************************************************) -(* $Id: ocamlprof.ml,v 1.41 2007/02/09 13:31:15 doligez Exp $ *) +(* $Id: ocamlprof.ml,v 1.42 2007/12/04 13:38:58 doligez Exp $ *) open Printf @@ -476,7 +476,7 @@ let main () = let report_error ppf = function | Lexer.Error(err, range) -> fprintf ppf "@[%a%a@]@." - Location.print range Lexer.report_error err + Location.print_error range Lexer.report_error err | Syntaxerr.Error err -> fprintf ppf "@[%a@]@." Syntaxerr.report_error err diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index 42f69001..c108811e 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: genprintval.ml,v 1.38 2005/06/13 04:55:53 garrigue Exp $ *) +(* $Id: genprintval.ml,v 1.39 2007/10/09 10:29:37 weis Exp $ *) (* To print values *) @@ -242,7 +242,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct tree_of_val depth obj (try Ctype.apply env decl.type_params body ty_list with Ctype.Cannot_apply -> abstract_type) - | {type_kind = Type_variant(constr_list, priv)} -> + | {type_kind = Type_variant constr_list} -> let tag = if O.is_block obj then Cstr_block(O.tag obj) @@ -257,7 +257,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct constr_args in tree_of_constr_with_args (tree_of_constr env path) constr_name 0 depth obj ty_args - | {type_kind = Type_record(lbl_list, rep, priv)} -> + | {type_kind = Type_record(lbl_list, rep)} -> begin match check_depth depth obj ty with Some x -> x | None -> diff --git a/toplevel/opttopdirs.ml b/toplevel/opttopdirs.ml new file mode 100644 index 00000000..6f6e7228 --- /dev/null +++ b/toplevel/opttopdirs.ml @@ -0,0 +1,189 @@ +(***********************************************************************) +(* *) +(* 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: opttopdirs.ml,v 1.2 2007/11/06 15:16:56 frisch Exp $ *) + +(* Toplevel directives *) + +open Format +open Misc +open Longident +open Path +open Types +open Opttoploop + +(* The standard output formatter *) +let std_out = std_formatter + +(* To quit *) + +let dir_quit () = exit 0 + +let _ = Hashtbl.add directive_table "quit" (Directive_none dir_quit) + +(* To add a directory to the load path *) + +let dir_directory s = + let d = expand_directory Config.standard_library s in + Config.load_path := d :: !Config.load_path + +let _ = Hashtbl.add directive_table "directory" (Directive_string dir_directory) +let _ = Hashtbl.add directive_table "show_dirs" + (Directive_none + (fun () -> + List.iter print_endline !Config.load_path + )) + +(* To change the current directory *) + +let dir_cd s = Sys.chdir s + +let _ = Hashtbl.add directive_table "cd" (Directive_string dir_cd) + +(* Load in-core a .cmxs file *) + +let load_file ppf name0 = + let name = + try Some (find_in_path !Config.load_path name0) + with Not_found -> None in + match name with + | None -> fprintf ppf "File not found: %s@." name0; false + | Some name -> + let fn,tmp = + if Filename.check_suffix name ".cmx" || Filename.check_suffix name ".cmxa" + then + let cmxs = Filename.temp_file "caml" ".cmxs" in + Asmlink.link_shared ppf [name] cmxs; + cmxs,true + else + name,false in + + let success = + (* The Dynlink interface does not allow us to distinguish between + a Dynlink.Error exceptions raised in the loaded modules + or a genuine error during dynlink... *) + try Dynlink.loadfile fn; true + with + | Dynlink.Error err -> + fprintf ppf "Error while loading %s: %s.@." + name (Dynlink.error_message err); + false + | exn -> + print_exception_outcome ppf exn; + false + in + if tmp then (try Sys.remove fn with Sys_error _ -> ()); + success + + +let dir_load ppf name = ignore (load_file ppf name) + +let _ = Hashtbl.add directive_table "load" (Directive_string (dir_load std_out)) + +(* Load commands from a file *) + +let dir_use ppf name = ignore(Opttoploop.use_file ppf name) + +let _ = Hashtbl.add directive_table "use" (Directive_string (dir_use std_out)) + +(* Install, remove a printer *) + +type 'a printer_type_new = Format.formatter -> 'a -> unit +type 'a printer_type_old = 'a -> unit + +let match_printer_type ppf desc typename = + let (printer_type, _) = + try + Env.lookup_type (Ldot(Lident "Topdirs", typename)) !toplevel_env + with Not_found -> + fprintf ppf "Cannot find type Topdirs.%s.@." typename; + raise Exit in + Ctype.init_def(Ident.current_time()); + Ctype.begin_def(); + let ty_arg = Ctype.newvar() in + Ctype.unify !toplevel_env + (Ctype.newconstr printer_type [ty_arg]) + (Ctype.instance desc.val_type); + Ctype.end_def(); + Ctype.generalize ty_arg; + ty_arg + +let find_printer_type ppf lid = + try + let (path, desc) = Env.lookup_value lid !toplevel_env in + let (ty_arg, is_old_style) = + try + (match_printer_type ppf desc "printer_type_new", false) + with Ctype.Unify _ -> + (match_printer_type ppf desc "printer_type_old", true) in + (ty_arg, path, is_old_style) + with + | Not_found -> + fprintf ppf "Unbound value %a.@." Printtyp.longident lid; + raise Exit + | Ctype.Unify _ -> + fprintf ppf "%a has a wrong type for a printing function.@." + Printtyp.longident lid; + raise Exit + +let dir_install_printer ppf lid = + try + let (ty_arg, path, is_old_style) = find_printer_type ppf lid in + let v = eval_path path in + let print_function = + if is_old_style then + (fun formatter repr -> Obj.obj v (Obj.obj repr)) + else + (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in + install_printer path ty_arg print_function + with Exit -> () + +let dir_remove_printer ppf lid = + try + let (ty_arg, path, is_old_style) = find_printer_type ppf lid in + begin try + remove_printer path + with Not_found -> + fprintf ppf "No printer named %a.@." Printtyp.longident lid + end + with Exit -> () + +let _ = Hashtbl.add directive_table "install_printer" + (Directive_ident (dir_install_printer std_out)) +let _ = Hashtbl.add directive_table "remove_printer" + (Directive_ident (dir_remove_printer std_out)) + +let parse_warnings ppf iserr s = + try Warnings.parse_options iserr s + with Arg.Bad err -> fprintf ppf "%s.@." err + +let _ = +(* Control the printing of values *) + + Hashtbl.add directive_table "print_depth" + (Directive_int(fun n -> max_printer_depth := n)); + Hashtbl.add directive_table "print_length" + (Directive_int(fun n -> max_printer_steps := n)); + +(* Set various compiler flags *) + + Hashtbl.add directive_table "labels" + (Directive_bool(fun b -> Clflags.classic := not b)); + + Hashtbl.add directive_table "principal" + (Directive_bool(fun b -> Clflags.principal := b)); + + Hashtbl.add directive_table "warnings" + (Directive_string (parse_warnings std_out false)); + + Hashtbl.add directive_table "warn_error" + (Directive_string (parse_warnings std_out true)) diff --git a/toplevel/opttopdirs.mli b/toplevel/opttopdirs.mli new file mode 100644 index 00000000..da877169 --- /dev/null +++ b/toplevel/opttopdirs.mli @@ -0,0 +1,31 @@ +(***********************************************************************) +(* *) +(* 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: opttopdirs.mli,v 1.2 2007/11/06 15:16:56 frisch Exp $ *) + +(* The toplevel directives. *) + +open Format + +val dir_quit : unit -> unit +val dir_directory : string -> unit +val dir_cd : string -> unit +val dir_load : formatter -> string -> unit +val dir_use : formatter -> string -> unit +val dir_install_printer : formatter -> Longident.t -> unit +val dir_remove_printer : formatter -> Longident.t -> unit + +type 'a printer_type_new = Format.formatter -> 'a -> unit +type 'a printer_type_old = 'a -> unit + +(* For topmain.ml. Maybe shouldn't be there *) +val load_file : formatter -> string -> bool diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml new file mode 100644 index 00000000..aa5dcccc --- /dev/null +++ b/toplevel/opttoploop.ml @@ -0,0 +1,446 @@ +(***********************************************************************) +(* *) +(* 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: opttoploop.ml,v 1.3 2007/12/04 13:38:58 doligez Exp $ *) + +(* The interactive toplevel loop *) + +open Path +open Lexing +open Format +open Config +open Misc +open Parsetree +open Types +open Typedtree +open Outcometree +open Lambda + +type res = Ok of Obj.t | Err of string +type evaluation_outcome = Result of Obj.t | Exception of exn + +external ndl_run_toplevel: string -> string -> res + = "caml_natdynlink_run_toplevel" +external ndl_loadsym: string -> Obj.t = "caml_natdynlink_loadsym" + +let global_symbol id = + let sym = Compilenv.symbol_for_global id in + try ndl_loadsym sym + with _ -> fatal_error ("Opttoploop.global_symbol " ^ (Ident.unique_name id)) + +let need_symbol sym = + try ignore (ndl_loadsym sym); false + with _ -> true + +let dll_run dll entry = + match (try Result (Obj.magic (ndl_run_toplevel dll entry)) with exn -> Exception exn) with + | Exception _ as r -> r + | Result r -> + match Obj.magic r with + | Ok x -> Result x + | Err s -> fatal_error ("Opttoploop.dll_run " ^ s) + + +type directive_fun = + | Directive_none of (unit -> unit) + | Directive_string of (string -> unit) + | Directive_int of (int -> unit) + | Directive_ident of (Longident.t -> unit) + | Directive_bool of (bool -> unit) + + +(* Return the value referred to by a path *) + +let toplevel_value id = + let (glb,pos) = Translmod.nat_toplevel_name id in + (Obj.magic (global_symbol glb)).(pos) + +let rec eval_path = function + | Pident id -> + if Ident.persistent id || Ident.global id + then global_symbol id + else toplevel_value id + | Pdot(p, s, pos) -> + Obj.field (eval_path p) pos + | Papply(p1, p2) -> + fatal_error "Toploop.eval_path" + +(* To print values *) + +module EvalPath = struct + type value = Obj.t + exception Error + let eval_path p = try eval_path p with _ -> raise Error + let same_value v1 v2 = (v1 == v2) +end + +module Printer = Genprintval.Make(Obj)(EvalPath) + +let max_printer_depth = ref 100 +let max_printer_steps = ref 300 + +let print_out_value = Oprint.out_value +let print_out_type = Oprint.out_type +let print_out_class_type = Oprint.out_class_type +let print_out_module_type = Oprint.out_module_type +let print_out_sig_item = Oprint.out_sig_item +let print_out_signature = Oprint.out_signature +let print_out_phrase = Oprint.out_phrase + +let print_untyped_exception ppf obj = + !print_out_value ppf (Printer.outval_of_untyped_exception obj) +let outval_of_value env obj ty = + Printer.outval_of_value !max_printer_steps !max_printer_depth + (fun _ _ _ -> None) env obj ty +let print_value env obj ppf ty = + !print_out_value ppf (outval_of_value env obj ty) + +let install_printer = Printer.install_printer +let remove_printer = Printer.remove_printer + +(* Hooks for parsing functions *) + +let parse_toplevel_phrase = ref Parse.toplevel_phrase +let parse_use_file = ref Parse.use_file +let print_location = Location.print_error (* FIXME change back to print *) +let print_error = Location.print_error +let print_warning = Location.print_warning +let input_name = Location.input_name + +(* Hooks for initialization *) + +let toplevel_startup_hook = ref (fun () -> ()) + +(* Load in-core and execute a lambda term *) + +let phrase_seqid = ref 0 +let phrase_name = ref "TOP" + +open Lambda + +let load_lambda ppf (size, lam) = + if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam; + let slam = Simplif.simplify_lambda lam in + if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam; + + let dll = + if !Clflags.keep_asm_file then !phrase_name ^ ext_dll + else Filename.temp_file ("caml" ^ !phrase_name) ext_dll + in + let fn = Filename.chop_extension dll in + Asmgen.compile_implementation ~toplevel:need_symbol fn ppf (size, lam); + Asmlink.call_linker_shared [fn ^ ext_obj] dll; + Sys.remove (fn ^ ext_obj); + + let dll = + if Filename.is_implicit dll + then Filename.concat (Sys.getcwd ()) dll + else dll in + let res = dll_run dll !phrase_name in + (try Sys.remove dll with Sys_error _ -> ()); + (* note: under windows, cannot remove a loaded dll + (should remember the handles, close them in at_exit, and then remove + files) *) + res + +(* Print the outcome of an evaluation *) + +let rec pr_item env = function + | Tsig_value(id, decl) :: rem -> + let tree = Printtyp.tree_of_value_description id decl in + let valopt = + match decl.val_kind with + | Val_prim _ -> None + | _ -> + let v = + outval_of_value env (toplevel_value id) + decl.val_type + in + Some v + in + Some (tree, valopt, rem) + | Tsig_type(id, _, _) :: rem when Btype.is_row_name (Ident.name id) -> + pr_item env rem + | Tsig_type(id, decl, rs) :: rem -> + let tree = Printtyp.tree_of_type_declaration id decl rs in + Some (tree, None, rem) + | Tsig_exception(id, decl) :: rem -> + let tree = Printtyp.tree_of_exception_declaration id decl in + Some (tree, None, rem) + | Tsig_module(id, mty, rs) :: rem -> + let tree = Printtyp.tree_of_module id mty rs in + Some (tree, None, rem) + | Tsig_modtype(id, decl) :: rem -> + let tree = Printtyp.tree_of_modtype_declaration id decl in + Some (tree, None, rem) + | Tsig_class(id, decl, rs) :: cltydecl :: tydecl1 :: tydecl2 :: rem -> + let tree = Printtyp.tree_of_class_declaration id decl rs in + Some (tree, None, rem) + | Tsig_cltype(id, decl, rs) :: tydecl1 :: tydecl2 :: rem -> + let tree = Printtyp.tree_of_cltype_declaration id decl rs in + Some (tree, None, rem) + | _ -> None + +let rec item_list env = function + | [] -> [] + | items -> + match pr_item env items with + | None -> [] + | Some (tree, valopt, items) -> (tree, valopt) :: item_list env items + +(* The current typing environment for the toplevel *) + +let toplevel_env = ref Env.empty + +(* Print an exception produced by an evaluation *) + +let print_out_exception ppf exn outv = + !print_out_phrase ppf (Ophr_exception (exn, outv)) + +let print_exception_outcome ppf exn = + if exn = Out_of_memory then Gc.full_major (); + let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in + print_out_exception ppf exn outv + +(* The table of toplevel directives. + Filled by functions from module topdirs. *) + +let directive_table = (Hashtbl.create 13 : (string, directive_fun) Hashtbl.t) + +(* Execute a toplevel phrase *) + +let execute_phrase print_outcome ppf phr = + match phr with + | Ptop_def sstr -> + let oldenv = !toplevel_env in + incr phrase_seqid; + phrase_name := Printf.sprintf "TOP%i" !phrase_seqid; + Compilenv.reset ?packname:None !phrase_name; + let _ = Unused_var.warn ppf sstr in + Typecore.reset_delayed_checks (); + let (str, sg, newenv) = Typemod.type_structure oldenv sstr Location.none + in + Typecore.force_delayed_checks (); + let res = Translmod.transl_store_phrases !phrase_name str in + Warnings.check_fatal (); + begin try + toplevel_env := newenv; + let res = load_lambda ppf res in + let out_phr = + match res with + | Result v -> + Compilenv.record_global_approx_toplevel (); + if print_outcome then + match str with + | [Tstr_eval exp] -> + let outv = outval_of_value newenv v exp.exp_type in + let ty = Printtyp.tree_of_type_scheme exp.exp_type in + Ophr_eval (outv, ty) + | [] -> Ophr_signature [] + | _ -> + Ophr_signature (item_list newenv + (Typemod.simplify_signature sg)) + + else Ophr_signature [] + | Exception exn -> + toplevel_env := oldenv; + if exn = Out_of_memory then Gc.full_major(); + let outv = + outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn + in + Ophr_exception (exn, outv) + in + !print_out_phrase ppf out_phr; + begin match out_phr with + | Ophr_eval (_, _) | Ophr_signature _ -> true + | Ophr_exception _ -> false + end + with x -> + toplevel_env := oldenv; raise x + end + | Ptop_dir(dir_name, dir_arg) -> + try + match (Hashtbl.find directive_table dir_name, dir_arg) with + | (Directive_none f, Pdir_none) -> f (); true + | (Directive_string f, Pdir_string s) -> f s; true + | (Directive_int f, Pdir_int n) -> f n; true + | (Directive_ident f, Pdir_ident lid) -> f lid; true + | (Directive_bool f, Pdir_bool b) -> f b; true + | (_, _) -> + fprintf ppf "Wrong type of argument for directive `%s'.@." dir_name; + false + with Not_found -> + fprintf ppf "Unknown directive `%s'.@." dir_name; + false + +(* Temporary assignment to a reference *) + +let protect r newval body = + let oldval = !r in + try + r := newval; + let res = body() in + r := oldval; + res + with x -> + r := oldval; + raise x + +(* Read and execute commands from a file *) + +let use_print_results = ref true + +let use_file ppf name = + try + let filename = find_in_path !Config.load_path name in + let ic = open_in_bin filename in + let lb = Lexing.from_channel ic in + Location.init lb filename; + (* Skip initial #! line if any *) + Lexer.skip_sharp_bang lb; + let success = + protect Location.input_name filename (fun () -> + try + List.iter + (fun ph -> + if !Clflags.dump_parsetree then Printast.top_phrase ppf ph; + if not (execute_phrase !use_print_results ppf ph) then raise Exit) + (!parse_use_file lb); + true + with + | Exit -> false + | Sys.Break -> fprintf ppf "Interrupted.@."; false + | x -> Opterrors.report_error ppf x; false) in + close_in ic; + success + with Not_found -> fprintf ppf "Cannot find file %s.@." name; false + +let use_silently ppf name = + protect use_print_results false (fun () -> use_file ppf name) + +(* Reading function for interactive use *) + +let first_line = ref true +let got_eof = ref false;; + +let read_input_default prompt buffer len = + output_string stdout prompt; flush stdout; + let i = ref 0 in + try + while true do + if !i >= len then raise Exit; + let c = input_char stdin in + buffer.[!i] <- c; + incr i; + if c = '\n' then raise Exit; + done; + (!i, false) + with + | End_of_file -> + (!i, true) + | Exit -> + (!i, false) + +let read_interactive_input = ref read_input_default + +let refill_lexbuf buffer len = + if !got_eof then (got_eof := false; 0) else begin + let prompt = + if !Clflags.noprompt then "" + else if !first_line then "# " + else if Lexer.in_comment () then "* " + else " " + in + first_line := false; + let (len, eof) = !read_interactive_input prompt buffer len in + if eof then begin + Location.echo_eof (); + if len > 0 then got_eof := true; + len + end else + len + end + +(* Toplevel initialization. Performed here instead of at the + beginning of loop() so that user code linked in with ocamlmktop + can call directives from Topdirs. *) + +let _ = + Sys.interactive := true; + Dynlink.init (); + Optcompile.init_path(); + Clflags.dlcode := true; + () + +let load_ocamlinit ppf = + match !Clflags.init_file with + | Some f -> if Sys.file_exists f then ignore (use_silently ppf f) + else fprintf ppf "Init file not found: \"%s\".@." f + | None -> + if Sys.file_exists ".ocamlinit" then ignore (use_silently ppf ".ocamlinit") + else try + let home_init = Filename.concat (Sys.getenv "HOME") ".ocamlinit" in + if Sys.file_exists home_init then ignore (use_silently ppf home_init) + with Not_found -> () +;; + +let set_paths () = + (* Add whatever -I options have been specified on the command line, + but keep the directories that user code linked in with ocamlmktop + may have added to load_path. *) + load_path := !load_path @ [Filename.concat Config.standard_library "camlp4"]; + load_path := "" :: (List.rev !Clflags.include_dirs @ !load_path); + () + +let initialize_toplevel_env () = + toplevel_env := Optcompile.initial_env() + +(* The interactive loop *) + +exception PPerror + +let loop ppf = + fprintf ppf " Objective Caml version %s - native toplevel@.@." Config.version; + initialize_toplevel_env (); + let lb = Lexing.from_function refill_lexbuf in + Location.input_name := ""; + Location.input_lexbuf := Some lb; + Sys.catch_break true; + load_ocamlinit ppf; + while true do + let snap = Btype.snapshot () in + try + Lexing.flush_input lb; + Location.reset(); + first_line := true; + let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in + if !Clflags.dump_parsetree then Printast.top_phrase ppf phr; + ignore(execute_phrase true ppf phr) + with + | End_of_file -> exit 0 + | Sys.Break -> fprintf ppf "Interrupted.@."; Btype.backtrack snap + | PPerror -> () + | x -> Opterrors.report_error ppf x; Btype.backtrack snap + done + +(* Execute a script *) + +let run_script ppf name args = + let len = Array.length args in + if Array.length Sys.argv < len then invalid_arg "Toploop.run_script"; + Array.blit args 0 Sys.argv 0 len; + Obj.truncate (Obj.repr Sys.argv) len; + Arg.current := 0; + Optcompile.init_path(); + toplevel_env := Optcompile.initial_env(); + Sys.interactive := false; + use_silently ppf name diff --git a/toplevel/opttoploop.mli b/toplevel/opttoploop.mli new file mode 100644 index 00000000..e1261b24 --- /dev/null +++ b/toplevel/opttoploop.mli @@ -0,0 +1,102 @@ +(***********************************************************************) +(* *) +(* 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: opttoploop.mli,v 1.3 2007/12/04 13:38:58 doligez Exp $ *) + +open Format + +(* Set the load paths, before running anything *) + +val set_paths : unit -> unit + +(* The interactive toplevel loop *) + +val loop : formatter -> unit + +(* Read and execute a script from the given file *) + +val run_script : formatter -> string -> string array -> bool + (* true if successful, false if error *) + +(* Interface with toplevel directives *) + +type directive_fun = + | Directive_none of (unit -> unit) + | Directive_string of (string -> unit) + | Directive_int of (int -> unit) + | Directive_ident of (Longident.t -> unit) + | Directive_bool of (bool -> unit) + +val directive_table : (string, directive_fun) Hashtbl.t + (* Table of known directives, with their execution function *) +val toplevel_env : Env.t ref + (* Typing environment for the toplevel *) +val initialize_toplevel_env : unit -> unit + (* Initialize the typing environment for the toplevel *) +val print_exception_outcome : formatter -> exn -> unit + (* Print an exception resulting from the evaluation of user code. *) +val execute_phrase : bool -> formatter -> Parsetree.toplevel_phrase -> bool + (* Execute the given toplevel phrase. Return [true] if the + phrase executed with no errors and [false] otherwise. + First bool says whether the values and types of the results + should be printed. Uncaught exceptions are always printed. *) +val use_file : formatter -> string -> bool +val use_silently : formatter -> string -> bool + (* Read and execute commands from a file. + [use_file] prints the types and values of the results. + [use_silently] does not print them. *) +val eval_path: Path.t -> Obj.t + (* Return the toplevel object referred to by the given path *) + +(* Printing of values *) + +val print_value: Env.t -> Obj.t -> formatter -> Types.type_expr -> unit +val print_untyped_exception: formatter -> Obj.t -> unit + +val install_printer : + Path.t -> Types.type_expr -> (formatter -> Obj.t -> unit) -> unit +val remove_printer : Path.t -> unit + +val max_printer_depth: int ref +val max_printer_steps: int ref + +(* Hooks for external parsers and printers *) + +val parse_toplevel_phrase : (Lexing.lexbuf -> Parsetree.toplevel_phrase) ref +val parse_use_file : (Lexing.lexbuf -> Parsetree.toplevel_phrase list) ref +val print_location : formatter -> Location.t -> unit +val print_error : formatter -> Location.t -> unit +val print_warning : Location.t -> formatter -> Warnings.t -> unit +val input_name : string ref + +val print_out_value : + (formatter -> Outcometree.out_value -> unit) ref +val print_out_type : + (formatter -> Outcometree.out_type -> unit) ref +val print_out_class_type : + (formatter -> Outcometree.out_class_type -> unit) ref +val print_out_module_type : + (formatter -> Outcometree.out_module_type -> unit) ref +val print_out_sig_item : + (formatter -> Outcometree.out_sig_item -> unit) ref +val print_out_signature : + (formatter -> Outcometree.out_sig_item list -> unit) ref +val print_out_phrase : + (formatter -> Outcometree.out_phrase -> unit) ref + +(* Hooks for external line editor *) + +val read_interactive_input : (string -> string -> int -> int * bool) ref + +(* Hooks for initialization *) + +val toplevel_startup_hook : (unit -> unit) ref diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml new file mode 100644 index 00000000..cb312d1f --- /dev/null +++ b/toplevel/opttopmain.ml @@ -0,0 +1,121 @@ +(***********************************************************************) +(* *) +(* 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: opttopmain.ml,v 1.2 2007/11/06 15:16:56 frisch Exp $ *) + +open Clflags + +let usage = "Usage: ocamlnat [script-file]\noptions are:" + +let preload_objects = ref [] + +let prepare ppf = + Opttoploop.set_paths (); + try + let res = + List.for_all (Opttopdirs.load_file ppf) (List.rev !preload_objects) + in + !Opttoploop.toplevel_startup_hook (); + res + with x -> + try Opterrors.report_error ppf x; false + with x -> + Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x); + false + +let file_argument name = + let ppf = Format.err_formatter in + if Filename.check_suffix name ".cmxs" + || Filename.check_suffix name ".cmx" + || Filename.check_suffix name ".cmxa" + then preload_objects := name :: !preload_objects + else + begin + let newargs = Array.sub Sys.argv !Arg.current + (Array.length Sys.argv - !Arg.current) + in + if prepare ppf && Opttoploop.run_script ppf name newargs + then exit 0 + else exit 2 + end + +let print_version () = + Printf.printf "The Objective Caml toplevel, version %s\n" Sys.ocaml_version; + exit 0; +;; + +let main () = + Arg.parse (Arch.command_line_options @ [ + "-compact", Arg.Clear optimize_for_speed, " Optimize code size rather than speed"; + "-inline", Arg.Int(fun n -> inline_threshold := n * 8), + " Set aggressiveness of inlining to "; + "-I", Arg.String(fun dir -> + let dir = Misc.expand_directory Config.standard_library dir in + include_dirs := dir :: !include_dirs), + " Add to the list of include directories"; + "-init", Arg.String (fun s -> init_file := Some s), + " Load instead of default init file"; + "-labels", Arg.Clear classic, " Labels commute (default)"; + "-noassert", Arg.Set noassert, " Do not compile assertion checks"; + "-nolabels", Arg.Set classic, " Ignore labels and do not commute"; + "-noprompt", Arg.Set noprompt, " Suppress all prompts"; + "-nostdlib", Arg.Set no_std_include, + " do not add default directory to the list of include directories"; + "-principal", Arg.Set principal, " Check principality of type inference"; + "-rectypes", Arg.Set recursive_types, " Allow arbitrary recursive types"; + "-S", Arg.Set keep_asm_file, " Keep intermediate assembly file"; + "-unsafe", Arg.Set fast, " No bound checking on array and string access"; + "-version", Arg.Unit print_version, " Print version and exit"; + "-w", Arg.String (Warnings.parse_options false), + " Enable or disable warnings according to :\n\ + \032 A/a enable/disable all warnings\n\ + \032 C/c enable/disable suspicious comment\n\ + \032 D/d enable/disable deprecated features\n\ + \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 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 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\ + \032 default setting is \"Aelz\""; + "-warn-error" , Arg.String (Warnings.parse_options true), + " Treat the warnings of as errors, if they are enabled.\n\ + \032 (see option -w for the list of flags)\n\ + \032 default setting is a (all warnings are non-fatal)"; + + "-dparsetree", Arg.Set dump_parsetree, " (undocumented)"; + "-drawlambda", Arg.Set dump_rawlambda, " (undocumented)"; + "-dlambda", Arg.Set dump_lambda, " (undocumented)"; + "-dcmm", Arg.Set dump_cmm, " (undocumented)"; + "-dsel", Arg.Set dump_selection, " (undocumented)"; + "-dcombine", Arg.Set dump_combine, " (undocumented)"; + "-dlive", Arg.Unit(fun () -> dump_live := true; + Printmach.print_live := true), + " (undocumented)"; + "-dspill", Arg.Set dump_spill, " (undocumented)"; + "-dsplit", Arg.Set dump_split, " (undocumented)"; + "-dinterf", Arg.Set dump_interf, " (undocumented)"; + "-dprefer", Arg.Set dump_prefer, " (undocumented)"; + "-dalloc", Arg.Set dump_regalloc, " (undocumented)"; + "-dreload", Arg.Set dump_reload, " (undocumented)"; + "-dscheduling", Arg.Set dump_scheduling, " (undocumented)"; + "-dlinear", Arg.Set dump_linear, " (undocumented)"; + "-dstartup", Arg.Set keep_startup_file, " (undocumented)"; + ]) file_argument usage; + if not (prepare Format.err_formatter) then exit 2; + Opttoploop.loop Format.std_formatter + diff --git a/toplevel/opttopmain.mli b/toplevel/opttopmain.mli new file mode 100644 index 00000000..70d24a5a --- /dev/null +++ b/toplevel/opttopmain.mli @@ -0,0 +1,17 @@ +(***********************************************************************) +(* *) +(* 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: opttopmain.mli,v 1.2 2007/11/06 15:16:56 frisch Exp $ *) + +(* Start the [ocaml] toplevel loop *) + +val main: unit -> unit diff --git a/toplevel/opttopstart.ml b/toplevel/opttopstart.ml new file mode 100644 index 00000000..1071a683 --- /dev/null +++ b/toplevel/opttopstart.ml @@ -0,0 +1,15 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* $Id: opttopstart.ml,v 1.2 2007/11/06 15:16:56 frisch Exp $ *) + +let _ = Opttopmain.main() diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index 1a202bb5..42f4a848 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: toploop.ml,v 1.93 2006/01/04 16:55:50 doligez Exp $ *) +(* $Id: toploop.ml,v 1.95 2007/12/04 13:38:58 doligez Exp $ *) (* The interactive toplevel loop *) @@ -100,7 +100,8 @@ let remove_printer = Printer.remove_printer let parse_toplevel_phrase = ref Parse.toplevel_phrase let parse_use_file = ref Parse.use_file -let print_location = Location.print +let print_location = Location.print_error (* FIXME change back to print *) +let print_error = Location.print_error let print_warning = Location.print_warning let input_name = Location.input_name @@ -218,7 +219,8 @@ let execute_phrase print_outcome ppf phr = let oldenv = !toplevel_env in let _ = Unused_var.warn ppf sstr in Typecore.reset_delayed_checks (); - let (str, sg, newenv) = Typemod.type_structure oldenv sstr in + let (str, sg, newenv) = Typemod.type_structure oldenv sstr Location.none + in Typecore.force_delayed_checks (); let lam = Translmod.transl_toplevel_definition str in Warnings.check_fatal (); diff --git a/toplevel/toploop.mli b/toplevel/toploop.mli index 7093f1b3..06c7d71f 100644 --- a/toplevel/toploop.mli +++ b/toplevel/toploop.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: toploop.mli,v 1.25 2004/05/15 09:59:37 xleroy Exp $ *) +(* $Id: toploop.mli,v 1.26 2007/12/04 13:38:58 doligez Exp $ *) open Format @@ -80,6 +80,7 @@ val max_printer_steps: int ref val parse_toplevel_phrase : (Lexing.lexbuf -> Parsetree.toplevel_phrase) ref val parse_use_file : (Lexing.lexbuf -> Parsetree.toplevel_phrase list) ref val print_location : formatter -> Location.t -> unit +val print_error : formatter -> Location.t -> unit val print_warning : Location.t -> formatter -> Warnings.t -> unit val input_name : string ref diff --git a/typing/annot.mli b/typing/annot.mli new file mode 100644 index 00000000..1dfdbaae --- /dev/null +++ b/typing/annot.mli @@ -0,0 +1,23 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Damien Doligez, 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: annot.mli,v 1.2 2008/07/29 15:42:44 doligez Exp $ *) + +(* Data types for annotations (Stypes.ml) *) + +type call = Tail | Stack | Inline;; + +type ident = + | Iref_internal of Location.t (* defining occurrence *) + | Iref_external + | Idef of Location.t (* scope *) +;; diff --git a/typing/btype.ml b/typing/btype.ml index fec7168e..ab6ee5ef 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: btype.ml,v 1.39.8.1 2007/06/08 08:03:15 garrigue Exp $ *) +(* $Id: btype.ml,v 1.42 2008/07/19 02:13:09 garrigue Exp $ *) (* Basic operations on core types *) @@ -140,7 +140,7 @@ let proxy ty = in proxy_obj ty | _ -> ty0 -(**** Utilities for private types ****) +(**** Utilities for fixed row private types ****) let has_constr_row t = match (repr t).desc with @@ -198,7 +198,7 @@ let iter_type_expr f ty = let rec iter_abbrev f = function Mnil -> () - | Mcons(_, ty, ty', rem) -> f ty; f ty'; iter_abbrev f rem + | Mcons(_, _, ty, ty', rem) -> f ty; f ty'; iter_abbrev f rem | Mlink rem -> iter_abbrev f !rem let copy_row f fixed row keep more = @@ -312,9 +312,9 @@ let unmark_type_decl decl = List.iter unmark_type decl.type_params; begin match decl.type_kind with Type_abstract -> () - | Type_variant (cstrs, priv) -> + | Type_variant cstrs -> List.iter (fun (c, tl) -> List.iter unmark_type tl) cstrs - | Type_record(lbls, rep, priv) -> + | Type_record(lbls, rep) -> List.iter (fun (c, mut, t) -> unmark_type t) lbls end; begin match decl.type_manifest with @@ -341,11 +341,12 @@ let rec unmark_class_type = (*******************************************) (* Search whether the expansion has been memorized. *) -let rec find_expans p1 = function +let rec find_expans priv p1 = function Mnil -> None - | Mcons (p2, ty0, ty, _) when Path.same p1 p2 -> Some ty - | Mcons (_, _, _, rem) -> find_expans p1 rem - | Mlink {contents = rem} -> find_expans p1 rem + | Mcons (priv', p2, ty0, ty, _) + when priv' >= priv && Path.same p1 p2 -> Some ty + | Mcons (_, _, _, _, rem) -> find_expans priv p1 rem + | Mlink {contents = rem} -> find_expans priv p1 rem (* debug: check for cycles in abbreviation. only works with -principal let rec check_expans visited ty = @@ -368,9 +369,9 @@ let cleanup_abbrev () = List.iter (fun abbr -> abbr := Mnil) !memo; memo := [] -let memorize_abbrev mem path v v' = +let memorize_abbrev mem priv path v v' = (* Memorize the expansion of an abbreviation. *) - mem := Mcons (path, v, v', !mem); + mem := Mcons (priv, path, v, v', !mem); (* check_expans [] v; *) memo := mem :: !memo @@ -378,10 +379,10 @@ let rec forget_abbrev_rec mem path = match mem with Mnil -> assert false - | Mcons (path', _, _, rem) when Path.same path path' -> + | Mcons (_, path', _, _, rem) when Path.same path path' -> rem - | Mcons (path', v, v', rem) -> - Mcons (path', v, v', forget_abbrev_rec rem path) + | Mcons (priv, path', v, v', rem) -> + Mcons (priv, path', v, v', forget_abbrev_rec rem path) | Mlink mem' -> mem' := forget_abbrev_rec !mem' path; raise Exit diff --git a/typing/btype.mli b/typing/btype.mli index 455ba5f3..96a0bcad 100644 --- a/typing/btype.mli +++ b/typing/btype.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: btype.mli,v 1.18 2006/01/04 16:55:50 doligez Exp $ *) +(* $Id: btype.mli,v 1.20 2008/07/19 02:13:09 garrigue Exp $ *) (* Basic operations on core types *) @@ -59,7 +59,7 @@ val proxy: type_expr -> type_expr (* Return the proxy representative of the type: either itself or a row variable *) -(**** Utilities for private types ****) +(**** Utilities for private abbreviations with fixed rows ****) val has_constr_row: type_expr -> bool val is_row_name: string -> bool @@ -104,14 +104,15 @@ val unmark_class_signature: class_signature -> unit (**** Memorization of abbreviation expansion ****) -val find_expans: Path.t -> abbrev_memo -> type_expr option +val find_expans: private_flag -> Path.t -> abbrev_memo -> type_expr option (* Look up a memorized abbreviation *) val cleanup_abbrev: unit -> unit (* Flush the cache of abbreviation expansions. When some types are saved (using [output_value]), this function MUST be called just before. *) val memorize_abbrev: - abbrev_memo ref -> Path.t -> type_expr -> type_expr -> unit + abbrev_memo ref -> + private_flag -> Path.t -> type_expr -> type_expr -> unit (* Add an expansion in the cache *) val forget_abbrev: abbrev_memo ref -> Path.t -> unit diff --git a/typing/ctype.ml b/typing/ctype.ml index ed96e6db..eb6ec2c8 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: ctype.ml,v 1.205.2.5 2008/02/12 04:49:25 garrigue Exp $ *) +(* $Id: ctype.ml,v 1.216.2.1 2008/10/08 13:07:13 doligez Exp $ *) (* Operations on core types *) @@ -101,7 +101,6 @@ let current_level = ref 0 let nongen_level = ref 0 let global_level = ref 1 let saved_level = ref [] -let saved_global_level = ref [] let init_def level = current_level := level; nongen_level := level let begin_def () = @@ -119,8 +118,7 @@ let end_def () = current_level := cl; nongen_level := nl let reset_global_level () = - global_level := !current_level + 1; - saved_global_level := [] + global_level := !current_level + 1 let increase_global_level () = let gl = !global_level in global_level := !current_level; @@ -443,9 +441,9 @@ let closed_type_decl decl = begin match decl.type_kind with Type_abstract -> () - | Type_variant(v, priv) -> + | Type_variant v -> List.iter (fun (_, tyl) -> List.iter closed_type tyl) v - | Type_record(r, rep, priv) -> + | Type_record(r, rep) -> List.iter (fun (_, _, ty) -> closed_type ty) r end; begin match decl.type_manifest with @@ -579,7 +577,7 @@ let rec generalize_spine ty = generalize_spine ty' | _ -> () -let try_expand_once' = (* Forward declaration *) +let forward_try_expand_once = (* Forward declaration *) ref (fun env ty -> raise Cannot_expand) (* @@ -601,7 +599,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_once' env ty); + link_type ty (!forward_try_expand_once env ty); update_level env level ty with Cannot_expand -> (* +++ Levels should be restored... *) @@ -724,9 +722,9 @@ let rec find_repr p1 = function Mnil -> None - | Mcons (p2, ty, _, _) when Path.same p1 p2 -> + | Mcons (Public, p2, ty, _, _) when Path.same p1 p2 -> Some ty - | Mcons (_, _, _, rem) -> + | Mcons (_, _, _, _, rem) -> find_repr p1 rem | Mlink {contents = rem} -> find_repr p1 rem @@ -998,7 +996,7 @@ let instance_label fixed lbl = let unify' = (* Forward declaration *) ref (fun env ty1 ty2 -> raise (Unify [])) -let rec subst env level abbrev ty params args body = +let rec subst env level priv abbrev ty params args body = if List.length params <> List.length args then raise (Unify []); let old_level = !current_level in current_level := level; @@ -1008,7 +1006,7 @@ let rec subst env level abbrev ty params args body = None -> () | Some ({desc = Tconstr (path, tl, _)} as ty) -> let abbrev = proper_abbrevs path tl abbrev in - memorize_abbrev abbrev path ty body0 + memorize_abbrev abbrev priv path ty body0 | _ -> assert false end; @@ -1031,7 +1029,7 @@ let rec subst env level abbrev ty params args body = *) let apply env params body args = try - subst env generic_level (ref Mnil) None params args body + subst env generic_level Public (ref Mnil) None params args body with Unify _ -> raise Cannot_apply @@ -1047,8 +1045,10 @@ let apply env params body args = type or module definition is overriden in the environnement. *) let previous_env = ref Env.empty +let string_of_kind = function Public -> "public" | Private -> "private" let check_abbrev_env env = if env != !previous_env then begin + (* prerr_endline "cleanup expansion cache"; *) cleanup_abbrev (); previous_env := env end @@ -1071,13 +1071,15 @@ let check_abbrev_env env = 4. The expansion requires the expansion of another abbreviation, and this other expansion fails. *) -let expand_abbrev env ty = +let expand_abbrev_gen kind find_type_expansion env ty = check_abbrev_env env; match ty with {desc = Tconstr (path, args, abbrev); level = level} -> let lookup_abbrev = proper_abbrevs path args abbrev in - begin match find_expans path !lookup_abbrev with + begin match find_expans kind path !lookup_abbrev with Some ty -> + (* prerr_endline + ("found a "^string_of_kind kind^" expansion for "^Path.name path);*) if level <> generic_level then begin try update_level env level ty @@ -1090,10 +1092,12 @@ let expand_abbrev env ty = ty | None -> let (params, body) = - try Env.find_type_expansion path env with Not_found -> + try find_type_expansion path env with Not_found -> raise Cannot_expand in - let ty' = subst env level abbrev (Some ty) params args body in + (* prerr_endline + ("add a "^string_of_kind kind^" expansion for "^Path.name path);*) + let ty' = subst env level kind abbrev (Some ty) params args body in (* Hack to name the variant type *) begin match repr ty' with {desc=Tvariant row} as ty when static_row row -> @@ -1105,6 +1109,8 @@ let expand_abbrev env ty = | _ -> assert false +let expand_abbrev = expand_abbrev_gen Public Env.find_type_expansion + let safe_abbrev env ty = let snap = Btype.snapshot () in try ignore (expand_abbrev env ty); true @@ -1118,7 +1124,7 @@ let try_expand_once env ty = Tconstr _ -> repr (expand_abbrev env ty) | _ -> raise Cannot_expand -let _ = try_expand_once' := try_expand_once +let _ = forward_try_expand_once := try_expand_once (* Fully expand the head of a type. Raise Cannot_expand if the type cannot be expanded. @@ -1146,6 +1152,36 @@ let expand_head env ty = Btype.backtrack snap; repr ty +(* Implementing function [expand_head_opt], the compiler's own version of + [expand_head] used for type-based optimisations. + [expand_head_opt] uses [Env.find_type_expansion_opt] to access the + manifest type information of private abstract data types which is + normally hidden to the type-checker out of the implementation module of + the private abbreviation. *) + +let expand_abbrev_opt = expand_abbrev_gen Private Env.find_type_expansion_opt + +let try_expand_once_opt env ty = + let ty = repr ty in + match ty.desc with + Tconstr _ -> repr (expand_abbrev_opt env ty) + | _ -> raise Cannot_expand + +let rec try_expand_head_opt env ty = + let ty' = try_expand_once_opt env ty in + begin try + try_expand_head_opt env ty' + with Cannot_expand -> + ty' + end + +let expand_head_opt env ty = + let snap = Btype.snapshot () in + try try_expand_head_opt env ty + with Cannot_expand | Unify _ -> (* expand_head shall never fail *) + Btype.backtrack snap; + repr ty + (* Make sure that the type parameters of the type constructor [ty] respect the type constraints *) let enforce_constraints env ty = @@ -1153,7 +1189,8 @@ let enforce_constraints env ty = {desc = Tconstr (path, args, abbrev); level = level} -> let decl = Env.find_type path env in ignore - (subst env level (ref Mnil) None decl.type_params args (newvar2 level)) + (subst env level Public (ref Mnil) None decl.type_params args + (newvar2 level)) | _ -> assert false @@ -1199,7 +1236,7 @@ let rec non_recursive_abbrev env ty0 ty = match ty.desc with Tconstr(p, args, abbrev) -> begin try - non_recursive_abbrev env ty0 (try_expand_head env ty) + non_recursive_abbrev env ty0 (try_expand_once env ty) with Cannot_expand -> if !Clflags.recursive_types then () else iter_type_expr (non_recursive_abbrev env ty0) ty @@ -1215,11 +1252,11 @@ let correct_abbrev env path params ty = check_abbrev_env env; let ty0 = newgenvar () in visited := []; - let abbrev = Mcons (path, ty0, ty0, Mnil) in + let abbrev = Mcons (Public, path, ty0, ty0, Mnil) in simple_abbrevs := abbrev; try non_recursive_abbrev env ty0 - (subst env generic_level (ref abbrev) None [] [] ty); + (subst env generic_level Public (ref abbrev) None [] [] ty); simple_abbrevs := Mnil; visited := [] with exn -> @@ -1415,7 +1452,7 @@ let univar_pairs = ref [] let rec has_cached_expansion p abbrev = match abbrev with Mnil -> false - | Mcons(p', _, _, rem) -> Path.same p p' || has_cached_expansion p rem + | Mcons(_, p', _, _, rem) -> Path.same p p' || has_cached_expansion p rem | Mlink rem -> has_cached_expansion p !rem (**** Transform error trace ****) @@ -1434,6 +1471,9 @@ let mkvariant fields closed = {row_fields = fields; row_closed = closed; row_more = newvar(); row_bound = (); row_fixed = false; row_name = None }) +(* force unification in Reither when one side has as non-conjunctive type *) +let rigid_variants = ref false + (**** Unification ****) (* Return whether [t0] occurs in [ty]. Objects are also traversed. *) @@ -1782,7 +1822,8 @@ and unify_row_field env fixed1 fixed2 l f1 f2 = | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) -> if e1 == e2 then () else let redo = - (m1 || m2) && + (m1 || m2 || + !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) && begin match tl1 @ tl2 with [] -> false | t1 :: tl -> if c1 || c2 then raise (Unify []); @@ -2204,6 +2245,12 @@ let matches env ty ty' = (* Equivalence between parameterized types *) (*********************************************) +let expand_head_rigid env ty = + let old = !rigid_variants in + rigid_variants := true; + let ty' = expand_head_unif env ty in + rigid_variants := old; ty' + let normalize_subst subst = if List.exists (function {desc=Tlink _}, _ | _, {desc=Tlink _} -> true | _ -> false) @@ -2228,8 +2275,8 @@ let rec eqtype rename type_pairs subst env t1 t2 = | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> () | _ -> - let t1' = expand_head_unif env t1 in - let t2' = expand_head_unif env t2 in + let t1' = expand_head_rigid env t1 in + let t2' = expand_head_rigid env t2 in (* Expansion may have changed the representative of the types... *) let t1' = repr t1' and t2' = repr t2' in if t1' == t2' then () else @@ -2283,10 +2330,9 @@ and eqtype_list rename type_pairs subst env tl1 tl2 = and eqtype_fields rename type_pairs subst env ty1 ty2 = let (fields2, rest2) = flatten_fields ty2 in (* Try expansion, needed when called from Includecore.type_manifest *) - try match try_expand_head env rest2 with + match expand_head_rigid env rest2 with {desc=Tobject(ty2,_)} -> eqtype_fields rename type_pairs subst env ty1 ty2 - | _ -> raise Cannot_expand - with Cannot_expand -> + | _ -> let (fields1, rest1) = flatten_fields ty1 in let (pairs, miss1, miss2) = associate_fields fields1 fields2 in eqtype rename type_pairs subst env rest1 rest2; @@ -2309,10 +2355,9 @@ and eqtype_kind k1 k2 = and eqtype_row rename type_pairs subst env row1 row2 = (* Try expansion, needed when called from Includecore.type_manifest *) - try match try_expand_head env (row_more row2) with + match expand_head_rigid env (row_more row2) with {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2 - | _ -> raise Cannot_expand - with Cannot_expand -> + | _ -> let row1 = row_repr row1 and row2 = row_repr row2 in let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in if row1.row_closed <> row2.row_closed @@ -2744,7 +2789,8 @@ let rec build_subtype env visited loops posi level t = Tobject _ when posi && not (opened_object t') -> let cl_abbr, body = find_cltype_for_path env p in let ty = - subst env !current_level abbrev None cl_abbr.type_params tl body in + subst env !current_level Public abbrev None + cl_abbr.type_params tl body in let ty = repr ty in let ty1, tl1 = match ty.desc with @@ -2752,6 +2798,10 @@ let rec build_subtype env visited loops posi level t = ty1, tl1 | _ -> raise Not_found in + (* Fix PR4505: do not set ty to Tvar when it appears in tl1, + as this occurence might break the occur check. + XXX not clear whether this correct anyway... *) + if List.exists (deep_occur ty) tl1 then raise Not_found; ty.desc <- Tvar; let t'' = newvar () in let loops = (ty, t'') :: loops in @@ -2887,6 +2937,12 @@ let subtypes = TypePairs.create 17 let subtype_error env trace = raise (Subtype (expand_trace env (List.rev trace), [])) +let private_abbrev env path = + try + let decl = Env.find_type path env in + decl.type_private = Private && decl.type_manifest <> None + with Not_found -> false + let rec subtype_rec env trace t1 t2 cstrs = let t1 = repr t1 in let t2 = repr t2 in @@ -2931,6 +2987,8 @@ let rec subtype_rec env trace t1 t2 cstrs = with Not_found -> (trace, t1, t2, !univar_pairs)::cstrs end + | (Tconstr(p1, tl1, _), _) when private_abbrev env p1 -> + subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs | (Tobject (f1, _), Tobject (f2, _)) when (object_row f1).desc = Tvar && (object_row f2).desc = Tvar -> (* Same row variable implies same object. *) @@ -2945,6 +3003,9 @@ let rec subtype_rec env trace t1 t2 cstrs = end | (Tpoly (u1, []), Tpoly (u2, [])) -> subtype_rec env trace u1 u2 cstrs + | (Tpoly (u1, tl1), Tpoly (u2, [])) -> + let _, u1' = instance_poly false tl1 u1 in + subtype_rec env trace u1' u2 cstrs | (Tpoly (u1, tl1), Tpoly (u2,tl2)) -> begin try enter_poly env univar_pairs u1 tl1 u2 tl2 @@ -3119,8 +3180,8 @@ let rec normalize_type_rec env ty = | Tvariant row -> let row = row_repr row in let fields = List.map - (fun (l,f) -> - let f = row_field_repr f in l, + (fun (l,f0) -> + let f = row_field_repr f0 in l, match f with Reither(b, ty::(_::_ as tyl), m, e) -> let tyl' = List.fold_left @@ -3129,10 +3190,8 @@ let rec normalize_type_rec env ty = then tyl else ty::tyl) [ty] tyl in - if List.length tyl' <= List.length tyl then - let f = Reither(b, List.rev tyl', m, ref None) in - set_row_field e f; - f + if f != f0 || List.length tyl' < List.length tyl then + Reither(b, List.rev tyl', m, e) else f | _ -> f) row.row_fields in @@ -3270,16 +3329,16 @@ let nondep_type_decl env mid id is_covariant decl = match decl.type_kind with Type_abstract -> Type_abstract - | Type_variant(cstrs, priv) -> + | Type_variant cstrs -> Type_variant(List.map (fun (c, tl) -> (c, List.map (nondep_type_rec env mid) tl)) - cstrs, priv) - | Type_record(lbls, rep, priv) -> + cstrs) + | Type_record(lbls, rep) -> Type_record( List.map (fun (c, mut, t) -> (c, mut, nondep_type_rec env mid t)) lbls, - rep, priv) + rep) with Not_found when is_covariant -> Type_abstract end; @@ -3292,6 +3351,7 @@ let nondep_type_decl env mid id is_covariant decl = with Not_found when is_covariant -> None end; + type_private = decl.type_private; type_variance = decl.type_variance; } in @@ -3299,9 +3359,9 @@ let nondep_type_decl env mid id is_covariant decl = List.iter unmark_type decl.type_params; begin match decl.type_kind with Type_abstract -> () - | Type_variant(cstrs, priv) -> + | Type_variant cstrs -> List.iter (fun (c, tl) -> List.iter unmark_type tl) cstrs - | Type_record(lbls, rep, priv) -> + | Type_record(lbls, rep) -> List.iter (fun (c, mut, t) -> unmark_type t) lbls end; begin match decl.type_manifest with diff --git a/typing/ctype.mli b/typing/ctype.mli index 856559d3..f0115532 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: ctype.mli,v 1.54 2006/04/05 02:28:13 garrigue Exp $ *) +(* $Id: ctype.mli,v 1.55 2007/11/01 18:36:43 weis Exp $ *) (* Operations on core types *) @@ -131,6 +131,9 @@ val apply: val expand_head_once: Env.t -> type_expr -> type_expr val expand_head: Env.t -> type_expr -> type_expr +val expand_head_opt: Env.t -> type_expr -> type_expr +(** The compiler's own version of [expand_head] necessary for type-based + optimisations. *) val full_expand: Env.t -> type_expr -> type_expr val enforce_constraints: Env.t -> type_expr -> unit diff --git a/typing/env.ml b/typing/env.ml index 780ed8d6..508ea1e4 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: env.ml,v 1.58 2006/10/13 12:56:28 xleroy Exp $ *) +(* $Id: env.ml,v 1.66 2008/10/06 13:53:54 doligez Exp $ *) (* Environment handling *) @@ -44,6 +44,7 @@ type summary = type t = { values: (Path.t * value_description) Ident.tbl; + annotations: (Path.t * Annot.ident) Ident.tbl; constrs: constructor_description Ident.tbl; labels: label_description Ident.tbl; types: (Path.t * type_declaration) Ident.tbl; @@ -63,6 +64,7 @@ and module_components_repr = and structure_components = { mutable comp_values: (string, (value_description * int)) Tbl.t; + mutable comp_annotations: (string, (Annot.ident * int)) Tbl.t; mutable comp_constrs: (string, (constructor_description * int)) Tbl.t; mutable comp_labels: (string, (label_description * int)) Tbl.t; mutable comp_types: (string, (type_declaration * int)) Tbl.t; @@ -83,7 +85,7 @@ and functor_components = { } let empty = { - values = Ident.empty; constrs = Ident.empty; + values = Ident.empty; annotations = Ident.empty; constrs = Ident.empty; labels = Ident.empty; types = Ident.empty; modules = Ident.empty; modtypes = Ident.empty; components = Ident.empty; classes = Ident.empty; @@ -257,11 +259,32 @@ and find_class = and find_cltype = find (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) +(* Find the manifest type associated to a type when appropriate: + - the type should be public or should have a private row, + - the type should have an associated manifest type. *) let find_type_expansion path env = let decl = find_type path env in match decl.type_manifest with - None -> raise Not_found + | Some body when decl.type_private = Public + || decl.type_kind <> Type_abstract + || Btype.has_constr_row body -> (decl.type_params, body) + (* The manifest type of Private abstract data types without + private row are still considered unknown to the type system. + Hence, this case is caught by the following clause that also handles + purely abstract data types without manifest type definition. *) + | _ -> raise Not_found + +(* Find the manifest type information associated to a type, i.e. + the necessary information for the compiler's type-based optimisations. + In particular, the manifest type associated to a private abstract type + is revealed for the sake of compiler's type-based optimisations. *) +let find_type_expansion_opt path env = + let decl = find_type path env in + match decl.type_manifest with + (* The manifest type of Private abstract data types can still get + an approximation using their manifest type. *) | Some body -> (decl.type_params, body) + | _ -> raise Not_found let find_modtype_expansion path env = match find_modtype path env with @@ -388,6 +411,8 @@ let lookup_simple proj1 proj2 lid env = let lookup_value = lookup (fun env -> env.values) (fun sc -> sc.comp_values) +let lookup_annot id e = + lookup (fun env -> env.annotations) (fun sc -> sc.comp_annotations) id e and lookup_constructor = lookup_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs) and lookup_label = @@ -417,20 +442,20 @@ let rec scrape_modtype mty env = let constructors_of_type ty_path decl = match decl.type_kind with - Type_variant(cstrs, priv) -> + Type_variant cstrs -> Datarepr.constructor_descrs (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) - cstrs priv + cstrs decl.type_private | Type_record _ | Type_abstract -> [] (* Compute label descriptions *) let labels_of_type ty_path decl = match decl.type_kind with - Type_record(labels, rep, priv) -> + Type_record(labels, rep) -> Datarepr.label_descrs (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) - labels rep priv + labels rep decl.type_private | Type_variant _ | Type_abstract -> [] (* Given a signature and a root path, prefix all idents in the signature @@ -478,7 +503,8 @@ let rec components_of_module env sub path mty = lazy(match scrape_modtype mty env with Tmty_signature sg -> let c = - { comp_values = Tbl.empty; comp_constrs = Tbl.empty; + { comp_values = Tbl.empty; comp_annotations = Tbl.empty; + comp_constrs = Tbl.empty; comp_labels = Tbl.empty; comp_types = Tbl.empty; comp_modules = Tbl.empty; comp_modtypes = Tbl.empty; comp_components = Tbl.empty; comp_classes = Tbl.empty; @@ -492,6 +518,11 @@ let rec components_of_module env sub path mty = let decl' = Subst.value_description sub decl in c.comp_values <- Tbl.add (Ident.name id) (decl', !pos) c.comp_values; + if !Clflags.annotations then begin + c.comp_annotations <- + Tbl.add (Ident.name id) (Annot.Iref_external, !pos) + c.comp_annotations; + end; begin match decl.val_kind with Val_prim _ -> () | _ -> incr pos end @@ -506,7 +537,7 @@ let rec components_of_module env sub path mty = List.iter (fun (name, descr) -> c.comp_labels <- Tbl.add name (descr, nopos) c.comp_labels) - (labels_of_type path decl'); + (labels_of_type path decl'); env := store_type_infos id path decl !env | Tsig_exception(id, decl) -> let decl' = Subst.exception_declaration sub decl in @@ -552,7 +583,8 @@ let rec components_of_module env sub path mty = fcomp_cache = Hashtbl.create 17 } | Tmty_ident p -> Structure_comps { - comp_values = Tbl.empty; comp_constrs = Tbl.empty; + comp_values = Tbl.empty; comp_annotations = Tbl.empty; + comp_constrs = Tbl.empty; comp_labels = Tbl.empty; comp_types = Tbl.empty; comp_modules = Tbl.empty; comp_modtypes = Tbl.empty; comp_components = Tbl.empty; comp_classes = Tbl.empty; @@ -565,6 +597,12 @@ and store_value id path decl env = values = Ident.add id (path, decl) env.values; summary = Env_value(env.summary, id, decl) } +and store_annot id path annot env = + if !Clflags.annotations then + { env with + annotations = Ident.add id (path, annot) env.annotations } + else env + and store_type id path info env = { env with constrs = @@ -645,6 +683,9 @@ let _ = let add_value id desc env = store_value id (Pident id) desc env +let add_annot id annot env = + store_annot id (Pident id) annot env + and add_type id info env = store_type id (Pident id) info env @@ -704,8 +745,9 @@ let open_signature root sg env = (fun env item p -> match item with Tsig_value(id, decl) -> - store_value (Ident.hide id) p + let e1 = store_value (Ident.hide id) p (Subst.value_description sub decl) env + in store_annot (Ident.hide id) p (Annot.Iref_external) e1 | Tsig_type(id, decl, _) -> store_type (Ident.hide id) p (Subst.type_declaration sub decl) env diff --git a/typing/env.mli b/typing/env.mli index e61df31e..76252ba6 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: env.mli,v 1.31 2006/06/26 09:38:06 garrigue Exp $ *) +(* $Id: env.mli,v 1.35 2008/10/06 13:53:54 doligez Exp $ *) (* Environment handling *) @@ -32,11 +32,15 @@ val find_class: Path.t -> t -> class_declaration val find_cltype: Path.t -> t -> cltype_declaration val find_type_expansion: Path.t -> t -> type_expr list * type_expr +val find_type_expansion_opt: Path.t -> t -> type_expr list * type_expr +(* Find the manifest type information associated to a type for the sake + of the compiler's type-based optimisations. *) val find_modtype_expansion: Path.t -> t -> Types.module_type (* Lookup by long identifiers *) val lookup_value: Longident.t -> t -> Path.t * value_description +val lookup_annot: Longident.t -> t -> Path.t * Annot.ident val lookup_constructor: Longident.t -> t -> constructor_description val lookup_label: Longident.t -> t -> label_description val lookup_type: Longident.t -> t -> Path.t * type_declaration @@ -48,6 +52,7 @@ val lookup_cltype: Longident.t -> t -> Path.t * cltype_declaration (* Insertion by identifier *) val add_value: Ident.t -> value_description -> t -> t +val add_annot: Ident.t -> Annot.ident -> t -> t val add_type: Ident.t -> type_declaration -> t -> t val add_exception: Ident.t -> exception_declaration -> t -> t val add_module: Ident.t -> module_type -> t -> t @@ -90,7 +95,7 @@ val save_signature: signature -> string -> string -> unit (* Arguments: signature, module name, file name. *) val save_signature_with_imports: signature -> string -> string -> (string * Digest.t) list -> unit - (* Arguments: signature, module name, file name, + (* Arguments: signature, module name, file name, imported units with their CRCs. *) (* Return the CRC of the interface of the given compilation unit *) @@ -139,4 +144,3 @@ val report_error: formatter -> error -> unit (* Forward declaration to break mutual recursion with Includemod. *) val check_modtype_inclusion: (t -> module_type -> Path.t -> module_type -> unit) ref - diff --git a/typing/includecore.ml b/typing/includecore.ml index 7ed51382..91750f21 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: includecore.ml,v 1.32 2005/08/08 05:40:52 garrigue Exp $ *) +(* $Id: includecore.ml,v 1.35 2007/11/28 22:27:35 weis Exp $ *) (* Inclusion checks for the core language *) @@ -37,8 +37,11 @@ let value_descriptions env vd1 vd2 = (* Inclusion between "private" annotations *) -let private_flags priv1 priv2 = - match (priv1, priv2) with (Private, Public) -> false | (_, _) -> true +let private_flags decl1 decl2 = + match decl1.type_private, decl2.type_private with + | Private, Public -> + decl2.type_kind = Type_abstract && decl2.type_manifest = None + | _, _ -> true (* Inclusion between manifest types (particularly for private row types) *) @@ -57,7 +60,7 @@ let type_manifest env ty1 params1 ty2 params2 = Tvariant row1, Tvariant row2 when is_absrow env (Btype.row_more row2) -> let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in Ctype.equal env true (ty1::params1) (row2.row_more::params2) && - (match row1.row_more with {desc=Tvar|Tconstr _} -> true | _ -> false) && + (match row1.row_more with {desc=Tvar|Tconstr _} -> true | _ -> false) && let r1, r2, pairs = Ctype.merge_row_fields row1.row_fields row2.row_fields in (not row2.row_closed || @@ -93,17 +96,17 @@ let type_manifest env ty1 params1 ty2 params2 = let tl1, tl2 = List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs) in Ctype.equal env true (params1 @ tl1) (params2 @ tl2) - | _ -> + | _ -> Ctype.equal env true (ty1 :: params1) (ty2 :: params2) (* Inclusion between type declarations *) let type_declarations env id decl1 decl2 = decl1.type_arity = decl2.type_arity && + private_flags decl1 decl2 && begin match (decl1.type_kind, decl2.type_kind) with (_, Type_abstract) -> true - | (Type_variant (cstrs1, priv1), Type_variant (cstrs2, priv2)) -> - private_flags priv1 priv2 && + | (Type_variant cstrs1, Type_variant cstrs2) -> Misc.for_all2 (fun (cstr1, arg1) (cstr2, arg2) -> cstr1 = cstr2 && @@ -113,8 +116,7 @@ let type_declarations env id decl1 decl2 = (ty2::decl2.type_params)) arg1 arg2) cstrs1 cstrs2 - | (Type_record(labels1,rep1,priv1), Type_record(labels2,rep2,priv2)) -> - private_flags priv1 priv2 && + | (Type_record(labels1,rep1), Type_record(labels2,rep2)) -> rep1 = rep2 && Misc.for_all2 (fun (lbl1, mut1, ty1) (lbl2, mut2, ty2) -> @@ -137,9 +139,10 @@ let type_declarations env id decl1 decl2 = Ctype.equal env false [ty1] [ty2] end && if match decl2.type_kind with - | Type_record(_,_,priv) | Type_variant(_,priv) -> priv = Private + | Type_record (_,_) | Type_variant _ -> decl2.type_private = Private | Type_abstract -> - match decl2.type_manifest with None -> true + match decl2.type_manifest with + | None -> true | Some ty -> Btype.has_constr_row (Ctype.expand_head env ty) then List.for_all2 diff --git a/typing/includemod.ml b/typing/includemod.ml index fbfe908b..fa7e2fd1 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: includemod.ml,v 1.38.6.1 2007/09/10 03:02:10 garrigue Exp $ *) +(* $Id: includemod.ml,v 1.39 2008/01/11 16:13:16 doligez Exp $ *) (* Inclusion checks for the module language *) diff --git a/typing/mtype.ml b/typing/mtype.ml index 453f979c..46ff73fe 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -10,10 +10,11 @@ (* *) (***********************************************************************) -(* $Id: mtype.ml,v 1.26 2005/09/28 07:18:30 garrigue Exp $ *) +(* $Id: mtype.ml,v 1.28 2007/10/19 13:25:21 garrigue Exp $ *) (* Operations on module types *) +open Asttypes open Path open Types @@ -48,9 +49,11 @@ and strengthen_sig env sg p = | Tsig_type(id, decl, rs) :: rem -> let newdecl = match decl.type_manifest with - Some ty when not (Btype.has_constr_row ty) -> decl + Some ty when decl.type_private = Public -> decl | _ -> - { decl with type_manifest = + { decl with + type_private = Public; + type_manifest = Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id, nopos), decl.type_params, ref Mnil))) } in diff --git a/typing/oprint.ml b/typing/oprint.ml index 456f30c1..dfc15639 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: oprint.ml,v 1.24.8.2 2007/08/16 08:01:33 garrigue Exp $ *) +(* $Id: oprint.ml,v 1.26.4.1 2008/10/08 13:07:14 doligez Exp $ *) open Format open Outcometree @@ -55,11 +55,13 @@ let float_repres f = | FP_infinite -> if f < 0.0 then "neg_infinity" else "infinity" | _ -> - let s1 = Printf.sprintf "%.12g" f in - if f = float_of_string s1 then valid_float_lexeme s1 else - let s2 = Printf.sprintf "%.15g" f in - if f = float_of_string s2 then valid_float_lexeme s2 else - Printf.sprintf "%.18g" f + let float_val = + let s1 = Printf.sprintf "%.12g" f in + if f = float_of_string s1 then s1 else + let s2 = Printf.sprintf "%.15g" f in + if f = float_of_string s2 then s2 else + Printf.sprintf "%.18g" f + in valid_float_lexeme float_val let parenthesize_if_neg ppf fmt v isneg = if isneg then pp_print_char ppf '('; @@ -340,7 +342,7 @@ and print_out_sig_item ppf = | Osig_modtype (name, mty) -> fprintf ppf "@[<2>module type %s =@ %a@]" name !out_module_type mty | Osig_module (name, mty, rs) -> - fprintf ppf "@[<2>%s %s :@ %a@]" + fprintf ppf "@[<2>%s %s :@ %a@]" (match rs with Orec_not -> "module" | Orec_first -> "module rec" | Orec_next -> "and") diff --git a/typing/parmatch.ml b/typing/parmatch.ml index be8f427e..7ea21eb2 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: parmatch.ml,v 1.71.6.1 2007/06/08 08:03:15 garrigue Exp $ *) +(* $Id: parmatch.ml,v 1.76 2008/07/15 18:11:46 mauny Exp $ *) (* Detection of partial matches and unused match cases. *) @@ -83,6 +83,7 @@ let rec compat p q = | _,Tpat_or (q1,q2,_) -> compat p q1 || compat p q2 | Tpat_constant c1, Tpat_constant c2 -> c1=c2 | Tpat_tuple ps, Tpat_tuple qs -> compats ps qs + | Tpat_lazy p, Tpat_lazy q -> compat p q | Tpat_construct (c1,ps1), Tpat_construct (c2,ps2) -> c1.cstr_tag = c2.cstr_tag && compats ps1 ps2 | Tpat_variant(l1,Some p1, r1), Tpat_variant(l2,Some p2,_) -> @@ -125,7 +126,7 @@ let get_type_descr ty tenv = let rec get_constr tag ty tenv = match get_type_descr ty tenv with - | {type_kind=Type_variant(constr_list, priv)} -> + | {type_kind=Type_variant constr_list} -> Datarepr.find_constr_by_tag tag constr_list | {type_manifest = Some _} -> get_constr tag (Ctype.expand_head_once tenv ty) tenv @@ -139,7 +140,7 @@ let find_label lbl lbls = let rec get_record_labels ty tenv = match get_type_descr ty tenv with - | {type_kind = Type_record(lbls, rep, priv)} -> lbls + | {type_kind = Type_record(lbls, rep)} -> lbls | {type_manifest = Some _} -> get_record_labels (Ctype.expand_head_once tenv ty) tenv | _ -> fatal_error "Parmatch.get_record_labels" @@ -164,7 +165,7 @@ let is_cons tag v = match get_constr_name tag v.pat_type v.pat_env with | "::" -> true | _ -> false - + let rec pretty_val ppf v = match v.pat_desc with | Tpat_any -> fprintf ppf "_" | Tpat_var x -> Ident.print ppf x @@ -204,6 +205,8 @@ let rec pretty_val ppf v = match v.pat_desc with | _ -> true) lvs) | Tpat_array vs -> fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs + | Tpat_lazy v -> + fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v | Tpat_alias (v,x) -> fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x | Tpat_or (v,w,_) -> @@ -269,6 +272,7 @@ let simple_match p1 p2 = float_of_string s1 = float_of_string s2 | Tpat_constant(c1), Tpat_constant(c2) -> c1 = c2 | Tpat_tuple _, Tpat_tuple _ -> true + | Tpat_lazy _, Tpat_lazy _ -> true | Tpat_record _ , Tpat_record _ -> true | Tpat_array p1s, Tpat_array p2s -> List.length p1s = List.length p2s | _, (Tpat_any | Tpat_var(_)) -> true @@ -329,6 +333,7 @@ let rec simple_match_args p1 p2 = match p2.pat_desc with | Tpat_tuple(args) -> args | Tpat_record(args) -> extract_fields (record_arg p1) args | Tpat_array(args) -> args +| Tpat_lazy arg -> [arg] | (Tpat_any | Tpat_var(_)) -> begin match p1.pat_desc with Tpat_construct(_, args) -> omega_list args @@ -336,6 +341,7 @@ let rec simple_match_args p1 p2 = match p2.pat_desc with | Tpat_tuple(args) -> omega_list args | Tpat_record(args) -> omega_list args | Tpat_array(args) -> omega_list args + | Tpat_lazy _ -> [omega] | _ -> [] end | _ -> [] @@ -361,6 +367,8 @@ let rec normalize_pat q = match q.pat_desc with | Tpat_record (largs) -> make_pat (Tpat_record (List.map (fun (lbl,_) -> lbl,omega) largs)) q.pat_type q.pat_env + | Tpat_lazy _ -> + make_pat (Tpat_lazy omega) q.pat_type q.pat_env | Tpat_or _ -> fatal_error "Parmatch.normalize_pat" @@ -379,6 +387,7 @@ let discr_pat q pss = | ({pat_desc = (Tpat_any | Tpat_var _)}::_)::pss -> acc_pat acc pss | (({pat_desc = Tpat_tuple _} as p)::_)::_ -> normalize_pat p + | (({pat_desc = Tpat_lazy _} as p)::_)::_ -> normalize_pat p | (({pat_desc = Tpat_record largs} as p)::_)::pss -> let new_omegas = List.fold_left @@ -448,6 +457,12 @@ let do_set_args erase_mutable q r = match q with make_pat (Tpat_variant (l, arg, row)) q.pat_type q.pat_env:: rest +| {pat_desc = Tpat_lazy omega} -> + begin match r with + arg::rest -> + make_pat (Tpat_lazy arg) q.pat_type q.pat_env::rest + | _ -> fatal_error "Parmatch.do_set_args (lazy)" + end | {pat_desc = Tpat_array omegas} -> let args,rest = read_args omegas r in make_pat @@ -541,7 +556,7 @@ let filter_all pat0 pss = filter_omega (filter_rec (match pat0.pat_desc with - (Tpat_record(_) | Tpat_tuple(_)) -> [pat0,[]] + (Tpat_record(_) | Tpat_tuple(_) | Tpat_lazy(_)) -> [pat0,[]] | _ -> []) pss) pss @@ -630,6 +645,7 @@ let full_match closing env = match env with | ({pat_desc = Tpat_tuple(_)},_) :: _ -> true | ({pat_desc = Tpat_record(_)},_) :: _ -> true | ({pat_desc = Tpat_array(_)},_) :: _ -> false +| ({pat_desc = Tpat_lazy(_)},_) :: _ -> true | _ -> fatal_error "Parmatch.full_match" let extendable_match env = match env with @@ -867,6 +883,7 @@ let rec has_instance p = match p.pat_desc with | Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2 | Tpat_construct (_,ps) | Tpat_tuple ps | Tpat_array ps -> has_instances ps | Tpat_record lps -> has_instances (List.map snd lps) + | Tpat_lazy p -> has_instance p and has_instances = function | [] -> true @@ -1299,6 +1316,7 @@ let rec le_pat p q = l1 = l2 | Tpat_variant(_,_,_), Tpat_variant(_,_,_) -> false | Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs + | Tpat_lazy p, Tpat_lazy q -> le_pat p q | Tpat_record l1, Tpat_record l2 -> let ps,qs = records_args l1 l2 in le_pats ps qs @@ -1337,6 +1355,9 @@ let rec lub p q = match p.pat_desc,q.pat_desc with | Tpat_tuple ps, Tpat_tuple qs -> let rs = lubs ps qs in make_pat (Tpat_tuple rs) p.pat_type p.pat_env +| Tpat_lazy p, Tpat_lazy q -> + let r = lub p q in + make_pat (Tpat_lazy r) p.pat_type p.pat_env | Tpat_construct (c1,ps1), Tpat_construct (c2,ps2) when c1.cstr_tag = c2.cstr_tag -> let rs = lubs ps1 ps2 in @@ -1570,6 +1591,8 @@ let rec collect_paths_from_pat r p = match p.pat_desc with | Tpat_variant (_, Some p, _) | Tpat_alias (p,_) -> collect_paths_from_pat r p | Tpat_or (p1,p2,_) -> collect_paths_from_pat (collect_paths_from_pat r p1) p2 +| Tpat_lazy p -> + collect_paths_from_pat r p (* @@ -1658,3 +1681,32 @@ let check_unused tdefs casel = do_rec ([q]::pref) rem in do_rec [] casel + +(*********************************) +(* Exported irrefutability tests *) +(*********************************) + +let irrefutable pat = le_pat pat omega + +(* An inactive pattern is a pattern whose matching needs only + trivial computations (tag/equality tests). + Patterns containing (lazy _) subpatterns are active. *) + +let rec inactive pat = match pat with +| Tpat_lazy _ -> + false +| Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_, None, _) -> + true +| Tpat_tuple ps | Tpat_construct (_, ps) | Tpat_array ps -> + List.for_all (fun p -> inactive p.pat_desc) ps +| Tpat_alias (p,_) | Tpat_variant (_, Some p, _) -> + inactive p.pat_desc +| Tpat_record ldps -> + List.exists (fun (_, p) -> inactive p.pat_desc) ldps +| Tpat_or (p,q,_) -> + inactive p.pat_desc && inactive q.pat_desc + + +(* A `fluid' pattern is both irrefutable and inactive *) + +let fluid pat = irrefutable pat && inactive pat.pat_desc diff --git a/typing/parmatch.mli b/typing/parmatch.mli index 803826f3..29767c0f 100644 --- a/typing/parmatch.mli +++ b/typing/parmatch.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: parmatch.mli,v 1.10 2005/03/11 10:12:05 maranget Exp $ *) +(* $Id: parmatch.mli,v 1.12 2008/07/09 13:03:37 mauny Exp $ *) (* Detection of partial matches and unused match cases. *) open Types @@ -54,5 +54,6 @@ val pressure_variants: Env.t -> pattern list -> unit val check_partial: Location.t -> (pattern * expression) list -> partial val check_unused: Env.t -> (pattern * expression) list -> unit - - +(* Irrefutability tests *) +val irrefutable : pattern -> bool +val fluid : pattern -> bool diff --git a/typing/predef.ml b/typing/predef.ml index 0afb493e..ae452723 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: predef.ml,v 1.31 2006/10/24 20:54:58 weis Exp $ *) +(* $Id: predef.ml,v 1.32 2007/10/09 10:29:37 weis Exp $ *) (* Predefined type constructors (with special typing rules in typecore) *) @@ -89,24 +89,28 @@ let build_initial_env add_type add_exception empty_env = {type_params = []; type_arity = 0; type_kind = Type_abstract; + type_private = Public; type_manifest = None; type_variance = []} and decl_bool = {type_params = []; type_arity = 0; - type_kind = Type_variant(["false",[]; "true",[]], Public); + type_kind = Type_variant(["false", []; "true", []]); + type_private = Public; type_manifest = None; type_variance = []} and decl_unit = {type_params = []; type_arity = 0; - type_kind = Type_variant(["()",[]], Public); + type_kind = Type_variant(["()", []]); + type_private = Public; type_manifest = None; type_variance = []} and decl_exn = {type_params = []; type_arity = 0; - type_kind = Type_variant([], Public); + type_kind = Type_variant []; + type_private = Public; type_manifest = None; type_variance = []} and decl_array = @@ -114,6 +118,7 @@ let build_initial_env add_type add_exception empty_env = {type_params = [tvar]; type_arity = 1; type_kind = Type_abstract; + type_private = Public; type_manifest = None; type_variance = [true, true, true]} and decl_list = @@ -121,7 +126,8 @@ let build_initial_env add_type add_exception empty_env = {type_params = [tvar]; type_arity = 1; type_kind = - Type_variant(["[]", []; "::", [tvar; type_list tvar]], Public); + Type_variant(["[]", []; "::", [tvar; type_list tvar]]); + type_private = Public; type_manifest = None; type_variance = [true, false, false]} and decl_format6 = @@ -131,6 +137,7 @@ let build_initial_env add_type add_exception empty_env = ]; type_arity = 6; type_kind = Type_abstract; + type_private = Public; type_manifest = None; type_variance = [ true, true, true; true, true, true; @@ -141,7 +148,8 @@ let build_initial_env add_type add_exception empty_env = let tvar = newgenvar() in {type_params = [tvar]; type_arity = 1; - type_kind = Type_variant(["None", []; "Some", [tvar]], Public); + type_kind = Type_variant(["None", []; "Some", [tvar]]); + type_private = Public; type_manifest = None; type_variance = [true, false, false]} and decl_lazy_t = @@ -149,6 +157,7 @@ let build_initial_env add_type add_exception empty_env = {type_params = [tvar]; type_arity = 1; type_kind = Type_abstract; + type_private = Public; type_manifest = None; type_variance = [true, false, false]} in diff --git a/typing/primitive.ml b/typing/primitive.ml index d48010ad..c14a1f3b 100644 --- a/typing/primitive.ml +++ b/typing/primitive.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: primitive.ml,v 1.8 2001/08/06 12:28:49 ddr Exp $ *) +(* $Id: primitive.ml,v 1.9 2008/07/24 05:35:22 frisch Exp $ *) (* Description of primitive functions *) @@ -54,3 +54,11 @@ let description_list p = in let list = if p.prim_native_float then "float" :: list else list in List.rev list + +let native_name p = + if p.prim_native_name <> "" + then p.prim_native_name + else p.prim_name + +let byte_name p = + p.prim_name diff --git a/typing/primitive.mli b/typing/primitive.mli index decd6700..8b39244c 100644 --- a/typing/primitive.mli +++ b/typing/primitive.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: primitive.mli,v 1.7 2001/08/06 12:28:49 ddr Exp $ *) +(* $Id: primitive.mli,v 1.8 2008/07/24 05:35:22 frisch Exp $ *) (* Description of primitive functions *) @@ -24,3 +24,6 @@ type description = val parse_declaration: int -> string list -> description val description_list: description -> string list + +val native_name: description -> string +val byte_name: description -> string diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 941024ee..32f3d571 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: printtyp.ml,v 1.143.2.1 2007/06/08 08:03:15 garrigue Exp $ *) +(* $Id: printtyp.ml,v 1.147 2008/07/19 02:13:09 garrigue Exp $ *) (* Printing functions *) @@ -96,7 +96,7 @@ let rec safe_repr v = function let rec list_of_memo = function Mnil -> [] - | Mcons (p, t1, t2, rem) -> p :: list_of_memo rem + | Mcons (priv, p, t1, t2, rem) -> p :: list_of_memo rem | Mlink rem -> list_of_memo !rem let visited = ref [] @@ -518,10 +518,10 @@ let rec tree_of_type_decl id decl = in begin match decl.type_kind with | Type_abstract -> () - | Type_variant ([], _) -> () - | Type_variant (cstrs, priv) -> + | Type_variant [] -> () + | Type_variant cstrs -> List.iter (fun (_, args) -> List.iter mark_loops args) cstrs - | Type_record(l, rep, priv) -> + | Type_record(l, rep) -> List.iter (fun (_, _, ty) -> mark_loops ty) l end; @@ -538,8 +538,8 @@ let rec tree_of_type_decl id decl = None -> true | Some ty -> has_constr_row ty end - | Type_variant(_,p) | Type_record(_,_,p) -> - p = Private + | Type_variant _ | Type_record(_,_) -> + decl.type_private = Private in let vari = List.map2 @@ -564,13 +564,14 @@ let rec tree_of_type_decl id decl = begin match ty_manifest with | None -> (Otyp_abstract, Public) | Some ty -> - tree_of_typexp false ty, - (if has_constr_row ty then Private else Public) + tree_of_typexp false ty, decl.type_private end - | Type_variant(cstrs, priv) -> - tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)), priv - | Type_record(lbls, rep, priv) -> - tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), priv + | Type_variant cstrs -> + tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)), + decl.type_private + | Type_record(lbls, rep) -> + tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), + decl.type_private in (name, args, ty, priv, constraints) diff --git a/typing/stypes.ml b/typing/stypes.ml index e9e96b9e..23065daf 100644 --- a/typing/stypes.ml +++ b/typing/stypes.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: stypes.ml,v 1.9 2006/04/16 23:28:22 doligez Exp $ *) +(* $Id: stypes.ml,v 1.11 2008/07/29 15:42:44 doligez Exp $ *) (* Recording and dumping (partial) type information *) @@ -21,16 +21,19 @@ interesting in case of errors. *) +open Annot;; open Format;; open Lexing;; open Location;; open Typedtree;; -type type_info = - Ti_pat of pattern +type annotation = + | Ti_pat of pattern | Ti_expr of expression | Ti_class of class_expr | Ti_mod of module_expr + | An_call of Location.t * Annot.call + | An_ident of Location.t * string * Annot.ident ;; let get_location ti = @@ -39,18 +42,20 @@ let get_location ti = | Ti_expr e -> e.exp_loc | Ti_class c -> c.cl_loc | Ti_mod m -> m.mod_loc + | An_call (l, k) -> l + | An_ident (l, s, k) -> l ;; -let type_info = ref ([] : type_info list);; +let annotations = ref ([] : annotation list);; let phrases = ref ([] : Location.t list);; let record ti = - if !Clflags.save_types && not (get_location ti).Location.loc_ghost then - type_info := ti :: !type_info + if !Clflags.annotations && not (get_location ti).Location.loc_ghost then + annotations := ti :: !annotations ;; let record_phrase loc = - if !Clflags.save_types then phrases := loc :: !phrases; + if !Clflags.annotations then phrases := loc :: !phrases; ;; (* comparison order: @@ -67,7 +72,17 @@ let cmp_ti_inner_first ti1 ti2 = ;; let print_position pp pos = - fprintf pp "%S %d %d %d" pos.pos_fname pos.pos_lnum pos.pos_bol pos.pos_cnum; + if pos = dummy_pos then + fprintf pp "--" + else + fprintf pp "%S %d %d %d" pos.pos_fname pos.pos_lnum pos.pos_bol + pos.pos_cnum; +;; + +let print_location pp loc = + print_position pp loc.loc_start; + fprintf pp " "; + print_position pp loc.loc_end; ;; let sort_filter_phrases () = @@ -93,38 +108,60 @@ let rec printtyp_reset_maybe loc = | _ -> () ;; +let call_kind_string k = + match k with + | Tail -> "tail" + | Stack -> "stack" + | Inline -> "inline" +;; + +let print_ident_annot pp str k = + match k with + | Idef l -> fprintf pp "def %s %a@." str print_location l; + | Iref_internal l -> fprintf pp "int_ref %s %a@." str print_location l; + | Iref_external -> fprintf pp "ext_ref %s@." str; +;; (* The format of the annotation file is documented in emacs/caml-types.el. *) -let print_info pp ti = +let print_info pp prev_loc ti = match ti with - | Ti_class _ | Ti_mod _ -> () + | Ti_class _ | Ti_mod _ -> prev_loc | Ti_pat {pat_loc = loc; pat_type = typ} | Ti_expr {exp_loc = loc; exp_type = typ} -> - print_position pp loc.loc_start; - fprintf pp " "; - print_position pp loc.loc_end; - fprintf pp "@.type(@. "; + if loc <> prev_loc then fprintf pp "%a@." print_location loc; + fprintf pp "type(@. "; printtyp_reset_maybe loc; Printtyp.mark_loops typ; Printtyp.type_sch pp typ; fprintf pp "@.)@."; + loc + | An_call (loc, k) -> + if loc <> prev_loc then fprintf pp "%a@." print_location loc; + fprintf pp "call(@. %s@.)@." (call_kind_string k); + loc + | An_ident (loc, str, k) -> + if loc <> prev_loc then fprintf pp "%a@." print_location loc; + fprintf pp "ident(@. "; + print_ident_annot pp str k; + fprintf pp ")@."; + loc ;; let get_info () = - let info = List.fast_sort cmp_ti_inner_first !type_info in - type_info := []; + let info = List.fast_sort cmp_ti_inner_first !annotations in + annotations := []; info ;; let dump filename = - if !Clflags.save_types then begin + if !Clflags.annotations then begin let info = get_info () in let pp = formatter_of_out_channel (open_out filename) in sort_filter_phrases (); - List.iter (print_info pp) info; + ignore (List.fold_left (print_info pp) Location.none info); phrases := []; end else begin - type_info := []; + annotations := []; end; ;; diff --git a/typing/stypes.mli b/typing/stypes.mli index 92ca2598..17663ec3 100644 --- a/typing/stypes.mli +++ b/typing/stypes.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: stypes.mli,v 1.3 2003/07/23 16:52:41 doligez Exp $ *) +(* $Id: stypes.mli,v 1.5 2008/07/29 15:42:44 doligez Exp $ *) (* Recording and dumping (partial) type information *) @@ -18,16 +18,18 @@ open Typedtree;; -type type_info = - Ti_pat of pattern +type annotation = + | Ti_pat of pattern | Ti_expr of expression | Ti_class of class_expr | Ti_mod of module_expr + | An_call of Location.t * Annot.call + | An_ident of Location.t * string * Annot.ident ;; -val record : type_info -> unit;; +val record : annotation -> unit;; val record_phrase : Location.t -> unit;; val dump : string -> unit;; -val get_location : type_info -> Location.t;; -val get_info : unit -> type_info list;; +val get_location : annotation -> Location.t;; +val get_info : unit -> annotation list;; diff --git a/typing/subst.ml b/typing/subst.ml index 04806125..6df3fb02 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: subst.ml,v 1.50.8.1 2007/06/08 08:03:16 garrigue Exp $ *) +(* $Id: subst.ml,v 1.52 2008/01/11 16:13:16 doligez Exp $ *) (* Substitutions *) @@ -152,22 +152,22 @@ let type_declaration s decl = type_kind = begin match decl.type_kind with Type_abstract -> Type_abstract - | Type_variant (cstrs, priv) -> + | Type_variant cstrs -> Type_variant( List.map (fun (n, args) -> (n, List.map (typexp s) args)) - cstrs, - priv) - | Type_record(lbls, rep, priv) -> + cstrs) + | Type_record(lbls, rep) -> Type_record( List.map (fun (n, mut, arg) -> (n, mut, typexp s arg)) lbls, - rep, priv) + rep) end; type_manifest = begin match decl.type_manifest with None -> None | Some ty -> Some(typexp s ty) end; + type_private = decl.type_private; type_variance = decl.type_variance; } in diff --git a/typing/subst.mli b/typing/subst.mli index 509080b5..4bf6c212 100644 --- a/typing/subst.mli +++ b/typing/subst.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: subst.mli,v 1.12.36.1 2007/12/26 16:00:41 xleroy Exp $ *) +(* $Id: subst.mli,v 1.13 2008/01/11 16:13:16 doligez Exp $ *) (* Substitutions *) diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 6c39fc8b..e26f777c 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typeclass.ml,v 1.89.6.3 2008/01/28 13:26:48 doligez Exp $ *) +(* $Id: typeclass.ml,v 1.93 2008/02/29 14:21:22 doligez Exp $ *) open Misc open Parsetree @@ -561,7 +561,7 @@ let rec class_field cl_num self_type meths vars | Pcf_let (rec_flag, sdefs, loc) -> let (defs, val_env) = try - Typecore.type_let val_env rec_flag sdefs + Typecore.type_let val_env rec_flag sdefs None with Ctype.Unify [(ty, _)] -> raise(Error(loc, Make_nongen_seltype ty)) in @@ -911,7 +911,7 @@ and class_expr cl_num val_env met_env scl = | Pcl_let (rec_flag, sdefs, scl') -> let (defs, val_env) = try - Typecore.type_let val_env rec_flag sdefs + Typecore.type_let val_env rec_flag sdefs None with Ctype.Unify [(ty, _)] -> raise(Error(scl.pcl_loc, Make_nongen_seltype ty)) in @@ -1008,6 +1008,7 @@ let temp_abbrev env id arity = {type_params = !params; type_arity = arity; type_kind = Type_abstract; + type_private = Public; type_manifest = Some ty; type_variance = List.map (fun _ -> true, true, true) !params} env @@ -1218,6 +1219,7 @@ let class_infos define_class kind {type_params = obj_params; type_arity = List.length obj_params; type_kind = Type_abstract; + type_private = Public; type_manifest = Some obj_ty; type_variance = List.map (fun _ -> true, true, true) obj_params} in @@ -1230,6 +1232,7 @@ let class_infos define_class kind {type_params = cl_params; type_arity = List.length cl_params; type_kind = Type_abstract; + type_private = Public; type_manifest = Some cl_ty; type_variance = List.map (fun _ -> true, true, true) cl_params} in diff --git a/typing/typecore.ml b/typing/typecore.ml index e48985bc..ade0e5c6 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typecore.ml,v 1.190.2.7 2007/11/26 16:13:38 doligez Exp $ *) +(* $Id: typecore.ml,v 1.199 2008/07/29 15:42:44 doligez Exp $ *) (* Typechecking for the core language *) @@ -128,7 +128,7 @@ let rec extract_label_names sexp env ty = | Tconstr (path, _, _) -> let td = Env.find_type path env in begin match td.type_kind with - | Type_record (fields, _, _) -> + | Type_record (fields, _) -> List.map (fun (name, _, _) -> name) fields | Type_abstract when td.type_manifest <> None -> extract_label_names sexp env (expand_head env ty) @@ -191,22 +191,29 @@ let has_variants p = (* pattern environment *) -let pattern_variables = ref ([]: (Ident.t * type_expr) list) +let pattern_variables = ref ([]: (Ident.t * type_expr * Location.t) list) let pattern_force = ref ([] : (unit -> unit) list) -let reset_pattern () = +let pattern_scope = ref (None : Annot.ident option);; +let reset_pattern scope = pattern_variables := []; - pattern_force := [] + pattern_force := []; + pattern_scope := scope; +;; let enter_variable loc name ty = - if List.exists (fun (id, _) -> Ident.name id = name) !pattern_variables + if List.exists (fun (id, _, _) -> Ident.name id = name) !pattern_variables then raise(Error(loc, Multiply_bound_variable name)); let id = Ident.create name in - pattern_variables := (id, ty) :: !pattern_variables; + pattern_variables := (id, ty, loc) :: !pattern_variables; + begin match !pattern_scope with + | None -> () + | Some s -> Stypes.record (Stypes.An_ident (loc, name, s)); + end; id let sort_pattern_variables vs = List.sort - (fun (x,_) (y,_) -> Pervasives.compare (Ident.name x) (Ident.name y)) + (fun (x,_,_) (y,_,_) -> Pervasives.compare (Ident.name x) (Ident.name y)) vs let enter_orpat_variables loc env p1_vs p2_vs = @@ -216,7 +223,7 @@ let enter_orpat_variables loc env p1_vs p2_vs = and p2_vs = sort_pattern_variables p2_vs in let rec unify_vars p1_vs p2_vs = match p1_vs, p2_vs with - | (x1,t1)::rem1, (x2,t2)::rem2 when Ident.equal x1 x2 -> + | (x1,t1,l1)::rem1, (x2,t2,l2)::rem2 when Ident.equal x1 x2 -> if x1==x2 then unify_vars rem1 rem2 else begin @@ -229,9 +236,9 @@ let enter_orpat_variables loc env p1_vs p2_vs = (x2,x1)::unify_vars rem1 rem2 end | [],[] -> [] - | (x,_)::_, [] -> raise (Error (loc, Orpat_vars x)) - | [],(x,_)::_ -> raise (Error (loc, Orpat_vars x)) - | (x,_)::_, (y,_)::_ -> + | (x,_,_)::_, [] -> raise (Error (loc, Orpat_vars x)) + | [],(x,_,_)::_ -> raise (Error (loc, Orpat_vars x)) + | (x,_,_)::_, (y,_,_)::_ -> let min_var = if Ident.name x < Ident.name y then x else y in @@ -287,7 +294,8 @@ let rec build_as_type env p = let row = row_repr row in newty (Tvariant{row with row_closed=false; row_more=newvar()}) end - | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_array _ -> p.pat_type + | Tpat_any | Tpat_var _ | Tpat_constant _ + | Tpat_array _ | Tpat_lazy _ -> p.pat_type let build_or_pat env loc lid = let path, decl = @@ -406,7 +414,7 @@ let rec type_pat env sp = None -> [] | Some {ppat_desc = Ppat_tuple spl} when explicit_arity -> spl | Some {ppat_desc = Ppat_tuple spl} when constr.cstr_arity > 1 -> spl - | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity > 1 -> + | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity <> 1 -> replicate_list sp constr.cstr_arity | Some sp -> [sp] in if List.length sargs <> constr.cstr_arity then @@ -502,6 +510,13 @@ let rec type_pat env sp = pat_loc = sp.ppat_loc; pat_type = p1.pat_type; pat_env = env } + | Ppat_lazy sp1 -> + let p1 = type_pat env sp1 in + rp { + pat_desc = Tpat_lazy p1; + pat_loc = sp.ppat_loc; + pat_type = instance (Predef.type_lazy_t p1.pat_type); + pat_env = env } | Ppat_constraint(sp, sty) -> let p = type_pat env sp in let ty, force = Typetexp.transl_simple_type_delayed env sty in @@ -517,24 +532,26 @@ let get_ref r = let add_pattern_variables env = let pv = get_ref pattern_variables in List.fold_right - (fun (id, ty) env -> - Env.add_value id {val_type = ty; val_kind = Val_reg} env) + (fun (id, ty, loc) env -> + let e1 = Env.add_value id {val_type = ty; val_kind = Val_reg} env in + Env.add_annot id (Annot.Iref_internal loc) e1; + ) pv env -let type_pattern env spat = - reset_pattern (); +let type_pattern env spat scope = + reset_pattern scope; let pat = type_pat env spat in let new_env = add_pattern_variables env in (pat, new_env, get_ref pattern_force) -let type_pattern_list env spatl = - reset_pattern (); +let type_pattern_list env spatl scope = + reset_pattern scope; let patl = List.map (type_pat env) spatl in let new_env = add_pattern_variables env in (patl, new_env, get_ref pattern_force) let type_class_arg_pattern cl_num val_env met_env l spat = - reset_pattern (); + reset_pattern None; let pat = type_pat val_env spat in if has_variants pat then begin Parmatch.pressure_variants val_env [pat]; @@ -544,7 +561,7 @@ let type_class_arg_pattern cl_num val_env met_env l spat = if is_optional l then unify_pat val_env pat (type_option (newvar ())); let (pv, met_env) = List.fold_right - (fun (id, ty) (pv, env) -> + (fun (id, ty, loc) (pv, env) -> let id' = Ident.create (Ident.name id) in ((id', id, ty)::pv, Env.add_value id' {val_type = ty; @@ -562,7 +579,7 @@ let type_self_pattern cl_num privty val_env met_env par_env spat = mkpat (Ppat_alias (mkpat(Ppat_alias (spat, "selfpat-*")), "selfpat-" ^ cl_num)) in - reset_pattern (); + reset_pattern None; let pat = type_pat val_env spat in List.iter (fun f -> f()) (get_ref pattern_force); let meths = ref Meths.empty in @@ -571,7 +588,7 @@ let type_self_pattern cl_num privty val_env met_env par_env spat = pattern_variables := []; let (val_env, met_env, par_env) = List.fold_right - (fun (id, ty) (val_env, met_env, par_env) -> + (fun (id, ty, loc) (val_env, met_env, par_env) -> (Env.add_value id {val_type = ty; val_kind = Val_unbound} val_env, Env.add_value id {val_type = ty; val_kind = Val_self (meths, vars, cl_num, privty)} @@ -884,6 +901,17 @@ let check_application_result env statement exp = if statement then Location.prerr_warning exp.exp_loc Warnings.Statement_type +(* Check that a type is generalizable at some level *) +let generalizable level ty = + let rec check ty = + let ty = repr ty in + if ty.level < lowest_level then () else + if ty.level <= level then raise Exit else + (mark_type_node ty; iter_type_expr check ty) + in + try check ty; unmark_type ty; true + with Exit -> unmark_type ty; false + (* Hack to allow coercion of self. Will clean-up later. *) let self_coercion = ref ([] : (Path.t * Location.t list ref) list) @@ -904,6 +932,12 @@ let rec type_exp env sexp = match sexp.pexp_desc with Pexp_ident lid -> begin try + if !Clflags.annotations then begin + try let (path, annot) = Env.lookup_annot lid env in + Stypes.record (Stypes.An_ident (sexp.pexp_loc, Path.name path, + annot)); + with _ -> () + end; let (path, desc) = Env.lookup_value lid env in re { exp_desc = @@ -936,7 +970,13 @@ let rec type_exp env sexp = exp_type = type_constant cst; exp_env = env } | Pexp_let(rec_flag, spat_sexp_list, sbody) -> - let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list in + let scp = + match rec_flag with + | Recursive -> Some (Annot.Idef sexp.pexp_loc) + | Nonrecursive -> Some (Annot.Idef sbody.pexp_loc) + | Default -> None + in + let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list scp in let body = type_exp new_env sbody in re { exp_desc = Texp_let(rec_flag, pat_exp_list, body); @@ -1209,12 +1249,41 @@ let rec type_exp env sexp = let (ty', force) = Typetexp.transl_simple_type_delayed env sty' in + if !Clflags.principal then begin_def (); let arg = type_exp env sarg in + let gen = + if !Clflags.principal then begin + end_def (); + let tv = newvar () in + let gen = generalizable tv.level arg.exp_type in + unify_var env tv arg.exp_type; + gen + end else true + in begin match arg.exp_desc, !self_coercion, (repr ty').desc with Texp_ident(_, {val_kind=Val_self _}), (path,r) :: _, Tconstr(path',_,_) when Path.same path path' -> r := sexp.pexp_loc :: !r; force () + | _ when free_variables arg.exp_type = [] + && free_variables ty' = [] -> + if not gen && (* first try a single coercion *) + let snap = snapshot () in + let ty, b = enlarge_type env ty' in + try + force (); Ctype.unify env arg.exp_type ty; true + with Unify _ -> + backtrack snap; false + then () + else begin try + let force' = subtype env arg.exp_type ty' in + force (); force' (); + if not gen then + Location.prerr_warning sexp.pexp_loc + (Warnings.Not_principal "this ground coercion"); + with Subtype (tr1, tr2) -> + raise(Error(sexp.pexp_loc, Not_subtype(tr1, tr2))) + end; | _ -> let ty, b = enlarge_type env ty' in force (); @@ -1446,7 +1515,7 @@ let rec type_exp env sexp = exp_type = newvar (); exp_env = env; } - | Pexp_lazy (e) -> + | Pexp_lazy e -> let arg = type_exp env e in re { exp_desc = Texp_lazy arg; @@ -1763,7 +1832,7 @@ and type_expect ?in_function env sexp ty_expected = | Pexp_construct(lid, sarg, explicit_arity) -> type_construct env sexp.pexp_loc lid sarg explicit_arity ty_expected | Pexp_let(rec_flag, spat_sexp_list, sbody) -> - let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list in + let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list None in let body = type_expect new_env sbody ty_expected in re { exp_desc = Texp_let(rec_flag, pat_exp_list, body); @@ -1912,7 +1981,8 @@ and type_cases ?in_function env ty_arg ty_res partial_loc caselist = List.map (fun (spat, sexp) -> if !Clflags.principal then begin_def (); - let (pat, ext_env, force) = type_pattern env spat in + let scope = Some (Annot.Idef sexp.pexp_loc) in + let (pat, ext_env, force) = type_pattern env spat scope in pattern_force := force @ !pattern_force; let pat = if !Clflags.principal then begin @@ -1952,12 +2022,11 @@ and type_cases ?in_function env ty_arg ty_res partial_loc caselist = (* Typing of let bindings *) -and type_let env rec_flag spat_sexp_list = +and type_let env rec_flag spat_sexp_list scope = begin_def(); if !Clflags.principal then begin_def (); - let (pat_list, new_env, force) = - type_pattern_list env (List.map (fun (spat, sexp) -> spat) spat_sexp_list) - in + let spatl = List.map (fun (spat, sexp) -> spat) spat_sexp_list in + let (pat_list, new_env, force) = type_pattern_list env spatl scope in if rec_flag = Recursive then List.iter2 (fun pat (_, sexp) -> unify_pat env pat (type_approx env sexp)) @@ -2003,9 +2072,9 @@ and type_let env rec_flag spat_sexp_list = (* Typing of toplevel bindings *) -let type_binding env rec_flag spat_sexp_list = +let type_binding env rec_flag spat_sexp_list scope = Typetexp.reset_type_variables(); - type_let env rec_flag spat_sexp_list + type_let env rec_flag spat_sexp_list scope (* Typing of toplevel expressions *) diff --git a/typing/typecore.mli b/typing/typecore.mli index f2f35e3c..7e8bea36 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typecore.mli,v 1.39.2.1 2007/11/19 21:27:17 doligez Exp $ *) +(* $Id: typecore.mli,v 1.41 2008/01/11 16:13:16 doligez Exp $ *) (* Type inference for the core language *) @@ -23,10 +23,12 @@ val is_nonexpansive: Typedtree.expression -> bool val type_binding: Env.t -> rec_flag -> (Parsetree.pattern * Parsetree.expression) list -> + Annot.ident option -> (Typedtree.pattern * Typedtree.expression) list * Env.t val type_let: Env.t -> rec_flag -> - (Parsetree.pattern * Parsetree.expression) list -> + (Parsetree.pattern * Parsetree.expression) list -> + Annot.ident option -> (Typedtree.pattern * Typedtree.expression) list * Env.t val type_expression: Env.t -> Parsetree.expression -> Typedtree.expression diff --git a/typing/typedecl.ml b/typing/typedecl.ml index e552b016..6e5702cf 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typedecl.ml,v 1.76.6.2 2007/03/12 13:14:26 garrigue Exp $ *) +(* $Id: typedecl.ml,v 1.82 2008/08/07 09:29:22 xleroy Exp $ *) (**** Typing of type definitions ****) @@ -38,7 +38,7 @@ type error = | Unbound_type_var of type_expr * type_declaration | Unbound_exception of Longident.t | Not_an_exception of Longident.t - | Bad_variance of int * (bool*bool) * (bool*bool) + | Bad_variance of int * (bool * bool) * (bool * bool) | Unavailable_type_constructor of Path.t | Bad_fixed_type of string @@ -52,6 +52,7 @@ let enter_type env (name, sdecl) id = List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params; type_arity = List.length sdecl.ptype_params; type_kind = Type_abstract; + type_private = sdecl.ptype_private; type_manifest = begin match sdecl.ptype_manifest with None -> None | Some _ -> Some(Ctype.newvar ()) end; @@ -71,12 +72,23 @@ let update_type temp_env env id loc = raise (Error(loc, Type_clash trace)) (* Determine if a type is (an abbreviation for) the type "float" *) - +(* We use the Ctype.expand_head_opt version of expand_head to get access + to the manifest type of private abbreviations. *) let is_float env ty = - match Ctype.repr (Ctype.expand_head env ty) with + match Ctype.repr (Ctype.expand_head_opt env ty) with {desc = Tconstr(p, _, _)} -> Path.same p Predef.path_float | _ -> false +(* Determine if a type definition defines a fixed type. (PW) *) +let is_fixed_type sd = + (match sd.ptype_manifest with + | Some { ptyp_desc = + (Ptyp_variant _|Ptyp_object _|Ptyp_class _|Ptyp_alias + ({ptyp_desc = Ptyp_variant _|Ptyp_object _|Ptyp_class _},_)) } -> true + | _ -> false) && + sd.ptype_kind = Ptype_abstract && + sd.ptype_private = Private + (* Set the row variable in a fixed type *) let set_fixed_row env loc p decl = let tm = @@ -128,9 +140,8 @@ let transl_declaration env (name, sdecl) id = type_arity = List.length params; type_kind = begin match sdecl.ptype_kind with - Ptype_abstract | Ptype_private -> - Type_abstract - | Ptype_variant (cstrs, priv) -> + Ptype_abstract -> Type_abstract + | Ptype_variant cstrs -> let all_constrs = ref StringSet.empty in List.iter (fun (name, args, loc) -> @@ -141,11 +152,12 @@ let transl_declaration env (name, sdecl) id = if List.length (List.filter (fun (_, args, _) -> args <> []) cstrs) > (Config.max_tag + 1) then raise(Error(sdecl.ptype_loc, Too_many_constructors)); - Type_variant(List.map - (fun (name, args, loc) -> - (name, List.map (transl_simple_type env true) args)) - cstrs, priv) - | Ptype_record (lbls, priv) -> + Type_variant + (List.map + (fun (name, args, loc) -> + (name, List.map (transl_simple_type env true) args)) + cstrs) + | Ptype_record lbls -> let all_labels = ref StringSet.empty in List.iter (fun (name, mut, arg, loc) -> @@ -163,14 +175,16 @@ let transl_declaration env (name, sdecl) id = if List.for_all (fun (name, mut, arg) -> is_float env arg) lbls' then Record_float else Record_regular in - Type_record(lbls', rep, priv) + Type_record(lbls', rep) end; + type_private = sdecl.ptype_private; type_manifest = begin match sdecl.ptype_manifest with None -> None | Some sty -> + let no_row = not (is_fixed_type sdecl) in let ty = - transl_simple_type env (sdecl.ptype_kind <> Ptype_private) sty in + transl_simple_type env no_row sty in if Ctype.cyclic_abbrev env id ty then raise(Error(sdecl.ptype_loc, Recursive_abbrev name)); Some ty @@ -185,7 +199,7 @@ let transl_declaration env (name, sdecl) id = raise(Error(loc, Unconsistent_constraint tr))) cstrs; Ctype.end_def (); - if sdecl.ptype_kind = Ptype_private then begin + if is_fixed_type sdecl then begin let (p, _) = try Env.lookup_type (Longident.Lident(Ident.name id ^ "#row")) env with Not_found -> assert false in @@ -200,9 +214,9 @@ let generalize_decl decl = begin match decl.type_kind with Type_abstract -> () - | Type_variant (v, priv) -> + | Type_variant v -> List.iter (fun (_, tyl) -> List.iter Ctype.generalize tyl) v - | Type_record(r, rep, priv) -> + | Type_record(r, rep) -> List.iter (fun (_, _, ty) -> Ctype.generalize ty) r end; begin match decl.type_manifest with @@ -245,10 +259,10 @@ let check_constraints env (_, sdecl) (_, decl) = let visited = ref TypeSet.empty in begin match decl.type_kind with | Type_abstract -> () - | Type_variant (l, _) -> + | Type_variant l -> let rec find_pl = function - Ptype_variant(pl, _) -> pl - | Ptype_record _ | Ptype_abstract | Ptype_private -> assert false + Ptype_variant pl -> pl + | Ptype_record _ | Ptype_abstract -> assert false in let pl = find_pl sdecl.ptype_kind in List.iter @@ -261,10 +275,10 @@ let check_constraints env (_, sdecl) (_, decl) = check_constraints_rec env sty.ptyp_loc visited ty) styl tyl) l - | Type_record (l, _, _) -> + | Type_record (l, _) -> let rec find_pl = function - Ptype_record(pl, _) -> pl - | Ptype_variant _ | Ptype_abstract | Ptype_private -> assert false + Ptype_record pl -> pl + | Ptype_variant _ | Ptype_abstract -> assert false in let pl = find_pl sdecl.ptype_kind in let rec get_loc name = function @@ -454,10 +468,10 @@ let compute_variance env tvl nega posi cntr ty = let make_variance ty = (ty, ref false, ref false, ref false) let whole_type decl = match decl.type_kind with - Type_variant (tll,_) -> + Type_variant tll -> Btype.newgenty (Ttuple (List.map (fun (_, tl) -> Btype.newgenty (Ttuple tl)) tll)) - | Type_record (ftl, _, _) -> + | Type_record (ftl, _) -> Btype.newgenty (Ttuple (List.map (fun (_, _, ty) -> ty) ftl)) | Type_abstract -> @@ -483,26 +497,19 @@ let compute_variance_decl env check decl (required, loc) = None -> assert false | Some ty -> compute_variance env tvl true false false ty end - | Type_variant (tll, _) -> + | Type_variant tll -> List.iter (fun (_,tl) -> List.iter (compute_variance env tvl true false false) tl) tll - | Type_record (ftl, _, _) -> + | Type_record (ftl, _) -> List.iter (fun (_, mut, ty) -> let cn = (mut = Mutable) in compute_variance env tvl true cn cn ty) ftl end; - let priv = - match decl.type_kind with - Type_abstract -> - begin match decl.type_manifest with - Some ty when not (Btype.has_constr_row ty) -> Public - | _ -> Private - end - | Type_variant (_, priv) | Type_record (_, _, priv) -> priv + let priv = decl.type_private and required = List.map (fun (c,n as r) -> if c || n then r else (true,true)) required @@ -589,22 +596,23 @@ let compute_variance_decls env 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 + | { type_kind = Type_abstract; + type_manifest = Some ty; + type_private = Private; } when is_fixed_type sdecl -> + 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 *) let fixed_types = - List.filter (fun (_,sd) -> sd.ptype_kind = Ptype_private) name_sdecl_list + List.filter (fun (_, sd) -> is_fixed_type sd) name_sdecl_list in let name_sdecl_list = List.map @@ -732,11 +740,12 @@ let transl_with_constraint env id row_path sdecl = with Ctype.Unify tr -> raise(Error(loc, Unconsistent_constraint tr))) sdecl.ptype_cstrs; - let no_row = sdecl.ptype_kind <> Ptype_private in + let no_row = not (is_fixed_type sdecl) in let decl = { type_params = params; type_arity = List.length params; type_kind = Type_abstract; + type_private = sdecl.ptype_private; type_manifest = begin match sdecl.ptype_manifest with None -> None @@ -771,6 +780,7 @@ let abstract_type_decl arity = { type_params = make_params arity; type_arity = arity; type_kind = Type_abstract; + type_private = Public; type_manifest = None; type_variance = replicate_list (true, true, true) arity } in Ctype.end_def(); @@ -791,7 +801,7 @@ let check_recmod_typedecl env loc recmod_ids path decl = (* recmod_ids is the list of recursively-defined module idents. (path, decl) is the type declaration to be checked. *) check_recursion env loc path decl - (fun path -> List.mem (Path.head path) recmod_ids) + (fun path -> List.exists (fun id -> Path.isfree id path) recmod_ids) (**** Error report ****) @@ -858,10 +868,10 @@ let report_error ppf = function kwd (lab ti) Printtyp.type_expr (typ ti) Printtyp.type_expr ty in begin try match decl.type_kind, decl.type_manifest with - Type_variant (tl, _), _ -> + Type_variant tl, _ -> explain tl (fun (_,tl) -> Btype.newgenty (Ttuple tl)) "case" (fun (lab,_) -> lab ^ " of ") - | Type_record (tl, _, _), _ -> + | Type_record (tl, _), _ -> explain tl (fun (_,_,t) -> t) "field" (fun (lab,_,_) -> lab ^ ": ") | Type_abstract, Some ty' -> diff --git a/typing/typedecl.mli b/typing/typedecl.mli index 9e52ec10..194c0133 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typedecl.mli,v 1.30 2006/11/02 01:10:04 garrigue Exp $ *) +(* $Id: typedecl.mli,v 1.31 2007/10/09 10:29:37 weis Exp $ *) (* Typing of type definitions and primitive definitions *) @@ -40,6 +40,9 @@ val approx_type_decl: val check_recmod_typedecl: Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit +(* for fixed types *) +val is_fixed_type : Parsetree.type_declaration -> bool + (* for typeclass.ml *) val compute_variance_decls: Env.t -> diff --git a/typing/typedtree.ml b/typing/typedtree.ml index e276ecfb..e2697d23 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typedtree.ml,v 1.37.8.2 2007/07/10 07:34:35 garrigue Exp $ *) +(* $Id: typedtree.ml,v 1.39 2008/07/09 13:03:38 mauny Exp $ *) (* Abstract syntax tree after typing *) @@ -37,6 +37,7 @@ and pattern_desc = | Tpat_record of (label_description * pattern) list | Tpat_array of pattern list | Tpat_or of pattern * pattern * row_desc option + | Tpat_lazy of pattern type partial = Partial | Total type optional = Required | Optional @@ -162,6 +163,7 @@ let iter_pattern_desc f = function List.iter (fun (lbl, pat) -> f pat) lbl_pat_list | Tpat_array patl -> List.iter f patl | Tpat_or(p1, p2, _) -> f p1; f p2 + | Tpat_lazy p -> f p | Tpat_any | Tpat_var _ | Tpat_constant _ -> () @@ -178,6 +180,7 @@ let map_pattern_desc f d = Tpat_construct (c, List.map f pats) | Tpat_array pats -> Tpat_array (List.map f pats) + | Tpat_lazy p1 -> Tpat_lazy (f p1) | Tpat_variant (x1, Some p1, x2) -> Tpat_variant (x1, Some (f p1), x2) | Tpat_or (p1,p2,path) -> diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 3569e5d8..dfd41711 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typedtree.mli,v 1.35.8.2 2007/07/10 07:34:35 garrigue Exp $ *) +(* $Id: typedtree.mli,v 1.37 2008/07/09 13:03:38 mauny Exp $ *) (* Abstract syntax tree after typing *) @@ -36,6 +36,7 @@ and pattern_desc = | Tpat_record of (label_description * pattern) list | Tpat_array of pattern list | Tpat_or of pattern * pattern * row_desc option + | Tpat_lazy of pattern type partial = Partial | Total type optional = Required | Optional diff --git a/typing/typemod.ml b/typing/typemod.ml index 72604520..85722ad3 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typemod.ml,v 1.78.2.4 2007/12/26 16:00:41 xleroy Exp $ *) +(* $Id: typemod.ml,v 1.86.2.1 2008/10/08 13:07:14 doligez Exp $ *) (* Type-checking of the module language *) @@ -87,13 +87,14 @@ let merge_constraint initial_env loc sg lid constr = ([], _, _) -> raise(Error(loc, With_no_component lid)) | (Tsig_type(id, decl, rs) :: rem, [s], - Pwith_type ({ptype_kind = Ptype_private} as sdecl)) - when Ident.name id = s -> + Pwith_type ({ptype_kind = Ptype_abstract} as sdecl)) + when Ident.name id = s && Typedecl.is_fixed_type sdecl -> 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_private = Private; type_manifest = None; type_variance = List.map (fun (c,n) -> (not n, not c, not c)) @@ -152,87 +153,83 @@ let rec map_rec' fn decls rem = components of signatures. For types, retain only their arity, making them abstract otherwise. *) -let approx_modtype transl_mty init_env smty = +let rec approx_modtype env smty = + match smty.pmty_desc with + Pmty_ident lid -> + begin try + let (path, info) = Env.lookup_modtype lid env in + Tmty_ident path + with Not_found -> + raise(Error(smty.pmty_loc, Unbound_modtype lid)) + end + | Pmty_signature ssg -> + Tmty_signature(approx_sig env ssg) + | Pmty_functor(param, sarg, sres) -> + let arg = approx_modtype env sarg in + let (id, newenv) = Env.enter_module param arg env in + let res = approx_modtype newenv sres in + Tmty_functor(id, arg, res) + | Pmty_with(sbody, constraints) -> + approx_modtype env sbody - let rec approx_mty env smty = - match smty.pmty_desc with - Pmty_ident lid -> - begin try - let (path, info) = Env.lookup_modtype lid env in - Tmty_ident path - with Not_found -> - raise(Error(smty.pmty_loc, Unbound_modtype lid)) - end - | Pmty_signature ssg -> - Tmty_signature(approx_sig env ssg) - | Pmty_functor(param, sarg, sres) -> - let arg = approx_mty env sarg in - let (id, newenv) = Env.enter_module param arg env in - let res = approx_mty newenv sres in - Tmty_functor(id, arg, res) - | Pmty_with(sbody, constraints) -> - approx_mty env sbody - - and approx_sig env ssg = - match ssg with - [] -> [] - | item :: srem -> - match item.psig_desc with - | Psig_type sdecls -> - let decls = Typedecl.approx_type_decl env sdecls in - let rem = approx_sig env srem in - map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem - | Psig_module(name, smty) -> - let mty = approx_mty env smty in - let (id, newenv) = Env.enter_module name mty env in - Tsig_module(id, mty, Trec_not) :: approx_sig newenv srem - | Psig_recmodule sdecls -> - let decls = - List.map - (fun (name, smty) -> - (Ident.create name, approx_mty env smty)) - sdecls in - let newenv = - List.fold_left (fun env (id, mty) -> Env.add_module id mty env) - env decls in - map_rec (fun rs (id, mty) -> Tsig_module(id, mty, rs)) decls - (approx_sig newenv srem) - | Psig_modtype(name, sinfo) -> - let info = approx_mty_info env sinfo in - let (id, newenv) = Env.enter_modtype name info env in - Tsig_modtype(id, info) :: approx_sig newenv srem - | Psig_open lid -> - let (path, mty) = type_module_path env item.psig_loc lid in - let sg = extract_sig_open env item.psig_loc mty in - let newenv = Env.open_signature path sg env in - approx_sig newenv srem - | Psig_include smty -> - let mty = transl_mty init_env smty in - 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 - | Psig_class sdecls | Psig_class_type sdecls -> - let decls = Typeclass.approx_class_declarations env sdecls in - let rem = approx_sig env srem in - List.flatten - (map_rec - (fun rs (i1, d1, i2, d2, i3, d3) -> - [Tsig_cltype(i1, d1, rs); - Tsig_type(i2, d2, rs); - Tsig_type(i3, d3, rs)]) - decls [rem]) - | _ -> - approx_sig env srem - - and approx_mty_info env sinfo = - match sinfo with - Pmodtype_abstract -> - Tmodtype_abstract - | Pmodtype_manifest smty -> - Tmodtype_manifest(approx_mty env smty) - - in approx_mty init_env smty +and approx_sig env ssg = + match ssg with + [] -> [] + | item :: srem -> + match item.psig_desc with + | Psig_type sdecls -> + let decls = Typedecl.approx_type_decl env sdecls in + let rem = approx_sig env srem in + map_rec' (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem + | Psig_module(name, smty) -> + let mty = approx_modtype env smty in + let (id, newenv) = Env.enter_module name mty env in + Tsig_module(id, mty, Trec_not) :: approx_sig newenv srem + | Psig_recmodule sdecls -> + let decls = + List.map + (fun (name, smty) -> + (Ident.create name, approx_modtype env smty)) + sdecls in + let newenv = + List.fold_left (fun env (id, mty) -> Env.add_module id mty env) + env decls in + map_rec (fun rs (id, mty) -> Tsig_module(id, mty, rs)) decls + (approx_sig newenv srem) + | Psig_modtype(name, sinfo) -> + let info = approx_modtype_info env sinfo in + let (id, newenv) = Env.enter_modtype name info env in + Tsig_modtype(id, info) :: approx_sig newenv srem + | Psig_open lid -> + let (path, mty) = type_module_path env item.psig_loc lid in + let sg = extract_sig_open env item.psig_loc mty in + let newenv = Env.open_signature path sg env in + approx_sig newenv srem + | Psig_include smty -> + let mty = approx_modtype env smty in + 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 + | Psig_class sdecls | Psig_class_type sdecls -> + let decls = Typeclass.approx_class_declarations env sdecls in + let rem = approx_sig env srem in + List.flatten + (map_rec + (fun rs (i1, d1, i2, d2, i3, d3) -> + [Tsig_cltype(i1, d1, rs); + Tsig_type(i2, d2, rs); + Tsig_type(i3, d3, rs)]) + decls [rem]) + | _ -> + approx_sig env srem + +and approx_modtype_info env sinfo = + match sinfo with + Pmodtype_abstract -> + Tmodtype_abstract + | Pmodtype_manifest smty -> + Tmodtype_manifest(approx_modtype env smty) (* Additional validity checks on type definitions arising from recursive modules *) @@ -408,20 +405,21 @@ and transl_recmodule_modtypes loc env sdecls = let init = List.map (fun (name, smty) -> - (Ident.create name, approx_modtype transl_modtype env smty)) + (Ident.create name, approx_modtype env smty)) sdecls in let env0 = make_env init in let dcl1 = transition env0 init in let env1 = make_env dcl1 in + check_recmod_typedecls env1 sdecls dcl1; let dcl2 = transition env1 dcl1 in - let env2 = make_env dcl2 in - check_recmod_typedecls env2 sdecls dcl2; (* List.iter (fun (id, mty) -> Format.printf "%a: %a@." Printtyp.ident id Printtyp.modtype mty) dcl2; *) + let env2 = make_env dcl2 in + check_recmod_typedecls env2 sdecls dcl2; (dcl2, env2) (* Try to convert a module expression to a module path. *) @@ -584,7 +582,7 @@ let rec type_module anchor env smod = mod_env = env; mod_loc = smod.pmod_loc } | Pmod_structure sstr -> - let (str, sg, finalenv) = type_structure anchor env sstr in + let (str, sg, finalenv) = type_structure anchor env sstr smod.pmod_loc in rm { mod_desc = Tmod_structure str; mod_type = Tmty_signature sg; mod_env = env; @@ -639,7 +637,7 @@ let rec type_module anchor env smod = mod_env = env; mod_loc = smod.pmod_loc } -and type_structure anchor env sstr = +and type_structure anchor env sstr scope = let type_names = ref StringSet.empty and module_names = ref StringSet.empty and modtype_names = ref StringSet.empty in @@ -652,9 +650,20 @@ and type_structure anchor env sstr = let expr = Typecore.type_expression env sexpr in let (str_rem, sig_rem, final_env) = type_struct env srem in (Tstr_eval expr :: str_rem, sig_rem, final_env) - | {pstr_desc = Pstr_value(rec_flag, sdefs)} :: srem -> + | {pstr_desc = Pstr_value(rec_flag, sdefs); pstr_loc = loc} :: srem -> + let scope = + match rec_flag with + | Recursive -> Some (Annot.Idef {scope with + Location.loc_start = loc.Location.loc_start}) + | Nonrecursive -> + let start = match srem with + | [] -> loc.Location.loc_end + | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start + in Some (Annot.Idef {scope with Location.loc_start = start}) + | Default -> None + in let (defs, newenv) = - Typecore.type_binding env rec_flag sdefs in + Typecore.type_binding env rec_flag sdefs scope in let (str_rem, sig_rem, final_env) = type_struct newenv srem in let bound_idents = let_bound_idents defs in let make_sig_value id = @@ -798,7 +807,7 @@ and type_structure anchor env sstr = sg @ sig_rem, final_env) in - if !Clflags.save_types + if !Clflags.annotations then List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr; type_struct env sstr @@ -859,10 +868,7 @@ and simplify_signature sg = let type_implementation sourcefile outputprefix modulename initial_env ast = Typecore.reset_delayed_checks (); - let (str, sg, finalenv) = - Misc.try_finally (fun () -> type_structure initial_env ast) - (fun () -> Stypes.dump (outputprefix ^ ".annot")) - in + let (str, sg, finalenv) = type_structure initial_env ast Location.none in let simple_sg = simplify_signature sg in Typecore.force_delayed_checks (); if !Clflags.print_types then begin @@ -882,7 +888,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = (str, coercion) end else begin check_nongen_schemes finalenv str; - normalize_signature finalenv sg; + normalize_signature finalenv simple_sg; let coercion = Includemod.compunit sourcefile sg "(inferred signature)" simple_sg in diff --git a/typing/typemod.mli b/typing/typemod.mli index 4fe13a10..33d49c93 100644 --- a/typing/typemod.mli +++ b/typing/typemod.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: typemod.mli,v 1.26 2005/08/08 09:41:52 xleroy Exp $ *) +(* $Id: typemod.mli,v 1.27 2007/05/16 08:21:40 doligez Exp $ *) (* Type-checking of the module language *) @@ -20,7 +20,8 @@ open Format val type_module: Env.t -> Parsetree.module_expr -> Typedtree.module_expr val type_structure: - Env.t -> Parsetree.structure -> Typedtree.structure * signature * Env.t + Env.t -> Parsetree.structure -> Location.t -> + Typedtree.structure * signature * Env.t val type_implementation: string -> string -> string -> Env.t -> Parsetree.structure -> Typedtree.structure * Typedtree.module_coercion diff --git a/typing/types.ml b/typing/types.ml index 46b2fe73..1e9b762a 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: types.ml,v 1.26.8.1 2007/06/08 08:03:16 garrigue Exp $ *) +(* $Id: types.ml,v 1.29 2008/07/19 02:13:09 garrigue Exp $ *) (* Representation of types and declarations *) @@ -20,7 +20,7 @@ open Asttypes (* Type expressions for the core language *) type type_expr = - { mutable desc: type_desc; + { mutable desc: type_desc; mutable level: int; mutable id: int } @@ -33,7 +33,7 @@ and type_desc = | Tfield of string * field_kind * type_expr * type_expr | Tnil | Tlink of type_expr - | Tsubst of type_expr + | Tsubst of type_expr (* for copying *) | Tvariant of row_desc | Tunivar | Tpoly of type_expr * type_expr list @@ -49,11 +49,14 @@ and row_desc = and row_field = Rpresent of type_expr option | Reither of bool * type_expr list * bool * row_field option ref + (* 1st true denotes a constant constructor *) + (* 2nd true denotes a tag in a pattern matching, and + is erased later *) | Rabsent and abbrev_memo = Mnil - | Mcons of Path.t * type_expr * type_expr * abbrev_memo + | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo | Mlink of abbrev_memo ref and field_kind = @@ -135,14 +138,16 @@ type type_declaration = { type_params: type_expr list; type_arity: int; type_kind: type_kind; + type_private: private_flag; type_manifest: type_expr option; type_variance: (bool * bool * bool) list } + (* covariant, contravariant, weakly contravariant *) and type_kind = Type_abstract - | Type_variant of (string * type_expr list) list * private_flag - | Type_record of (string * mutable_flag * type_expr) list - * record_representation * private_flag + | Type_variant of (string * type_expr list) list + | Type_record of + (string * mutable_flag * type_expr) list * record_representation type exception_declaration = type_expr list @@ -198,6 +203,6 @@ and modtype_declaration = | Tmodtype_manifest of module_type and rec_status = - Trec_not - | Trec_first - | Trec_next + Trec_not (* not recursive *) + | Trec_first (* first in a recursive group *) + | Trec_next (* not first in a recursive group *) diff --git a/typing/types.mli b/typing/types.mli index 0c1c350d..8340d95b 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: types.mli,v 1.26.8.1 2007/06/08 08:03:16 garrigue Exp $ *) +(* $Id: types.mli,v 1.29 2008/07/19 02:13:09 garrigue Exp $ *) (* Representation of types and declarations *) @@ -19,7 +19,7 @@ open Asttypes (* Type expressions for the core language *) type type_expr = - { mutable desc: type_desc; + { mutable desc: type_desc; mutable level: int; mutable id: int } @@ -55,7 +55,7 @@ and row_field = and abbrev_memo = Mnil - | Mcons of Path.t * type_expr * type_expr * abbrev_memo + | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo | Mlink of abbrev_memo ref and field_kind = @@ -136,15 +136,16 @@ type type_declaration = { type_params: type_expr list; type_arity: int; type_kind: type_kind; + type_private: private_flag; type_manifest: type_expr option; type_variance: (bool * bool * bool) list } (* covariant, contravariant, weakly contravariant *) and type_kind = Type_abstract - | Type_variant of (string * type_expr list) list * private_flag - | Type_record of (string * mutable_flag * type_expr) list - * record_representation * private_flag + | Type_variant of (string * type_expr list) list + | Type_record of + (string * mutable_flag * type_expr) list * record_representation type exception_declaration = type_expr list diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 0e4072b9..fa3f0c89 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -122,6 +122,12 @@ let rec transl_type env policy styp = newty (Ttuple(List.map (transl_type env policy) stl)) | Ptyp_constr(lid, stl) -> let (path, decl) = + let lid, env = + match lid with + | Longident.Ldot (Longident.Lident "*predef*", lid) -> + Longident.Lident lid, Env.initial + | _ -> lid, env + in try Env.lookup_type lid env with Not_found -> diff --git a/typing/unused_var.ml b/typing/unused_var.ml index 9446f5d7..3d44a85f 100644 --- a/typing/unused_var.ml +++ b/typing/unused_var.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: unused_var.ml,v 1.6 2006/04/05 02:28:13 garrigue Exp $ *) +(* $Id: unused_var.ml,v 1.7 2008/07/09 13:03:38 mauny Exp $ *) open Parsetree @@ -73,6 +73,7 @@ let rec get_vars ((vacc, asacc) as acc) p = List.fold_left (fun a (_, p) -> get_vars a p) acc ipl | Ppat_array pl -> List.fold_left get_vars acc pl | Ppat_or (p1, _p2) -> get_vars acc p1 + | Ppat_lazy p -> get_vars acc p | Ppat_constraint (pp, _) -> get_vars acc pp | Ppat_type _ -> acc diff --git a/utils/ccomp.ml b/utils/ccomp.ml index 692c6dfd..17ba4c4d 100644 --- a/utils/ccomp.ml +++ b/utils/ccomp.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: ccomp.ml,v 1.21.2.1 2007/11/10 12:23:37 xleroy Exp $ *) +(* $Id: ccomp.ml,v 1.28.4.1 2008/10/15 08:48:51 xleroy Exp $ *) (* Compiling C files and building C libraries *) @@ -28,38 +28,42 @@ let run_command cmdline = ignore(command cmdline) command-line length *) let build_diversion lst = let (responsefile, oc) = Filename.open_temp_file "camlresp" "" in - List.iter - (fun f -> - if f <> "" then begin - output_string oc (Filename.quote f); output_char oc '\n' - end) - lst; + List.iter (fun f -> Printf.fprintf oc "%s\n" f) lst; close_out oc; at_exit (fun () -> Misc.remove_file responsefile); "@" ^ responsefile let quote_files lst = - let s = - String.concat " " - (List.map (fun f -> if f = "" then f else Filename.quote f) lst) in - if Sys.os_type = "Win32" && String.length s >= 256 - then build_diversion lst + let lst = List.filter (fun f -> f <> "") lst in + let quoted = List.map Filename.quote lst in + let s = String.concat " " quoted in + if String.length s >= 4096 && Sys.os_type = "Win32" + then build_diversion quoted else s +let quote_prefixed pr lst = + let lst = List.filter (fun f -> f <> "") lst in + let lst = List.map (fun f -> pr ^ f) lst in + quote_files lst + let quote_optfile = function | None -> "" | Some f -> Filename.quote f let compile_file name = - command - (Printf.sprintf - "%s -c %s %s %s %s" - !Clflags.c_compiler - (String.concat " " (List.rev !Clflags.ccopts)) - (quote_files - (List.rev_map (fun dir -> "-I" ^ dir) !Clflags.include_dirs)) - (Clflags.std_include_flag "-I") - (Filename.quote name)) + command + (Printf.sprintf + "%s -c %s %s %s %s" + (match !Clflags.c_compiler with + | Some cc -> cc + | None -> + if !Clflags.native_code + then Config.native_c_compiler + else Config.bytecomp_c_compiler) + (String.concat " " (List.rev !Clflags.ccopts)) + (quote_prefixed "-I" (List.rev !Clflags.include_dirs)) + (Clflags.std_include_flag "-I") + (Filename.quote name)) let create_archive archive file_list = Misc.remove_file archive; @@ -88,29 +92,36 @@ let expand_libname name = 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 +type link_mode = + | Exe + | Dll + | MainDll + | Partial -(* 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 +let call_linker mode output_name files extra = + let files = quote_files files in + let cmd = + if mode = Partial then + Printf.sprintf "%s%s %s %s" + Config.native_pack_linker + (Filename.quote output_name) + files + extra + else + Printf.sprintf "%s -o %s %s %s %s %s %s %s" + (match !Clflags.c_compiler, mode with + | Some cc, _ -> cc + | None, Exe -> Config.mkexe + | None, Dll -> Config.mkdll + | None, MainDll -> Config.mkmaindll + | None, Partial -> assert false + ) + (Filename.quote output_name) + (if !Clflags.gprofile then Config.cc_profile else "") + (Clflags.std_include_flag "-I") + (quote_prefixed "-L" !Config.load_path) + files + extra + (String.concat " " (List.rev !Clflags.ccopts)) + in + command cmd = 0 diff --git a/utils/ccomp.mli b/utils/ccomp.mli index 4e8bd1f1..3843a6d4 100644 --- a/utils/ccomp.mli +++ b/utils/ccomp.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: ccomp.mli,v 1.11.6.1 2007/11/10 12:23:37 xleroy Exp $ *) +(* $Id: ccomp.mli,v 1.16 2008/01/11 16:13:18 doligez Exp $ *) (* Compiling C files and building C libraries *) @@ -21,5 +21,12 @@ val create_archive: string -> string list -> int val expand_libname: string -> string val quote_files: string list -> string val quote_optfile: string option -> string -val make_link_options: string list -> string -val merge_manifest: string -> int +(*val make_link_options: string list -> string*) + +type link_mode = + | Exe + | Dll + | MainDll + | Partial + +val call_linker: link_mode -> string -> string list -> string -> bool diff --git a/utils/clflags.ml b/utils/clflags.ml index 494e4062..4ac0de8c 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: clflags.ml,v 1.49 2005/08/01 15:51:09 xleroy Exp $ *) +(* $Id: clflags.ml,v 1.53.2.1 2008/10/15 08:48:51 xleroy Exp $ *) (* Command-line parameters *) @@ -33,7 +33,7 @@ and ccopts = ref ([] : string list) (* -ccopt *) and classic = ref false (* -nolabels *) and nopervasives = ref false (* -nopervasives *) and preprocessor = ref(None : string option) (* -pp *) -let save_types = ref false (* -stypes *) +let annotations = ref false (* -annot *) and use_threads = ref false (* -thread *) and use_vmthreads = ref false (* -vmthread *) and noassert = ref false (* -noassert *) @@ -46,8 +46,7 @@ and principal = ref false (* -principal *) and recursive_types = ref false (* -rectypes *) and make_runtime = ref false (* -make_runtime *) and gprofile = ref false (* -p *) -and c_compiler = ref Config.bytecomp_c_compiler (* -cc *) -and c_linker = ref Config.bytecomp_c_linker (* -cc *) +and c_compiler = ref (None: string option) (* -cc *) and no_auto_link = ref false (* -noautolink *) and dllpaths = ref ([] : string list) (* -dllpath *) and make_package = ref false (* -pack *) @@ -88,3 +87,7 @@ let std_include_flag prefix = let std_include_dir () = if !no_std_include then [] else [Config.standard_library] ;; + +let shared = ref false (* -shared *) +let dlcode = ref true (* not -nodynlink *) + diff --git a/utils/clflags.mli b/utils/clflags.mli index 9b86d6fc..eba4f9ee 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: clflags.mli,v 1.1 2005/10/26 13:23:27 doligez Exp $ *) +(* $Id: clflags.mli,v 1.4.2.1 2008/10/15 08:48:51 xleroy Exp $ *) val objfiles : string list ref val ccobjs : string list ref @@ -30,7 +30,7 @@ val ccopts : string list ref val classic : bool ref val nopervasives : bool ref val preprocessor : string option ref -val save_types : bool ref +val annotations : bool ref val use_threads : bool ref val use_vmthreads : bool ref val noassert : bool ref @@ -43,8 +43,7 @@ val principal : bool ref val recursive_types : bool ref val make_runtime : bool ref val gprofile : bool ref -val c_compiler : string ref -val c_linker : string ref +val c_compiler : string option ref val no_auto_link : bool ref val dllpaths : string list ref val make_package : bool ref @@ -73,3 +72,5 @@ val inline_threshold : int ref val dont_write_files : bool ref val std_include_flag : string -> string val std_include_dir : unit -> string list +val shared : bool ref +val dlcode : bool ref diff --git a/utils/config.mlbuild b/utils/config.mlbuild index c1ba9668..6afd4106 100644 --- a/utils/config.mlbuild +++ b/utils/config.mlbuild @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: config.mlbuild,v 1.2 2007/02/07 15:47:36 ertai Exp $ *) +(* $Id: config.mlbuild,v 1.3 2007/11/27 12:22:59 ertai Exp $ *) (* The main OCaml version string has moved to ../VERSION *) let version = Sys.ocaml_version @@ -40,28 +40,26 @@ let standard_runtime = 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_linker = if windows then "flexlink" else 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_linker = if windows then "flexlink" else 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 native_pack_linker = C.packld let ranlib = C.ranlibcmd let cc_profile = C.cc_profile +let mkdll = C.mkdll +let mkexe = C.mkexe +let mkmaindll = C.mkmaindll let exec_magic_number = "Caml1999X008" -and cmi_magic_number = "Caml1999I010" +and cmi_magic_number = "Caml1999I011" 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" +and ast_impl_magic_number = "Caml1999M012" +and ast_intf_magic_number = "Caml1999N011" let load_path = ref ([] : string list) @@ -80,6 +78,8 @@ let architecture = C.arch let model = C.model let system = C.system +let asm = C.asm + let ext_obj = C.ext_obj let ext_asm = C.ext_asm let ext_lib = C.ext_lib @@ -107,12 +107,13 @@ let print_config oc = 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 "native_pack_linker" native_pack_linker; p "ranlib" ranlib; p "cc_profile" cc_profile; p "architecture" architecture; p "model" model; p "system" system; + p "asm" asm; p "ext_obj" ext_obj; p "ext_asm" ext_asm; p "ext_lib" ext_lib; diff --git a/utils/config.mli b/utils/config.mli index a8b6cd85..b3b71ca1 100644 --- a/utils/config.mli +++ b/utils/config.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: config.mli,v 1.35 2005/08/01 15:51:09 xleroy Exp $ *) +(* $Id: config.mli,v 1.41 2008/04/16 06:50:31 frisch Exp $ *) (* System configuration *) @@ -29,23 +29,22 @@ val ccomp_type: string val bytecomp_c_compiler: string (* The C compiler to use for compiling C files with the bytecode compiler *) -val bytecomp_c_linker: string - (* The C compiler to use for building custom runtime systems - with the bytecode compiler *) val bytecomp_c_libraries: string (* The C libraries to link with custom runtimes *) val native_c_compiler: string (* The C compiler to use for compiling C files with the native-code compiler *) -val native_c_linker: string - (* The C compiler to use for the final linking step - in the native code compiler *) val native_c_libraries: string (* The C libraries to link with native-code programs *) -val native_partial_linker: string - (* The linker to use for partial links (ocamlopt -output-obj) *) val native_pack_linker: string - (* The linker to use for packaging (ocamlopt -pack) *) + (* The linker to use for packaging (ocamlopt -pack) and for partial links + (ocamlopt -output-obj). *) +val mkdll: string + (* The linker command line to build dynamic libraries. *) +val mkexe: string + (* The linker command line to build executables. *) +val mkmaindll: string + (* The linker command line to build main programs as dlls. *) val ranlib: string (* Command to randomize a library, or "" if not needed *) val cc_profile : string @@ -93,6 +92,10 @@ val model: string val system: string (* Name of operating system for the native-code compiler *) +val asm: string + (* The assembler (and flags) to use for assembling + ocamlopt-generated code. *) + val ext_obj: string (* Extension for object files, e.g. [.o] under Unix. *) val ext_asm: string diff --git a/utils/config.mlp b/utils/config.mlp index 0b5e28ae..c6fa0e6e 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: config.mlp,v 1.201 2007/02/07 14:49:42 doligez Exp $ *) +(* $Id: config.mlp,v 1.208 2008/04/16 06:50:31 frisch Exp $ *) (* The main OCaml version string has moved to ../VERSION *) let version = Sys.ocaml_version @@ -29,24 +29,24 @@ let standard_library = let standard_runtime = "%%BYTERUN%%" let ccomp_type = "%%CCOMPTYPE%%" let bytecomp_c_compiler = "%%BYTECC%%" -let bytecomp_c_linker = "%%BYTELINK%%" let bytecomp_c_libraries = "%%BYTECCLIBS%%" let native_c_compiler = "%%NATIVECC%%" -let native_c_linker = "%%NATIVELINK%%" let native_c_libraries = "%%NATIVECCLIBS%%" -let native_partial_linker = "%%PARTIALLD%%" let native_pack_linker = "%%PACKLD%%" let ranlib = "%%RANLIBCMD%%" let cc_profile = "%%CC_PROFILE%%" +let mkdll = "%%MKDLL%%" +let mkexe = "%%MKEXE%%" +let mkmaindll = "%%MKMAINDLL%%" let exec_magic_number = "Caml1999X008" -and cmi_magic_number = "Caml1999I010" +and cmi_magic_number = "Caml1999I011" 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" +and ast_impl_magic_number = "Caml1999M012" +and ast_intf_magic_number = "Caml1999N011" let load_path = ref ([] : string list) @@ -65,6 +65,8 @@ let architecture = "%%ARCH%%" let model = "%%MODEL%%" let system = "%%SYSTEM%%" +let asm = "%%ASM%%" + let ext_obj = "%%EXT_OBJ%%" let ext_asm = "%%EXT_ASM%%" let ext_lib = "%%EXT_LIB%%" @@ -87,17 +89,16 @@ let print_config oc = 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 "native_pack_linker" native_pack_linker; p "ranlib" ranlib; p "cc_profile" cc_profile; p "architecture" architecture; p "model" model; p "system" system; + p "asm" asm; p "ext_obj" ext_obj; p "ext_asm" ext_asm; p "ext_lib" ext_lib; diff --git a/utils/warnings.ml b/utils/warnings.ml index 27910a7d..c0fbe9f2 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: warnings.ml,v 1.27 2006/09/21 14:54:54 maranget Exp $ *) +(* $Id: warnings.ml,v 1.28 2008/10/06 13:53:54 doligez Exp $ *) (* Please keep them in alphabetical order *) @@ -38,6 +38,7 @@ type t = (* A is all *) | Camlp4 of string | All_clauses_guarded | Useless_record_with + | Bad_module_name of string | Unused_var of string (* Y *) | Unused_var_strict of string (* Z *) ;; @@ -65,6 +66,7 @@ let letter = function (* 'a' is all *) | Nonreturning_statement | Camlp4 _ | Useless_record_with + | Bad_module_name _ | All_clauses_guarded -> 'x' | Unused_var _ -> 'y' | Unused_var_strict _ -> 'z' @@ -156,6 +158,8 @@ let message = function | Useless_record_with -> "this record is defined by a `with' expression,\n\ but no fields are borrowed from the original." + | Bad_module_name (modname) -> + "bad source file name: \"" ^ modname ^ "\" is not a valid module name." ;; let nerrors = ref 0;; diff --git a/utils/warnings.mli b/utils/warnings.mli index a99ea0f8..42af60cc 100644 --- a/utils/warnings.mli +++ b/utils/warnings.mli @@ -10,7 +10,7 @@ (* *) (***********************************************************************) -(* $Id: warnings.mli,v 1.18 2006/09/21 14:54:54 maranget Exp $ *) +(* $Id: warnings.mli,v 1.19 2008/10/06 13:53:54 doligez Exp $ *) open Format @@ -38,6 +38,7 @@ type t = (* A is all *) | Camlp4 of string | All_clauses_guarded | Useless_record_with + | Bad_module_name of string | Unused_var of string (* Y *) | Unused_var_strict of string (* Z *) ;; diff --git a/win32caml/Makefile b/win32caml/Makefile index 967c924f..c803ace7 100644 --- a/win32caml/Makefile +++ b/win32caml/Makefile @@ -11,7 +11,7 @@ # # ######################################################################### -# $Id: Makefile,v 1.11 2006/10/03 11:53:57 xleroy Exp $ +# $Id: Makefile,v 1.12 2007/11/15 13:21:15 frisch Exp $ include ../config/Makefile @@ -27,7 +27,7 @@ LIBS=$(call SYSLIB,kernel32) $(call SYSLIB,advapi32) $(call SYSLIB,gdi32) \ all: ocamlwin.exe ocamlwin.exe: $(OBJS) - $(call MKEXE,ocamlwin.exe,$(OBJS) $(LIBS) $(EXTRALIBS)) + $(MKEXE) -o ocamlwin.exe $(OBJS) $(LIBS) $(EXTRALIBS) -subsystem windows ocamlres.$(O): ocaml.rc ocaml.ico ifeq ($(TOOLCHAIN),msvc) diff --git a/win32caml/inria.h b/win32caml/inria.h index fc1e7e59..446c1fe1 100644 --- a/win32caml/inria.h +++ b/win32caml/inria.h @@ -10,7 +10,7 @@ /* */ /***********************************************************************/ -/* $Id: inria.h,v 1.5.18.1 2007/05/12 09:20:51 xleroy Exp $ */ +/* $Id: inria.h,v 1.6.4.1 2008/10/08 13:07:14 doligez Exp $ */ /*------------------------------------------------------------------------ Module: D:\lcc\inria\inria.h @@ -63,7 +63,7 @@ #include "editbuffer.h" #include "history.h" -#if _MSC_VER <= 1200 +#if _MSC_VER <= 1200 && !defined(__MINGW32__) #define GetWindowLongPtr GetWindowLong #define SetWindowLongPtr SetWindowLong #define DWLP_USER DWL_USER diff --git a/yacc/Makefile.nt b/yacc/Makefile.nt index b3cfbd95..3ec232df 100644 --- a/yacc/Makefile.nt +++ b/yacc/Makefile.nt @@ -10,7 +10,7 @@ # # ######################################################################### -# $Id: Makefile.nt,v 1.9 2007/02/07 14:49:42 doligez Exp $ +# $Id: Makefile.nt,v 1.11 2007/11/15 13:21:15 frisch Exp $ # Makefile for the parser generator. @@ -23,7 +23,7 @@ OBJS= closure.$(O) error.$(O) lalr.$(O) lr0.$(O) main.$(O) \ all: ocamlyacc.exe ocamlyacc.exe: $(OBJS) - $(call MKEXE,ocamlyacc.exe,$(BYTECCLINKOPTS) $(OBJS) $(EXTRALIBS)) + $(MKEXE) -o ocamlyacc.exe $(OBJS) $(EXTRALIBS) version.h : ../VERSION echo "#define OCAML_VERSION \"`head -1 ../VERSION`\"" >version.h