+utils/ccomp.cmi:
+utils/clflags.cmi:
+utils/config.cmi:
+utils/consistbl.cmi:
+utils/misc.cmi:
+utils/tbl.cmi:
+utils/terminfo.cmi:
+utils/warnings.cmi:
utils/ccomp.cmo: utils/misc.cmi utils/config.cmi utils/clflags.cmi \
utils/ccomp.cmi
utils/ccomp.cmx: utils/misc.cmx utils/config.cmx utils/clflags.cmx \
utils/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 \
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 \
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
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 \
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 \
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 \
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 \
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 \
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
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
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
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
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
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 \
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
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
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 \
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 \
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 \
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 \
+Objective Caml 3.11.0:
+----------------------
+
+(Changes that can break existing programs are marked with a "*" )
+
+Language features:
+- Addition of lazy patterns: "lazy <pat>" matches suspensions whose values,
+ after forcing, match the pattern <pat>.
+- Introduction of private abbreviation types "type t = private <type-expr>",
+ 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 <caml/memory.h>.)
+- 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:
----------------------
- many other small changes and bugfixes in camlp4, ocamlbuild, labltk,
emacs files
+
Objective Caml 3.10.0:
----------------------
- 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
* 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
options for finding the header files, and "-dllibs" for finding
the C libraries.
--binutils <directory>
- This option specifies where to find the GNU binutils (objcopy
- and nm) executables.
+-as <assembler and options> (default: determined automatically)
+ The assembler to use for assembling ocamlopt-generated code.
+
+-aspp <assembler and options> (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
# #
#########################################################################
-# $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
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=
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 \
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]
+# <change the source>
+# make core [cross-compiler]
+# make partialclean [if you get "inconsistent assumptions"]
+# <debug your changes>
+# make core [cross-compiler]
+# make coreboot [new system -- now you are in a stable state]
# Core bootstrapping cycle
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
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
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
# 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
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
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 \
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:
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; \
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
-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)|' \
-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
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
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
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
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
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
camlp4out: ocamlc otherlibraries ocamlbuild-partial-boot ocamlbuild.byte
./build/camlp4-byte-only.sh
+
camlp4opt: ocamlopt otherlibrariesopt ocamlbuild-partial-boot ocamlbuild.native
./build/camlp4-native-only.sh
ocamlbuild.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.
# 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
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
# #
#########################################################################
-# $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
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
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 \
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 \
@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.
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
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
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
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
-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)|" \
-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
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
Speed of bytecode interpreter 70% 100% 100%
-Replay debugger no no yes
+Replay debugger yes (**) yes (**) yes
The Unix library partial partial full
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.
------------------------------------------------------------------------------
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]).
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.
[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
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
* 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:
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.
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.
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
* 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).
------------------------------------------------------------------------------
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.
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:
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:
- 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
* 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.
-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 $
<camlp4/Camlp4_{config,import}.ml*>: -camlp4boot
"camlp4/Camlp4_import.ml": -warn_Ale
<camlp4/build/*> or <camlp4/boot/*> or "camlp4/Camlp4/Struct/Lexer.ml": -camlp4boot, -warn_Ale, warn_a
-"camlp4/Camlp4Bin.byte" or "camlp4/mkcamlp4.byte" or "camlp4/camlp4lib.cma": use_dynlink
+<camlp4/Camlp4Bin.{byte,native}> or "camlp4/camlp4lib.cma" or <camlp4/{mkcamlp4,boot/camlp4boot}.byte>: use_dynlink
"camlp4/Camlp4/Printers/OCaml.ml" or "camlp4/Camlp4/Printers/OCamlr.ml": warn_Alezv
<camlp4/Camlp4Printers/**.ml>: include_unix
-"camlp4/Camlp4/Struct/DynLoader.ml": include_dynlink
+"camlp4/Camlp4/Struct/DynLoader.ml" or "camlp4/boot/Camlp4.ml": include_dynlink
<camlp4/Camlp4Top/**>: include_toplevel
<camlp4/camlp4{,boot,o,r,of,rf,oof,orf}.byte>: -debug
(* *)
(***********************************************************************)
-(* $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 *)
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;;
(* *)
(***********************************************************************)
-(* $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 *)
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 =
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 =
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)`
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.
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 *)
` 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();
` 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
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`;
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
| 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`
` 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
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
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`;
` 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`
| _ ->
(* 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`;
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`
+
(* *)
(***********************************************************************)
-(* $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 *)
(* *)
(***********************************************************************)
-(* $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 *)
| 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
(* Calling the assembler *)
let assemble_file infile outfile =
- Ccomp.command ("as -o " ^ outfile ^ " " ^ infile)
+ Ccomp.command (Config.asm ^ " -o " ^ outfile ^ " " ^ infile)
(* *)
(***********************************************************************)
-(* $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 *)
(* 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 *)
(* *)
(***********************************************************************)
-(* $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
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 *)
(* *)
(***********************************************************************)
-(* $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 *)
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)
(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
(* *)
(***********************************************************************)
-(* $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 *)
(* *)
(***********************************************************************)
-(* $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 *)
(* 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;;
(* *)
(***********************************************************************)
-(* $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 *)
(* *)
(***********************************************************************)
-(* $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 *)
| 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
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 ->
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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 *)
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)
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)
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
(* 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
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 *)
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
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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. *)
(* 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 ->
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 *)
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
(* *)
(***********************************************************************)
-(* $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 *)
| 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 *)
| 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
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)),
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
(* *)
(***********************************************************************)
-(* $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-- *)
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 *)
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 ->
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])])
| 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 ->
| 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 *)
| 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
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
| 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
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) ->
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
| 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
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 =
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 *)
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 }
(* *)
(***********************************************************************)
-(* $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-- *)
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
(* *)
(***********************************************************************)
-(* $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 *)
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 =
(* 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 *)
(* *)
(***********************************************************************)
-(* $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 *)
(* 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
(* 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
(* 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
exception Error of error
val report_error: Format.formatter -> error -> unit
+
+
(* *)
(***********************************************************************)
-(* $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 *)
(* 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;;
(* *)
(***********************************************************************)
-(* $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 *)
(* *)
(***********************************************************************)
-(* $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 *)
(* *)
(***********************************************************************)
-(* $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 *)
(* 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
(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
| 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 =
` 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
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`
(* *)
(***********************************************************************)
-(* $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. *)
(* *)
(***********************************************************************)
-(* $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 *)
(* 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;;
(* *)
(***********************************************************************)
-(* $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 *)
(* 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"))
(* *)
(***********************************************************************)
-(* $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 *)
(* 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;;
(* *)
(***********************************************************************)
-(* $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 *)
(* 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;;
(* *)
(***********************************************************************)
-(* $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 *)
(* *)
(***********************************************************************)
-(* $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 *)
(* 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;;
(* *)
(***********************************************************************)
-(* $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 *)
(* *)
(***********************************************************************)
-(* $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 *)
(* 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)
../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 \
../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 \
../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 \
../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 \
../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 \
../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 \
../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 \
../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 \
../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 \
../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 \
../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 \
../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 \
../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 \
../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 \
../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 \
../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 \
../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 \
../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 \
# #
#########################################################################
-# $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)
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
.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
@ 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 *~
# #
#########################################################################
-# $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
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 \
$(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
# 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)
/* */
/***********************************************************************/
-/* $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 */
.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
/* */
/***********************************************************************/
-/* $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 */
/* */
/***********************************************************************/
-/* $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 <stdio.h>
+#include "alloc.h"
#include "backtrace.h"
#include "memory.h"
#include "misc.h"
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
}
}
-/* 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) +
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);
}
+
/* */
/***********************************************************************/
-/* $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. */
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));
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);
}
/* */
/***********************************************************************/
-/* $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 */
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
--- /dev/null
+#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 <stdio.h>
+#include <string.h>
+
+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);
+}
/* */
/***********************************************************************/
-/* $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 */
#include "mlvalues.h"
#include "stack.h"
#include "roots.h"
+#include <string.h>
+#include <stdio.h>
/* Roots registered from C functions */
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;
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 */
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++) {
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. */
#endif
value glob;
value * root;
- struct global_root * gr;
struct caml__roots_block *lr;
+ link *lnk;
/* The global roots */
for (i = caml_globals_scanned;
}
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;
}
}
/* 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 */
{
int i, j;
value glob;
- struct global_root * gr;
+ link *lnk;
/* The global roots */
for (i = 0; caml_globals[i] != 0; i++) {
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 */
/* */
/***********************************************************************/
-/* $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 */
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.
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
}
&& 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 */
/* */
/***********************************************************************/
-/* $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 */
static void name(int sig, siginfo_t * info, void * context)
#include <sys/ucontext.h>
- #include <AvailabilityMacros.h>
+ #include <AvailabilityMacros.h>
#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
/* */
/***********************************************************************/
-/* $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 */
(((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;
extern intnat caml_globals_inited;
extern intnat * caml_frametable[];
-
#endif /* CAML_STACK_H */
/* */
/***********************************************************************/
-/* $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 */
#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 */
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;
}
}
#!/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
#!/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
#!/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'
#!/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`/..
#!/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
#!/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
#!/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"
#!/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) || :
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 \
#!/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
#!/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`/..
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 \
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 \
#!/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
#!/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 *)/' \
#!/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/;$//'; \
#!/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
#!/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
#!/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
#!/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
#!/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=""
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
#!/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"
#!/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
-# $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
#!/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
#!/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
#!/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
#!/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
(* *)
(***********************************************************************)
-(* $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. *)
| 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.
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))
(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
| 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
(* *)
(***********************************************************************)
-(* $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. *)
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
(* 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
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)
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
(* *)
(***********************************************************************)
-(* $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 *)
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
(* *)
(***********************************************************************)
-(* $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
| Pfloatfield of int
| Psetfloatfield of int
| Pduprecord of Types.record_representation * int
+ (* Force lazy values *)
+ | Plazyforce
(* External call *)
| Pccall of Primitive.description
(* Exceptions *)
| 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
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
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
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
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)
(* *)
(***********************************************************************)
-(* $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 *)
| Pfloatfield of int
| Psetfloatfield of int
| Pduprecord of Types.record_representation * int
+ (* Force lazy values *)
+ | Plazyforce
(* External call *)
| Pccall of Primitive.description
(* Exceptions *)
| 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
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
(* *)
(***********************************************************************)
-(* $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 *)
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"
| 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
| {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
| Tpat_record _ -> group_record
| Tpat_array _ -> group_array
| Tpat_variant (_,_,_) -> group_variant
+| Tpat_lazy _ -> group_lazy
| _ -> fatal_error "Matching.get_group"
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 *)
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)
end
with Unused ->
assert false (* ; partial_function loc () *)
-
(* *)
(***********************************************************************)
-(* $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 *)
val make_test_sequence:
lambda option -> primitive -> primitive -> lambda ->
(Asttypes.constant * lambda) list -> lambda
+
+val inline_lazy_force : lambda -> Location.t -> lambda
(* *)
(***********************************************************************)
-(* $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
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"
| 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 "&&"
| 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
(* *)
(***********************************************************************)
-(* $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. *)
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
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
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) ->
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
(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) ;
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
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));
(* *)
(***********************************************************************)
-(* $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
| _ ->
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)
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 =
(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 []
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
| 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) =
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
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)
"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))
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
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))
| _ ->
(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))
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)))
| _ ->
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 =
| 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)
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));
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 ->
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 ->
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
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 ->
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
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),
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 =
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 =
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))
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]
(* *)
(***********************************************************************)
-(* $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 *)
"%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;
"%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 =
| [{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
| (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 ->
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 *)
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
(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
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) ->
| 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))
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
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 ->
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
(* *)
(***********************************************************************)
-(* $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 *)
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
(* *)
(***********************************************************************)
-(* $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 *)
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
(* 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. *)
| (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
[] ->
| (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
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
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
"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),
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
[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). *)
| _ ->
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"
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)
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 =
(* *)
(***********************************************************************)
-(* $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 *)
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
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
(* *)
(***********************************************************************)
-(* $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
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;
cache_required := req;
top_env := env;
classes := [];
+ method_ids := IdentSet.empty;
let lambda = f x in
let lambda =
List.fold_left
(* *)
(***********************************************************************)
-(* $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
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
(* *)
(***********************************************************************)
-(* $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 *)
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
| _ -> 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
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 = _} ->
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 ->
"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,
interp.a.lst
*.[sd]obj
*.lib
+.gdb_history
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
../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
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
../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
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
# #
#########################################################################
-# $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)
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
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
--- /dev/null
+#########################################################################
+# #
+# 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
# #
#########################################################################
-# $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
/* */
/***********************************************************************/
-/* $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 */
#include "misc.h"
#include "mlvalues.h"
-#ifndef NATIVE_CODE
-
CAMLprim value caml_array_get_addr(value array, value index)
{
intnat idx = Long_val(index);
return caml_array_unsafe_set_addr(array, index, newval);
}
-#endif
-
CAMLprim value caml_make_vect(value len, value init)
{
CAMLparam2 (len, 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;
} 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 {
/* */
/***********************************************************************/
-/* $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 */
#include "intext.h"
#include "exec.h"
#include "fix_code.h"
+#include "memory.h"
#include "startup.h"
#include "stacks.h"
#include "sys.h"
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
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";
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);
}
}
{
value events;
int i;
+ struct loc_info li;
events = read_debug_info();
if (events == Val_false) {
"(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);
}
+
/* */
/***********************************************************************/
-/* $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
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
/* */
/***********************************************************************/
-/* $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 <string.h>
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.
/* 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. */
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;
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);
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)
{
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;
/* */
/***********************************************************************/
-/* $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 <string.h>
#include <stdlib.h>
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;
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;
/* 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 */
/* */
/***********************************************************************/
-/* $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 */
/* **** major_gc.c */
#define heap_start caml_heap_start
-#define heap_end caml_heap_end
#define page_table caml_page_table
/* **** md5.c */
/* */
/***********************************************************************/
-/* $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
/* 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). */
#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
/* */
/***********************************************************************/
-/* $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 <io.h>
+#endif /* _WIN32 */
+
#include <string.h>
#include "config.h"
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)
{
#ifdef HAS_UNISTD
#include <unistd.h>
#endif
+#include <errno.h>
#include <sys/types.h>
+#ifndef _WIN32
#include <sys/wait.h>
#include <sys/socket.h>
#include <sys/un.h>
#include <netinet/in.h>
#include <arpa/inet.h>
#include <netdb.h>
+#else
+#define ATOM ATOM_WS
+#include <winsock.h>
+#undef ATOM
+#include <process.h>
+#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 */
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);
}
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;
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;
caml_flush(dbg_out);
command_loop:
-
+
/* Read and execute the commands sent by the debugger */
while(1) {
switch(getch(dbg_in)) {
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. */
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);
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;
/* */
/***********************************************************************/
-/* $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. */
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());
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;
/* */
/***********************************************************************/
-/* $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 */
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;
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)
/* */
/***********************************************************************/
-/* $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. */
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);
/* */
/***********************************************************************/
-/* $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
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;
/* */
/***********************************************************************/
-/* $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. */
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;
/* 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);
/* */
/***********************************************************************/
-/* $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" */
#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;
/* */
/***********************************************************************/
-/* $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 <string.h>
#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"
} 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
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);
}
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);
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);
}
*/
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;
#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 ();
}
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);
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);
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);
if (prev == caml_fl_merge && bp < caml_gc_sweep_hp){
caml_fl_merge = (char *) Field (bp, 1);
}
+ truncate_flp (bp);
}
}
/* */
/***********************************************************************/
-/* $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. */
/* */
/***********************************************************************/
-/* $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"
{
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);
/* */
/***********************************************************************/
-/* $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
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;
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 *));
}
}
-/* 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;
/* 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);
}
/* */
/***********************************************************************/
-/* $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 */
#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 */
/* */
/***********************************************************************/
-/* $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 */
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:
/* 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 */
/* */
/***********************************************************************/
-/* $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 */
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);
/* */
/***********************************************************************/
-/* $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 */
/* */
/***********************************************************************/
-/* $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 <stdio.h>
#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 \
/* 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
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;
/* */
/***********************************************************************/
-/* $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 <stdio.h>
#include <string.h>
/* */
/***********************************************************************/
-/* $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 */
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) \
/* */
/***********************************************************************/
-/* $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). */
/* */
/***********************************************************************/
-/* $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 <limits.h>
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;
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;
&& 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;
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);
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 ();
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;
/* */
/***********************************************************************/
-/* $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
#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 *);
/* */
/***********************************************************************/
-/* $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 <stdlib.h>
#include <string.h>
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.
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;
*/
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
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. */
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. */
{
++ 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;
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
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
{
*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);
/* */
/***********************************************************************/
-/* $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 */
/* <private> */
+#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; \
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 */
/* */
/***********************************************************************/
-/* $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 */
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;
/* */
/***********************************************************************/
-/* $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 <string.h>
#include "config.h"
#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;
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;
}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);
/* */
/***********************************************************************/
-/* $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
/* */
/***********************************************************************/
-/* $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 <stdio.h>
#include "config.h"
/* */
/***********************************************************************/
-/* $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. */
/* 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 */
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 */
/* */
/***********************************************************************/
-/* $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
#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
#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. */
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)
/* */
/***********************************************************************/
-/* $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 */
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 */
}
}
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{
CAMLreturn (res);
}
-/* For camlinternalOO.ml
+/* For mlvalues.h and camlinternalOO.ml
See also GETPUBMET in interp.c
*/
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 */
/* */
/***********************************************************************/
-/* $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 */
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);
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);
/* */
/***********************************************************************/
-/* $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 */
}
}
+
+/* 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;
+}
/* */
/***********************************************************************/
-/* $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 */
void caml_oldify_local_roots (void)
{
register value * sp;
- struct global_root * gr;
struct caml__roots_block *lr;
intnat i, j;
}
}
/* 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 */
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 */
/* */
/***********************************************************************/
-/* $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 */
{
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 */
exit(0);
break;
case 'b':
- caml_init_backtrace();
+ caml_record_backtrace(Val_true);
break;
case 'I':
if (argv[i + 1] != NULL) {
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;
}
}
/* */
/***********************************************************************/
-/* $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 <stddef.h>
#include <stdlib.h>
#include <string.h>
#include <fcntl.h>
#include "config.h"
#ifdef SUPPORT_DYNAMIC_LINKING
-#ifdef HAS_NSLINKMODULE
-#include <mach-o/dyld.h>
+#ifdef __CYGWIN32__
+#include "flexdll.h"
#else
#include <dlfcn.h>
#endif
}
#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
#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 */
}
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;
}
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 <sys/mman.h>
-
-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
/* */
/***********************************************************************/
-/* $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 */
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{
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);
/* */
/***********************************************************************/
-/* $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 */
#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)
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 */
}
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)
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;
| 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 *)
value expr = Gram.Entry.mk "expr";
value expr_eoi = Gram.Entry.mk "expr_eoi";
value field_expr = Gram.Entry.mk "field_expr";
+ value field_expr_list = Gram.Entry.mk "field_expr_list";
value fun_binding = Gram.Entry.mk "fun_binding";
value fun_def = Gram.Entry.mk "fun_def";
value ident = Gram.Entry.mk "ident";
value 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";
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 ==
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)
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)
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
| [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
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;
| <: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 "@[<hv0>@[<hv2>object@ %a@]@ end@]" o#class_str_item cst
+ | <:expr< object ($p$ : $t$) $cst$ end >> ->
+ pp f "@[<hv0>@[<hv2>object @[<1>(%a :@ %a)@]@ %a@]@ end@]"
+ o#patt p o#ctyp t o#class_str_item cst
+ | <:expr< object ($p$) $cst$ end >> ->
+ pp f "@[<hv0>@[<hv2>object @[<2>(%a)@]@ %a@]@ end@]"
+ o#patt p o#class_str_item cst
| e -> o#apply_expr f e ];
method apply_expr f e =
| <: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$) >> ->
| <:expr< ` $lid:s$ >> -> pp f "`%a" o#var s
| <:expr< {< $b$ >} >> ->
pp f "@[<hv0>@[<hv2>{<%a@]@ >}@]" o#record_binding b
- | <:expr< object $cst$ end >> ->
- pp f "@[<hv0>@[<hv2>object@ %a@]@ end@]" o#class_str_item cst
- | <:expr< object ($p$ : $t$) $cst$ end >> ->
- pp f "@[<hv0>@[<hv2>object @[<1>(%a :@ %a)@]@ %a@]@ end@]"
- o#patt p o#ctyp t o#class_str_item cst
- | <:expr< object ($p$) $cst$ end >> ->
- pp f "@[<hv0>@[<hv2>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$ >> ->
<: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 =
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
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
| <: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$ >> ->
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>@[<hv2>struct@ %a@]@ end :@ @[<hv2>sig@ %a@]@ end@]"
+ o#str_item st o#sig_item sg
+ | _ -> o#simple_module_expr f me ];
+
+ method simple_module_expr f me =
+ let () = o#node f me Ast.loc_of_module_expr in
+ match me with
+ [ <:module_expr<>> -> assert False
| <:module_expr< $id:i$ >> -> o#ident f i
| <:module_expr< $anti:s$ >> -> o#anti f s
| <:module_expr< $me1$ $me2$ >> ->
pp f "@[<2>functor@ @[<1>(%a :@ %a)@]@ ->@ %a@]" o#var s o#module_type mt o#module_expr me
| <:module_expr< struct $st$ end >> ->
pp f "@[<hv0>@[<hv2>struct@ %a@]@ end@]" o#str_item st
- | <:module_expr< ( struct $st$ end : sig $sg$ end ) >> ->
- pp f "@[<2>@[<hv2>struct@ %a@]@ end :@ @[<hv2>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 ];
| <: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
| <: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
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) ->
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
| 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
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 "@[<v0>%a@]@." o#str_item st;
method class_type f ct =
* - Nicolas Pouillard: refactoring
*)
+(* $Id: Sig.ml,v 1.7 2008/10/04 10:47:56 ertai Exp $ *)
+
(** Camlp4 signature repository *)
(** {6 Basic signatures} *)
(** 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;
(** [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. *)
value expr_eoi : Gram.Entry.t Ast.expr;
value expr_quot : Gram.Entry.t Ast.expr;
value field_expr : Gram.Entry.t Ast.rec_binding;
+ value field_expr_list : Gram.Entry.t Ast.rec_binding;
value fun_binding : Gram.Entry.t Ast.expr;
value fun_def : Gram.Entry.t Ast.expr;
value ident : Gram.Entry.t Ast.ident;
value 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;
[ <:patt< $lid:_$ >> -> True
| <:patt< () >> -> True
| <:patt< _ >> -> True
+ | <:patt<>> -> True (* why not *)
| <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y
| <:patt< { $p$ } >> -> is_irrefut_patt p
| <:patt< $_$ = $p$ >> -> is_irrefut_patt p
| <:patt< $p1$; $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2
| <:patt< $p1$, $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2
+ | <:patt< $p1$ | $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2 (* could be more fine grained *)
+ | <:patt< $p1$ $p2$ >> -> is_irrefut_patt p1 && is_irrefut_patt p2
| <:patt< ($p$ : $_$) >> -> is_irrefut_patt p
| <:patt< ($tup:pl$) >> -> is_irrefut_patt pl
| <:patt< ? $_$ >> -> True
| <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p
| <:patt< ~ $_$ >> -> 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
* - 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;
| 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 ]
;
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 =
| _ -> 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);
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
[ <: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;
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
| 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 ->
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 =
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)
| 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< _ >>
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< () >> ->
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 ->
* - 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;
*)
-(* $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;
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 ();
in
try Dynlink.loadfile fname with
[ Dynlink.Error e -> raise (Error fname (Dynlink.error_message e)) ]
- }
- END;
+ };
+
+
+value is_native = Dynlink.is_native;
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;
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;
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) :] ->
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
(* *)
(****************************************************************************)
-(* $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
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;
* - 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
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;
* - 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 *)
* - 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
* - 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;
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
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 {
| ("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") ->
| ("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 ();
};
Options:
<file>.ml Parse this implementation file
<file>.mli Parse this interface file
-<file>.(cmo|cma) Load this module inside the Camlp4 core@.";
+<file>.%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
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
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 =
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
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
(* 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;
+++ /dev/null
-(* 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 ();
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
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
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
* - Nicolas Pouillard: refactoring
* - Aleksey Nogin: extra features and bug fixes.
* - Christopher Conway: extra feature (-D<uident>=)
+ * - 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;
(*
[ 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 =
[ 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
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
;
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" -> ()
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
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;
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;
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
<: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 ";" ->
] ];
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$ >>
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$ >>
] ]
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 ]
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$ >>
| "`"; 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 ] ]
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<>>$ ] >>
<: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$ >>
| 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"
[ [ "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$ >>
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
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
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;
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;
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
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$) >>
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:
[ [ -> () ] ]
| 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$ >>
| ".." 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$ >>
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$) >>
| 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 ->
] ]
;
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 ->
| `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
<: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:
| 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$ >>
| 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:
;
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 ->
| 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$ >>
] ]
;
rec_binding_quot:
- [ [ x = label_expr -> x
+ [ [ x = label_expr_list -> x
| -> <:rec_binding<>> ] ]
;
module_binding_quot:
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
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)
* - 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
* - 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
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
| [: :] -> 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 {
| x -> x ]
in
do {
+ cleanup lb;
Format.eprintf "@[<0>%a@]@." Camlp4.ErrorHandler.print x;
raise Exit
} ];
* - Daniel de Rauglaudre: initial version
* - Nicolas Pouillard: refactoring
*)
+ (* $Id$ *)
(** Camlp4 signature repository *)
(** {6 Basic signatures} *)
(** Signature with just a type. *)
(** 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
(** 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 *)
| 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
val find_in_path : t -> string -> string
+ val is_native : bool
+
end
module Grammar =
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
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
\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\
\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\
\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\
\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\
\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\
\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\
\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\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\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\
\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\
\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\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\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\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\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\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\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\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\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\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\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\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\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\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\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\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\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\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\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\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\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\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\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\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\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\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\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\
\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\
\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\
\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\
\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\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\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\
\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\
\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\
\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\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\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\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\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\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\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\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\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\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\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\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\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\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\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\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\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\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\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\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\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\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\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\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\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\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\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\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\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\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
- \000\000\000\000\000\000\000\000\000\000\000\000\000\000";
+ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+ \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\
+ \000\000\000\000\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\
\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\
\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\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\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\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\
\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\
__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
(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 =
__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
__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 =
(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
| __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
(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
| 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
(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
| 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
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,
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,
| 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
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
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
(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;
| 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
(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
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
| 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
ptype_params = params;
ptype_cstrs = [];
ptype_kind = kind;
+ ptype_private = priv;
ptype_manifest = Some ct;
ptype_loc = mkloc loc;
ptype_variance = variance;
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 =
| (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)
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
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
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)
(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
__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
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
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 =
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
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
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 =
| 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 "@[<hv0>@[<hv2>object@ %a@]@ end@]"
+ o#class_str_item cst
+ | Ast.ExObj (_, (Ast.PaTyc (_, p, t)), cst) ->
+ pp f
+ "@[<hv0>@[<hv2>object @[<1>(%a :@ %a)@]@ %a@]@ end@]"
+ o#patt p o#ctyp t o#class_str_item cst
+ | Ast.ExObj (_, p, cst) ->
+ pp f
+ "@[<hv0>@[<hv2>object @[<2>(%a)@]@ %a@]@ end@]"
+ o#patt p o#class_str_item cst
| e -> o#apply_expr f e
method apply_expr =
| Ast.ExOvr (_, b) ->
pp f "@[<hv0>@[<hv2>{<%a@]@ >}@]" o#record_binding
b
- | Ast.ExObj (_, (Ast.PaNil _), cst) ->
- pp f "@[<hv0>@[<hv2>object@ %a@]@ end@]"
- o#class_str_item cst
- | Ast.ExObj (_, (Ast.PaTyc (_, p, t)), cst) ->
- pp f
- "@[<hv0>@[<hv2>object @[<1>(%a :@ %a)@]@ %a@]@ end@]"
- o#patt p o#ctyp t o#class_str_item cst
- | Ast.ExObj (_, p, cst) ->
- pp f
- "@[<hv0>@[<hv2>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) ->
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 ->
(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
| (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 =
| 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
| 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>@[<hv2>struct@ %a@]@ end :@ @[<hv2>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
| Ast.MeStr (_, st) ->
pp f "@[<hv0>@[<hv2>struct@ %a@]@ end@]" o#str_item
st
- | Ast.MeTyc (_, (Ast.MeStr (_, st)),
- (Ast.MtSig (_, sg))) ->
- pp f
- "@[<2>@[<hv2>struct@ %a@]@ end :@ @[<hv2>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
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
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 "@[<v0>%a@]@." o#str_item st
method class_type =
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"
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"
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
[ 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
| 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
(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
(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
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
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
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
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
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)
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)
(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
([ 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) ->
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 "[|";
((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))));
(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,
(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 () ->
(_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) ->
([ 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
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 :
->
(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 () ->
([ 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 () ->
(_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 :
->
(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 () ->
(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
([ 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 "[<";
'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));
| 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 () ->
(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) ->
(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));
(_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 _")) ],
| QUOTATION x ->
(Quotation.expand _loc x Quotation.
DynAst.ctyp_tag :
- 'meth_list)
+ 'meth_decl)
| _ -> assert false)));
([ Gram.Stoken
(((function
| ANTIQUOT ((("list" as n)), s) ->
(Ast.TyAnt (_loc,
mk_anti ~c: "ctyp;" n s) :
- 'meth_list)
+ 'meth_decl)
| _ -> assert false)));
([ Gram.Stoken
(((function
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 () ->
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
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
(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)
| 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
| 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 =
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 =
[ {
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 =
[ {
} ];
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
| 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
* - Nicolas Pouillard: refactoring
* - Aleksey Nogin: extra features and bug fixes.
* - Christopher Conway: extra feature (-D<uident>=)
+ * - Jean-vincent Loddo: definitions inside IFs.
*)
module Id =
struct let name = "Camlp4MacroParser"
| 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 =
| 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
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)
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
'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)) ],
'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)) ],
(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,
([] : '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)
([] : '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 () ->
(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 :
(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 :
(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 :
(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 () ->
(_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)))) ]) ]))
());
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
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" | ""),
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" | ""), ("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 ())
Options:
<file>.ml Parse this implementation file
<file>.mli Parse this interface file
-<file>.(cmo|cma) Load this module inside the Camlp4 core@.";
+<file>.%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
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)))
Camlp4Filters/Camlp4MapGenerator
Camlp4Filters/Camlp4MetaGenerator
Camlp4Filters/Camlp4Profiler
-Camlp4Filters/Camlp4Tracer
Camlp4Filters/Camlp4TrashRemover
Camlp4Top
+true: warn_A, warn_e
<{apply_operator,type_quotation,global_handler,expression_closure{,_filter}}.ml> or <free_vars_test.*>: 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 <arith.*> 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)
<parse_files.*>: camlp4of, use_camlp4_full, use_dynlink
"test_type_quotation.ml": pp(camlp4of ./type_quotation.cmo)
"apply_operator_test.ml": pp(camlp4o ./apply_operator.cmo)
"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)
--- /dev/null
+(* 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
--- /dev/null
+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))) >>
+;;
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 "@]@.";
--- /dev/null
+f "test", f "foo", "bar"
--- /dev/null
+(* 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;;
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";;
--- /dev/null
+(* 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";;
* - 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;
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();
}
# #
#########################################################################
-# $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
# 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:
# #
#########################################################################
-# $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
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
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)
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
# 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
# #
#########################################################################
-# $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
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
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)
#ml let syslib x = x ^ ".lib";;
### The ranlib command
-RANLIB=
+RANLIB=echo
RANLIBCMD=
############# Configuration for the native-code compiler
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
# 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
# #
#########################################################################
-# $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
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
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)
#ml let syslib x = x ^ ".lib";;
### The ranlib command
-RANLIB=
+RANLIB=echo
RANLIBCMD=
############# Configuration for the native-code compiler
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
/* */
/***********************************************************************/
-/* $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 <stdio.h>
#include <signal.h>
# #
#########################################################################
-# $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
manext=1
host_type=unknown
ccoption=''
+asoption=''
+asppoption=''
cclibs=''
curseslibs=''
mathlib='-lm'
host_type=$2; shift;;
-cc*)
ccoption="$2"; shift;;
+ -as)
+ asoption="$2"; shift;;
+ -aspp)
+ asppoption="$2"; shift;;
-lib*)
cclibs="$2 $cclibs"; shift;;
-no-curses)
# Configure the bytecode compiler
bytecc="$cc"
+mkexe="\$(BYTECC)"
bytecccompopts=""
bytecclinkopts=""
+dllccompopts=""
ostype="Unix"
exe=""
+iflexdir=""
case "$bytecc,$host" in
cc,*-*-nextstep*)
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*)
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;;
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
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]*)
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
*,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';;
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."
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
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" \
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
-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
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."
echo "SUPPORTS_SHARED_LIBRARIES=$shared_libraries_supported" >> Makefile
echo "SHAREDCCCOMPOPTS=$sharedcccompopts" >> Makefile
echo "MKSHAREDLIBRPATH=$mksharedlibrpath" >> Makefile
+echo "NATDYNLINKOPTS=$natdynlinkopts" >> Makefile
cat >> Makefile <<EOF
SYSLIB=-l\$(1)
#ml let syslib x = "-l"^x;;
-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=$mksharedlib \$(1) \$(3)
-#ml let mkdll out _implib files opts = Printf.sprintf "%s %s %s %s" "$mksharedlib" out opts files;;
-
### How to build a static library
MKLIB=ar rc \$(1) \$(2); ranlib \$(1)
#ml let mklib out files opts = Printf.sprintf "ar rc %s %s %s; ranlib %s" out opts files out;;
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
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
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
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
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
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
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 \
# #
#########################################################################
-# $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
--- /dev/null
+#########################################################################
+# #
+# 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
+
--- /dev/null
+#########################################################################
+# #
+# 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
(* *)
(***********************************************************************)
-(* $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 ***************)
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
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
let instr_reverse ppf lexbuf =
eol lexbuf;
+ check_not_windows "reverse";
ensure_loaded ();
reset_named_values();
back_run ();
| None -> _1
| Some x -> x
in
+ check_not_windows "backstep";
ensure_loaded ();
reset_named_values();
step (_0 -- step_count);
let instr_start ppf lexbuf =
eol lexbuf;
+ check_not_windows "start";
ensure_loaded ();
reset_named_values();
start ();
| None -> 1
| Some x -> x
in
+ check_not_windows "previous";
ensure_loaded ();
reset_named_values();
previous step_count;
| None -> _1
| Some x -> x
in
+ check_not_windows "last";
reset_named_values();
go_to (History.previous_time count);
show_current_event ppf
(* *)
(***********************************************************************)
-(* $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 *)
(* 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 =
(* *)
(***********************************************************************)
-(* $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 ***********************)
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"
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)
(* *)
(***********************************************************************)
-(* $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
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)))
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)
(* *)
(***********************************************************************)
-(* $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 *)
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
(* *)
(***********************************************************************)
-(* $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
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
(* *)
(***********************************************************************)
-(* $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 *)
(*** 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 =
(_, 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)
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)
(* *)
(***********************************************************************)
-(* $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 *)
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);
(* *)
(***********************************************************************)
-(* $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 *************************************)
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
(* *)
(***********************************************************************)
-(* $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 *)
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
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
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
++ 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
(* *)
(***********************************************************************)
-(* $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
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
(* *)
(***********************************************************************)
-(* $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
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
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
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)
(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 ->
(* *)
(***********************************************************************)
-(* $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
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
struct
let list = [
"-a", Arg.Unit F._a, " Build a library";
+ "-annot", Arg.Unit F._annot, " Save information in <filename>.annot";
"-c", Arg.Unit F._c, " Compile only (do not link)";
"-cc", Arg.String F._cc,
"<command> Use <command> as the C compiler and linker";
"<lib> Use the dynamically-loaded library <lib>";
"-dllpath", Arg.String F._dllpath,
"<dir> Add <dir> to the run-time search path for shared libraries";
- "-dtypes", Arg.Unit F._dtypes, " Save type information in <filename>.annot";
+ "-dtypes", Arg.Unit F._annot, " (deprecated) same as -annot";
"-for-pack", Arg.String (fun s -> ()),
"<ident> Ignored (for compatibility with ocamlopt)";
"-g", Arg.Unit F._g, " Save debugging information";
(* *)
(***********************************************************************)
-(* $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
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
(* *)
(***********************************************************************)
-(* $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 *)
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
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 *)
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
+++ 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
(* *)
(***********************************************************************)
-(* $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.
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
(* *)
(***********************************************************************)
-(* $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
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;
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
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 <filename>.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),
"<comp> Use <comp> as the C compiler and linker";
"-cclib", Arg.String(fun s ->
ccobjs := Misc.rev_split_words s @ !ccobjs),
" 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 <filename>.annot";
+ "-dtypes", Arg.Set annotations,
+ " (deprecated) same as -annot";
"-for-pack", Arg.String (fun s -> for_package := Some s),
"<ident> Generate code that can later be `packed' with\n\
\ ocamlopt -pack -o <ident>.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),
" 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";
" 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";
"-", Arg.String (process_file ppf),
"<file> Treat <file> 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 ->
- 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
;(* *)
;(***********************************************************************)
-;(* $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
;(* *)
;(***********************************************************************)
-;(* $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)))
(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 <SP> position <LF> annotation *
position ::= filename <SP> num <SP> num <SP> num
- annotation ::= keyword open-paren <LF> <SP> <SP> data <LF> close-paren
+ annotation ::= keyword open-paren <LF> <SP> <SP> data <LF> close-paren <LF>
<SP> is a space character (ASCII 0x20)
<LF> is a line-feed character (ASCII 0x0A)
- 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)
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.
(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)
(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)
(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))))
(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)
(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)))))
"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))
(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)))
(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)))
(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)
(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))
(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
(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).
"
(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)
)
(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))
(condition-case nil
(scroll-up 1)
(error (message "End of buffer!"))))
- )
+ )
(setq speed (* speed speed))
)))
;; main action, when the motion is inside the window
(<= (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))))
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)
;; 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))
)))
(defun caml-types-version ()
"internal version number of caml-types.el"
(interactive)
- (message "2")
+ (message "4")
)
(provide 'caml-types)
;(* *)
;(***********************************************************************)
-;(* $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
(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
(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))
(setq command "ocamlyacc"))
)
(if command
- (progn
+ (progn
(make-local-variable 'compile-command)
(setq compile-command (concat command " " filename))))
)))
(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)
(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."
;; 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
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)
(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)
(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.
(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
;; 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
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
(* *)
(***********************************************************************)
-(* $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 *)
{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")
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)) ;
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 ;
reachs chars follow st.others)
end
-(*
let dtags chan tags =
Tags.iter
(fun t -> fprintf chan " %a" dtag t)
dtransset t.(i)
done ;
prerr_endline "]"
-*)
+
let make_tag_entry id start act a r = match a with
| Sum (Mem m,0) ->
(*
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 "}" ;
*)
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)
+\" $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
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
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
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
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".
-
+\" $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
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
.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
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 ,
.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".
+\" $Id: ocamlcp.m,v 1.4 2008/09/15 14:05:30 doligez Exp $
+
.TH OCAMLCP 1
.SH NAME
.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, ...
.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".
+\" $Id: ocamldebug.m,v 1.2 2008/09/15 14:05:30 doligez Exp $
+
.TH OCAMLDEBUG 1
.SH NAME
.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 <luther@debian.org>,
for the Debian GNU/Linux system (but may be used by others).
-
+\" $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,
The typical usage is:
.P
-ocamldep
+ocamldep
.I options
*.mli *.ml > .depend
.P
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
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".
-.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
.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
.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" .
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
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
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
.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
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/ .
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.
merge @author
.B v
-merge @version
+merge @version
.B l
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
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 ,
.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)
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
+\" $Id: ocamllex.m,v 1.5 2008/09/15 14:12:56 doligez Exp $
.TH OCAMLLEX 1
.SH NAME
.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
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".
+\" $Id: ocamlmktop.m,v 1.3 2008/09/15 14:12:56 doligez Exp $
.TH OCAMLMKTOP 1
.SH NAME
.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
+\" $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:
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
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
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.
.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
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".
+\" $Id: ocamlprof.m,v 1.6 2008/09/15 14:25:42 doligez Exp $
.TH OCAMLPROF 1
.SH NAME
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
.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".
+\" $Id: ocamlrun.m,v 1.6 2008/09/15 14:12:56 doligez Exp $
.TH OCAMLRUN 1
.SH NAME
.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.
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.
.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.
.SH SEE ALSO
.BR ocamlc (1).
.br
-.I The Objective Caml user's manual,
+.IR "The Objective Caml user's manual" ,
chapter "Runtime system".
+\" $Id: ocamlyacc.m,v 1.4 2008/09/15 14:12:56 doligez Exp $
.TH OCAMLYACC 1
.SH NAME
.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
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
.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".
+(***********************************************************************)
+(* *)
+(* 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
(* 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 =
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
"toplevel"; "typing"; "utils"]
in Ocamlbuild_pack.Configuration.parse_string
(sprintf "<{%s}/**>: not_hygienic, -traverse" patt)
-
+
| After_options ->
begin
Options.ocamlrun := ocamlrun;
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"];;
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"
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;;
~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;;
~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/};$/ |]/' \
| 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;;
let pr_o = pr "Camlp4OCamlPrinter"
let pr_a = pr "Camlp4AutoPrinter"
let fi_exc = fi "Camlp4ExceptionTracer"
-let fi_tracer = fi "Camlp4Tracer"
let fi_meta = fi "MetaGenerator"
let camlp4_bin = p4 "Camlp4Bin"
let top_rprint = top "Rprint"
let 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)
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;;
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";
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
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
$(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
# 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
(* *)
(***********************************************************************)
-(* $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 *)
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
| 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
| [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 =
(* *)
(***********************************************************************)
-(* $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 *)
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
(** 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
+
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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 *)
(* *)
(***********************************************************************)
-(* $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;;
(* *)
(***********************************************************************)
-(* $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 *)
(* *)
(***********************************************************************)
-(* $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;;
(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 =
(* *)
(***********************************************************************)
-(* $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 *)
(* *)
(***********************************************************************)
-(* $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 *)
{
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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
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' ',']
| (_ | 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)) }
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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 *)
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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
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)
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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
(* 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)"
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"
~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;;
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";;
(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");;
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"]);;
(* *)
(***********************************************************************)
-(* $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
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])
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])
(* *)
(***********************************************************************)
-(* $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
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
(* *)
(***********************************************************************)
-(* $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
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
| 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";
(* *)
(***********************************************************************)
-(* $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
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
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@@
paragraph.huge1 "Warning: this presentation has a degraded style compared to the Beamer/PDF version"
end
+short_version = true
+
maketitle
h1 "Introduction"
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_
or _stdlib.ml_ file be generated beforehand.
end
end
+end
h1 "Dealing with exceptions to standard rules"
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
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
<main.{byte,native}>: use_unix
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.
* (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
> 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
end
end
+unless short_version
slide "Acknowledgments" do
box "For enlightening discussions about OCaml internals:", '<1->' do
* Xavier Leroy
* ocamlbuild is not perfect but already damn useful
* Try it now! It's in OCaml 3.10!
end
+end
(* *)
(***********************************************************************)
-(* $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 ()
Ocaml_utils
Ocaml_tools
Ocaml_compiler
-Ocamldep
Ocaml_dependencies
+Exit_codes
+Digest_cache
Ocamlbuild_plugin
(* *)
(***********************************************************************)
-(* $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 *)
(* *)
(***********************************************************************)
-(* $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 *)
(* *)
(***********************************************************************)
-(* $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
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
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
(* *)
(***********************************************************************)
-(* $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
| 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
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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 *)
(* *)
(***********************************************************************)
-(* $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
"-ocamllex", set_cmd ocamllex, "<command> Set the ocamllex tool";
(* Not set since we perhaps want to replace ocamlmklib *)
(* "-ocamlmklib", set_cmd ocamlmklib, "<command> Set the ocamlmklib tool"; *)
- "-ocamlmktop", set_cmd ocamlmklib, "<command> Set the ocamlmktop tool";
+ "-ocamlmktop", set_cmd ocamlmktop, "<command> Set the ocamlmktop tool";
"-ocamlrun", set_cmd ocamlrun, "<command> Set the ocamlrun tool";
"--", Rest (fun x -> program_to_execute := true; add_to' program_args_internal x),
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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
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
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
(* *)
(***********************************************************************)
-(* $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
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
?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
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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. *)
([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"]
(** 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. *)
(* *)
(***********************************************************************)
-(* $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
| 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
#!/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
(* *)
(***********************************************************************)
-(* $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 *)
(* *)
(***********************************************************************)
-(* $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 *)
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 \
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 \
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
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 \
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 \
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 \
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
odoc_exception.cmo odoc_class.cmo
odoc_text.cmi: odoc_types.cmi
odoc_text_parser.cmi: odoc_types.cmi
+odoc_types.cmi:
#(* *)
#(***********************************************************************)
-# $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
INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP)
COMPFLAGS=$(INCLUDES) -warn-error A
-LINKFLAGS=$(INCLUDES)
+LINKFLAGS=$(INCLUDES) -nostdlib
CMOFILES= odoc_config.cmo \
odoc_global.cmo\
#(* *)
#(***********************************************************************)
-# $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
INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP)
COMPFLAGS=$(INCLUDES)
-LINKFLAGS=$(INCLUDES)
+LINKFLAGS=$(INCLUDES) -nostdlib
CMOFILES= odoc_config.cmo \
odoc_global.cmo\
(* *)
(***********************************************************************)
-(* $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 :-) *)
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."
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
)
| 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
None
)
| Odoc_args.Text_file file ->
+ Location.input_name := file;
try
let mod_name =
String.capitalize (Filename.basename (Filename.chop_extension file))
(* *)
(***********************************************************************)
-(* 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. *)
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)
"-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 ;
(* *)
(***********************************************************************)
-(* $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. *)
(** 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
(* *)
(***********************************************************************)
-(* $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
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
| [] ->
(** 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
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 =
{
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
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 =
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) )
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)) ->
| (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
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
pos_start
p_class_decl.Parsetree.pci_expr
tt_class_exp
+ table
in
let cl =
{
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
class_decl
tt_type_params
tt_class_exp
+ table
in
ele_comments @ ((Element_class new_class) :: (f last_pos2 q))
in
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 ;
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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. *)
(* *)
(***********************************************************************)
-(* $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. *)
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
(* *)
(***********************************************************************)
-(* $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. *)
in
(match t.T.ty_kind with
T.Type_abstract -> ()
- | T.Type_variant (cl, _) ->
+ | T.Type_variant cl ->
List.iter
(fun c ->
List.iter
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
(* *)
(***********************************************************************)
-(* $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.*)
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 "</pre>"
- | 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
print_concat b "\n" print_one l;
bs b "</table>\n"
- | Type_record (l, priv) ->
+ | Type_record l ->
bs b "= ";
if priv then bs b "private " ;
bs b "{";
(* html mark *)
bp b "<a name=\"%s\"></a>" (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 ->
bp b "<a href=\"%s\">%s</a>" 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 "</pre>";
self#html_of_info b a.att_value.val_info
(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 ;
}
(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 ;
}
(* *)
(***********************************************************************)
-(* $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. *)
(* *)
(***********************************************************************)
-(* $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. *)
(** 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 =
{
(** 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 =
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;
{
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. *)
(** 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
(* *)
(***********************************************************************)
-(* $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. *)
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
(
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
let defs =
match t.ty_kind with
Type_abstract -> []
- | Type_variant (l, _) ->
+ | Type_variant l ->
(List.flatten
(List.map
(fun constr ->
l
)
)
- | Type_record (l, _) ->
+ | Type_record l ->
(List.flatten
(List.map
(fun r ->
(* *)
(***********************************************************************)
-(* $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. *)
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 ""
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");
[]
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");
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
}
{
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
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
(* 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
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+
{
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
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
}
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" ->
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
}
| [ '\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;
(
reset_string_buffer ();
description := "";
- special_comment lexbuf
+ special_comment lexbuf
)
else
(
Odoc_comments_global.nb_chars := !Odoc_comments_global.nb_chars + (String.length s);
decr comments_level ;
simple lexbuf
- }
+ }
| _
{
(* *)
(***********************************************************************)
-(* $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
);
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 ";
)
)
l
- | Type_record (l, priv) ->
+ | Type_record l ->
bs b "= ";
if priv then bs b "private ";
bs b "{";
(** 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;
(* *)
(***********************************************************************)
-(* $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.*)
Type_abstract, _ ->
()
- | Type_variant (l1, _), Type_variant (l2, _) ->
+ | Type_variant l1, Type_variant l2 ->
let f cons =
try
let cons2 = List.find
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
(* *)
(***********************************************************************)
-(* $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. *)
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")
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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. *)
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
[] ->
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
[] ->
[]
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
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
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
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
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
)
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
([], 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
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
(* *)
(***********************************************************************)
-(* $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, ...). *)
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 "^
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
l
)
)
- | M.Type_record (l, priv) ->
+ | M.Type_record l ->
"= "^(if priv then "private " else "")^"{\n"^
(String.concat ""
(List.map
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"^
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 $ *)
(* 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. *)
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" ;
[ 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
((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
(* *)
(***********************************************************************)
-(* $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
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)
| _ ->
[ 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 =
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 ]
| _ ->
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)
(** 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
None ->
[]
| Some info ->
- let t =
+ let t =
(match info.i_deprecated with
None -> []
| Some t -> ( Italic [Raw (Odoc_messages.deprecated^" ")] ) :: t
(self#text_of_custom info.i_custom)
in
if block then
- [Block t]
- else
+ [Block t]
+ else
t
end
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
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
(** 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
(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 "@[<hov 2>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)
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 "@[<hov 2>val %s%s :@ %s"
+ let s =
+ Format.fprintf Format.str_formatter "@[<hov 2>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)
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 "@[<hov 2>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
Format.fprintf Format.str_formatter "@[<hov 2>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
)
l2
)
- ]
+ ]
(** Return [text] value for a list of parameters. *)
| 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 =
[] ->
[]
| _ ->
- [ Newline ;
+ [ Newline ;
Bold [Raw Odoc_messages.parameters] ;
Raw ":" ;
List
)
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
(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 "] "]
| 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 "( "] @
(** 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 "] "]
(
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
[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 "( "] @
[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^" ")]
| 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]
(match mt_alias.mta_module with
None -> mt_alias.mta_name
| Some mt -> mt.mt_name))
- ]
+ ]
end
(* *)
(***********************************************************************)
-(* $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 = {
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;
- }
+ }
(* *)
(***********************************************************************)
-(* $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. *)
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 *)
(** 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 _ ->
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
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.*)
in
f v.val_type
-
+
--- /dev/null
+#########################################################################
+# #
+# 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)
--- /dev/null
+#########################################################################
+# #
+# 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)
+
--- /dev/null
+#########################################################################
+# #
+# 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 $<
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
# #
#########################################################################
-# $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
# #
#########################################################################
-# $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
(* *)
(***********************************************************************)
-(* $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 *)
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"
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|]
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"
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
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
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;
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"
(* *)
(***********************************************************************)
-(* $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.
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. *)
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"
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
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
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]. *)
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)]. *)
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:
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
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
[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"
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
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"
(** 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} *)
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"
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"
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} *)
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. *)
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
/* */
/***********************************************************************/
-/* $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 <stddef.h>
#include <stdarg.h>
#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;
/* 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];
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) {
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;
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;
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);
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);
}
}
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;
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]); }
}
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);
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);
}
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]);
}
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;
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;
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; \
} \
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
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);
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;
#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
{
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
}
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 */
++ 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;
}
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;
/* 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;
}
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);
{
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;
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];
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);
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;
/* 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 */
}
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;
{
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;
}
/* */
/***********************************************************************/
-/* $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 <stddef.h>
#include <string.h>
{
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;
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 */
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
/* */
/***********************************************************************/
-/* $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 <stddef.h>
#include <stdio.h>
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;
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);
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);
/* 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)
sizeof(buffer),
NULL))
sprintf(buffer, "Unknown error %ld\n", errnum);
- raise_sys_error(copy_string(buffer));
+ caml_raise_sys_error(caml_copy_string(buffer));
}
+dbm.cmi:
dbm.cmo: dbm.cmi
dbm.cmx: dbm.cmi
# #
#########################################################################
-# $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
+++ /dev/null
-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
# #
#########################################################################
-# $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)
../../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) $<
.ml.cmo:
$(CAMLC) -c $(COMPFLAGS) $<
+.ml.cmx:
+ $(CAMLOPT) -c $(COMPFLAGS) $<
+
depend:
dynlink.cmo: dynlinkaux.cmi dynlink.cmi
# #
#########################################################################
-# $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
(* *)
(***********************************************************************)
-(* $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 *)
| Corrupted_interface of string
| File_not_found of string
| Cannot_open_dll of string
+ | Inconsistent_implementation of string
exception Error of error
(* 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 *)
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
close_in ic; raise exc
let loadfile_private file_name =
+ init();
let initial_symtable = Symtable.current_state()
and initial_crc = !crc_interfaces in
try
"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
(* *)
(***********************************************************************)
-(* $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
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
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} *)
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
(** 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 =
| 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]
--- /dev/null
+(***********************************************************************)
+(* *)
+(* 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"
../../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
# #
#########################################################################
-# $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
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
include ../../config/Makefile
+
+
SUBDIRS=compiler support lib labltk camltk jpf frx tkanim examples_labltk examples_camltk browser
all:
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
-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
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
-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
-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)
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
--- /dev/null
+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
(* *)
(*************************************************************************)
-(* $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
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 }
(* *)
(*************************************************************************)
-(* $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
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 []
| 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
(* *)
(*************************************************************************)
-(* $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
| 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:
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 ->
| 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
[] -> []
(* *)
(*************************************************************************)
-(* $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
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
(* *)
(*************************************************************************)
-(* $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
txt.signature <- [];
txt.psignature <- [];
ignore (Stypes.get_info ());
- Clflags.save_types := true;
+ Clflags.annotations := true;
begin try
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'
#include <callback.h>
#include <sys.h>
-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)
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
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
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'; \
) > _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
-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
-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
-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
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 \
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
-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
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
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
-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
include ../support/Makefile.common
-COMPFLAGS= -I ../support
+COMPFLAGS= -I ../support -I $(OTHERS)/win32unix -I $(OTHERS)/unix
all: 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
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'; \
) > _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
-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
-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
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
$(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
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
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)
-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
-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
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) $<
.ml.cmx:
$(CAMLOPT) -c $(COMPFLAGS) $<
-.c.o:
+.c.$(O):
$(BYTECC) $(BYTECCCOMPOPTS) $(CCFLAGS) -c $<
tkthread.cmi: tkthread.mli
## Where you compiled Objective Caml
TOPDIR=../../..
## Path to the otherlibs subdirectory
-OTHERS=../..
+OTHERS=$(TOPDIR)/otherlibs
LIBNAME=labltk
## 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
+++ /dev/null
-## 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
-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
/* */
/*************************************************************************/
-/* $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
#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);
/* 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 */
/* */
/***********************************************************************/
-/* $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 <tcl.h>
#include <tk.h>
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();
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;
/* */
/*************************************************************************/
-/* $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 <unistd.h>
-#include <fcntl.h>
+#include <fcntl.h>
#include <tcl.h>
#include <tk.h>
#include "gc.h"
#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.
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;
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 */
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);
stat_free(f);
}
}
-
+
/* Initialisations from caml_main */
{
int verbose_init = 0,
/* */
/***********************************************************************/
-/* $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 <stdlib.h>
#include <string.h>
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
}
}
-
-/*
+/*
* Calling Tcl from Caml
* direct call, argument is TkArgs vect
type TkArgs =
* 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.
*/
}
/* 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 */
fill_args(tmpargv,0,Field(v,0));
tmpargv[size] = NULL;
merged = Tcl_Merge(size,tmpargv);
- for(i = 0 ; i<size; i++){ stat_free(tmpargv[i]); }
+ for(i = 0; i<size; i++){ stat_free(tmpargv[i]); }
stat_free((char *)tmpargv);
/* must be freed by stat_free */
- argv[where] = (char*)stat_alloc(strlen(merged)+1);
+ argv[where] = (char*)stat_alloc(strlen(merged)+1);
strcpy(argv[where], merged);
Tcl_Free(merged);
return (where + 1);
CheckInit();
/* walk the array to compute final size for Tcl */
- for(i=0,size=0;i<Wosize_val(v);i++)
+ for(i=0, size=0; i<Wosize_val(v); i++)
size += argv_size(Field(v,i));
/* +2: one slot for NULL
/* Copy -- argv[i] must be freed by stat_free */
{
int where;
- for(i=0, where=0;i<Wosize_val(v);i++){
+ for(i=0, where=0; i<Wosize_val(v); i++){
where = fill_args(argv,where,Field(v,i));
}
if( size != where ){ tk_error("fill_args error!!! Call the CamlTk maintainer!"); }
- for(i=0; i<where; i++){ allocated[i] = argv[i]; }
+ for(i=0; i<where; i++){ allocated[i] = argv[i]; }
argv[size] = NULL;
argv[size + 1] = NULL;
}
result = (*info.proc)(info.clientData,cltclinterp,size+1,argv);
} else { /* ah, it isn't there at all */
result = TCL_ERROR;
- Tcl_AppendResult(cltclinterp, "Unknown command \"",
+ Tcl_AppendResult(cltclinterp, "Unknown command \"",
argv[0], "\"", NULL);
}
}
}
stat_free((char *)argv);
stat_free((char *)allocated);
-
+
switch (result) {
case TCL_OK:
return tcl_string_to_caml (cltclinterp->result);
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
}
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
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)
/* */
/***********************************************************************/
-/* $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 <string.h>
#include <tcl.h>
#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.
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 */
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 */
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);
(* *)
(***********************************************************************)
-(* $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 ()
(* *)
(***********************************************************************)
-(* $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 *)
+# 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) \
$(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) $<
.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
-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
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
../../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
# #
#########################################################################
-# $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:
# #
#########################################################################
-# $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
(* *)
(***********************************************************************)
-(* $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
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
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
(* *)
(***********************************************************************)
-(* $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.
(** 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. *)
(* *)
(***********************************************************************)
-(* $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
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"
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)
-
(* *)
(***********************************************************************)
-(* $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 *)
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"
/* */
/***********************************************************************/
-/* $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"
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)),
(* *)
(***********************************************************************)
-(* $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
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
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))
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)
((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)) ->
| ((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)) ->
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)
| 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) ->
| 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)
(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
| 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)
| 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
| 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)
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
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 =
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 _ ->
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:
+ <sign> xxxx . yyy
+ if s2 without last digit is yy with <= n digits:
+ <sign> 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 =
# #
#########################################################################
-# $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 \
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 $<
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
--- /dev/null
+(* 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 <number of digits to compute for pi>";
+ 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 ()
+;;
--- /dev/null
+
+(* 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 <number of digits to compute for pi>";
+ 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 ()
+;;
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;;
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;;
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";;
(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);;
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))
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
;;
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")
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
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")
+;;
../../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
# #
#########################################################################
-# $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
# #
#########################################################################
-# $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:
(* *)
(***********************************************************************)
-(* $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 *)
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
(** 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
../../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
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:
# #
#########################################################################
-# $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
# 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
# #
#########################################################################
-# $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
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
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
/* */
/***********************************************************************/
-/* $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 */
#include <sys/time.h>
#ifdef __linux__
#include <unistd.h>
-#include <sys/utsname.h>
#endif
#include "alloc.h"
#include "backtrace.h"
/* 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;
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,
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 */
/* 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);
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;
}
{
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;
}
{
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);
{
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;
}
{
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;
}
{
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;
}
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
-}
-
(* *)
(***********************************************************************)
-(* $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. *)
/* */
/***********************************************************************/
-/* $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 */
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,
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);
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;
}
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;
}
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;
}
../../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
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:
# #
#########################################################################
-# $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
$(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
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:
(* *)
(***********************************************************************)
-(* $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. *)
| 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 :
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"
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;
../../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 \
../../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
# #
#########################################################################
-# $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 \
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
/* */
/***********************************************************************/
-/* $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 <mlvalues.h>
#include <alloc.h>
/* */
/***********************************************************************/
-/* $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 <mlvalues.h>
#include "unixsupport.h"
#include <errno.h>
-
-#ifdef HAS_GETPRIORITY
-
-#include <sys/types.h>
-#include <sys/time.h>
-#include <sys/resource.h>
-
-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 <unistd.h>
+#endif
CAMLprim value unix_nice(value incr)
{
if (ret == -1 && errno != 0) uerror("nice", Nothing);
return Val_int(ret);
}
-
-#endif
/* */
/***********************************************************************/
-/* $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 <errno.h>
#include <signal.h>
/* */
/***********************************************************************/
-/* $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 <mlvalues.h>
+#include <memory.h>
#include <alloc.h>
#include <fail.h>
#include "unixsupport.h"
#ifdef HAS_SOCKETS
+#include <errno.h>
#include <sys/time.h>
#include <sys/types.h>
#include <sys/socket.h>
+#include <netinet/tcp.h>
#include "socketaddr.h"
#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
(* *)
(***********************************************************************)
-(* $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
| 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 :
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;
(* *)
(***********************************************************************)
-(* $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 *)
| 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 =
| 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. *)
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 *)
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} *)
(* *)
(***********************************************************************)
-(* $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,
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
| 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. *)
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 *)
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} *)
# #
#########################################################################
-# $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
/* */
/***********************************************************************/
-/* $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 <fcntl.h>
#include <signal.h>
#include "mlvalues.h"
#include "fail.h"
#include "libgraph.h"
+#include "callback.h"
#include <windows.h>
static value gr_reset(void);
/* Processing of graphic errors */
-value * caml_named_value (char * name);
static value * graphic_failure_exn = NULL;
void gr_fail(char *fmt, char *arg)
{
# #
#########################################################################
-# $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 \
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 \
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
/* */
/***********************************************************************/
-/* $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 <windows.h>
#include <mlvalues.h>
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
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
/* Objective Caml */
/* */
/* Contributed by Tracy Camp, PolyServe Inc., <campt@polyserve.com> */
+/* Further improvements by Reed Wilson */
/* */
/* Copyright 2002 Institut National de Recherche en Informatique et */
/* en Automatique. All rights reserved. This file is distributed */
/* */
/***********************************************************************/
-/* $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 <errno.h>
#include <fcntl.h>
#include <mlvalues.h>
+#include <memory.h>
#include <fail.h>
#include "unixsupport.h"
#include <stdio.h>
-
-/*
-
-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 <signals.h>
#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);
}
-
/* */
/***********************************************************************/
-/* $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 <mlvalues.h>
#include <alloc.h>
/* */
/* 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 <mlvalues.h>
#include <alloc.h>
#include <memory.h>
#include <signals.h>
+#include <winsock2.h>
+#include <windows.h>
#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);
}
/* */
/***********************************************************************/
-/* $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 <errno.h>
#include <mlvalues.h>
+#include <memory.h>
#include <alloc.h>
+#include <fail.h>
#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);
}
-
#include <stdlib.h>
#include <mlvalues.h>
#include "unixsupport.h"
+#include "winworker.h"
+#include "windbug.h"
value val_process_id;
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;
}
(* *)
(***********************************************************************)
-(* $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 *)
| 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"
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 *)
--- /dev/null
+/***********************************************************************/
+/* */
+/* 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 <windows.h>
+
+int dbug = 0;
+
+void dbug_init (void)
+{
+ dbug = (getenv("OCAMLDBUG") != NULL);
+}
+
+void dbug_cleanup (void)
+{
+}
+
+int dbug_test (void)
+{
+ return dbug;
+}
--- /dev/null
+/***********************************************************************/
+/* */
+/* 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 <stdio.h>
+#include <windows.h>
+
+#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
+
--- /dev/null
+/***********************************************************************/
+/* */
+/* 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 <windows.h>
+
+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;
+}
--- /dev/null
+/***********************************************************************/
+/* */
+/* 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 */
/* */
/***********************************************************************/
-/* $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 <windows.h>
#include <mlvalues.h>
#include <memory.h>
#include "unixsupport.h"
#include <sys/types.h>
+#include <signals.h>
static value alloc_process_status(HANDLE pid, int status)
{
--- /dev/null
+/***********************************************************************/
+/* */
+/* 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 <mlvalues.h>
+#include <alloc.h>
+#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);
+}
--- /dev/null
+/***********************************************************************/
+/* */
+/* 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 <windows.h>
+
+/* 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 */
(* *)
(***********************************************************************)
-(* $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 *)
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 =
(* *)
(***********************************************************************)
-(* $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
loc_ghost = false;
};;
-let input_name = ref ""
+let input_name = ref "_none_"
let input_lexbuf = ref (None : lexbuf option)
(* Terminal info *)
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
(* *)
(***********************************************************************)
-(* $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. *)
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
/* */
/***********************************************************************/
-/* $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 */
| 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")),
{ $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
false)) }
| pattern BAR pattern
{ mkpat(Ppat_or($1, $3)) }
+ | LAZY simple_pattern
+ { mkpat(Ppat_lazy $2) }
;
simple_pattern:
val_ident %prec below_EQUAL
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()}) }
;
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*/ { [] }
{ 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
{ ($2, Pwith_module $4) }
;
with_type_binder:
- EQUAL { Ptype_abstract }
- | EQUAL PRIVATE { Ptype_private }
+ EQUAL { Public }
+ | EQUAL PRIVATE { Private }
;
/* Polymorphic types */
{ $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)) }
(* *)
(***********************************************************************)
-(* $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 *)
| 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;
{ 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
(* *)
(***********************************************************************)
-(* $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;;
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 =
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;
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
(* *)
(***********************************************************************)
-(* $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 *)
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
+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
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 \
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
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 \
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
# #
#########################################################################
-# $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)
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:
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)
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
# #
#########################################################################
-# $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
--- /dev/null
+#########################################################################
+# #
+# 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
# 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 \
arrayLabels \
buffer \
callback \
+ camlinternalLazy \
camlinternalMod \
camlinternalOO \
char \
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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.
(* *)
(***********************************************************************)
-(* $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 *)
'î'|'ô'|'û'|'ë'|'ï'|'ü'|'ç'|
'É'|'À'|'Á'|'È'|'Ù'|'Â'|'Ê'|
'Î'|'Ô'|'Û'|'Ë'|'Ï'|'Ü'|'Ç' ->
- 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 ->
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;;
--- /dev/null
+(***********************************************************************)
+(* *)
+(* 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
+;;
--- /dev/null
+(***********************************************************************)
+(* *)
+(* 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 ;;
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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
(* *)
(***********************************************************************)
-(* $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 *)
= "%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')
(* *)
(***********************************************************************)
-(* $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. *)
(**************************************************************
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 : *)
mutable elem_size : size;
token : pp_token;
length : int;
-};;
+}
+;;
(* Scan stack:
each element is (left_total, queue element) where left_total
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 = {
mark_close_tag : tag -> string;
print_open_tag : tag -> unit;
print_close_tag : tag -> unit;
-};;
+}
+;;
(* A formatter with all its machinery. *)
type formatter = {
mutable pp_print_close_tag : tag -> unit;
(* The pretty-printer queue. *)
mutable pp_queue : pp_queue_elem 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.
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;;
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;;
(* 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
(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 =
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.
**************************************************************)
(* 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;;
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. *)
(* 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;
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
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
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 =
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;;
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;
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 =
state.pp_right_total <- pp_infinity;
advance_left state;
if b then pp_output_newline state;
- pp_rinit state;;
+ pp_rinit state
+;;
(**************************************************************
(* 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);;
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
(* 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
(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 () =
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 () =
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 =
(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;;
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
+;;
(**************************************************************
(* 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 =
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)
+;;
(**************************************************************
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 ' ';;
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
+;;
(**************************************************************
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);;
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. *)
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,
Tformat.kapr kpr fmt in
- kprintf;;
+ kprintf
+;;
(**************************************************************
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
+;;
(* *)
(***********************************************************************)
-(* $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. *)
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.
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
(* *)
(***********************************************************************)
-(* $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.
(* *)
(***********************************************************************)
-(* $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.
(* *)
(***********************************************************************)
-(* $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 *)
*)
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
(* *)
(***********************************************************************)
-(* $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. *)
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,
(* *)
(***********************************************************************)
-(* $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 *)
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. *)
(* *)
(***********************************************************************)
-(* $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]. *)
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
(** 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
(* *)
(***********************************************************************)
-(* $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 *)
let int_tag = 1000
let out_of_heap_tag = 1001
+let unaligned_tag = 1002
(* *)
(***********************************************************************)
-(* $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.
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. *)
(* *)
(***********************************************************************)
-(* $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 *)
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 ());
(* *)
(***********************************************************************)
-(* $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]. *)
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. *)
(**/**)
(* *)
(***********************************************************************)
-(* $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.
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.(=)}. *)
(** 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 *)
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
(** {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. *)
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
(* *)
(***********************************************************************)
-(* $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;;
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"
+
(* *)
(***********************************************************************)
-(* $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. *)
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. *)
(* *)
(***********************************************************************)
-(* $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"
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 =
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. *)
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 =
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
| '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].
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;;
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'
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.
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 = {
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
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 [||]
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]. *)
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' ->
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
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;;
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;;
mutable ac_rglr : int;
mutable ac_skip : int;
mutable ac_rdrs : int;
- };;
+ }
+ ;;
let ac_of_format = ac_of_format;;
let kapr = kapr;;
- end;;
+ end
+ ;;
-end;;
+end
+;;
(* *)
(***********************************************************************)
-(* $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. *)
(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,
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
(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;;
-
(* *)
(***********************************************************************)
-(* $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. *)
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'. *)
val from_file_bin : string -> scanbuf;;
val from_function : (unit -> char) -> scanbuf;;
-end;;
+end
+;;
module Scanning : SCANNING = struct
mutable get_next_char : unit -> char;
tokbuf : Buffer.t;
file_name : file_name;
-};;
+}
+;;
let null_char = '\000';;
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;;
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;;
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;;
get_next_char = next;
tokbuf = Buffer.create default_token_buffer_size;
file_name = fname;
-};;
+}
+;;
let from_string s =
let i = ref 0 in
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
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;;
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;;
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);;
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.
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. *)
| '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);;
| '_' ->
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
| '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
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;;
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
| '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
| '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. *)
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 =
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):
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
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
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
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. *)
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 '\''. *)
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 =
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 =
| '\\', 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
| '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 =
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;;
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
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
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;;
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 =
| 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
| ' ' | '\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;;
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;;
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)
+;;
(* *)
(***********************************************************************)
-(* $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
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
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;;
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]:
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. *)
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 ->
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]. *)
# 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
ArrayLabels
Buffer
Callback
+CamlinternalLazy
CamlinternalMod
CamlinternalOO
Char
(* *)
(***********************************************************************)
-(* $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
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 }
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 =
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 *)
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"
;;
(* *)
(***********************************************************************)
-(* $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 *)
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
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
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
(* *)
(***********************************************************************)
-(* $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
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]. *)
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]. *)
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]
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
(* *)
(***********************************************************************)
-(* $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 *)
(* *)
(***********************************************************************)
-(* $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. *)
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.
*)
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 \
../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 \
../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
# #
#########################################################################
-# $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
# #
#########################################################################
-# $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)
--- /dev/null
+#########################################################################
+# #
+# 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
-(* $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
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 _ ->
[]
(* *)
(***********************************************************************)
-(* $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
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
| 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
(* *)
(***********************************************************************)
-(* $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 *)
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
# #
#########################################################################
-# $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
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 <<EOF
-# Title Objective Caml
-# Version ${VERSION}
-# Description This package installs Objective Caml version ${VERSION}
-# DefaultLocation /
-# Relocatable no
-# NeedsAuthorization yes
-# Application no
-# InstallOnly no
-# DisableStop no
-# EOF
-#package root ocaml.info
-
cat >Description.plist <<EOF
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN"
# stop here -> |
cat >resources/ReadMe.txt <<EOF
This package installs Objective Caml version ${VERSION}.
-You need Mac OS X 10.5.x (Leopard), with X11 and the
-XCode tools (v3.x) installed.
+You need Mac OS X 10.5.x (Leopard), with the
+XCode tools (v3.x) installed (and optionally X11).
Files will be installed in the following directories:
(* *)
(***********************************************************************)
-(* $Id: ocamlcp.ml,v 1.40 2006/11/28 15:59:35 doligez Exp $ *)
+(* $Id: ocamlcp.ml,v 1.41 2007/05/16 08:21:40 doligez Exp $ *)
open Printf
module Options = Main_args.Make_options (struct
let _a () = make_archive := true; option "-a" ()
+ let _annot = option "-annot"
let _c = option "-c"
let _cc s = option_with_arg "-cc" s
let _cclib s = option_with_arg "-cclib" s
(* *)
(***********************************************************************)
-(* $Id: ocamldep.ml,v 1.41 2007/02/12 08:10:00 weis Exp $ *)
+(* $Id: ocamldep.ml,v 1.44 2008/08/01 09:02:55 xleroy Exp $ *)
open Format
open Location
;;
let print_dependencies target_file deps =
- match deps with
- [] -> ()
- | _ ->
- 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 ":";
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])
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
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
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] <source files>\nOptions are:"
Arg.parse [
"-I", Arg.String add_to_load_path,
"<dir> Add <dir> to the list of include directories";
+ "-impl", Arg.String (file_dependencies_as ML),
+ "<f> Process <f> as a .ml file";
+ "-intf", Arg.String (file_dependencies_as MLI),
+ "<f> Process <f> 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),
- "<command> Pipe sources through preprocessor <command>";
+ "<cmd> Pipe sources through preprocessor <cmd>";
"-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;
(* *)
(***********************************************************************)
-(* $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
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 =
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
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
(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 <lib> C library passed to ocamlc -a or ocamlopt -a only
-ccopt <opt> C option passed to ocamlc -a or ocamlopt -a only
-custom disable dynamic loading
-dllpath <dir> Add <dir> to the run-time search path for DLLs
+ -F<dir> Specify a framework directory (MacOSX)
+ -framework <name> Use framework <name> (MacOSX)
+ -help Print this help message and exit
+ --help Same as -help
+ -h Same as -help
-I <dir> Add <dir> to the path searched for Caml object files
-failsafe fall back to static linking if DLL construction failed
-ldopt <opt> C option passed to the shared linker only
-rpath <dir> Same as -dllpath <dir>
-R<dir> Same as -rpath
-verbose Print commands before executing them
+ -v same as -verbose
+ -version Print version and exit
-Wl,-rpath,<dir> Same as -dllpath <dir>
-Wl,-rpath -Wl,<dir> Same as -dllpath <dir>
-Wl,-R<dir> Same as -dllpath <dir>
- -F<dir> Specify a framework directory (MacOSX)
- -framework <name> Use framework <name> (MacOSX)
- -version Print version and exit
"
let command cmd =
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);
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)
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)
(* *)
(***********************************************************************)
-(* $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
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
(* *)
(***********************************************************************)
-(* $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 *)
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)
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 ->
--- /dev/null
+(***********************************************************************)
+(* *)
+(* 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))
--- /dev/null
+(***********************************************************************)
+(* *)
+(* 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
--- /dev/null
+(***********************************************************************)
+(* *)
+(* 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
--- /dev/null
+(***********************************************************************)
+(* *)
+(* 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
--- /dev/null
+(***********************************************************************)
+(* *)
+(* 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 <options> <object-files> [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),
+ "<n> Set aggressiveness of inlining to <n>";
+ "-I", Arg.String(fun dir ->
+ let dir = Misc.expand_directory Config.standard_library dir in
+ include_dirs := dir :: !include_dirs),
+ "<dir> Add <dir> to the list of include directories";
+ "-init", Arg.String (fun s -> init_file := Some s),
+ "<file> Load <file> 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),
+ "<flags> Enable or disable warnings according to <flags>:\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),
+ "<flags> Treat the warnings of <flags> 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
+
--- /dev/null
+(***********************************************************************)
+(* *)
+(* 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
--- /dev/null
+(***********************************************************************)
+(* *)
+(* 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()
(* *)
(***********************************************************************)
-(* $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 *)
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
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 ();
(* *)
(***********************************************************************)
-(* $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
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
--- /dev/null
+(***********************************************************************)
+(* *)
+(* 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 *)
+;;
(* *)
(***********************************************************************)
-(* $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 *)
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
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 =
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
(*******************************************)
(* 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 =
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
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
(* *)
(***********************************************************************)
-(* $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 *)
(* 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
(**** 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
(* *)
(***********************************************************************)
-(* $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 *)
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 () =
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;
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
generalize_spine ty'
| _ -> ()
-let try_expand_once' = (* Forward declaration *)
+let forward_try_expand_once = (* Forward declaration *)
ref (fun env ty -> raise Cannot_expand)
(*
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... *)
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
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;
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;
*)
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
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
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
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 ->
| _ ->
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
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.
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 =
{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
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
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 ->
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 ****)
{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. *)
| 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 []);
(* 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)
| (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
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;
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
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
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
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
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. *)
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
| 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
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
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;
with Not_found when is_covariant ->
None
end;
+ type_private = decl.type_private;
type_variance = decl.type_variance;
}
in
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
(* *)
(***********************************************************************)
-(* $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 *)
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
(* *)
(***********************************************************************)
-(* $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 *)
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;
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;
}
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;
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
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 =
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
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;
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
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
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;
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 =
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
(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
(* *)
(***********************************************************************)
-(* $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 *)
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
(* 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
(* 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 *)
(* Forward declaration to break mutual recursion with Includemod. *)
val check_modtype_inclusion:
(t -> module_type -> Path.t -> module_type -> unit) ref
-
(* *)
(***********************************************************************)
-(* $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 *)
(* 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) *)
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 ||
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 &&
(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) ->
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
(* *)
(***********************************************************************)
-(* $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 *)
(* *)
(***********************************************************************)
-(* $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
| 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
(* *)
(***********************************************************************)
-(* $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
| 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 '(';
| 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")
(* *)
(***********************************************************************)
-(* $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. *)
| _,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,_) ->
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
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"
| "::" -> true
| _ -> false
-
+
let rec pretty_val ppf v = match v.pat_desc with
| Tpat_any -> fprintf ppf "_"
| Tpat_var x -> Ident.print ppf x
| _ -> 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,_) ->
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
| 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
| Tpat_tuple(args) -> omega_list args
| Tpat_record(args) -> omega_list args
| Tpat_array(args) -> omega_list args
+ | Tpat_lazy _ -> [omega]
| _ -> []
end
| _ -> []
| 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"
| ({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
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
filter_omega
(filter_rec
(match pat0.pat_desc with
- (Tpat_record(_) | Tpat_tuple(_)) -> [pat0,[]]
+ (Tpat_record(_) | Tpat_tuple(_) | Tpat_lazy(_)) -> [pat0,[]]
| _ -> [])
pss)
pss
| ({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
| 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
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
| 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
| 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
(*
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
(* *)
(***********************************************************************)
-(* $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
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
(* *)
(***********************************************************************)
-(* $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) *)
{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 =
{type_params = [tvar];
type_arity = 1;
type_kind = Type_abstract;
+ type_private = Public;
type_manifest = None;
type_variance = [true, true, true]}
and decl_list =
{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 =
];
type_arity = 6;
type_kind = Type_abstract;
+ type_private = Public;
type_manifest = None;
type_variance = [
true, true, true; true, true, true;
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 =
{type_params = [tvar];
type_arity = 1;
type_kind = Type_abstract;
+ type_private = Public;
type_manifest = None;
type_variance = [true, false, false]}
in
(* *)
(***********************************************************************)
-(* $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 *)
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
(* *)
(***********************************************************************)
-(* $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 *)
val parse_declaration: int -> string list -> description
val description_list: description -> string list
+
+val native_name: description -> string
+val byte_name: description -> string
(* *)
(***********************************************************************)
-(* $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 *)
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 []
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;
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
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)
(* *)
(***********************************************************************)
-(* $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 *)
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 =
| 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:
;;
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 () =
| _ -> ()
;;
+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;
;;
(* *)
(***********************************************************************)
-(* $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 *)
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;;
(* *)
(***********************************************************************)
-(* $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 *)
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
(* *)
(***********************************************************************)
-(* $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 *)
(* *)
(***********************************************************************)
-(* $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
| 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
| 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
{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
{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
{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
(* *)
(***********************************************************************)
-(* $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 *)
| 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)
(* 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 =
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
(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
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 =
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
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
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];
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;
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
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)}
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)
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 =
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);
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 ();
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;
| 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);
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
(* 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))
(* 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 *)
(* *)
(***********************************************************************)
-(* $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 *)
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
(* *)
(***********************************************************************)
-(* $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 ****)
| 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
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;
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 =
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) ->
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) ->
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
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
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
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
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
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 ->
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
(* 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
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
{ 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();
(* 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 ****)
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' ->
(* *)
(***********************************************************************)
-(* $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 *)
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 ->
(* *)
(***********************************************************************)
-(* $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 *)
| 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
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 _ -> ()
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) ->
(* *)
(***********************************************************************)
-(* $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 *)
| 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
(* *)
(***********************************************************************)
-(* $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 *)
([], _, _) ->
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))
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 *)
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. *)
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;
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
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 =
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
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
(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
(* *)
(***********************************************************************)
-(* $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 *)
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
(* *)
(***********************************************************************)
-(* $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 *)
(* Type expressions for the core language *)
type type_expr =
- { mutable desc: type_desc;
+ { mutable desc: type_desc;
mutable level: int;
mutable id: int }
| 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
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 =
{ 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
| 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 *)
(* *)
(***********************************************************************)
-(* $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 *)
(* Type expressions for the core language *)
type type_expr =
- { mutable desc: type_desc;
+ { mutable desc: type_desc;
mutable level: int;
mutable id: int }
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 =
{ 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
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 ->
(* *)
(***********************************************************************)
-(* $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
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
(* *)
(***********************************************************************)
-(* $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 *)
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;
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
(* *)
(***********************************************************************)
-(* $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 *)
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
(* *)
(***********************************************************************)
-(* $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 *)
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 *)
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 *)
let std_include_dir () =
if !no_std_include then [] else [Config.standard_library]
;;
+
+let shared = ref false (* -shared *)
+let dlcode = ref true (* not -nodynlink *)
+
(* *)
(***********************************************************************)
-(* $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
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
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
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
(* *)
(***********************************************************************)
-(* $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
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)
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
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;
(* *)
(***********************************************************************)
-(* $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 *)
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
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
(* *)
(***********************************************************************)
-(* $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
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)
let model = "%%MODEL%%"
let system = "%%SYSTEM%%"
+let asm = "%%ASM%%"
+
let ext_obj = "%%EXT_OBJ%%"
let ext_asm = "%%EXT_ASM%%"
let ext_lib = "%%EXT_LIB%%"
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;
(* *)
(***********************************************************************)
-(* $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 *)
| 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 *)
;;
| Nonreturning_statement
| Camlp4 _
| Useless_record_with
+ | Bad_module_name _
| All_clauses_guarded -> 'x'
| Unused_var _ -> 'y'
| Unused_var_strict _ -> 'z'
| 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;;
(* *)
(***********************************************************************)
-(* $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
| 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 *)
;;
# #
#########################################################################
-# $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
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)
/* */
/***********************************************************************/
-/* $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
#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
# #
#########################################################################
-# $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.
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
projects / ocaml.git / commitdiff